From 8e8af651258448fc09fe187f0a89a1031e79a61f Mon Sep 17 00:00:00 2001 From: John Alanbrook Date: Tue, 10 Jan 2023 13:13:00 +0000 Subject: [PATCH] duktape --- source/engine/duk_config.h | 3779 ++ source/engine/duktape.c | 101351 ++++++++++++++++++++++++++++++++++ source/engine/duktape.h | 1456 + source/engine/ffi.c | 110 + source/engine/ffi.h | 8 + source/engine/s7.c | 96029 -------------------------------- source/engine/s7.h | 1239 - source/engine/script.c | 6 +- source/engine/script.h | 4 +- source/engine/yugine.c | 9 +- 10 files changed, 106718 insertions(+), 97273 deletions(-) create mode 100644 source/engine/duk_config.h create mode 100644 source/engine/duktape.c create mode 100644 source/engine/duktape.h create mode 100644 source/engine/ffi.c create mode 100644 source/engine/ffi.h delete mode 100644 source/engine/s7.c delete mode 100644 source/engine/s7.h diff --git a/source/engine/duk_config.h b/source/engine/duk_config.h new file mode 100644 index 00000000..a4e997ed --- /dev/null +++ b/source/engine/duk_config.h @@ -0,0 +1,3779 @@ +/* + * duk_config.h configuration header generated by genconfig.py. + * + * Git commit: 03d4d728f8365021de6955c649e6dcd05dcca99f + * Git describe: 03d4d72-dirty + * Git branch: HEAD + * + * Supported platforms: + * - Mac OSX, iPhone, Darwin + * - Orbis + * - OpenBSD + * - Generic BSD + * - Atari ST TOS + * - AmigaOS + * - Durango (XboxOne) + * - Windows + * - Flashplayer (Crossbridge) + * - QNX + * - TI-Nspire + * - Emscripten + * - Android + * - Linux + * - Solaris + * - AIX + * - HPUX + * - Generic POSIX + * - Cygwin + * - Generic UNIX + * - Generic fallback + * + * Supported architectures: + * - x86 + * - x64 + * - x32 + * - ARM 32-bit + * - ARM 64-bit + * - MIPS 32-bit + * - MIPS 64-bit + * - PowerPC 32-bit + * - PowerPC 64-bit + * - SPARC 32-bit + * - SPARC 64-bit + * - RISC-V 32-bit + * - RISC-V 64-bit + * - SuperH + * - Motorola 68k + * - Emscripten + * - Generic + * + * Supported compilers: + * - Clang + * - GCC + * - MSVC + * - Emscripten + * - TinyC + * - VBCC + * - Bruce's C compiler + * - Generic + * + */ + +#if !defined(DUK_CONFIG_H_INCLUDED) +#define DUK_CONFIG_H_INCLUDED + +/* + * Intermediate helper defines + */ + +/* DLL build detection */ +/* not configured for DLL build */ +#undef DUK_F_DLL_BUILD + +/* Apple OSX, iOS */ +#if defined(__APPLE__) +#define DUK_F_APPLE +#endif + +/* FreeBSD */ +#if defined(__FreeBSD__) || defined(__FreeBSD) +#define DUK_F_FREEBSD +#endif + +/* Orbis (PS4) variant */ +#if defined(DUK_F_FREEBSD) && defined(__ORBIS__) +#define DUK_F_ORBIS +#endif + +/* OpenBSD */ +#if defined(__OpenBSD__) || defined(__OpenBSD) +#define DUK_F_OPENBSD +#endif + +/* NetBSD */ +#if defined(__NetBSD__) || defined(__NetBSD) +#define DUK_F_NETBSD +#endif + +/* BSD variant */ +#if defined(DUK_F_FREEBSD) || defined(DUK_F_NETBSD) || defined(DUK_F_OPENBSD) || \ + defined(__bsdi__) || defined(__DragonFly__) +#define DUK_F_BSD +#endif + +/* Atari ST TOS. __TOS__ defined by PureC. No platform define in VBCC + * apparently, so to use with VBCC user must define __TOS__ manually. + */ +#if defined(__TOS__) +#define DUK_F_TOS +#endif + +/* Motorola 68K. Not defined by VBCC, so user must define one of these + * manually when using VBCC. + */ +#if defined(__m68k__) || defined(M68000) || defined(__MC68K__) +#define DUK_F_M68K +#endif + +/* AmigaOS. Neither AMIGA nor __amigaos__ is defined on VBCC, so user must + * define 'AMIGA' manually when using VBCC. + */ +#if defined(AMIGA) || defined(__amigaos__) +#define DUK_F_AMIGAOS +#endif + +/* PowerPC */ +#if defined(__powerpc) || defined(__powerpc__) || defined(__PPC__) +#define DUK_F_PPC +#if defined(__PPC64__) || defined(__LP64__) || defined(_LP64) +#define DUK_F_PPC64 +#else +#define DUK_F_PPC32 +#endif +#endif + +/* Durango (Xbox One) */ +#if defined(_DURANGO) || defined(_XBOX_ONE) +#define DUK_F_DURANGO +#endif + +/* Windows, both 32-bit and 64-bit */ +#if defined(_WIN32) || defined(WIN32) || defined(_WIN64) || defined(WIN64) || \ + defined(__WIN32__) || defined(__TOS_WIN__) || defined(__WINDOWS__) +#define DUK_F_WINDOWS +#if defined(_WIN64) || defined(WIN64) +#define DUK_F_WIN64 +#else +#define DUK_F_WIN32 +#endif +#endif + +/* Flash player (e.g. Crossbridge) */ +#if defined(__FLASHPLAYER__) +#define DUK_F_FLASHPLAYER +#endif + +/* QNX */ +#if defined(__QNX__) +#define DUK_F_QNX +#endif + +/* TI-Nspire (using Ndless) */ +#if defined(_TINSPIRE) +#define DUK_F_TINSPIRE +#endif + +/* Emscripten (provided explicitly by user), improve if possible */ +#if defined(EMSCRIPTEN) +#define DUK_F_EMSCRIPTEN +#endif + +/* BCC (Bruce's C compiler): this is a "torture target" for compilation */ +#if defined(__BCC__) || defined(__BCC_VERSION__) +#define DUK_F_BCC +#endif + +#if defined(ANDROID) || defined(__ANDROID__) +#define DUK_F_ANDROID +#endif + +/* Linux */ +#if defined(__linux) || defined(__linux__) || defined(linux) +#define DUK_F_LINUX +#endif + +/* illumos / Solaris */ +#if defined(__sun) && defined(__SVR4) +#define DUK_F_SUN +#if defined(__SUNPRO_C) && (__SUNPRO_C < 0x550) +#define DUK_F_OLD_SOLARIS +/* Defines _ILP32 / _LP64 required by DUK_F_X86/DUK_F_X64. Platforms + * are processed before architectures, so this happens before the + * DUK_F_X86/DUK_F_X64 detection is emitted. + */ +#include +#endif +#endif + +/* AIX */ +#if defined(_AIX) +/* defined(__xlc__) || defined(__IBMC__): works but too wide */ +#define DUK_F_AIX +#endif + +/* HPUX */ +#if defined(__hpux) +#define DUK_F_HPUX +#if defined(__ia64) +#define DUK_F_HPUX_ITANIUM +#endif +#endif + +/* POSIX */ +#if defined(__posix) +#define DUK_F_POSIX +#endif + +/* Cygwin */ +#if defined(__CYGWIN__) +#define DUK_F_CYGWIN +#endif + +/* Generic Unix (includes Cygwin) */ +#if defined(__unix) || defined(__unix__) || defined(unix) || \ + defined(DUK_F_LINUX) || defined(DUK_F_BSD) +#define DUK_F_UNIX +#endif + +/* Intel x86 (32-bit), x64 (64-bit) or x32 (64-bit but 32-bit pointers), + * define only one of DUK_F_X86, DUK_F_X64, DUK_F_X32. + * https://sites.google.com/site/x32abi/ + * + * With DUK_F_OLD_SOLARIS the header must be included + * before this. + */ +#if defined(__amd64__) || defined(__amd64) || \ + defined(__x86_64__) || defined(__x86_64) || \ + defined(_M_X64) || defined(_M_AMD64) +#if defined(__ILP32__) || defined(_ILP32) +#define DUK_F_X32 +#else +#define DUK_F_X64 +#endif +#elif defined(i386) || defined(__i386) || defined(__i386__) || \ + defined(__i486__) || defined(__i586__) || defined(__i686__) || \ + defined(__IA32__) || defined(_M_IX86) || defined(__X86__) || \ + defined(_X86_) || defined(__THW_INTEL__) || defined(__I86__) +#if defined(__LP64__) || defined(_LP64) +/* This should not really happen, but would indicate x64. */ +#define DUK_F_X64 +#else +#define DUK_F_X86 +#endif +#endif + +/* ARM */ +#if defined(__arm__) || defined(__thumb__) || defined(_ARM) || defined(_M_ARM) || defined(_M_ARM64) || defined(__aarch64__) +#define DUK_F_ARM +#if defined(__LP64__) || defined(_LP64) || defined(__arm64) || defined(__arm64__) || defined(_M_ARM64) || defined(__aarch64__) +#define DUK_F_ARM64 +#else +#define DUK_F_ARM32 +#endif +#endif + +/* MIPS. Related defines: __MIPSEB__, __MIPSEL__, __mips_isa_rev, __LP64__ */ +#if defined(__mips__) || defined(mips) || defined(_MIPS_ISA) || \ + defined(_R3000) || defined(_R4000) || defined(_R5900) || \ + defined(_MIPS_ISA_MIPS1) || defined(_MIPS_ISA_MIPS2) || \ + defined(_MIPS_ISA_MIPS3) || defined(_MIPS_ISA_MIPS4) || \ + defined(__mips) || defined(__MIPS__) +#define DUK_F_MIPS +#if defined(__LP64__) || defined(_LP64) || defined(__mips64) || \ + defined(__mips64__) || defined(__mips_n64) +#define DUK_F_MIPS64 +#else +#define DUK_F_MIPS32 +#endif +#endif + +/* SPARC */ +#if defined(sparc) || defined(__sparc) || defined(__sparc__) +#define DUK_F_SPARC +#if defined(__LP64__) || defined(_LP64) +#define DUK_F_SPARC64 +#else +#define DUK_F_SPARC32 +#endif +#endif + +/* RISC-V, https://github.com/riscv/riscv-toolchain-conventions#cc-preprocessor-definitions */ +#if defined(__riscv) +#define DUK_F_RISCV +#if defined(__riscv_xlen) +#if (__riscv_xlen == 32) +#define DUK_F_RISCV32 +#elif (__riscv_xlen == 64) +#define DUK_F_RISCV64 +#else +#error __riscv_xlen has unsupported value (not 32 or 64) +#endif +#else +#error __riscv defined without __riscv_xlen +#endif +#endif /* __riscv */ + +/* SuperH */ +#if defined(__sh__) || \ + defined(__sh1__) || defined(__SH1__) || \ + defined(__sh2__) || defined(__SH2__) || \ + defined(__sh3__) || defined(__SH3__) || \ + defined(__sh4__) || defined(__SH4__) || \ + defined(__sh5__) || defined(__SH5__) +#define DUK_F_SUPERH +#endif + +/* Clang */ +#if defined(__clang__) +#define DUK_F_CLANG +#endif + +/* C++ */ +#undef DUK_F_CPP +#if defined(__cplusplus) +#define DUK_F_CPP +#endif + +/* C99 or above */ +#undef DUK_F_C99 +#if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) +#define DUK_F_C99 +#endif + +/* C++11 or above */ +#undef DUK_F_CPP11 +#if defined(__cplusplus) && (__cplusplus >= 201103L) +#define DUK_F_CPP11 +#endif + +/* GCC. Clang also defines __GNUC__ so don't detect GCC if using Clang. */ +#if defined(__GNUC__) && !defined(__clang__) && !defined(DUK_F_CLANG) +#define DUK_F_GCC +#if defined(__GNUC__) && defined(__GNUC_MINOR__) && defined(__GNUC_PATCHLEVEL__) +/* Convenience, e.g. gcc 4.5.1 == 40501; http://stackoverflow.com/questions/6031819/emulating-gccs-builtin-unreachable */ +#define DUK_F_GCC_VERSION (__GNUC__ * 10000L + __GNUC_MINOR__ * 100L + __GNUC_PATCHLEVEL__) +#else +#error cannot figure out gcc version +#endif +#endif + +/* MinGW. Also GCC flags (DUK_F_GCC) are enabled now. */ +#if defined(__MINGW32__) || defined(__MINGW64__) +#define DUK_F_MINGW +#endif + +/* MSVC */ +#if defined(_MSC_VER) +/* MSVC preprocessor defines: http://msdn.microsoft.com/en-us/library/b0084kay.aspx + * _MSC_FULL_VER includes the build number, but it has at least two formats, see e.g. + * BOOST_MSVC_FULL_VER in http://www.boost.org/doc/libs/1_52_0/boost/config/compiler/visualc.hpp + */ +#define DUK_F_MSVC +#if defined(_MSC_FULL_VER) +#if (_MSC_FULL_VER > 100000000) +#define DUK_F_MSVC_FULL_VER _MSC_FULL_VER +#else +#define DUK_F_MSCV_FULL_VER (_MSC_FULL_VER * 10) +#endif +#endif +#endif /* _MSC_VER */ + +/* TinyC */ +#if defined(__TINYC__) +/* http://bellard.org/tcc/tcc-doc.html#SEC9 */ +#define DUK_F_TINYC +#endif + +/* VBCC */ +#if defined(__VBCC__) +#define DUK_F_VBCC +#endif + +/* Atari Mint */ +#if defined(__MINT__) +#define DUK_F_MINT +#endif + +/* + * Platform autodetection + */ + +/* Workaround for older C++ compilers before including , + * see e.g.: https://sourceware.org/bugzilla/show_bug.cgi?id=15366 + */ +#if defined(__cplusplus) && !defined(__STDC_LIMIT_MACROS) +#define __STDC_LIMIT_MACROS +#endif +#if defined(__cplusplus) && !defined(__STDC_CONSTANT_MACROS) +#define __STDC_CONSTANT_MACROS +#endif + +#if defined(DUK_F_APPLE) +/* --- Mac OSX, iPhone, Darwin --- */ +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include +#include +#include + +/* http://stackoverflow.com/questions/5919996/how-to-detect-reliably-mac-os-x-ios-linux-windows-in-c-preprocessor */ +#if TARGET_IPHONE_SIMULATOR +#define DUK_USE_OS_STRING "iphone-sim" +#elif TARGET_OS_IPHONE +#define DUK_USE_OS_STRING "iphone" +#elif TARGET_OS_MAC +#define DUK_USE_OS_STRING "osx" +#else +#define DUK_USE_OS_STRING "osx-unknown" +#endif + +/* Use _setjmp() on Apple by default, see GH-55. */ +#define DUK_JMPBUF_TYPE jmp_buf +#define DUK_SETJMP(jb) _setjmp((jb)) +#define DUK_LONGJMP(jb) _longjmp((jb), 1) +#elif defined(DUK_F_ORBIS) +/* --- Orbis --- */ +/* Orbis = PS4 */ +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_S +/* no parsing (not an error) */ +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include +#include +#include + +#define DUK_USE_OS_STRING "orbis" +#elif defined(DUK_F_OPENBSD) +/* --- OpenBSD --- */ +/* http://www.monkey.org/openbsd/archive/ports/0401/msg00089.html */ +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include +#include +#include + +#define DUK_USE_OS_STRING "openbsd" +#elif defined(DUK_F_BSD) +/* --- Generic BSD --- */ +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include +#include +#include + +#define DUK_USE_OS_STRING "bsd" +#elif defined(DUK_F_TOS) +/* --- Atari ST TOS --- */ +#define DUK_USE_DATE_NOW_TIME +#define DUK_USE_DATE_TZO_GMTIME +/* no parsing (not an error) */ +#define DUK_USE_DATE_FMT_STRFTIME +#include + +#define DUK_USE_OS_STRING "tos" + +/* TOS on M68K is always big endian. */ +#if !defined(DUK_USE_BYTEORDER) && defined(DUK_F_M68K) +#define DUK_USE_BYTEORDER 3 +#endif +#elif defined(DUK_F_AMIGAOS) +/* --- AmigaOS --- */ +#if defined(DUK_F_M68K) +/* AmigaOS on M68k */ +#define DUK_USE_DATE_NOW_TIME +#define DUK_USE_DATE_TZO_GMTIME +/* no parsing (not an error) */ +#define DUK_USE_DATE_FMT_STRFTIME +#include +#elif defined(DUK_F_PPC) +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#if !defined(UINTPTR_MAX) +#define UINTPTR_MAX UINT_MAX +#endif +#else +#error AmigaOS but not M68K/PPC, not supported now +#endif + +#define DUK_USE_OS_STRING "amigaos" + +/* AmigaOS on M68K or PPC is always big endian. */ +#if !defined(DUK_USE_BYTEORDER) && (defined(DUK_F_M68K) || defined(DUK_F_PPC)) +#define DUK_USE_BYTEORDER 3 +#endif +#elif defined(DUK_F_DURANGO) +/* --- Durango (XboxOne) --- */ +/* Durango = XboxOne + * Configuration is nearly identical to Windows, except for + * DUK_USE_DATE_TZO_WINDOWS. + */ + +/* Initial fix: disable secure CRT related warnings when compiling Duktape + * itself (must be defined before including Windows headers). Don't define + * for user code including duktape.h. + */ +#if defined(DUK_COMPILING_DUKTAPE) && !defined(_CRT_SECURE_NO_WARNINGS) +#define _CRT_SECURE_NO_WARNINGS +#endif + +/* MSVC does not have sys/param.h */ +#define DUK_USE_DATE_NOW_WINDOWS +#define DUK_USE_DATE_TZO_WINDOWS_NO_DST +/* Note: PRS and FMT are intentionally left undefined for now. This means + * there is no platform specific date parsing/formatting but there is still + * the ISO 8601 standard format. + */ +#if defined(DUK_COMPILING_DUKTAPE) +/* Only include when compiling Duktape to avoid polluting application build + * with a lot of unnecessary defines. + */ +#include +#endif + +#define DUK_USE_OS_STRING "durango" + +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 1 +#endif +#elif defined(DUK_F_WINDOWS) +/* --- Windows --- */ +/* Windows version can't obviously be determined at compile time, + * but _WIN32_WINNT indicates the minimum version targeted: + * - https://msdn.microsoft.com/en-us/library/6sehtctf.aspx + */ + +/* Initial fix: disable secure CRT related warnings when compiling Duktape + * itself (must be defined before including Windows headers). Don't define + * for user code including duktape.h. + */ +#if defined(DUK_COMPILING_DUKTAPE) && !defined(_CRT_SECURE_NO_WARNINGS) +#define _CRT_SECURE_NO_WARNINGS +#endif + +/* Windows 32-bit and 64-bit are currently the same. */ +/* MSVC does not have sys/param.h */ + +#if defined(DUK_COMPILING_DUKTAPE) +/* Only include when compiling Duktape to avoid polluting application build + * with a lot of unnecessary defines. + */ +#include +#endif + +/* GetSystemTimePreciseAsFileTime() available from Windows 8: + * https://msdn.microsoft.com/en-us/library/windows/desktop/hh706895(v=vs.85).aspx + */ +#if defined(DUK_USE_DATE_NOW_WINDOWS_SUBMS) || defined(DUK_USE_DATE_NOW_WINDOWS) +/* User forced provider. */ +#else +#if defined(_WIN32_WINNT) && (_WIN32_WINNT >= 0x0602) +#define DUK_USE_DATE_NOW_WINDOWS_SUBMS +#else +#define DUK_USE_DATE_NOW_WINDOWS +#endif +#endif + +#define DUK_USE_DATE_TZO_WINDOWS + +/* Note: PRS and FMT are intentionally left undefined for now. This means + * there is no platform specific date parsing/formatting but there is still + * the ISO 8601 standard format. + */ + +/* QueryPerformanceCounter() may go backwards in Windows XP, so enable for + * Vista and later: https://msdn.microsoft.com/en-us/library/windows/desktop/dn553408(v=vs.85).aspx#qpc_support_in_windows_versions + */ +#if !defined(DUK_USE_GET_MONOTONIC_TIME_WINDOWS_QPC) && \ + defined(_WIN32_WINNT) && (_WIN32_WINNT >= 0x0600) +#define DUK_USE_GET_MONOTONIC_TIME_WINDOWS_QPC +#endif + +#define DUK_USE_OS_STRING "windows" + +/* On Windows, assume we're little endian. Even Itanium which has a + * configurable endianness runs little endian in Windows. + */ +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 1 +#endif +#elif defined(DUK_F_FLASHPLAYER) +/* --- Flashplayer (Crossbridge) --- */ +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include +#include + +#define DUK_USE_OS_STRING "flashplayer" + +#if !defined(DUK_USE_BYTEORDER) && defined(DUK_F_FLASHPLAYER) +#define DUK_USE_BYTEORDER 1 +#endif +#elif defined(DUK_F_QNX) +/* --- QNX --- */ +#if defined(DUK_F_QNX) && defined(DUK_COMPILING_DUKTAPE) +/* See: /opt/qnx650/target/qnx6/usr/include/sys/platform.h */ +#define _XOPEN_SOURCE 600 +#define _POSIX_C_SOURCE 200112L +#endif + +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include +#include + +#define DUK_USE_OS_STRING "qnx" +#elif defined(DUK_F_TINSPIRE) +/* --- TI-Nspire --- */ +#if defined(DUK_COMPILING_DUKTAPE) && !defined(_XOPEN_SOURCE) +#define _XOPEN_SOURCE /* e.g. strptime */ +#endif + +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include +#include + +#define DUK_USE_OS_STRING "tinspire" +#elif defined(DUK_F_EMSCRIPTEN) +/* --- Emscripten --- */ +#if defined(DUK_COMPILING_DUKTAPE) +#if !defined(_POSIX_C_SOURCE) +#define _POSIX_C_SOURCE 200809L +#endif +#if !defined(_GNU_SOURCE) +#define _GNU_SOURCE /* e.g. getdate_r */ +#endif +#if !defined(_XOPEN_SOURCE) +#define _XOPEN_SOURCE /* e.g. strptime */ +#endif +#endif /* DUK_COMPILING_DUKTAPE */ + +#include +#if defined(DUK_F_BCC) +/* no endian.h */ +#else +#include +#endif /* DUK_F_BCC */ +#include +#include +#include +#include + +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME + +#define DUK_USE_OS_STRING "emscripten" +#elif defined(DUK_F_ANDROID) +/* --- Android --- */ +#if defined(DUK_COMPILING_DUKTAPE) +#if !defined(_POSIX_C_SOURCE) +#define _POSIX_C_SOURCE 200809L +#endif +#if !defined(_GNU_SOURCE) +#define _GNU_SOURCE /* e.g. getdate_r */ +#endif +#if !defined(_XOPEN_SOURCE) +#define _XOPEN_SOURCE /* e.g. strptime */ +#endif +#endif /* DUK_COMPILING_DUKTAPE */ + +#include +#if defined(DUK_F_BCC) +/* no endian.h or stdint.h */ +#else +#include +#include +#endif /* DUK_F_BCC */ +#include +#include +#include + +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME + +#if 0 /* XXX: safe condition? */ +#define DUK_USE_GET_MONOTONIC_TIME_CLOCK_GETTIME +#endif + +#define DUK_USE_OS_STRING "android" +#elif defined(DUK_F_LINUX) +/* --- Linux --- */ +#if defined(DUK_COMPILING_DUKTAPE) +#if !defined(_POSIX_C_SOURCE) +#define _POSIX_C_SOURCE 200809L +#endif +#if !defined(_GNU_SOURCE) +#define _GNU_SOURCE /* e.g. getdate_r */ +#endif +#if !defined(_XOPEN_SOURCE) +#define _XOPEN_SOURCE /* e.g. strptime */ +#endif +#endif /* DUK_COMPILING_DUKTAPE */ + +#include +#if defined(DUK_F_BCC) +/* no endian.h or stdint.h */ +#else +#include +#include +#endif /* DUK_F_BCC */ +#include +#include +#include + +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME + +#if 0 /* XXX: safe condition? */ +#define DUK_USE_GET_MONOTONIC_TIME_CLOCK_GETTIME +#endif + +#define DUK_USE_OS_STRING "linux" +#elif defined(DUK_F_SUN) +/* --- Solaris --- */ +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME + +#include +#if defined(DUK_F_OLD_SOLARIS) +/* Old Solaris with no endian.h, stdint.h */ +#define DUK_F_NO_STDINT_H +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 3 +#endif +#else /* DUK_F_OLD_SOLARIS */ +#include +#endif /* DUK_F_OLD_SOLARIS */ + +#include +#include +#include + +#define DUK_USE_OS_STRING "solaris" +#elif defined(DUK_F_AIX) +/* --- AIX --- */ +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 3 +#endif +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include + +#define DUK_USE_OS_STRING "aix" +#elif defined(DUK_F_HPUX) +/* --- HPUX --- */ +#define DUK_F_NO_STDINT_H +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 3 +#endif +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include + +#define DUK_USE_OS_STRING "hpux" +#elif defined(DUK_F_POSIX) +/* --- Generic POSIX --- */ +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include +#include +#include + +#define DUK_USE_OS_STRING "posix" +#elif defined(DUK_F_CYGWIN) +/* --- Cygwin --- */ +/* don't use strptime() for now */ +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#include +#include +#include + +#define DUK_JMPBUF_TYPE jmp_buf +#define DUK_SETJMP(jb) _setjmp((jb)) +#define DUK_LONGJMP(jb) _longjmp((jb), 1) + +#define DUK_USE_OS_STRING "windows" +#elif defined(DUK_F_UNIX) +/* --- Generic UNIX --- */ +#define DUK_USE_DATE_NOW_GETTIMEOFDAY +#define DUK_USE_DATE_TZO_GMTIME_R +#define DUK_USE_DATE_PRS_STRPTIME +#define DUK_USE_DATE_FMT_STRFTIME +#include +#include +#define DUK_USE_OS_STRING "unknown" +#else +/* --- Generic fallback --- */ +/* The most portable current time provider is time(), but it only has a + * one second resolution. + */ +#define DUK_USE_DATE_NOW_TIME + +/* The most portable way to figure out local time offset is gmtime(), + * but it's not thread safe so use with caution. + */ +#define DUK_USE_DATE_TZO_GMTIME + +/* Avoid custom date parsing and formatting for portability. */ +#undef DUK_USE_DATE_PRS_STRPTIME +#undef DUK_USE_DATE_FMT_STRFTIME + +/* Rely on C89 headers only; time.h must be here. */ +#include + +#define DUK_USE_OS_STRING "unknown" +#endif /* autodetect platform */ + +/* Shared includes: C89 */ +#include +#include +#include +#include /* varargs */ +#include +#include /* e.g. ptrdiff_t */ +#include +#include + +/* date.h is omitted, and included per platform */ + +/* Shared includes: stdint.h is C99 */ +#if defined(DUK_F_NO_STDINT_H) +/* stdint.h not available */ +#else +/* Technically C99 (C++11) but found in many systems. On some systems + * __STDC_LIMIT_MACROS and __STDC_CONSTANT_MACROS must be defined before + * including stdint.h (see above). + */ +#include +#endif + +/* is only included if needed, based on DUK_USE_xxx flags. */ + +/* + * Architecture autodetection + */ + +#if defined(DUK_F_X86) +/* --- x86 --- */ +#define DUK_USE_ARCH_STRING "x86" +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 1 +#endif + +#define DUK_USE_PACKED_TVAL + +/* FreeBSD, -m32, and clang prior to 5.0 has union aliasing issues which + * break duk_tval copying. Disable packed duk_tval automatically. + */ +#if defined(DUK_F_FREEBSD) && defined(DUK_F_X86) && \ + defined(__clang__) && defined(__clang_major__) && (__clang_major__ < 5) +#undef DUK_USE_PACKED_TVAL +#endif +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_X64) +/* --- x64 --- */ +#define DUK_USE_ARCH_STRING "x64" +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 1 +#endif +#undef DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_X32) +/* --- x32 --- */ +#define DUK_USE_ARCH_STRING "x32" +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 1 +#endif +#define DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_ARM32) +/* --- ARM 32-bit --- */ +#define DUK_USE_ARCH_STRING "arm32" +/* Byte order varies, so rely on autodetect. */ +#define DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_ARM64) +/* --- ARM 64-bit --- */ +#define DUK_USE_ARCH_STRING "arm64" +/* Byte order varies, so rely on autodetect. */ +#undef DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_MIPS32) +/* --- MIPS 32-bit --- */ +#define DUK_USE_ARCH_STRING "mips32" +/* MIPS byte order varies so rely on autodetection. */ +#define DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_MIPS64) +/* --- MIPS 64-bit --- */ +#define DUK_USE_ARCH_STRING "mips64" +/* MIPS byte order varies so rely on autodetection. */ +#undef DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_PPC32) +/* --- PowerPC 32-bit --- */ +#define DUK_USE_ARCH_STRING "ppc32" +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 3 +#endif +#define DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_PPC64) +/* --- PowerPC 64-bit --- */ +#define DUK_USE_ARCH_STRING "ppc64" +/* No forced byteorder (both little and big endian are possible). */ +#undef DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_SPARC32) +/* --- SPARC 32-bit --- */ +#define DUK_USE_ARCH_STRING "sparc32" +/* SPARC byte order varies so rely on autodetection. */ +#define DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_SPARC64) +/* --- SPARC 64-bit --- */ +#define DUK_USE_ARCH_STRING "sparc64" +/* SPARC byte order varies so rely on autodetection. */ +#undef DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_RISCV32) +/* --- RISC-V 32-bit --- */ +#define DUK_USE_ARCH_STRING "riscv32" +#define DUK_USE_BYTEORDER 1 +#define DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_RISCV64) +/* --- RISC-V 64-bit --- */ +#define DUK_USE_ARCH_STRING "riscv64" +#define DUK_USE_BYTEORDER 1 +#undef DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_SUPERH) +/* --- SuperH --- */ +#define DUK_USE_ARCH_STRING "sh" +/* Byte order varies, rely on autodetection. */ +#define DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_M68K) +/* --- Motorola 68k --- */ +#define DUK_USE_ARCH_STRING "m68k" +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 3 +#endif +#define DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#elif defined(DUK_F_EMSCRIPTEN) +/* --- Emscripten --- */ +#define DUK_USE_ARCH_STRING "emscripten" +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 1 +#endif +#undef DUK_USE_PACKED_TVAL +#define DUK_F_PACKED_TVAL_PROVIDED +#else +/* --- Generic --- */ +/* These are necessary wild guesses. */ +#define DUK_USE_ARCH_STRING "generic" +/* Rely on autodetection for byte order, alignment, and packed tval. */ +#endif /* autodetect architecture */ + +/* + * Compiler autodetection + */ + +#if defined(DUK_F_CLANG) +/* --- Clang --- */ +#if defined(DUK_F_C99) || defined(DUK_F_CPP11) +/* C99 / C++11 and above: rely on va_copy() which is required. */ +#define DUK_VA_COPY(dest,src) va_copy(dest,src) +#else +/* Clang: assume we have __va_copy() in non-C99 mode. */ +#define DUK_VA_COPY(dest,src) __va_copy(dest,src) +#endif + +#define DUK_NORETURN(decl) decl __attribute__((noreturn)) + +#if defined(__clang__) && defined(__has_builtin) +#if __has_builtin(__builtin_unreachable) +#define DUK_UNREACHABLE() do { __builtin_unreachable(); } while (0) +#endif +#endif + +#define DUK_USE_BRANCH_HINTS +#define DUK_LIKELY(x) __builtin_expect((x), 1) +#define DUK_UNLIKELY(x) __builtin_expect((x), 0) +#if defined(__clang__) && defined(__has_builtin) +#if __has_builtin(__builtin_unpredictable) +#define DUK_UNPREDICTABLE(x) __builtin_unpredictable((x)) +#endif +#endif + +#if defined(DUK_F_C99) || defined(DUK_F_CPP11) +#define DUK_NOINLINE __attribute__((noinline)) +#define DUK_INLINE inline +#define DUK_ALWAYS_INLINE inline __attribute__((always_inline)) +#endif + +/* DUK_HOT */ +/* DUK_COLD */ + +#if defined(DUK_F_DLL_BUILD) && defined(DUK_F_WINDOWS) +/* MSVC dllexport/dllimport: appropriate __declspec depends on whether we're + * compiling Duktape or the application. + */ +#if defined(DUK_COMPILING_DUKTAPE) +#define DUK_EXTERNAL_DECL extern __declspec(dllexport) +#define DUK_EXTERNAL __declspec(dllexport) +#else +#define DUK_EXTERNAL_DECL extern __declspec(dllimport) +#define DUK_EXTERNAL should_not_happen +#endif +#if defined(DUK_SINGLE_FILE) +#define DUK_INTERNAL_DECL static +#define DUK_INTERNAL static +#else +#define DUK_INTERNAL_DECL extern +#define DUK_INTERNAL /*empty*/ +#endif +#define DUK_LOCAL_DECL static +#define DUK_LOCAL static +#else +#define DUK_EXTERNAL_DECL __attribute__ ((visibility("default"))) extern +#define DUK_EXTERNAL __attribute__ ((visibility("default"))) +#if defined(DUK_SINGLE_FILE) +#if (defined(DUK_F_GCC_VERSION) && DUK_F_GCC_VERSION >= 30101) || defined(DUK_F_CLANG) +/* Minimize warnings for unused internal functions with GCC >= 3.1.1 and + * Clang. Based on documentation it should suffice to have the attribute + * in the declaration only, but in practice some warnings are generated unless + * the attribute is also applied to the definition. + */ +#define DUK_INTERNAL_DECL static __attribute__ ((unused)) +#define DUK_INTERNAL static __attribute__ ((unused)) +#else +#define DUK_INTERNAL_DECL static +#define DUK_INTERNAL static +#endif +#else +#if (defined(DUK_F_GCC_VERSION) && DUK_F_GCC_VERSION >= 30101) || defined(DUK_F_CLANG) +#define DUK_INTERNAL_DECL __attribute__ ((visibility("hidden"))) __attribute__ ((unused)) extern +#define DUK_INTERNAL __attribute__ ((visibility("hidden"))) __attribute__ ((unused)) +#else +#define DUK_INTERNAL_DECL __attribute__ ((visibility("hidden"))) extern +#define DUK_INTERNAL __attribute__ ((visibility("hidden"))) +#endif +#endif +#define DUK_LOCAL_DECL static +#define DUK_LOCAL static +#endif + +#if defined(DUK_F_CPP) +#define DUK_USE_COMPILER_STRING "clang" +#else +#define DUK_USE_COMPILER_STRING "clang" +#endif + +#undef DUK_USE_VARIADIC_MACROS +#if defined(DUK_F_C99) || defined(DUK_F_CPP11) +#define DUK_USE_VARIADIC_MACROS +#endif + +#define DUK_USE_UNION_INITIALIZERS + +#undef DUK_USE_FLEX_C99 +#undef DUK_USE_FLEX_ZEROSIZE +#undef DUK_USE_FLEX_ONESIZE +#if defined(DUK_F_C99) +#define DUK_USE_FLEX_C99 +#else +#define DUK_USE_FLEX_ZEROSIZE +#endif + +#define DUK_USE_CLANG_PRAGMAS +#define DUK_USE_PACK_CLANG_ATTR + +#if defined(__clang__) && defined(__has_builtin) +#if __has_builtin(__builtin_bswap64) +#define DUK_BSWAP64(x) ((duk_uint64_t) __builtin_bswap64((duk_uint64_t) (x))) +#endif +#if __has_builtin(__builtin_bswap32) +#define DUK_BSWAP32(x) ((duk_uint32_t) __builtin_bswap32((duk_uint32_t) (x))) +#endif +#if __has_builtin(__builtin_bswap16) +#define DUK_BSWAP16(x) ((duk_uint16_t) __builtin_bswap16((duk_uint16_t) (x))) +#endif +#endif +#elif defined(DUK_F_GCC) +/* --- GCC --- */ +#if defined(DUK_F_C99) || defined(DUK_F_CPP11) +/* C99 / C++11 and above: rely on va_copy() which is required. */ +#define DUK_VA_COPY(dest,src) va_copy(dest,src) +#else +/* GCC: assume we have __va_copy() in non-C99 mode. */ +#define DUK_VA_COPY(dest,src) __va_copy(dest,src) +#endif + +#if defined(DUK_F_GCC_VERSION) && (DUK_F_GCC_VERSION >= 20500L) && (DUK_F_GCC_VERSION < 50000L) +/* Since gcc-2.5. + * + * Disabled temporarily in GCC 5+ because of an unresolved noreturn-related + * issue: https://github.com/svaarala/duktape/issues/2155. + */ +#define DUK_NORETURN(decl) decl __attribute__((noreturn)) +#endif + +#if defined(DUK_F_GCC_VERSION) && (DUK_F_GCC_VERSION >= 40500L) +/* Since gcc-4.5. */ +#define DUK_UNREACHABLE() do { __builtin_unreachable(); } while (0) +#endif + +#define DUK_USE_BRANCH_HINTS +#if defined(DUK_F_GCC_VERSION) && (DUK_F_GCC_VERSION >= 40500L) +/* GCC: test not very accurate; enable only in relatively recent builds + * because of bugs in gcc-4.4 (http://lists.debian.org/debian-gcc/2010/04/msg00000.html) + */ +#define DUK_LIKELY(x) __builtin_expect((x), 1) +#define DUK_UNLIKELY(x) __builtin_expect((x), 0) +#endif +/* XXX: equivalent of clang __builtin_unpredictable? */ + +#if (defined(DUK_F_C99) || defined(DUK_F_CPP11)) && \ + defined(DUK_F_GCC_VERSION) && (DUK_F_GCC_VERSION >= 30101) +#define DUK_NOINLINE __attribute__((noinline)) +#define DUK_INLINE inline +#define DUK_ALWAYS_INLINE inline __attribute__((always_inline)) +#endif + +#if (defined(DUK_F_C99) || defined(DUK_F_CPP11)) && \ + defined(DUK_F_GCC_VERSION) && (DUK_F_GCC_VERSION >= 40300) +#define DUK_HOT __attribute__((hot)) +#define DUK_COLD __attribute__((cold)) +#endif + +#if defined(DUK_F_DLL_BUILD) && defined(DUK_F_WINDOWS) +/* MSVC dllexport/dllimport: appropriate __declspec depends on whether we're + * compiling Duktape or the application. + */ +#if defined(DUK_COMPILING_DUKTAPE) +#define DUK_EXTERNAL_DECL extern __declspec(dllexport) +#define DUK_EXTERNAL __declspec(dllexport) +#else +#define DUK_EXTERNAL_DECL extern __declspec(dllimport) +#define DUK_EXTERNAL should_not_happen +#endif +#if defined(DUK_SINGLE_FILE) +#define DUK_INTERNAL_DECL static +#define DUK_INTERNAL static +#else +#define DUK_INTERNAL_DECL extern +#define DUK_INTERNAL /*empty*/ +#endif +#define DUK_LOCAL_DECL static +#define DUK_LOCAL static +#elif defined(DUK_F_GCC_VERSION) && (DUK_F_GCC_VERSION >= 40000) +#define DUK_EXTERNAL_DECL __attribute__ ((visibility("default"))) extern +#define DUK_EXTERNAL __attribute__ ((visibility("default"))) +#if defined(DUK_SINGLE_FILE) +#if (defined(DUK_F_GCC_VERSION) && DUK_F_GCC_VERSION >= 30101) || defined(DUK_F_CLANG) +/* Minimize warnings for unused internal functions with GCC >= 3.1.1 and + * Clang. Based on documentation it should suffice to have the attribute + * in the declaration only, but in practice some warnings are generated unless + * the attribute is also applied to the definition. + */ +#define DUK_INTERNAL_DECL static __attribute__ ((unused)) +#define DUK_INTERNAL static __attribute__ ((unused)) +#else +#define DUK_INTERNAL_DECL static +#define DUK_INTERNAL static +#endif +#else +#if (defined(DUK_F_GCC_VERSION) && DUK_F_GCC_VERSION >= 30101) || defined(DUK_F_CLANG) +#define DUK_INTERNAL_DECL __attribute__ ((visibility("hidden"))) __attribute__ ((unused)) extern +#define DUK_INTERNAL __attribute__ ((visibility("hidden"))) __attribute__ ((unused)) +#else +#define DUK_INTERNAL_DECL __attribute__ ((visibility("hidden"))) extern +#define DUK_INTERNAL __attribute__ ((visibility("hidden"))) +#endif +#endif +#define DUK_LOCAL_DECL static +#define DUK_LOCAL static +#endif + +#if defined(DUK_F_MINGW) +#if defined(DUK_F_CPP) +#define DUK_USE_COMPILER_STRING "mingw++" +#else +#define DUK_USE_COMPILER_STRING "mingw" +#endif +#else +#if defined(DUK_F_CPP) +#define DUK_USE_COMPILER_STRING "g++" +#else +#define DUK_USE_COMPILER_STRING "gcc" +#endif +#endif + +#undef DUK_USE_VARIADIC_MACROS +#if defined(DUK_F_C99) || (defined(DUK_F_CPP11) && defined(__GNUC__)) +#define DUK_USE_VARIADIC_MACROS +#endif + +#define DUK_USE_UNION_INITIALIZERS + +#undef DUK_USE_FLEX_C99 +#undef DUK_USE_FLEX_ZEROSIZE +#undef DUK_USE_FLEX_ONESIZE +#if defined(DUK_F_C99) +#define DUK_USE_FLEX_C99 +#else +#define DUK_USE_FLEX_ZEROSIZE +#endif + +/* Since 4.6 one can '#pragma GCC diagnostic push/pop'. */ +#if defined(DUK_F_GCC_VERSION) && (DUK_F_GCC_VERSION >= 40600) +#define DUK_USE_GCC_PRAGMAS +#else +#undef DUK_USE_GCC_PRAGMAS +#endif + +#define DUK_USE_PACK_GCC_ATTR + +/* Availability varies based on platform (between GCC 4.4 and 4.8), and there + * are apparently some bugs in GCC 4.x. Check for GCC 5.0 before enabling + * these to be safe. + */ +#if defined(DUK_F_GCC_VERSION) && (DUK_F_GCC_VERSION >= 50000L) +#define DUK_BSWAP64(x) ((duk_uint64_t) __builtin_bswap64((duk_uint64_t) (x))) +#define DUK_BSWAP32(x) ((duk_uint32_t) __builtin_bswap32((duk_uint32_t) (x))) +#define DUK_BSWAP16(x) ((duk_uint16_t) __builtin_bswap16((duk_uint16_t) (x))) +#endif +#elif defined(DUK_F_MSVC) +/* --- MSVC --- */ +/* http://msdn.microsoft.com/en-us/library/aa235362(VS.60).aspx */ +#define DUK_NORETURN(decl) __declspec(noreturn) decl + +/* XXX: DUK_UNREACHABLE for msvc? */ + +#undef DUK_USE_BRANCH_HINTS + +/* XXX: DUK_LIKELY, DUK_UNLIKELY for msvc? */ +/* XXX: DUK_NOINLINE, DUK_INLINE, DUK_ALWAYS_INLINE for msvc? */ + +#if defined(DUK_F_DLL_BUILD) && defined(DUK_F_WINDOWS) +/* MSVC dllexport/dllimport: appropriate __declspec depends on whether we're + * compiling Duktape or the application. + */ +#if defined(DUK_COMPILING_DUKTAPE) +#define DUK_EXTERNAL_DECL extern __declspec(dllexport) +#define DUK_EXTERNAL __declspec(dllexport) +#else +#define DUK_EXTERNAL_DECL extern __declspec(dllimport) +#define DUK_EXTERNAL should_not_happen +#endif +#if defined(DUK_SINGLE_FILE) +#define DUK_INTERNAL_DECL static +#define DUK_INTERNAL static +#else +#define DUK_INTERNAL_DECL extern +#define DUK_INTERNAL /*empty*/ +#endif +#define DUK_LOCAL_DECL static +#define DUK_LOCAL static +#endif + +#if defined(DUK_F_CPP) +#define DUK_USE_COMPILER_STRING "msvc++" +#else +#define DUK_USE_COMPILER_STRING "msvc" +#endif + +#undef DUK_USE_VARIADIC_MACROS +#if defined(DUK_F_C99) +#define DUK_USE_VARIADIC_MACROS +#elif defined(_MSC_VER) && (_MSC_VER >= 1400) +/* VS2005+ should have variadic macros even when they're not C99. */ +#define DUK_USE_VARIADIC_MACROS +#endif + +#undef DUK_USE_UNION_INITIALIZERS +#if defined(_MSC_VER) && (_MSC_VER >= 1800) +/* VS2013+ supports union initializers but there's a bug involving union-inside-struct: + * https://connect.microsoft.com/VisualStudio/feedback/details/805981 + * The bug was fixed (at least) in VS2015 so check for VS2015 for now: + * https://blogs.msdn.microsoft.com/vcblog/2015/07/01/c-compiler-front-end-fixes-in-vs2015/ + * Manually tested using VS2013, CL reports 18.00.31101, so enable for VS2013 too. + */ +#define DUK_USE_UNION_INITIALIZERS +#endif + +#undef DUK_USE_FLEX_C99 +#undef DUK_USE_FLEX_ZEROSIZE +#undef DUK_USE_FLEX_ONESIZE +#if defined(DUK_F_C99) +#define DUK_USE_FLEX_C99 +#else +#define DUK_USE_FLEX_ZEROSIZE +#endif + +#undef DUK_USE_GCC_PRAGMAS + +#define DUK_USE_PACK_MSVC_PRAGMA + +/* These have been tested from VS2008 onwards; may work in older VS versions + * too but not enabled by default. + */ +#if defined(_MSC_VER) && (_MSC_VER >= 1500) +#define DUK_NOINLINE __declspec(noinline) +#define DUK_INLINE __inline +#define DUK_ALWAYS_INLINE __forceinline +#endif + +#if defined(_MSC_VER) && (_MSC_VER >= 1900) +#define DUK_SNPRINTF snprintf +#define DUK_VSNPRINTF vsnprintf +#else +/* (v)snprintf() is missing before MSVC 2015. Note that _(v)snprintf() does + * NOT NUL terminate on truncation, but Duktape code never assumes that. + * http://stackoverflow.com/questions/2915672/snprintf-and-visual-studio-2010 + */ +#define DUK_SNPRINTF _snprintf +#define DUK_VSNPRINTF _vsnprintf +#endif + +/* Avoid warning when doing DUK_UNREF(some_function). */ +#if defined(_MSC_VER) && (_MSC_VER < 1500) +#pragma warning(disable: 4100 4101 4550 4551) +#define DUK_UNREF(x) +#else +#define DUK_UNREF(x) do { __pragma(warning(suppress:4100 4101 4550 4551)) (x); } while (0) +#endif + +/* Older versions of MSVC don't support the LL/ULL suffix. */ +#define DUK_U64_CONSTANT(x) x##ui64 +#define DUK_I64_CONSTANT(x) x##i64 +#elif defined(DUK_F_EMSCRIPTEN) +/* --- Emscripten --- */ +#define DUK_NORETURN(decl) decl __attribute__((noreturn)) + +#if defined(__clang__) && defined(__has_builtin) +#if __has_builtin(__builtin_unreachable) +#define DUK_UNREACHABLE() do { __builtin_unreachable(); } while (0) +#endif +#endif + +#define DUK_USE_BRANCH_HINTS +#define DUK_LIKELY(x) __builtin_expect((x), 1) +#define DUK_UNLIKELY(x) __builtin_expect((x), 0) +#if defined(__clang__) && defined(__has_builtin) +#if __has_builtin(__builtin_unpredictable) +#define DUK_UNPREDICTABLE(x) __builtin_unpredictable((x)) +#endif +#endif + +#if defined(DUK_F_C99) || defined(DUK_F_CPP11) +#define DUK_NOINLINE __attribute__((noinline)) +#define DUK_INLINE inline +#define DUK_ALWAYS_INLINE inline __attribute__((always_inline)) +#endif + +#define DUK_EXTERNAL_DECL __attribute__ ((visibility("default"))) extern +#define DUK_EXTERNAL __attribute__ ((visibility("default"))) +#if defined(DUK_SINGLE_FILE) +#if (defined(DUK_F_GCC_VERSION) && DUK_F_GCC_VERSION >= 30101) || defined(DUK_F_CLANG) +/* Minimize warnings for unused internal functions with GCC >= 3.1.1 and + * Clang. Based on documentation it should suffice to have the attribute + * in the declaration only, but in practice some warnings are generated unless + * the attribute is also applied to the definition. + */ +#define DUK_INTERNAL_DECL static __attribute__ ((unused)) +#define DUK_INTERNAL static __attribute__ ((unused)) +#else +#define DUK_INTERNAL_DECL static +#define DUK_INTERNAL static +#endif +#else +#if (defined(DUK_F_GCC_VERSION) && DUK_F_GCC_VERSION >= 30101) || defined(DUK_F_CLANG) +#define DUK_INTERNAL_DECL __attribute__ ((visibility("hidden"))) __attribute__ ((unused)) extern +#define DUK_INTERNAL __attribute__ ((visibility("hidden"))) __attribute__ ((unused)) +#else +#define DUK_INTERNAL_DECL __attribute__ ((visibility("hidden"))) extern +#define DUK_INTERNAL __attribute__ ((visibility("hidden"))) +#endif +#endif +#define DUK_LOCAL_DECL static +#define DUK_LOCAL static + +#define DUK_USE_COMPILER_STRING "emscripten" + +#undef DUK_USE_VARIADIC_MACROS +#if defined(DUK_F_C99) || defined(DUK_F_CPP11) +#define DUK_USE_VARIADIC_MACROS +#endif + +#define DUK_USE_UNION_INITIALIZERS + +#undef DUK_USE_FLEX_C99 +#undef DUK_USE_FLEX_ZEROSIZE +#undef DUK_USE_FLEX_ONESIZE +#if defined(DUK_F_C99) +#define DUK_USE_FLEX_C99 +#else +#define DUK_USE_FLEX_ZEROSIZE +#endif + +#undef DUK_USE_GCC_PRAGMAS +#define DUK_USE_PACK_CLANG_ATTR +#elif defined(DUK_F_TINYC) +/* --- TinyC --- */ +#undef DUK_USE_BRANCH_HINTS + +#if defined(DUK_F_CPP) +#define DUK_USE_COMPILER_STRING "tinyc++" +#else +#define DUK_USE_COMPILER_STRING "tinyc" +#endif + +/* http://bellard.org/tcc/tcc-doc.html#SEC7 */ +#define DUK_USE_VARIADIC_MACROS + +#define DUK_USE_UNION_INITIALIZERS + +/* Most portable, wastes space */ +#define DUK_USE_FLEX_ONESIZE + +/* Most portable, potentially wastes space */ +#define DUK_USE_PACK_DUMMY_MEMBER +#elif defined(DUK_F_VBCC) +/* --- VBCC --- */ +#undef DUK_USE_BRANCH_HINTS + +#if defined(DUK_F_CPP) +#define DUK_USE_COMPILER_STRING "vbcc-c++" +#else +#define DUK_USE_COMPILER_STRING "vbcc" +#endif + +#undef DUK_USE_VARIADIC_MACROS +#if defined(DUK_F_C99) || defined(DUK_F_CPP11) +#define DUK_USE_VARIADIC_MACROS +#endif + +/* VBCC supports C99 so check only for C99 for union initializer support. + * Designated union initializers would possibly work even without a C99 check. + */ +#undef DUK_USE_UNION_INITIALIZERS +#if defined(DUK_F_C99) +#define DUK_USE_UNION_INITIALIZERS +#endif + +#define DUK_USE_FLEX_ZEROSIZE +#define DUK_USE_PACK_DUMMY_MEMBER +#elif defined(DUK_F_BCC) +/* --- Bruce's C compiler --- */ +#undef DUK_USE_BRANCH_HINTS + +#if defined(DUK_F_CPP) +#define DUK_USE_COMPILER_STRING "bcc++" +#else +#define DUK_USE_COMPILER_STRING "bcc" +#endif + +/* Most portable */ +#undef DUK_USE_VARIADIC_MACROS + +/* Most portable, wastes space */ +#undef DUK_USE_UNION_INITIALIZERS + +/* Most portable, wastes space */ +#define DUK_USE_FLEX_ONESIZE + +/* Most portable, potentially wastes space */ +#define DUK_USE_PACK_DUMMY_MEMBER + +/* BCC, assume we're on x86. */ +#if !defined(DUK_USE_BYTEORDER) +#define DUK_USE_BYTEORDER 1 +#endif +#else +/* --- Generic --- */ +#undef DUK_USE_BRANCH_HINTS + +#if defined(DUK_F_CPP) +#define DUK_USE_COMPILER_STRING "generic-c++" +#else +#define DUK_USE_COMPILER_STRING "generic" +#endif + +#undef DUK_USE_VARIADIC_MACROS +#if defined(DUK_F_C99) || defined(DUK_F_CPP11) +#define DUK_USE_VARIADIC_MACROS +#endif + +/* C++ doesn't have standard designated union initializers ({ .foo = 1 }). */ +#undef DUK_USE_UNION_INITIALIZERS +#if defined(DUK_F_C99) +#define DUK_USE_UNION_INITIALIZERS +#endif + +/* Most portable, wastes space */ +#define DUK_USE_FLEX_ONESIZE + +/* Most portable, potentially wastes space */ +#define DUK_USE_PACK_DUMMY_MEMBER +#endif /* autodetect compiler */ + +/* uclibc */ +#if defined(__UCLIBC__) +#define DUK_F_UCLIBC +#endif + +/* + * Wrapper typedefs and constants for integer types, also sanity check types. + * + * C99 typedefs are quite good but not always available, and we want to avoid + * forcibly redefining the C99 typedefs. So, there are Duktape wrappers for + * all C99 typedefs and Duktape code should only use these typedefs. Type + * detection when C99 is not supported is best effort and may end up detecting + * some types incorrectly. + * + * Pointer sizes are a portability problem: pointers to different types may + * have a different size and function pointers are very difficult to manage + * portably. + * + * http://en.wikipedia.org/wiki/C_data_types#Fixed-width_integer_types + * + * Note: there's an interesting corner case when trying to define minimum + * signed integer value constants which leads to the current workaround of + * defining e.g. -0x80000000 as (-0x7fffffffL - 1L). See doc/code-issues.txt + * for a longer discussion. + * + * Note: avoid typecasts and computations in macro integer constants as they + * can then no longer be used in macro relational expressions (such as + * #if DUK_SIZE_MAX < 0xffffffffUL). There is internal code which relies on + * being able to compare DUK_SIZE_MAX against a limit. + */ + +/* XXX: add feature options to force basic types from outside? */ + +#if !defined(INT_MAX) +#error INT_MAX not defined +#endif + +/* Check that architecture is two's complement, standard C allows e.g. + * INT_MIN to be -2**31+1 (instead of -2**31). + */ +#if defined(INT_MAX) && defined(INT_MIN) +#if INT_MAX != -(INT_MIN + 1) +#error platform does not seem complement of two +#endif +#else +#error cannot check complement of two +#endif + +/* Pointer size determination based on __WORDSIZE or architecture when + * that's not available. + */ +#if defined(DUK_F_X86) || defined(DUK_F_X32) || \ + defined(DUK_F_M68K) || defined(DUK_F_PPC32) || \ + defined(DUK_F_BCC) || \ + (defined(__WORDSIZE) && (__WORDSIZE == 32)) || \ + ((defined(DUK_F_OLD_SOLARIS) || defined(DUK_F_AIX) || \ + defined(DUK_F_HPUX)) && defined(_ILP32)) || \ + defined(DUK_F_ARM32) +#define DUK_F_32BIT_PTRS +#elif defined(DUK_F_X64) || \ + (defined(__WORDSIZE) && (__WORDSIZE == 64)) || \ + ((defined(DUK_F_OLD_SOLARIS) || defined(DUK_F_AIX) || \ + defined(DUK_F_HPUX)) && defined(_LP64)) || \ + defined(DUK_F_ARM64) +#define DUK_F_64BIT_PTRS +#else +/* not sure, not needed with C99 anyway */ +#endif + +/* Intermediate define for 'have inttypes.h' */ +#undef DUK_F_HAVE_INTTYPES +#if defined(__STDC_VERSION__) && (__STDC_VERSION__ >= 199901L) && \ + !(defined(DUK_F_AMIGAOS) && defined(DUK_F_VBCC)) +/* vbcc + AmigaOS has C99 but no inttypes.h */ +#define DUK_F_HAVE_INTTYPES +#elif defined(__cplusplus) && (__cplusplus >= 201103L) +/* C++11 apparently ratified stdint.h */ +#define DUK_F_HAVE_INTTYPES +#endif + +/* Basic integer typedefs and limits, preferably from inttypes.h, otherwise + * through automatic detection. + */ +#if defined(DUK_F_HAVE_INTTYPES) +/* C99 or compatible */ + +#define DUK_F_HAVE_64BIT +#include + +typedef uint8_t duk_uint8_t; +typedef int8_t duk_int8_t; +typedef uint16_t duk_uint16_t; +typedef int16_t duk_int16_t; +typedef uint32_t duk_uint32_t; +typedef int32_t duk_int32_t; +typedef uint64_t duk_uint64_t; +typedef int64_t duk_int64_t; +typedef uint_least8_t duk_uint_least8_t; +typedef int_least8_t duk_int_least8_t; +typedef uint_least16_t duk_uint_least16_t; +typedef int_least16_t duk_int_least16_t; +typedef uint_least32_t duk_uint_least32_t; +typedef int_least32_t duk_int_least32_t; +typedef uint_least64_t duk_uint_least64_t; +typedef int_least64_t duk_int_least64_t; +typedef uint_fast8_t duk_uint_fast8_t; +typedef int_fast8_t duk_int_fast8_t; +typedef uint_fast16_t duk_uint_fast16_t; +typedef int_fast16_t duk_int_fast16_t; +typedef uint_fast32_t duk_uint_fast32_t; +typedef int_fast32_t duk_int_fast32_t; +typedef uint_fast64_t duk_uint_fast64_t; +typedef int_fast64_t duk_int_fast64_t; +typedef uintptr_t duk_uintptr_t; +typedef intptr_t duk_intptr_t; +typedef uintmax_t duk_uintmax_t; +typedef intmax_t duk_intmax_t; + +#define DUK_UINT8_MIN 0 +#define DUK_UINT8_MAX UINT8_MAX +#define DUK_INT8_MIN INT8_MIN +#define DUK_INT8_MAX INT8_MAX +#define DUK_UINT_LEAST8_MIN 0 +#define DUK_UINT_LEAST8_MAX UINT_LEAST8_MAX +#define DUK_INT_LEAST8_MIN INT_LEAST8_MIN +#define DUK_INT_LEAST8_MAX INT_LEAST8_MAX +#define DUK_UINT_FAST8_MIN 0 +#define DUK_UINT_FAST8_MAX UINT_FAST8_MAX +#define DUK_INT_FAST8_MIN INT_FAST8_MIN +#define DUK_INT_FAST8_MAX INT_FAST8_MAX +#define DUK_UINT16_MIN 0 +#define DUK_UINT16_MAX UINT16_MAX +#define DUK_INT16_MIN INT16_MIN +#define DUK_INT16_MAX INT16_MAX +#define DUK_UINT_LEAST16_MIN 0 +#define DUK_UINT_LEAST16_MAX UINT_LEAST16_MAX +#define DUK_INT_LEAST16_MIN INT_LEAST16_MIN +#define DUK_INT_LEAST16_MAX INT_LEAST16_MAX +#define DUK_UINT_FAST16_MIN 0 +#define DUK_UINT_FAST16_MAX UINT_FAST16_MAX +#define DUK_INT_FAST16_MIN INT_FAST16_MIN +#define DUK_INT_FAST16_MAX INT_FAST16_MAX +#define DUK_UINT32_MIN 0 +#define DUK_UINT32_MAX UINT32_MAX +#define DUK_INT32_MIN INT32_MIN +#define DUK_INT32_MAX INT32_MAX +#define DUK_UINT_LEAST32_MIN 0 +#define DUK_UINT_LEAST32_MAX UINT_LEAST32_MAX +#define DUK_INT_LEAST32_MIN INT_LEAST32_MIN +#define DUK_INT_LEAST32_MAX INT_LEAST32_MAX +#define DUK_UINT_FAST32_MIN 0 +#define DUK_UINT_FAST32_MAX UINT_FAST32_MAX +#define DUK_INT_FAST32_MIN INT_FAST32_MIN +#define DUK_INT_FAST32_MAX INT_FAST32_MAX +#define DUK_UINT64_MIN 0 +#define DUK_UINT64_MAX UINT64_MAX +#define DUK_INT64_MIN INT64_MIN +#define DUK_INT64_MAX INT64_MAX +#define DUK_UINT_LEAST64_MIN 0 +#define DUK_UINT_LEAST64_MAX UINT_LEAST64_MAX +#define DUK_INT_LEAST64_MIN INT_LEAST64_MIN +#define DUK_INT_LEAST64_MAX INT_LEAST64_MAX +#define DUK_UINT_FAST64_MIN 0 +#define DUK_UINT_FAST64_MAX UINT_FAST64_MAX +#define DUK_INT_FAST64_MIN INT_FAST64_MIN +#define DUK_INT_FAST64_MAX INT_FAST64_MAX + +#define DUK_UINTPTR_MIN 0 +#define DUK_UINTPTR_MAX UINTPTR_MAX +#define DUK_INTPTR_MIN INTPTR_MIN +#define DUK_INTPTR_MAX INTPTR_MAX + +#define DUK_UINTMAX_MIN 0 +#define DUK_UINTMAX_MAX UINTMAX_MAX +#define DUK_INTMAX_MIN INTMAX_MIN +#define DUK_INTMAX_MAX INTMAX_MAX + +#define DUK_SIZE_MIN 0 +#define DUK_SIZE_MAX SIZE_MAX +#undef DUK_SIZE_MAX_COMPUTED + +#else /* C99 types */ + +/* When C99 types are not available, we use heuristic detection to get + * the basic 8, 16, 32, and (possibly) 64 bit types. The fast/least + * types are then assumed to be exactly the same for now: these could + * be improved per platform but C99 types are very often now available. + * 64-bit types are not available on all platforms; this is OK at least + * on 32-bit platforms. + * + * This detection code is necessarily a bit hacky and can provide typedefs + * and defines that won't work correctly on some exotic platform. + */ + +#if (defined(CHAR_BIT) && (CHAR_BIT == 8)) || \ + (defined(UCHAR_MAX) && (UCHAR_MAX == 255)) +typedef unsigned char duk_uint8_t; +typedef signed char duk_int8_t; +#else +#error cannot detect 8-bit type +#endif + +#if defined(USHRT_MAX) && (USHRT_MAX == 65535UL) +typedef unsigned short duk_uint16_t; +typedef signed short duk_int16_t; +#elif defined(UINT_MAX) && (UINT_MAX == 65535UL) +/* On some platforms int is 16-bit but long is 32-bit (e.g. PureC) */ +typedef unsigned int duk_uint16_t; +typedef signed int duk_int16_t; +#else +#error cannot detect 16-bit type +#endif + +#if defined(UINT_MAX) && (UINT_MAX == 4294967295UL) +typedef unsigned int duk_uint32_t; +typedef signed int duk_int32_t; +#elif defined(ULONG_MAX) && (ULONG_MAX == 4294967295UL) +/* On some platforms int is 16-bit but long is 32-bit (e.g. PureC) */ +typedef unsigned long duk_uint32_t; +typedef signed long duk_int32_t; +#else +#error cannot detect 32-bit type +#endif + +/* 64-bit type detection is a bit tricky. + * + * ULLONG_MAX is a standard define. __LONG_LONG_MAX__ and __ULONG_LONG_MAX__ + * are used by at least GCC (even if system headers don't provide ULLONG_MAX). + * Some GCC variants may provide __LONG_LONG_MAX__ but not __ULONG_LONG_MAX__. + * + * ULL / LL constants are rejected / warned about by some compilers, even if + * the compiler has a 64-bit type and the compiler/system headers provide an + * unsupported constant (ULL/LL)! Try to avoid using ULL / LL constants. + * As a side effect we can only check that e.g. ULONG_MAX is larger than 32 + * bits but can't be sure it is exactly 64 bits. Self tests will catch such + * cases. + */ +#undef DUK_F_HAVE_64BIT +#if !defined(DUK_F_HAVE_64BIT) && defined(ULONG_MAX) +#if (ULONG_MAX > 4294967295UL) +#define DUK_F_HAVE_64BIT +typedef unsigned long duk_uint64_t; +typedef signed long duk_int64_t; +#endif +#endif +#if !defined(DUK_F_HAVE_64BIT) && defined(ULLONG_MAX) +#if (ULLONG_MAX > 4294967295UL) +#define DUK_F_HAVE_64BIT +typedef unsigned long long duk_uint64_t; +typedef signed long long duk_int64_t; +#endif +#endif +#if !defined(DUK_F_HAVE_64BIT) && defined(__ULONG_LONG_MAX__) +#if (__ULONG_LONG_MAX__ > 4294967295UL) +#define DUK_F_HAVE_64BIT +typedef unsigned long long duk_uint64_t; +typedef signed long long duk_int64_t; +#endif +#endif +#if !defined(DUK_F_HAVE_64BIT) && defined(__LONG_LONG_MAX__) +#if (__LONG_LONG_MAX__ > 2147483647L) +#define DUK_F_HAVE_64BIT +typedef unsigned long long duk_uint64_t; +typedef signed long long duk_int64_t; +#endif +#endif +#if !defined(DUK_F_HAVE_64BIT) && defined(DUK_F_MINGW) +#define DUK_F_HAVE_64BIT +typedef unsigned long duk_uint64_t; +typedef signed long duk_int64_t; +#endif +#if !defined(DUK_F_HAVE_64BIT) && defined(DUK_F_MSVC) +#define DUK_F_HAVE_64BIT +typedef unsigned __int64 duk_uint64_t; +typedef signed __int64 duk_int64_t; +#endif +#if !defined(DUK_F_HAVE_64BIT) +/* cannot detect 64-bit type, not always needed so don't error */ +#endif + +typedef duk_uint8_t duk_uint_least8_t; +typedef duk_int8_t duk_int_least8_t; +typedef duk_uint16_t duk_uint_least16_t; +typedef duk_int16_t duk_int_least16_t; +typedef duk_uint32_t duk_uint_least32_t; +typedef duk_int32_t duk_int_least32_t; +typedef duk_uint8_t duk_uint_fast8_t; +typedef duk_int8_t duk_int_fast8_t; +typedef duk_uint16_t duk_uint_fast16_t; +typedef duk_int16_t duk_int_fast16_t; +typedef duk_uint32_t duk_uint_fast32_t; +typedef duk_int32_t duk_int_fast32_t; +#if defined(DUK_F_HAVE_64BIT) +typedef duk_uint64_t duk_uint_least64_t; +typedef duk_int64_t duk_int_least64_t; +typedef duk_uint64_t duk_uint_fast64_t; +typedef duk_int64_t duk_int_fast64_t; +#endif +#if defined(DUK_F_HAVE_64BIT) +typedef duk_uint64_t duk_uintmax_t; +typedef duk_int64_t duk_intmax_t; +#else +typedef duk_uint32_t duk_uintmax_t; +typedef duk_int32_t duk_intmax_t; +#endif + +/* Note: the funny looking computations for signed minimum 16-bit, 32-bit, and + * 64-bit values are intentional as the obvious forms (e.g. -0x80000000L) are + * -not- portable. See code-issues.txt for a detailed discussion. + */ +#define DUK_UINT8_MIN 0UL +#define DUK_UINT8_MAX 0xffUL +#define DUK_INT8_MIN (-0x80L) +#define DUK_INT8_MAX 0x7fL +#define DUK_UINT_LEAST8_MIN 0UL +#define DUK_UINT_LEAST8_MAX 0xffUL +#define DUK_INT_LEAST8_MIN (-0x80L) +#define DUK_INT_LEAST8_MAX 0x7fL +#define DUK_UINT_FAST8_MIN 0UL +#define DUK_UINT_FAST8_MAX 0xffUL +#define DUK_INT_FAST8_MIN (-0x80L) +#define DUK_INT_FAST8_MAX 0x7fL +#define DUK_UINT16_MIN 0UL +#define DUK_UINT16_MAX 0xffffUL +#define DUK_INT16_MIN (-0x7fffL - 1L) +#define DUK_INT16_MAX 0x7fffL +#define DUK_UINT_LEAST16_MIN 0UL +#define DUK_UINT_LEAST16_MAX 0xffffUL +#define DUK_INT_LEAST16_MIN (-0x7fffL - 1L) +#define DUK_INT_LEAST16_MAX 0x7fffL +#define DUK_UINT_FAST16_MIN 0UL +#define DUK_UINT_FAST16_MAX 0xffffUL +#define DUK_INT_FAST16_MIN (-0x7fffL - 1L) +#define DUK_INT_FAST16_MAX 0x7fffL +#define DUK_UINT32_MIN 0UL +#define DUK_UINT32_MAX 0xffffffffUL +#define DUK_INT32_MIN (-0x7fffffffL - 1L) +#define DUK_INT32_MAX 0x7fffffffL +#define DUK_UINT_LEAST32_MIN 0UL +#define DUK_UINT_LEAST32_MAX 0xffffffffUL +#define DUK_INT_LEAST32_MIN (-0x7fffffffL - 1L) +#define DUK_INT_LEAST32_MAX 0x7fffffffL +#define DUK_UINT_FAST32_MIN 0UL +#define DUK_UINT_FAST32_MAX 0xffffffffUL +#define DUK_INT_FAST32_MIN (-0x7fffffffL - 1L) +#define DUK_INT_FAST32_MAX 0x7fffffffL + +/* 64-bit constants. Since LL / ULL constants are not always available, + * use computed values. These values can't be used in preprocessor + * comparisons; flag them as such. + */ +#if defined(DUK_F_HAVE_64BIT) +#define DUK_UINT64_MIN ((duk_uint64_t) 0) +#define DUK_UINT64_MAX ((duk_uint64_t) -1) +#define DUK_INT64_MIN ((duk_int64_t) (~(DUK_UINT64_MAX >> 1))) +#define DUK_INT64_MAX ((duk_int64_t) (DUK_UINT64_MAX >> 1)) +#define DUK_UINT_LEAST64_MIN DUK_UINT64_MIN +#define DUK_UINT_LEAST64_MAX DUK_UINT64_MAX +#define DUK_INT_LEAST64_MIN DUK_INT64_MIN +#define DUK_INT_LEAST64_MAX DUK_INT64_MAX +#define DUK_UINT_FAST64_MIN DUK_UINT64_MIN +#define DUK_UINT_FAST64_MAX DUK_UINT64_MAX +#define DUK_INT_FAST64_MIN DUK_INT64_MIN +#define DUK_INT_FAST64_MAX DUK_INT64_MAX +#define DUK_UINT64_MIN_COMPUTED +#define DUK_UINT64_MAX_COMPUTED +#define DUK_INT64_MIN_COMPUTED +#define DUK_INT64_MAX_COMPUTED +#define DUK_UINT_LEAST64_MIN_COMPUTED +#define DUK_UINT_LEAST64_MAX_COMPUTED +#define DUK_INT_LEAST64_MIN_COMPUTED +#define DUK_INT_LEAST64_MAX_COMPUTED +#define DUK_UINT_FAST64_MIN_COMPUTED +#define DUK_UINT_FAST64_MAX_COMPUTED +#define DUK_INT_FAST64_MIN_COMPUTED +#define DUK_INT_FAST64_MAX_COMPUTED +#endif + +#if defined(DUK_F_HAVE_64BIT) +#define DUK_UINTMAX_MIN DUK_UINT64_MIN +#define DUK_UINTMAX_MAX DUK_UINT64_MAX +#define DUK_INTMAX_MIN DUK_INT64_MIN +#define DUK_INTMAX_MAX DUK_INT64_MAX +#define DUK_UINTMAX_MIN_COMPUTED +#define DUK_UINTMAX_MAX_COMPUTED +#define DUK_INTMAX_MIN_COMPUTED +#define DUK_INTMAX_MAX_COMPUTED +#else +#define DUK_UINTMAX_MIN 0UL +#define DUK_UINTMAX_MAX 0xffffffffUL +#define DUK_INTMAX_MIN (-0x7fffffffL - 1L) +#define DUK_INTMAX_MAX 0x7fffffffL +#endif + +/* This detection is not very reliable. */ +#if defined(DUK_F_32BIT_PTRS) +typedef duk_int32_t duk_intptr_t; +typedef duk_uint32_t duk_uintptr_t; +#define DUK_UINTPTR_MIN DUK_UINT32_MIN +#define DUK_UINTPTR_MAX DUK_UINT32_MAX +#define DUK_INTPTR_MIN DUK_INT32_MIN +#define DUK_INTPTR_MAX DUK_INT32_MAX +#elif defined(DUK_F_64BIT_PTRS) && defined(DUK_F_HAVE_64BIT) +typedef duk_int64_t duk_intptr_t; +typedef duk_uint64_t duk_uintptr_t; +#define DUK_UINTPTR_MIN DUK_UINT64_MIN +#define DUK_UINTPTR_MAX DUK_UINT64_MAX +#define DUK_INTPTR_MIN DUK_INT64_MIN +#define DUK_INTPTR_MAX DUK_INT64_MAX +#define DUK_UINTPTR_MIN_COMPUTED +#define DUK_UINTPTR_MAX_COMPUTED +#define DUK_INTPTR_MIN_COMPUTED +#define DUK_INTPTR_MAX_COMPUTED +#else +#error cannot determine intptr type +#endif + +/* SIZE_MAX may be missing so use an approximate value for it. */ +#undef DUK_SIZE_MAX_COMPUTED +#if !defined(SIZE_MAX) +#define DUK_SIZE_MAX_COMPUTED +#define SIZE_MAX ((size_t) (-1)) +#endif +#define DUK_SIZE_MIN 0 +#define DUK_SIZE_MAX SIZE_MAX + +#endif /* C99 types */ + +/* A few types are assumed to always exist. */ +typedef size_t duk_size_t; +typedef ptrdiff_t duk_ptrdiff_t; + +/* The best type for an "all around int" in Duktape internals is "at least + * 32 bit signed integer" which is most convenient. Same for unsigned type. + * Prefer 'int' when large enough, as it is almost always a convenient type. + */ +#if defined(UINT_MAX) && (UINT_MAX >= 0xffffffffUL) +typedef int duk_int_t; +typedef unsigned int duk_uint_t; +#define DUK_INT_MIN INT_MIN +#define DUK_INT_MAX INT_MAX +#define DUK_UINT_MIN 0 +#define DUK_UINT_MAX UINT_MAX +#else +typedef duk_int_fast32_t duk_int_t; +typedef duk_uint_fast32_t duk_uint_t; +#define DUK_INT_MIN DUK_INT_FAST32_MIN +#define DUK_INT_MAX DUK_INT_FAST32_MAX +#define DUK_UINT_MIN DUK_UINT_FAST32_MIN +#define DUK_UINT_MAX DUK_UINT_FAST32_MAX +#endif + +/* Same as 'duk_int_t' but guaranteed to be a 'fast' variant if this + * distinction matters for the CPU. These types are used mainly in the + * executor where it might really matter. + */ +typedef duk_int_fast32_t duk_int_fast_t; +typedef duk_uint_fast32_t duk_uint_fast_t; +#define DUK_INT_FAST_MIN DUK_INT_FAST32_MIN +#define DUK_INT_FAST_MAX DUK_INT_FAST32_MAX +#define DUK_UINT_FAST_MIN DUK_UINT_FAST32_MIN +#define DUK_UINT_FAST_MAX DUK_UINT_FAST32_MAX + +/* Small integers (16 bits or more) can fall back to the 'int' type, but + * have a typedef so they are marked "small" explicitly. + */ +typedef int duk_small_int_t; +typedef unsigned int duk_small_uint_t; +#define DUK_SMALL_INT_MIN INT_MIN +#define DUK_SMALL_INT_MAX INT_MAX +#define DUK_SMALL_UINT_MIN 0 +#define DUK_SMALL_UINT_MAX UINT_MAX + +/* Fast variants of small integers, again for really fast paths like the + * executor. + */ +typedef duk_int_fast16_t duk_small_int_fast_t; +typedef duk_uint_fast16_t duk_small_uint_fast_t; +#define DUK_SMALL_INT_FAST_MIN DUK_INT_FAST16_MIN +#define DUK_SMALL_INT_FAST_MAX DUK_INT_FAST16_MAX +#define DUK_SMALL_UINT_FAST_MIN DUK_UINT_FAST16_MIN +#define DUK_SMALL_UINT_FAST_MAX DUK_UINT_FAST16_MAX + +/* Boolean values are represented with the platform 'unsigned int'. */ +typedef duk_small_uint_t duk_bool_t; +#define DUK_BOOL_MIN DUK_SMALL_UINT_MIN +#define DUK_BOOL_MAX DUK_SMALL_UINT_MAX + +/* Index values must have at least 32-bit signed range. */ +typedef duk_int_t duk_idx_t; +#define DUK_IDX_MIN DUK_INT_MIN +#define DUK_IDX_MAX DUK_INT_MAX + +/* Unsigned index variant. */ +typedef duk_uint_t duk_uidx_t; +#define DUK_UIDX_MIN DUK_UINT_MIN +#define DUK_UIDX_MAX DUK_UINT_MAX + +/* Array index values, could be exact 32 bits. + * Currently no need for signed duk_arridx_t. + */ +typedef duk_uint_t duk_uarridx_t; +#define DUK_UARRIDX_MIN DUK_UINT_MIN +#define DUK_UARRIDX_MAX DUK_UINT_MAX + +/* Duktape/C function return value, platform int is enough for now to + * represent 0, 1, or negative error code. Must be compatible with + * assigning truth values (e.g. duk_ret_t rc = (foo == bar);). + */ +typedef duk_small_int_t duk_ret_t; +#define DUK_RET_MIN DUK_SMALL_INT_MIN +#define DUK_RET_MAX DUK_SMALL_INT_MAX + +/* Error codes are represented with platform int. High bits are used + * for flags and such, so 32 bits are needed. + */ +typedef duk_int_t duk_errcode_t; +#define DUK_ERRCODE_MIN DUK_INT_MIN +#define DUK_ERRCODE_MAX DUK_INT_MAX + +/* Codepoint type. Must be 32 bits or more because it is used also for + * internal codepoints. The type is signed because negative codepoints + * are used as internal markers (e.g. to mark EOF or missing argument). + * (X)UTF-8/CESU-8 encode/decode take and return an unsigned variant to + * ensure duk_uint32_t casts back and forth nicely. Almost everything + * else uses the signed one. + */ +typedef duk_int_t duk_codepoint_t; +typedef duk_uint_t duk_ucodepoint_t; +#define DUK_CODEPOINT_MIN DUK_INT_MIN +#define DUK_CODEPOINT_MAX DUK_INT_MAX +#define DUK_UCODEPOINT_MIN DUK_UINT_MIN +#define DUK_UCODEPOINT_MAX DUK_UINT_MAX + +/* IEEE float/double typedef. */ +typedef float duk_float_t; +typedef double duk_double_t; + +/* We're generally assuming that we're working on a platform with a 32-bit + * address space. If DUK_SIZE_MAX is a typecast value (which is necessary + * if SIZE_MAX is missing), the check must be avoided because the + * preprocessor can't do a comparison. + */ +#if !defined(DUK_SIZE_MAX) +#error DUK_SIZE_MAX is undefined, probably missing SIZE_MAX +#elif !defined(DUK_SIZE_MAX_COMPUTED) +#if DUK_SIZE_MAX < 0xffffffffUL +/* On some systems SIZE_MAX can be smaller than max unsigned 32-bit value + * which seems incorrect if size_t is (at least) an unsigned 32-bit type. + * However, it doesn't seem useful to error out compilation if this is the + * case. + */ +#endif +#endif + +/* Type used in public API declarations and user code. Typedef maps to + * 'struct duk_hthread' like the 'duk_hthread' typedef which is used + * exclusively in internals. + */ +typedef struct duk_hthread duk_context; + +/* Check whether we should use 64-bit integers or not. + * + * Quite incomplete now. Use 64-bit types if detected (C99 or other detection) + * unless they are known to be unreliable. For instance, 64-bit types are + * available on VBCC but seem to misbehave. + */ +#if defined(DUK_F_HAVE_64BIT) && !defined(DUK_F_VBCC) +#define DUK_USE_64BIT_OPS +#else +#undef DUK_USE_64BIT_OPS +#endif + +/* + * Fill-ins for platform, architecture, and compiler + */ + +/* An abort()-like primitive is needed by the default fatal error handler. */ +#if !defined(DUK_ABORT) +#define DUK_ABORT abort +#endif + +#if !defined(DUK_SETJMP) +#define DUK_JMPBUF_TYPE jmp_buf +#define DUK_SETJMP(jb) setjmp((jb)) +#define DUK_LONGJMP(jb) longjmp((jb), 1) +#endif + +#if 0 +/* sigsetjmp() alternative */ +#define DUK_JMPBUF_TYPE sigjmp_buf +#define DUK_SETJMP(jb) sigsetjmp((jb)) +#define DUK_LONGJMP(jb) siglongjmp((jb), 1) +#endif + +/* Special naming to avoid conflict with e.g. DUK_FREE() in duk_heap.h + * (which is unfortunately named). May sometimes need replacement, e.g. + * some compilers don't handle zero length or NULL correctly in realloc(). + */ +#if !defined(DUK_ANSI_MALLOC) +#define DUK_ANSI_MALLOC malloc +#endif +#if !defined(DUK_ANSI_REALLOC) +#define DUK_ANSI_REALLOC realloc +#endif +#if !defined(DUK_ANSI_CALLOC) +#define DUK_ANSI_CALLOC calloc +#endif +#if !defined(DUK_ANSI_FREE) +#define DUK_ANSI_FREE free +#endif + +/* ANSI C (various versions) and some implementations require that the + * pointer arguments to memset(), memcpy(), and memmove() be valid values + * even when byte size is 0 (even a NULL pointer is considered invalid in + * this context). Zero-size operations as such are allowed, as long as their + * pointer arguments point to a valid memory area. The DUK_MEMSET(), + * DUK_MEMCPY(), and DUK_MEMMOVE() macros require this same behavior, i.e.: + * (1) pointers must be valid and non-NULL, (2) zero size must otherwise be + * allowed. If these are not fulfilled, a macro wrapper is needed. + * + * http://stackoverflow.com/questions/5243012/is-it-guaranteed-to-be-safe-to-perform-memcpy0-0-0 + * http://lists.cs.uiuc.edu/pipermail/llvmdev/2007-October/011065.html + * + * Not sure what's the required behavior when a pointer points just past the + * end of a buffer, which often happens in practice (e.g. zero size memmoves). + * For example, if allocation size is 3, the following pointer would not + * technically point to a valid memory byte: + * + * <-- alloc --> + * | 0 | 1 | 2 | ..... + * ^-- p=3, points after last valid byte (2) + */ +#if !defined(DUK_MEMCPY) +#if defined(DUK_F_UCLIBC) +/* Old uclibcs have a broken memcpy so use memmove instead (this is overly wide + * now on purpose): http://lists.uclibc.org/pipermail/uclibc-cvs/2008-October/025511.html + */ +#define DUK_MEMCPY memmove +#else +#define DUK_MEMCPY memcpy +#endif +#endif +#if !defined(DUK_MEMMOVE) +#define DUK_MEMMOVE memmove +#endif +#if !defined(DUK_MEMCMP) +#define DUK_MEMCMP memcmp +#endif +#if !defined(DUK_MEMSET) +#define DUK_MEMSET memset +#endif +#if !defined(DUK_STRLEN) +#define DUK_STRLEN strlen +#endif +#if !defined(DUK_STRCMP) +#define DUK_STRCMP strcmp +#endif +#if !defined(DUK_STRNCMP) +#define DUK_STRNCMP strncmp +#endif +#if !defined(DUK_SPRINTF) +#define DUK_SPRINTF sprintf +#endif +#if !defined(DUK_SNPRINTF) +/* snprintf() is technically not part of C89 but usually available. */ +#define DUK_SNPRINTF snprintf +#endif +#if !defined(DUK_VSPRINTF) +#define DUK_VSPRINTF vsprintf +#endif +#if !defined(DUK_VSNPRINTF) +/* vsnprintf() is technically not part of C89 but usually available. */ +#define DUK_VSNPRINTF vsnprintf +#endif +#if !defined(DUK_SSCANF) +#define DUK_SSCANF sscanf +#endif +#if !defined(DUK_VSSCANF) +#define DUK_VSSCANF vsscanf +#endif +#if !defined(DUK_MEMZERO) +#define DUK_MEMZERO(p,n) DUK_MEMSET((p), 0, (n)) +#endif + +#if !defined(DUK_DOUBLE_INFINITY) +#undef DUK_USE_COMPUTED_INFINITY +#if defined(DUK_F_GCC_VERSION) && (DUK_F_GCC_VERSION < 40600) +/* GCC older than 4.6: avoid overflow warnings related to using INFINITY */ +#define DUK_DOUBLE_INFINITY (__builtin_inf()) +#elif defined(INFINITY) +#define DUK_DOUBLE_INFINITY ((double) INFINITY) +#elif !defined(DUK_F_VBCC) && !defined(DUK_F_MSVC) && !defined(DUK_F_BCC) && \ + !defined(DUK_F_OLD_SOLARIS) && !defined(DUK_F_AIX) +#define DUK_DOUBLE_INFINITY (1.0 / 0.0) +#else +/* In VBCC (1.0 / 0.0) results in a warning and 0.0 instead of infinity. + * Use a computed infinity (initialized when a heap is created at the + * latest). + */ +#define DUK_USE_COMPUTED_INFINITY +#define DUK_DOUBLE_INFINITY duk_computed_infinity +#endif +#endif + +#if !defined(DUK_DOUBLE_NAN) +#undef DUK_USE_COMPUTED_NAN +#if defined(NAN) +#define DUK_DOUBLE_NAN NAN +#elif !defined(DUK_F_VBCC) && !defined(DUK_F_MSVC) && !defined(DUK_F_BCC) && \ + !defined(DUK_F_OLD_SOLARIS) && !defined(DUK_F_AIX) +#define DUK_DOUBLE_NAN (0.0 / 0.0) +#else +/* In VBCC (0.0 / 0.0) results in a warning and 0.0 instead of NaN. + * In MSVC (VS2010 Express) (0.0 / 0.0) results in a compile error. + * Use a computed NaN (initialized when a heap is created at the + * latest). + */ +#define DUK_USE_COMPUTED_NAN +#define DUK_DOUBLE_NAN duk_computed_nan +#endif +#endif + +/* Many platforms are missing fpclassify() and friends, so use replacements + * if necessary. The replacement constants (FP_NAN etc) can be anything but + * match Linux constants now. + */ +#undef DUK_USE_REPL_FPCLASSIFY +#undef DUK_USE_REPL_SIGNBIT +#undef DUK_USE_REPL_ISFINITE +#undef DUK_USE_REPL_ISNAN +#undef DUK_USE_REPL_ISINF + +/* Complex condition broken into separate parts. */ +#undef DUK_F_USE_REPL_ALL +#if !(defined(FP_NAN) && defined(FP_INFINITE) && defined(FP_ZERO) && \ + defined(FP_SUBNORMAL) && defined(FP_NORMAL)) +/* Missing some obvious constants. */ +#define DUK_F_USE_REPL_ALL +#elif defined(DUK_F_AMIGAOS) && defined(DUK_F_VBCC) +/* VBCC is missing the built-ins even in C99 mode (perhaps a header issue). */ +#define DUK_F_USE_REPL_ALL +#elif defined(DUK_F_AMIGAOS) && defined(DUK_F_M68K) +/* AmigaOS + M68K seems to have math issues even when using GCC cross + * compilation. Use replacements for all AmigaOS versions on M68K + * regardless of compiler. + */ +#define DUK_F_USE_REPL_ALL +#elif defined(DUK_F_FREEBSD) && defined(DUK_F_CLANG) +/* Placeholder fix for (detection is wider than necessary): + * http://llvm.org/bugs/show_bug.cgi?id=17788 + */ +#define DUK_F_USE_REPL_ALL +#elif defined(DUK_F_UCLIBC) +/* At least some uclibc versions have broken floating point math. For + * example, fpclassify() can incorrectly classify certain NaN formats. + * To be safe, use replacements. + */ +#define DUK_F_USE_REPL_ALL +#elif defined(DUK_F_AIX) +/* Older versions may be missing isnan(), etc. */ +#define DUK_F_USE_REPL_ALL +#endif + +#if defined(DUK_F_USE_REPL_ALL) +#define DUK_USE_REPL_FPCLASSIFY +#define DUK_USE_REPL_SIGNBIT +#define DUK_USE_REPL_ISFINITE +#define DUK_USE_REPL_ISNAN +#define DUK_USE_REPL_ISINF +#define DUK_FPCLASSIFY duk_repl_fpclassify +#define DUK_SIGNBIT duk_repl_signbit +#define DUK_ISFINITE duk_repl_isfinite +#define DUK_ISNAN duk_repl_isnan +#define DUK_ISINF duk_repl_isinf +#define DUK_FP_NAN 0 +#define DUK_FP_INFINITE 1 +#define DUK_FP_ZERO 2 +#define DUK_FP_SUBNORMAL 3 +#define DUK_FP_NORMAL 4 +#else +#define DUK_FPCLASSIFY fpclassify +#define DUK_SIGNBIT signbit +#define DUK_ISFINITE isfinite +#define DUK_ISNAN isnan +#define DUK_ISINF isinf +#define DUK_FP_NAN FP_NAN +#define DUK_FP_INFINITE FP_INFINITE +#define DUK_FP_ZERO FP_ZERO +#define DUK_FP_SUBNORMAL FP_SUBNORMAL +#define DUK_FP_NORMAL FP_NORMAL +#endif + +#if defined(DUK_F_USE_REPL_ALL) +#undef DUK_F_USE_REPL_ALL +#endif + +/* These functions don't currently need replacement but are wrapped for + * completeness. Because these are used as function pointers, they need + * to be defined as concrete C functions (not macros). + */ +#if !defined(DUK_FABS) +#define DUK_FABS fabs +#endif +#if !defined(DUK_FLOOR) +#define DUK_FLOOR floor +#endif +#if !defined(DUK_CEIL) +#define DUK_CEIL ceil +#endif +#if !defined(DUK_FMOD) +#define DUK_FMOD fmod +#endif +#if !defined(DUK_POW) +#define DUK_POW pow +#endif +#if !defined(DUK_ACOS) +#define DUK_ACOS acos +#endif +#if !defined(DUK_ASIN) +#define DUK_ASIN asin +#endif +#if !defined(DUK_ATAN) +#define DUK_ATAN atan +#endif +#if !defined(DUK_ATAN2) +#define DUK_ATAN2 atan2 +#endif +#if !defined(DUK_SIN) +#define DUK_SIN sin +#endif +#if !defined(DUK_COS) +#define DUK_COS cos +#endif +#if !defined(DUK_TAN) +#define DUK_TAN tan +#endif +#if !defined(DUK_EXP) +#define DUK_EXP exp +#endif +#if !defined(DUK_LOG) +#define DUK_LOG log +#endif +#if !defined(DUK_SQRT) +#define DUK_SQRT sqrt +#endif + +/* The functions below exist only in C99/C++11 or later and need a workaround + * for platforms that don't include them. MSVC isn't detected as C99, but + * these functions also exist in MSVC 2013 and later so include a clause for + * that too. Android doesn't have log2; disable all of these for Android. + */ +#if (defined(DUK_F_C99) || defined(DUK_F_CPP11) || (defined(_MSC_VER) && (_MSC_VER >= 1800))) && \ + !defined(DUK_F_ANDROID) && !defined(DUK_F_MINT) +#if !defined(DUK_CBRT) +#define DUK_CBRT cbrt +#endif +#if !defined(DUK_LOG2) +#define DUK_LOG2 log2 +#endif +#if !defined(DUK_LOG10) +#define DUK_LOG10 log10 +#endif +#if !defined(DUK_TRUNC) +#define DUK_TRUNC trunc +#endif +#endif /* DUK_F_C99 etc */ + +/* NetBSD 6.0 x86 (at least) has a few problems with pow() semantics, + * see test-bug-netbsd-math-pow.js. MinGW has similar (but different) + * issues, see test-bug-mingw-math-issues.js. Enable pow() workarounds + * for these targets. + */ +#undef DUK_USE_POW_WORKAROUNDS +#if defined(DUK_F_NETBSD) || defined(DUK_F_MINGW) +#define DUK_USE_POW_WORKAROUNDS +#endif + +/* Similar workarounds for atan2() semantics issues. MinGW issues are + * documented in test-bug-mingw-math-issues.js. + */ +#undef DUK_USE_ATAN2_WORKAROUNDS +#if defined(DUK_F_MINGW) +#define DUK_USE_ATAN2_WORKAROUNDS +#endif + +/* Rely as little as possible on compiler behavior for NaN comparison, + * signed zero handling, etc. Currently never activated but may be needed + * for broken compilers. + */ +#undef DUK_USE_PARANOID_MATH + +/* There was a curious bug where test-bi-date-canceling.js would fail e.g. + * on 64-bit Ubuntu, gcc-4.8.1, -m32, and no -std=c99. Some date computations + * using doubles would be optimized which then broke some corner case tests. + * The problem goes away by adding 'volatile' to the datetime computations. + * Not sure what the actual triggering conditions are, but using this on + * non-C99 systems solves the known issues and has relatively little cost + * on other platforms. + */ +#undef DUK_USE_PARANOID_DATE_COMPUTATION +#if !defined(DUK_F_C99) +#define DUK_USE_PARANOID_DATE_COMPUTATION +#endif + +/* + * Byte order and double memory layout detection + * + * Endianness detection is a major portability hassle because the macros + * and headers are not standardized. There's even variance across UNIX + * platforms. Even with "standard" headers, details like underscore count + * varies between platforms, e.g. both __BYTE_ORDER and _BYTE_ORDER are used + * (Crossbridge has a single underscore, for instance). + * + * The checks below are structured with this in mind: several approaches are + * used, and at the end we check if any of them worked. This allows generic + * approaches to be tried first, and platform/compiler specific hacks tried + * last. As a last resort, the user can force a specific endianness, as it's + * not likely that automatic detection will work on the most exotic platforms. + * + * Duktape supports little and big endian machines. There's also support + * for a hybrid used by some ARM machines where integers are little endian + * but IEEE double values use a mixed order (12345678 -> 43218765). This + * byte order for doubles is referred to as "mixed endian". + */ + +/* GCC and Clang provide endianness defines as built-in predefines, with + * leading and trailing double underscores (e.g. __BYTE_ORDER__). See + * output of "make gccpredefs" and "make clangpredefs". Clang doesn't + * seem to provide __FLOAT_WORD_ORDER__; assume not mixed endian for clang. + * http://gcc.gnu.org/onlinedocs/cpp/Common-Predefined-Macros.html + */ +#if !defined(DUK_USE_BYTEORDER) && defined(__BYTE_ORDER__) +#if defined(__ORDER_LITTLE_ENDIAN__) && (__BYTE_ORDER__ == __ORDER_LITTLE_ENDIAN__) +#if defined(__FLOAT_WORD_ORDER__) && defined(__ORDER_LITTLE_ENDIAN__) && (__FLOAT_WORD_ORDER__ == __ORDER_LITTLE_ENDIAN__) +#define DUK_USE_BYTEORDER 1 +#elif defined(__FLOAT_WORD_ORDER__) && defined(__ORDER_BIG_ENDIAN__) && (__FLOAT_WORD_ORDER__ == __ORDER_BIG_ENDIAN__) +#define DUK_USE_BYTEORDER 2 +#elif !defined(__FLOAT_WORD_ORDER__) +/* Float word order not known, assume not a hybrid. */ +#define DUK_USE_BYTEORDER 1 +#else +/* Byte order is little endian but cannot determine IEEE double word order. */ +#endif /* float word order */ +#elif defined(__ORDER_BIG_ENDIAN__) && (__BYTE_ORDER__ == __ORDER_BIG_ENDIAN__) +#if defined(__FLOAT_WORD_ORDER__) && defined(__ORDER_BIG_ENDIAN__) && (__FLOAT_WORD_ORDER__ == __ORDER_BIG_ENDIAN__) +#define DUK_USE_BYTEORDER 3 +#elif !defined(__FLOAT_WORD_ORDER__) +/* Float word order not known, assume not a hybrid. */ +#define DUK_USE_BYTEORDER 3 +#else +/* Byte order is big endian but cannot determine IEEE double word order. */ +#endif /* float word order */ +#else +/* Cannot determine byte order; __ORDER_PDP_ENDIAN__ is related to 32-bit + * integer ordering and is not relevant. + */ +#endif /* integer byte order */ +#endif /* !defined(DUK_USE_BYTEORDER) && defined(__BYTE_ORDER__) */ + +/* More or less standard endianness predefines provided by header files. + * The ARM hybrid case is detected by assuming that __FLOAT_WORD_ORDER + * will be big endian, see: http://lists.mysql.com/internals/443. + * On some platforms some defines may be present with an empty value which + * causes comparisons to fail: https://github.com/svaarala/duktape/issues/453. + */ +#if !defined(DUK_USE_BYTEORDER) +#if defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && (__BYTE_ORDER == __LITTLE_ENDIAN) || \ + defined(_BYTE_ORDER) && defined(_LITTLE_ENDIAN) && (_BYTE_ORDER == _LITTLE_ENDIAN) || \ + defined(__LITTLE_ENDIAN__) +#if defined(__FLOAT_WORD_ORDER) && defined(__LITTLE_ENDIAN) && (__FLOAT_WORD_ORDER == __LITTLE_ENDIAN) || \ + defined(_FLOAT_WORD_ORDER) && defined(_LITTLE_ENDIAN) && (_FLOAT_WORD_ORDER == _LITTLE_ENDIAN) +#define DUK_USE_BYTEORDER 1 +#elif defined(__FLOAT_WORD_ORDER) && defined(__BIG_ENDIAN) && (__FLOAT_WORD_ORDER == __BIG_ENDIAN) || \ + defined(_FLOAT_WORD_ORDER) && defined(_BIG_ENDIAN) && (_FLOAT_WORD_ORDER == _BIG_ENDIAN) +#define DUK_USE_BYTEORDER 2 +#elif !defined(__FLOAT_WORD_ORDER) && !defined(_FLOAT_WORD_ORDER) +/* Float word order not known, assume not a hybrid. */ +#define DUK_USE_BYTEORDER 1 +#else +/* Byte order is little endian but cannot determine IEEE double word order. */ +#endif /* float word order */ +#elif defined(__BYTE_ORDER) && defined(__BIG_ENDIAN) && (__BYTE_ORDER == __BIG_ENDIAN) || \ + defined(_BYTE_ORDER) && defined(_BIG_ENDIAN) && (_BYTE_ORDER == _BIG_ENDIAN) || \ + defined(__BIG_ENDIAN__) +#if defined(__FLOAT_WORD_ORDER) && defined(__BIG_ENDIAN) && (__FLOAT_WORD_ORDER == __BIG_ENDIAN) || \ + defined(_FLOAT_WORD_ORDER) && defined(_BIG_ENDIAN) && (_FLOAT_WORD_ORDER == _BIG_ENDIAN) +#define DUK_USE_BYTEORDER 3 +#elif !defined(__FLOAT_WORD_ORDER) && !defined(_FLOAT_WORD_ORDER) +/* Float word order not known, assume not a hybrid. */ +#define DUK_USE_BYTEORDER 3 +#else +/* Byte order is big endian but cannot determine IEEE double word order. */ +#endif /* float word order */ +#else +/* Cannot determine byte order. */ +#endif /* integer byte order */ +#endif /* !defined(DUK_USE_BYTEORDER) */ + +/* QNX gcc cross compiler seems to define e.g. __LITTLEENDIAN__ or __BIGENDIAN__: + * $ /opt/qnx650/host/linux/x86/usr/bin/i486-pc-nto-qnx6.5.0-gcc -dM -E - > 56U) | \ + ((((duk_uint64_t) (x)) >> 40U) & DUK_U64_CONSTANT(0xff00)) | \ + ((((duk_uint64_t) (x)) >> 24U) & DUK_U64_CONSTANT(0xff0000)) | \ + ((((duk_uint64_t) (x)) >> 8U) & DUK_U64_CONSTANT(0xff000000)) | \ + ((((duk_uint64_t) (x)) << 8U) & DUK_U64_CONSTANT(0xff00000000)) | \ + ((((duk_uint64_t) (x)) << 24U) & DUK_U64_CONSTANT(0xff0000000000)) | \ + ((((duk_uint64_t) (x)) << 40U) & DUK_U64_CONSTANT(0xff000000000000)) | \ + (((duk_uint64_t) (x)) << 56U)) +#endif +#endif +#if !defined(DUK_BSWAP32) +#define DUK_BSWAP32(x) \ + ((((duk_uint32_t) (x)) >> 24U) | \ + ((((duk_uint32_t) (x)) >> 8U) & 0xff00UL) | \ + ((((duk_uint32_t) (x)) << 8U) & 0xff0000UL) | \ + (((duk_uint32_t) (x)) << 24U)) +#endif +#if !defined(DUK_BSWAP16) +#define DUK_BSWAP16(x) \ + ((duk_uint16_t) (x) >> 8U) | \ + ((duk_uint16_t) (x) << 8U) +#endif + +/* DUK_USE_VARIADIC_MACROS: required from compilers, so no fill-in. */ +/* DUK_USE_UNION_INITIALIZERS: required from compilers, so no fill-in. */ + +#if !(defined(DUK_USE_FLEX_C99) || defined(DUK_USE_FLEX_ZEROSIZE) || defined(DUK_USE_FLEX_ONESIZE)) +#if defined(DUK_F_C99) +#define DUK_USE_FLEX_C99 +#else +#define DUK_USE_FLEX_ZEROSIZE /* Not standard but common enough */ +#endif +#endif + +#if !(defined(DUK_USE_PACK_GCC_ATTR) || defined(DUK_USE_PACK_CLANG_ATTR) || \ + defined(DUK_USE_PACK_MSVC_PRAGMA) || defined(DUK_USE_PACK_DUMMY_MEMBER)) +#define DUK_USE_PACK_DUMMY_MEMBER +#endif + +#if 0 /* not defined by default */ +#undef DUK_USE_GCC_PRAGMAS +#endif + +/* Workaround for GH-323: avoid inlining control when compiling from + * multiple sources, as it causes compiler portability trouble. + */ +#if !defined(DUK_SINGLE_FILE) +#undef DUK_NOINLINE +#undef DUK_INLINE +#undef DUK_ALWAYS_INLINE +#define DUK_NOINLINE /*nop*/ +#define DUK_INLINE /*nop*/ +#define DUK_ALWAYS_INLINE /*nop*/ +#endif + +/* + * Check whether or not a packed duk_tval representation is possible. + * What's basically required is that pointers are 32-bit values + * (sizeof(void *) == 4). Best effort check, not always accurate. + * If guess goes wrong, crashes may result; self tests also verify + * the guess. + */ + +/* Explicit marker needed; may be 'defined', 'undefined, 'or 'not provided'. */ +#if !defined(DUK_F_PACKED_TVAL_PROVIDED) +#undef DUK_F_PACKED_TVAL_POSSIBLE + +/* Strict C99 case: DUK_UINTPTR_MAX (= UINTPTR_MAX) should be very reliable */ +#if !defined(DUK_F_PACKED_TVAL_POSSIBLE) && defined(DUK_UINTPTR_MAX) +#if (DUK_UINTPTR_MAX <= 0xffffffffUL) +#define DUK_F_PACKED_TVAL_POSSIBLE +#endif +#endif + +/* Non-C99 case, still relying on DUK_UINTPTR_MAX, as long as it is not a computed value */ +#if !defined(DUK_F_PACKED_TVAL_POSSIBLE) && defined(DUK_UINTPTR_MAX) && !defined(DUK_UINTPTR_MAX_COMPUTED) +#if (DUK_UINTPTR_MAX <= 0xffffffffUL) +#define DUK_F_PACKED_TVAL_POSSIBLE +#endif +#endif + +/* DUK_SIZE_MAX (= SIZE_MAX) is often reliable */ +#if !defined(DUK_F_PACKED_TVAL_POSSIBLE) && defined(DUK_SIZE_MAX) && !defined(DUK_SIZE_MAX_COMPUTED) +#if (DUK_SIZE_MAX <= 0xffffffffUL) +#define DUK_F_PACKED_TVAL_POSSIBLE +#endif +#endif + +#undef DUK_USE_PACKED_TVAL +#if defined(DUK_F_PACKED_TVAL_POSSIBLE) +#define DUK_USE_PACKED_TVAL +#endif +#undef DUK_F_PACKED_TVAL_POSSIBLE + +#endif /* DUK_F_PACKED_TVAL_PROVIDED */ +/* Object property allocation layout has implications for memory and code + * footprint and generated code size/speed. The best layout also depends + * on whether the platform has alignment requirements or benefits from + * having mostly aligned accesses. + */ +#undef DUK_USE_HOBJECT_LAYOUT_1 +#undef DUK_USE_HOBJECT_LAYOUT_2 +#undef DUK_USE_HOBJECT_LAYOUT_3 +#if (DUK_USE_ALIGN_BY == 1) +/* On platforms without any alignment issues, layout 1 is preferable + * because it compiles to slightly less code and provides direct access + * to property keys. + */ +#define DUK_USE_HOBJECT_LAYOUT_1 +#else +/* On other platforms use layout 2, which requires some padding but + * is a bit more natural than layout 3 in ordering the entries. Layout + * 3 is currently not used. + */ +#define DUK_USE_HOBJECT_LAYOUT_2 +#endif + +/* GCC/clang inaccurate math would break compliance and probably duk_tval, + * so refuse to compile. Relax this if -ffast-math is tested to work. + */ +#if defined(__FAST_MATH__) +#error __FAST_MATH__ defined, refusing to compile +#endif + +/* + * Autogenerated defaults + */ + +#undef DUK_USE_ALLOW_UNDEFINED_BEHAVIOR +#define DUK_USE_ARRAY_BUILTIN +#define DUK_USE_ARRAY_FASTPATH +#define DUK_USE_ARRAY_PROP_FASTPATH +#undef DUK_USE_ASSERTIONS +#define DUK_USE_AUGMENT_ERROR_CREATE +#define DUK_USE_AUGMENT_ERROR_THROW +#define DUK_USE_AVOID_PLATFORM_FUNCPTRS +#define DUK_USE_BASE64_FASTPATH +#define DUK_USE_BASE64_SUPPORT +#define DUK_USE_BOOLEAN_BUILTIN +#define DUK_USE_BUFFEROBJECT_SUPPORT +#undef DUK_USE_BUFLEN16 +#define DUK_USE_BYTECODE_DUMP_SUPPORT +#define DUK_USE_CACHE_ACTIVATION +#define DUK_USE_CACHE_CATCHER +#define DUK_USE_CALLSTACK_LIMIT 10000 +#define DUK_USE_CBOR_BUILTIN +#define DUK_USE_CBOR_DEC_RECLIMIT 1000 +#define DUK_USE_CBOR_ENC_RECLIMIT 1000 +#define DUK_USE_CBOR_SUPPORT +#define DUK_USE_COMPILER_RECLIMIT 2500 +#define DUK_USE_COROUTINE_SUPPORT +#undef DUK_USE_CPP_EXCEPTIONS +#undef DUK_USE_DATAPTR16 +#undef DUK_USE_DATAPTR_DEC16 +#undef DUK_USE_DATAPTR_ENC16 +#define DUK_USE_DATE_BUILTIN +#undef DUK_USE_DATE_FORMAT_STRING +#undef DUK_USE_DATE_GET_LOCAL_TZOFFSET +#undef DUK_USE_DATE_GET_NOW +#undef DUK_USE_DATE_PARSE_STRING +#undef DUK_USE_DATE_PRS_GETDATE +#undef DUK_USE_DEBUG +#undef DUK_USE_DEBUGGER_DUMPHEAP +#undef DUK_USE_DEBUGGER_INSPECT +#undef DUK_USE_DEBUGGER_PAUSE_UNCAUGHT +#undef DUK_USE_DEBUGGER_SUPPORT +#define DUK_USE_DEBUGGER_THROW_NOTIFY +#undef DUK_USE_DEBUGGER_TRANSPORT_TORTURE +#define DUK_USE_DEBUG_BUFSIZE 65536L +#define DUK_USE_DEBUG_LEVEL 0 +#undef DUK_USE_DEBUG_WRITE +#define DUK_USE_DOUBLE_LINKED_HEAP +#define DUK_USE_DUKTAPE_BUILTIN +#define DUK_USE_ENCODING_BUILTINS +#define DUK_USE_ERRCREATE +#define DUK_USE_ERRTHROW +#define DUK_USE_ES6 +#define DUK_USE_ES6_OBJECT_PROTO_PROPERTY +#define DUK_USE_ES6_OBJECT_SETPROTOTYPEOF +#define DUK_USE_ES6_PROXY +#define DUK_USE_ES6_REGEXP_SYNTAX +#define DUK_USE_ES6_UNICODE_ESCAPE +#define DUK_USE_ES7 +#define DUK_USE_ES7_EXP_OPERATOR +#define DUK_USE_ES8 +#define DUK_USE_ES9 +#define DUK_USE_ESBC_LIMITS +#define DUK_USE_ESBC_MAX_BYTES 2147418112L +#define DUK_USE_ESBC_MAX_LINENUMBER 2147418112L +#undef DUK_USE_EXEC_FUN_LOCAL +#undef DUK_USE_EXEC_INDIRECT_BOUND_CHECK +#undef DUK_USE_EXEC_PREFER_SIZE +#define DUK_USE_EXEC_REGCONST_OPTIMIZE +#undef DUK_USE_EXEC_TIMEOUT_CHECK +#undef DUK_USE_EXPLICIT_NULL_INIT +#undef DUK_USE_EXTSTR_FREE +#undef DUK_USE_EXTSTR_INTERN_CHECK +#undef DUK_USE_FASTINT +#define DUK_USE_FAST_REFCOUNT_DEFAULT +#undef DUK_USE_FATAL_HANDLER +#define DUK_USE_FATAL_MAXLEN 128 +#define DUK_USE_FINALIZER_SUPPORT +#undef DUK_USE_FINALIZER_TORTURE +#undef DUK_USE_FUNCPTR16 +#undef DUK_USE_FUNCPTR_DEC16 +#undef DUK_USE_FUNCPTR_ENC16 +#define DUK_USE_FUNCTION_BUILTIN +#define DUK_USE_FUNC_FILENAME_PROPERTY +#define DUK_USE_FUNC_NAME_PROPERTY +#undef DUK_USE_GC_TORTURE +#undef DUK_USE_GET_MONOTONIC_TIME +#undef DUK_USE_GET_RANDOM_DOUBLE +#define DUK_USE_GLOBAL_BINDING +#define DUK_USE_GLOBAL_BUILTIN +#undef DUK_USE_HEAPPTR16 +#undef DUK_USE_HEAPPTR_DEC16 +#undef DUK_USE_HEAPPTR_ENC16 +#define DUK_USE_HEX_FASTPATH +#define DUK_USE_HEX_SUPPORT +#define DUK_USE_HOBJECT_ARRAY_ABANDON_LIMIT 2 +#define DUK_USE_HOBJECT_ARRAY_ABANDON_MINSIZE 257 +#define DUK_USE_HOBJECT_ARRAY_FAST_RESIZE_LIMIT 9 +#define DUK_USE_HOBJECT_ARRAY_MINGROW_ADD 16 +#define DUK_USE_HOBJECT_ARRAY_MINGROW_DIVISOR 8 +#define DUK_USE_HOBJECT_ENTRY_MINGROW_ADD 16 +#define DUK_USE_HOBJECT_ENTRY_MINGROW_DIVISOR 8 +#define DUK_USE_HOBJECT_HASH_PART +#define DUK_USE_HOBJECT_HASH_PROP_LIMIT 8 +#define DUK_USE_HSTRING_ARRIDX +#define DUK_USE_HSTRING_CLEN +#undef DUK_USE_HSTRING_EXTDATA +#define DUK_USE_HSTRING_LAZY_CLEN +#define DUK_USE_HTML_COMMENTS +#define DUK_USE_IDCHAR_FASTPATH +#undef DUK_USE_INJECT_HEAP_ALLOC_ERROR +#undef DUK_USE_INTERRUPT_COUNTER +#undef DUK_USE_INTERRUPT_DEBUG_FIXUP +#define DUK_USE_JC +#define DUK_USE_JSON_BUILTIN +#define DUK_USE_JSON_DECNUMBER_FASTPATH +#define DUK_USE_JSON_DECSTRING_FASTPATH +#define DUK_USE_JSON_DEC_RECLIMIT 1000 +#define DUK_USE_JSON_EATWHITE_FASTPATH +#define DUK_USE_JSON_ENC_RECLIMIT 1000 +#define DUK_USE_JSON_QUOTESTRING_FASTPATH +#undef DUK_USE_JSON_STRINGIFY_FASTPATH +#define DUK_USE_JSON_SUPPORT +#define DUK_USE_JX +#define DUK_USE_LEXER_SLIDING_WINDOW +#undef DUK_USE_LIGHTFUNC_BUILTINS +#define DUK_USE_LITCACHE_SIZE 256 +#define DUK_USE_MARK_AND_SWEEP_RECLIMIT 256 +#define DUK_USE_MATH_BUILTIN +#define DUK_USE_NATIVE_CALL_RECLIMIT 1000 +#undef DUK_USE_NATIVE_STACK_CHECK +#define DUK_USE_NONSTD_ARRAY_SPLICE_DELCOUNT +#undef DUK_USE_NONSTD_FUNC_CALLER_PROPERTY +#undef DUK_USE_NONSTD_FUNC_SOURCE_PROPERTY +#define DUK_USE_NONSTD_FUNC_STMT +#define DUK_USE_NONSTD_GETTER_KEY_ARGUMENT +#define DUK_USE_NONSTD_JSON_ESC_U2028_U2029 +#define DUK_USE_NONSTD_SETTER_KEY_ARGUMENT +#define DUK_USE_NONSTD_STRING_FROMCHARCODE_32BIT +#define DUK_USE_NUMBER_BUILTIN +#define DUK_USE_OBJECT_BUILTIN +#undef DUK_USE_OBJSIZES16 +#undef DUK_USE_PARANOID_ERRORS +#define DUK_USE_PC2LINE +#define DUK_USE_PERFORMANCE_BUILTIN +#undef DUK_USE_PREFER_SIZE +#undef DUK_USE_PROMISE_BUILTIN +#define DUK_USE_PROVIDE_DEFAULT_ALLOC_FUNCTIONS +#undef DUK_USE_REFCOUNT16 +#define DUK_USE_REFCOUNT32 +#define DUK_USE_REFERENCE_COUNTING +#define DUK_USE_REFLECT_BUILTIN +#define DUK_USE_REGEXP_CANON_BITMAP +#undef DUK_USE_REGEXP_CANON_WORKAROUND +#define DUK_USE_REGEXP_COMPILER_RECLIMIT 10000 +#define DUK_USE_REGEXP_EXECUTOR_RECLIMIT 10000 +#define DUK_USE_REGEXP_SUPPORT +#undef DUK_USE_ROM_GLOBAL_CLONE +#undef DUK_USE_ROM_GLOBAL_INHERIT +#undef DUK_USE_ROM_OBJECTS +#define DUK_USE_ROM_PTRCOMP_FIRST 63488L +#undef DUK_USE_ROM_STRINGS +#define DUK_USE_SECTION_B +#undef DUK_USE_SELF_TESTS +#define DUK_USE_SHEBANG_COMMENTS +#undef DUK_USE_SHUFFLE_TORTURE +#define DUK_USE_SOURCE_NONBMP +#undef DUK_USE_STRHASH16 +#undef DUK_USE_STRHASH_DENSE +#define DUK_USE_STRHASH_SKIP_SHIFT 5 +#define DUK_USE_STRICT_DECL +#undef DUK_USE_STRICT_UTF8_SOURCE +#define DUK_USE_STRING_BUILTIN +#undef DUK_USE_STRLEN16 +#define DUK_USE_STRTAB_GROW_LIMIT 17 +#define DUK_USE_STRTAB_MAXSIZE 268435456L +#define DUK_USE_STRTAB_MINSIZE 1024 +#undef DUK_USE_STRTAB_PTRCOMP +#define DUK_USE_STRTAB_RESIZE_CHECK_MASK 255 +#define DUK_USE_STRTAB_SHRINK_LIMIT 6 +#undef DUK_USE_STRTAB_TORTURE +#define DUK_USE_SYMBOL_BUILTIN +#define DUK_USE_TAILCALL +#define DUK_USE_TARGET_INFO "unknown" +#define DUK_USE_TRACEBACKS +#define DUK_USE_TRACEBACK_DEPTH 10 +#define DUK_USE_VALSTACK_GROW_SHIFT 2 +#define DUK_USE_VALSTACK_LIMIT 1000000L +#define DUK_USE_VALSTACK_SHRINK_CHECK_SHIFT 2 +#define DUK_USE_VALSTACK_SHRINK_SLACK_SHIFT 4 +#undef DUK_USE_VALSTACK_UNSAFE +#define DUK_USE_VERBOSE_ERRORS +#define DUK_USE_VERBOSE_EXECUTOR_ERRORS +#define DUK_USE_VOLUNTARY_GC +#define DUK_USE_ZERO_BUFFER_DATA + +/* + * You may add overriding #define/#undef directives below for + * customization. You of course cannot un-#include or un-typedef + * anything; these require direct changes above. + */ + +/* __OVERRIDE_DEFINES__ */ + +/* + * Conditional includes + */ + +#if defined(DUK_F_CPP) && defined(DUK_USE_CPP_EXCEPTIONS) +#include /* std::exception */ +#include /* std::runtime_error */ +#endif + +/* + * Date provider selection + * + * User may define DUK_USE_DATE_GET_NOW() etc directly, in which case we'll + * rely on an external provider. If this is not done, revert to previous + * behavior and use Unix/Windows built-in provider. + */ + +#if defined(DUK_COMPILING_DUKTAPE) + +#if defined(DUK_USE_DATE_GET_NOW) +/* External provider already defined. */ +#elif defined(DUK_USE_DATE_NOW_GETTIMEOFDAY) +#define DUK_USE_DATE_GET_NOW(ctx) duk_bi_date_get_now_gettimeofday() +#elif defined(DUK_USE_DATE_NOW_TIME) +#define DUK_USE_DATE_GET_NOW(ctx) duk_bi_date_get_now_time() +#elif defined(DUK_USE_DATE_NOW_WINDOWS) +#define DUK_USE_DATE_GET_NOW(ctx) duk_bi_date_get_now_windows() +#elif defined(DUK_USE_DATE_NOW_WINDOWS_SUBMS) +#define DUK_USE_DATE_GET_NOW(ctx) duk_bi_date_get_now_windows_subms() +#else +#error no provider for DUK_USE_DATE_GET_NOW() +#endif + +#if defined(DUK_USE_DATE_GET_LOCAL_TZOFFSET) +/* External provider already defined. */ +#elif defined(DUK_USE_DATE_TZO_GMTIME_R) || defined(DUK_USE_DATE_TZO_GMTIME_S) || defined(DUK_USE_DATE_TZO_GMTIME) +#define DUK_USE_DATE_GET_LOCAL_TZOFFSET(d) duk_bi_date_get_local_tzoffset_gmtime((d)) +#elif defined(DUK_USE_DATE_TZO_WINDOWS) +#define DUK_USE_DATE_GET_LOCAL_TZOFFSET(d) duk_bi_date_get_local_tzoffset_windows((d)) +#elif defined(DUK_USE_DATE_TZO_WINDOWS_NO_DST) +#define DUK_USE_DATE_GET_LOCAL_TZOFFSET(d) duk_bi_date_get_local_tzoffset_windows_no_dst((d)) +#else +#error no provider for DUK_USE_DATE_GET_LOCAL_TZOFFSET() +#endif + +#if defined(DUK_USE_DATE_PARSE_STRING) +/* External provider already defined. */ +#elif defined(DUK_USE_DATE_PRS_STRPTIME) +#define DUK_USE_DATE_PARSE_STRING(ctx,str) duk_bi_date_parse_string_strptime((ctx), (str)) +#elif defined(DUK_USE_DATE_PRS_GETDATE) +#define DUK_USE_DATE_PARSE_STRING(ctx,str) duk_bi_date_parse_string_getdate((ctx), (str)) +#else +/* No provider for DUK_USE_DATE_PARSE_STRING(), fall back to ISO 8601 only. */ +#endif + +#if defined(DUK_USE_DATE_FORMAT_STRING) +/* External provider already defined. */ +#elif defined(DUK_USE_DATE_FMT_STRFTIME) +#define DUK_USE_DATE_FORMAT_STRING(ctx,parts,tzoffset,flags) \ + duk_bi_date_format_parts_strftime((ctx), (parts), (tzoffset), (flags)) +#else +/* No provider for DUK_USE_DATE_FORMAT_STRING(), fall back to ISO 8601 only. */ +#endif + +#if defined(DUK_USE_GET_MONOTONIC_TIME) +/* External provider already defined. */ +#elif defined(DUK_USE_GET_MONOTONIC_TIME_CLOCK_GETTIME) +#define DUK_USE_GET_MONOTONIC_TIME(ctx) duk_bi_date_get_monotonic_time_clock_gettime() +#elif defined(DUK_USE_GET_MONOTONIC_TIME_WINDOWS_QPC) +#define DUK_USE_GET_MONOTONIC_TIME(ctx) duk_bi_date_get_monotonic_time_windows_qpc() +#else +/* No provider for DUK_USE_GET_MONOTONIC_TIME(), fall back to DUK_USE_DATE_GET_NOW(). */ +#endif + +#endif /* DUK_COMPILING_DUKTAPE */ + +/* + * Checks for legacy feature options (DUK_OPT_xxx) + */ + +#if defined(DUK_OPT_ASSERTIONS) +#error unsupported legacy feature option DUK_OPT_ASSERTIONS used +#endif +#if defined(DUK_OPT_BUFFEROBJECT_SUPPORT) +#error unsupported legacy feature option DUK_OPT_BUFFEROBJECT_SUPPORT used +#endif +#if defined(DUK_OPT_BUFLEN16) +#error unsupported legacy feature option DUK_OPT_BUFLEN16 used +#endif +#if defined(DUK_OPT_DATAPTR16) +#error unsupported legacy feature option DUK_OPT_DATAPTR16 used +#endif +#if defined(DUK_OPT_DATAPTR_DEC16) +#error unsupported legacy feature option DUK_OPT_DATAPTR_DEC16 used +#endif +#if defined(DUK_OPT_DATAPTR_ENC16) +#error unsupported legacy feature option DUK_OPT_DATAPTR_ENC16 used +#endif +#if defined(DUK_OPT_DDDPRINT) +#error unsupported legacy feature option DUK_OPT_DDDPRINT used +#endif +#if defined(DUK_OPT_DDPRINT) +#error unsupported legacy feature option DUK_OPT_DDPRINT used +#endif +#if defined(DUK_OPT_DEBUG) +#error unsupported legacy feature option DUK_OPT_DEBUG used +#endif +#if defined(DUK_OPT_DEBUGGER_DUMPHEAP) +#error unsupported legacy feature option DUK_OPT_DEBUGGER_DUMPHEAP used +#endif +#if defined(DUK_OPT_DEBUGGER_FWD_LOGGING) +#error unsupported legacy feature option DUK_OPT_DEBUGGER_FWD_LOGGING used +#endif +#if defined(DUK_OPT_DEBUGGER_FWD_PRINTALERT) +#error unsupported legacy feature option DUK_OPT_DEBUGGER_FWD_PRINTALERT used +#endif +#if defined(DUK_OPT_DEBUGGER_SUPPORT) +#error unsupported legacy feature option DUK_OPT_DEBUGGER_SUPPORT used +#endif +#if defined(DUK_OPT_DEBUGGER_TRANSPORT_TORTURE) +#error unsupported legacy feature option DUK_OPT_DEBUGGER_TRANSPORT_TORTURE used +#endif +#if defined(DUK_OPT_DEBUG_BUFSIZE) +#error unsupported legacy feature option DUK_OPT_DEBUG_BUFSIZE used +#endif +#if defined(DUK_OPT_DECLARE) +#error unsupported legacy feature option DUK_OPT_DECLARE used +#endif +#if defined(DUK_OPT_DEEP_C_STACK) +#error unsupported legacy feature option DUK_OPT_DEEP_C_STACK used +#endif +#if defined(DUK_OPT_DLL_BUILD) +#error unsupported legacy feature option DUK_OPT_DLL_BUILD used +#endif +#if defined(DUK_OPT_DPRINT) +#error unsupported legacy feature option DUK_OPT_DPRINT used +#endif +#if defined(DUK_OPT_DPRINT_COLORS) +#error unsupported legacy feature option DUK_OPT_DPRINT_COLORS used +#endif +#if defined(DUK_OPT_DPRINT_RDTSC) +#error unsupported legacy feature option DUK_OPT_DPRINT_RDTSC used +#endif +#if defined(DUK_OPT_EXEC_TIMEOUT_CHECK) +#error unsupported legacy feature option DUK_OPT_EXEC_TIMEOUT_CHECK used +#endif +#if defined(DUK_OPT_EXTERNAL_STRINGS) +#error unsupported legacy feature option DUK_OPT_EXTERNAL_STRINGS used +#endif +#if defined(DUK_OPT_EXTSTR_FREE) +#error unsupported legacy feature option DUK_OPT_EXTSTR_FREE used +#endif +#if defined(DUK_OPT_EXTSTR_INTERN_CHECK) +#error unsupported legacy feature option DUK_OPT_EXTSTR_INTERN_CHECK used +#endif +#if defined(DUK_OPT_FASTINT) +#error unsupported legacy feature option DUK_OPT_FASTINT used +#endif +#if defined(DUK_OPT_FORCE_ALIGN) +#error unsupported legacy feature option DUK_OPT_FORCE_ALIGN used +#endif +#if defined(DUK_OPT_FORCE_BYTEORDER) +#error unsupported legacy feature option DUK_OPT_FORCE_BYTEORDER used +#endif +#if defined(DUK_OPT_FUNCPTR16) +#error unsupported legacy feature option DUK_OPT_FUNCPTR16 used +#endif +#if defined(DUK_OPT_FUNCPTR_DEC16) +#error unsupported legacy feature option DUK_OPT_FUNCPTR_DEC16 used +#endif +#if defined(DUK_OPT_FUNCPTR_ENC16) +#error unsupported legacy feature option DUK_OPT_FUNCPTR_ENC16 used +#endif +#if defined(DUK_OPT_FUNC_NONSTD_CALLER_PROPERTY) +#error unsupported legacy feature option DUK_OPT_FUNC_NONSTD_CALLER_PROPERTY used +#endif +#if defined(DUK_OPT_FUNC_NONSTD_SOURCE_PROPERTY) +#error unsupported legacy feature option DUK_OPT_FUNC_NONSTD_SOURCE_PROPERTY used +#endif +#if defined(DUK_OPT_GC_TORTURE) +#error unsupported legacy feature option DUK_OPT_GC_TORTURE used +#endif +#if defined(DUK_OPT_HAVE_CUSTOM_H) +#error unsupported legacy feature option DUK_OPT_HAVE_CUSTOM_H used +#endif +#if defined(DUK_OPT_HEAPPTR16) +#error unsupported legacy feature option DUK_OPT_HEAPPTR16 used +#endif +#if defined(DUK_OPT_HEAPPTR_DEC16) +#error unsupported legacy feature option DUK_OPT_HEAPPTR_DEC16 used +#endif +#if defined(DUK_OPT_HEAPPTR_ENC16) +#error unsupported legacy feature option DUK_OPT_HEAPPTR_ENC16 used +#endif +#if defined(DUK_OPT_INTERRUPT_COUNTER) +#error unsupported legacy feature option DUK_OPT_INTERRUPT_COUNTER used +#endif +#if defined(DUK_OPT_JSON_STRINGIFY_FASTPATH) +#error unsupported legacy feature option DUK_OPT_JSON_STRINGIFY_FASTPATH used +#endif +#if defined(DUK_OPT_LIGHTFUNC_BUILTINS) +#error unsupported legacy feature option DUK_OPT_LIGHTFUNC_BUILTINS used +#endif +#if defined(DUK_OPT_NONSTD_FUNC_CALLER_PROPERTY) +#error unsupported legacy feature option DUK_OPT_NONSTD_FUNC_CALLER_PROPERTY used +#endif +#if defined(DUK_OPT_NONSTD_FUNC_SOURCE_PROPERTY) +#error unsupported legacy feature option DUK_OPT_NONSTD_FUNC_SOURCE_PROPERTY used +#endif +#if defined(DUK_OPT_NO_ARRAY_SPLICE_NONSTD_DELCOUNT) +#error unsupported legacy feature option DUK_OPT_NO_ARRAY_SPLICE_NONSTD_DELCOUNT used +#endif +#if defined(DUK_OPT_NO_AUGMENT_ERRORS) +#error unsupported legacy feature option DUK_OPT_NO_AUGMENT_ERRORS used +#endif +#if defined(DUK_OPT_NO_BROWSER_LIKE) +#error unsupported legacy feature option DUK_OPT_NO_BROWSER_LIKE used +#endif +#if defined(DUK_OPT_NO_BUFFEROBJECT_SUPPORT) +#error unsupported legacy feature option DUK_OPT_NO_BUFFEROBJECT_SUPPORT used +#endif +#if defined(DUK_OPT_NO_BYTECODE_DUMP_SUPPORT) +#error unsupported legacy feature option DUK_OPT_NO_BYTECODE_DUMP_SUPPORT used +#endif +#if defined(DUK_OPT_NO_COMMONJS_MODULES) +#error unsupported legacy feature option DUK_OPT_NO_COMMONJS_MODULES used +#endif +#if defined(DUK_OPT_NO_ES6_OBJECT_PROTO_PROPERTY) +#error unsupported legacy feature option DUK_OPT_NO_ES6_OBJECT_PROTO_PROPERTY used +#endif +#if defined(DUK_OPT_NO_ES6_OBJECT_SETPROTOTYPEOF) +#error unsupported legacy feature option DUK_OPT_NO_ES6_OBJECT_SETPROTOTYPEOF used +#endif +#if defined(DUK_OPT_NO_ES6_PROXY) +#error unsupported legacy feature option DUK_OPT_NO_ES6_PROXY used +#endif +#if defined(DUK_OPT_NO_FILE_IO) +#error unsupported legacy feature option DUK_OPT_NO_FILE_IO used +#endif +#if defined(DUK_OPT_NO_FUNC_STMT) +#error unsupported legacy feature option DUK_OPT_NO_FUNC_STMT used +#endif +#if defined(DUK_OPT_NO_JC) +#error unsupported legacy feature option DUK_OPT_NO_JC used +#endif +#if defined(DUK_OPT_NO_JSONC) +#error unsupported legacy feature option DUK_OPT_NO_JSONC used +#endif +#if defined(DUK_OPT_NO_JSONX) +#error unsupported legacy feature option DUK_OPT_NO_JSONX used +#endif +#if defined(DUK_OPT_NO_JX) +#error unsupported legacy feature option DUK_OPT_NO_JX used +#endif +#if defined(DUK_OPT_NO_MARK_AND_SWEEP) +#error unsupported legacy feature option DUK_OPT_NO_MARK_AND_SWEEP used +#endif +#if defined(DUK_OPT_NO_MS_STRINGTABLE_RESIZE) +#error unsupported legacy feature option DUK_OPT_NO_MS_STRINGTABLE_RESIZE used +#endif +#if defined(DUK_OPT_NO_NONSTD_ACCESSOR_KEY_ARGUMENT) +#error unsupported legacy feature option DUK_OPT_NO_NONSTD_ACCESSOR_KEY_ARGUMENT used +#endif +#if defined(DUK_OPT_NO_NONSTD_ARRAY_CONCAT_TRAILER) +#error unsupported legacy feature option DUK_OPT_NO_NONSTD_ARRAY_CONCAT_TRAILER used +#endif +#if defined(DUK_OPT_NO_NONSTD_ARRAY_MAP_TRAILER) +#error unsupported legacy feature option DUK_OPT_NO_NONSTD_ARRAY_MAP_TRAILER used +#endif +#if defined(DUK_OPT_NO_NONSTD_ARRAY_SPLICE_DELCOUNT) +#error unsupported legacy feature option DUK_OPT_NO_NONSTD_ARRAY_SPLICE_DELCOUNT used +#endif +#if defined(DUK_OPT_NO_NONSTD_FUNC_STMT) +#error unsupported legacy feature option DUK_OPT_NO_NONSTD_FUNC_STMT used +#endif +#if defined(DUK_OPT_NO_NONSTD_JSON_ESC_U2028_U2029) +#error unsupported legacy feature option DUK_OPT_NO_NONSTD_JSON_ESC_U2028_U2029 used +#endif +#if defined(DUK_OPT_NO_NONSTD_STRING_FROMCHARCODE_32BIT) +#error unsupported legacy feature option DUK_OPT_NO_NONSTD_STRING_FROMCHARCODE_32BIT used +#endif +#if defined(DUK_OPT_NO_OBJECT_ES6_PROTO_PROPERTY) +#error unsupported legacy feature option DUK_OPT_NO_OBJECT_ES6_PROTO_PROPERTY used +#endif +#if defined(DUK_OPT_NO_OBJECT_ES6_SETPROTOTYPEOF) +#error unsupported legacy feature option DUK_OPT_NO_OBJECT_ES6_SETPROTOTYPEOF used +#endif +#if defined(DUK_OPT_NO_OCTAL_SUPPORT) +#error unsupported legacy feature option DUK_OPT_NO_OCTAL_SUPPORT used +#endif +#if defined(DUK_OPT_NO_PACKED_TVAL) +#error unsupported legacy feature option DUK_OPT_NO_PACKED_TVAL used +#endif +#if defined(DUK_OPT_NO_PC2LINE) +#error unsupported legacy feature option DUK_OPT_NO_PC2LINE used +#endif +#if defined(DUK_OPT_NO_REFERENCE_COUNTING) +#error unsupported legacy feature option DUK_OPT_NO_REFERENCE_COUNTING used +#endif +#if defined(DUK_OPT_NO_REGEXP_SUPPORT) +#error unsupported legacy feature option DUK_OPT_NO_REGEXP_SUPPORT used +#endif +#if defined(DUK_OPT_NO_SECTION_B) +#error unsupported legacy feature option DUK_OPT_NO_SECTION_B used +#endif +#if defined(DUK_OPT_NO_SOURCE_NONBMP) +#error unsupported legacy feature option DUK_OPT_NO_SOURCE_NONBMP used +#endif +#if defined(DUK_OPT_NO_STRICT_DECL) +#error unsupported legacy feature option DUK_OPT_NO_STRICT_DECL used +#endif +#if defined(DUK_OPT_NO_TRACEBACKS) +#error unsupported legacy feature option DUK_OPT_NO_TRACEBACKS used +#endif +#if defined(DUK_OPT_NO_VERBOSE_ERRORS) +#error unsupported legacy feature option DUK_OPT_NO_VERBOSE_ERRORS used +#endif +#if defined(DUK_OPT_NO_VOLUNTARY_GC) +#error unsupported legacy feature option DUK_OPT_NO_VOLUNTARY_GC used +#endif +#if defined(DUK_OPT_NO_ZERO_BUFFER_DATA) +#error unsupported legacy feature option DUK_OPT_NO_ZERO_BUFFER_DATA used +#endif +#if defined(DUK_OPT_OBJSIZES16) +#error unsupported legacy feature option DUK_OPT_OBJSIZES16 used +#endif +#if defined(DUK_OPT_PANIC_HANDLER) +#error unsupported legacy feature option DUK_OPT_PANIC_HANDLER used +#endif +#if defined(DUK_OPT_REFCOUNT16) +#error unsupported legacy feature option DUK_OPT_REFCOUNT16 used +#endif +#if defined(DUK_OPT_SEGFAULT_ON_PANIC) +#error unsupported legacy feature option DUK_OPT_SEGFAULT_ON_PANIC used +#endif +#if defined(DUK_OPT_SELF_TESTS) +#error unsupported legacy feature option DUK_OPT_SELF_TESTS used +#endif +#if defined(DUK_OPT_SETJMP) +#error unsupported legacy feature option DUK_OPT_SETJMP used +#endif +#if defined(DUK_OPT_SHUFFLE_TORTURE) +#error unsupported legacy feature option DUK_OPT_SHUFFLE_TORTURE used +#endif +#if defined(DUK_OPT_SIGSETJMP) +#error unsupported legacy feature option DUK_OPT_SIGSETJMP used +#endif +#if defined(DUK_OPT_STRHASH16) +#error unsupported legacy feature option DUK_OPT_STRHASH16 used +#endif +#if defined(DUK_OPT_STRICT_UTF8_SOURCE) +#error unsupported legacy feature option DUK_OPT_STRICT_UTF8_SOURCE used +#endif +#if defined(DUK_OPT_STRLEN16) +#error unsupported legacy feature option DUK_OPT_STRLEN16 used +#endif +#if defined(DUK_OPT_STRTAB_CHAIN) +#error unsupported legacy feature option DUK_OPT_STRTAB_CHAIN used +#endif +#if defined(DUK_OPT_STRTAB_CHAIN_SIZE) +#error unsupported legacy feature option DUK_OPT_STRTAB_CHAIN_SIZE used +#endif +#if defined(DUK_OPT_TARGET_INFO) +#error unsupported legacy feature option DUK_OPT_TARGET_INFO used +#endif +#if defined(DUK_OPT_TRACEBACK_DEPTH) +#error unsupported legacy feature option DUK_OPT_TRACEBACK_DEPTH used +#endif +#if defined(DUK_OPT_UNDERSCORE_SETJMP) +#error unsupported legacy feature option DUK_OPT_UNDERSCORE_SETJMP used +#endif +#if defined(DUK_OPT_USER_INITJS) +#error unsupported legacy feature option DUK_OPT_USER_INITJS used +#endif + +/* + * Checks for config option consistency (DUK_USE_xxx) + */ + +#if defined(DUK_USE_32BIT_PTRS) +#error unsupported config option used (option has been removed): DUK_USE_32BIT_PTRS +#endif +#if defined(DUK_USE_ALIGN_4) +#error unsupported config option used (option has been removed): DUK_USE_ALIGN_4 +#endif +#if defined(DUK_USE_ALIGN_8) +#error unsupported config option used (option has been removed): DUK_USE_ALIGN_8 +#endif +#if defined(DUK_USE_BROWSER_LIKE) +#error unsupported config option used (option has been removed): DUK_USE_BROWSER_LIKE +#endif +#if defined(DUK_USE_BUILTIN_INITJS) +#error unsupported config option used (option has been removed): DUK_USE_BUILTIN_INITJS +#endif +#if defined(DUK_USE_BYTEORDER_FORCED) +#error unsupported config option used (option has been removed): DUK_USE_BYTEORDER_FORCED +#endif +#if defined(DUK_USE_COMMONJS_MODULES) +#error unsupported config option used (option has been removed): DUK_USE_COMMONJS_MODULES +#endif +#if defined(DUK_USE_DATAPTR_DEC16) && !defined(DUK_USE_DATAPTR16) +#error config option DUK_USE_DATAPTR_DEC16 requires option DUK_USE_DATAPTR16 (which is missing) +#endif +#if defined(DUK_USE_DATAPTR_ENC16) && !defined(DUK_USE_DATAPTR16) +#error config option DUK_USE_DATAPTR_ENC16 requires option DUK_USE_DATAPTR16 (which is missing) +#endif +#if defined(DUK_USE_DDDPRINT) +#error unsupported config option used (option has been removed): DUK_USE_DDDPRINT +#endif +#if defined(DUK_USE_DDPRINT) +#error unsupported config option used (option has been removed): DUK_USE_DDPRINT +#endif +#if defined(DUK_USE_DEBUGGER_FWD_LOGGING) +#error unsupported config option used (option has been removed): DUK_USE_DEBUGGER_FWD_LOGGING +#endif +#if defined(DUK_USE_DEBUGGER_FWD_PRINTALERT) +#error unsupported config option used (option has been removed): DUK_USE_DEBUGGER_FWD_PRINTALERT +#endif +#if defined(DUK_USE_DEBUGGER_SUPPORT) && !defined(DUK_USE_INTERRUPT_COUNTER) +#error config option DUK_USE_DEBUGGER_SUPPORT requires option DUK_USE_INTERRUPT_COUNTER (which is missing) +#endif +#if defined(DUK_USE_DEEP_C_STACK) +#error unsupported config option used (option has been removed): DUK_USE_DEEP_C_STACK +#endif +#if defined(DUK_USE_DOUBLE_BE) +#error unsupported config option used (option has been removed): DUK_USE_DOUBLE_BE +#endif +#if defined(DUK_USE_DOUBLE_BE) && defined(DUK_USE_DOUBLE_LE) +#error config option DUK_USE_DOUBLE_BE conflicts with option DUK_USE_DOUBLE_LE (which is also defined) +#endif +#if defined(DUK_USE_DOUBLE_BE) && defined(DUK_USE_DOUBLE_ME) +#error config option DUK_USE_DOUBLE_BE conflicts with option DUK_USE_DOUBLE_ME (which is also defined) +#endif +#if defined(DUK_USE_DOUBLE_LE) +#error unsupported config option used (option has been removed): DUK_USE_DOUBLE_LE +#endif +#if defined(DUK_USE_DOUBLE_LE) && defined(DUK_USE_DOUBLE_BE) +#error config option DUK_USE_DOUBLE_LE conflicts with option DUK_USE_DOUBLE_BE (which is also defined) +#endif +#if defined(DUK_USE_DOUBLE_LE) && defined(DUK_USE_DOUBLE_ME) +#error config option DUK_USE_DOUBLE_LE conflicts with option DUK_USE_DOUBLE_ME (which is also defined) +#endif +#if defined(DUK_USE_DOUBLE_ME) +#error unsupported config option used (option has been removed): DUK_USE_DOUBLE_ME +#endif +#if defined(DUK_USE_DOUBLE_ME) && defined(DUK_USE_DOUBLE_LE) +#error config option DUK_USE_DOUBLE_ME conflicts with option DUK_USE_DOUBLE_LE (which is also defined) +#endif +#if defined(DUK_USE_DOUBLE_ME) && defined(DUK_USE_DOUBLE_BE) +#error config option DUK_USE_DOUBLE_ME conflicts with option DUK_USE_DOUBLE_BE (which is also defined) +#endif +#if defined(DUK_USE_DPRINT) +#error unsupported config option used (option has been removed): DUK_USE_DPRINT +#endif +#if defined(DUK_USE_DPRINT) && !defined(DUK_USE_DEBUG) +#error config option DUK_USE_DPRINT requires option DUK_USE_DEBUG (which is missing) +#endif +#if defined(DUK_USE_DPRINT_COLORS) +#error unsupported config option used (option has been removed): DUK_USE_DPRINT_COLORS +#endif +#if defined(DUK_USE_DPRINT_RDTSC) +#error unsupported config option used (option has been removed): DUK_USE_DPRINT_RDTSC +#endif +#if defined(DUK_USE_ES6_REGEXP_BRACES) +#error unsupported config option used (option has been removed): DUK_USE_ES6_REGEXP_BRACES +#endif +#if defined(DUK_USE_ESBC_MAX_BYTES) && !defined(DUK_USE_ESBC_LIMITS) +#error config option DUK_USE_ESBC_MAX_BYTES requires option DUK_USE_ESBC_LIMITS (which is missing) +#endif +#if defined(DUK_USE_ESBC_MAX_LINENUMBER) && !defined(DUK_USE_ESBC_LIMITS) +#error config option DUK_USE_ESBC_MAX_LINENUMBER requires option DUK_USE_ESBC_LIMITS (which is missing) +#endif +#if defined(DUK_USE_EXEC_TIMEOUT_CHECK) && !defined(DUK_USE_INTERRUPT_COUNTER) +#error config option DUK_USE_EXEC_TIMEOUT_CHECK requires option DUK_USE_INTERRUPT_COUNTER (which is missing) +#endif +#if defined(DUK_USE_EXTSTR_FREE) && !defined(DUK_USE_HSTRING_EXTDATA) +#error config option DUK_USE_EXTSTR_FREE requires option DUK_USE_HSTRING_EXTDATA (which is missing) +#endif +#if defined(DUK_USE_EXTSTR_INTERN_CHECK) && !defined(DUK_USE_HSTRING_EXTDATA) +#error config option DUK_USE_EXTSTR_INTERN_CHECK requires option DUK_USE_HSTRING_EXTDATA (which is missing) +#endif +#if defined(DUK_USE_FASTINT) && !defined(DUK_USE_64BIT_OPS) +#error config option DUK_USE_FASTINT requires option DUK_USE_64BIT_OPS (which is missing) +#endif +#if defined(DUK_USE_FILE_IO) +#error unsupported config option used (option has been removed): DUK_USE_FILE_IO +#endif +#if defined(DUK_USE_FULL_TVAL) +#error unsupported config option used (option has been removed): DUK_USE_FULL_TVAL +#endif +#if defined(DUK_USE_FUNCPTR_DEC16) && !defined(DUK_USE_FUNCPTR16) +#error config option DUK_USE_FUNCPTR_DEC16 requires option DUK_USE_FUNCPTR16 (which is missing) +#endif +#if defined(DUK_USE_FUNCPTR_ENC16) && !defined(DUK_USE_FUNCPTR16) +#error config option DUK_USE_FUNCPTR_ENC16 requires option DUK_USE_FUNCPTR16 (which is missing) +#endif +#if defined(DUK_USE_HASHBYTES_UNALIGNED_U32_ACCESS) +#error unsupported config option used (option has been removed): DUK_USE_HASHBYTES_UNALIGNED_U32_ACCESS +#endif +#if defined(DUK_USE_HEAPPTR16) && defined(DUK_USE_DEBUG) +#error config option DUK_USE_HEAPPTR16 conflicts with option DUK_USE_DEBUG (which is also defined) +#endif +#if defined(DUK_USE_HEAPPTR_DEC16) && !defined(DUK_USE_HEAPPTR16) +#error config option DUK_USE_HEAPPTR_DEC16 requires option DUK_USE_HEAPPTR16 (which is missing) +#endif +#if defined(DUK_USE_HEAPPTR_ENC16) && !defined(DUK_USE_HEAPPTR16) +#error config option DUK_USE_HEAPPTR_ENC16 requires option DUK_USE_HEAPPTR16 (which is missing) +#endif +#if defined(DUK_USE_INTEGER_BE) +#error unsupported config option used (option has been removed): DUK_USE_INTEGER_BE +#endif +#if defined(DUK_USE_INTEGER_BE) && defined(DUK_USE_INTEGER_LE) +#error config option DUK_USE_INTEGER_BE conflicts with option DUK_USE_INTEGER_LE (which is also defined) +#endif +#if defined(DUK_USE_INTEGER_BE) && defined(DUK_USE_INTEGER_ME) +#error config option DUK_USE_INTEGER_BE conflicts with option DUK_USE_INTEGER_ME (which is also defined) +#endif +#if defined(DUK_USE_INTEGER_LE) +#error unsupported config option used (option has been removed): DUK_USE_INTEGER_LE +#endif +#if defined(DUK_USE_INTEGER_LE) && defined(DUK_USE_INTEGER_BE) +#error config option DUK_USE_INTEGER_LE conflicts with option DUK_USE_INTEGER_BE (which is also defined) +#endif +#if defined(DUK_USE_INTEGER_LE) && defined(DUK_USE_INTEGER_ME) +#error config option DUK_USE_INTEGER_LE conflicts with option DUK_USE_INTEGER_ME (which is also defined) +#endif +#if defined(DUK_USE_INTEGER_ME) +#error unsupported config option used (option has been removed): DUK_USE_INTEGER_ME +#endif +#if defined(DUK_USE_INTEGER_ME) && defined(DUK_USE_INTEGER_LE) +#error config option DUK_USE_INTEGER_ME conflicts with option DUK_USE_INTEGER_LE (which is also defined) +#endif +#if defined(DUK_USE_INTEGER_ME) && defined(DUK_USE_INTEGER_BE) +#error config option DUK_USE_INTEGER_ME conflicts with option DUK_USE_INTEGER_BE (which is also defined) +#endif +#if defined(DUK_USE_MARKANDSWEEP_FINALIZER_TORTURE) +#error unsupported config option used (option has been removed): DUK_USE_MARKANDSWEEP_FINALIZER_TORTURE +#endif +#if defined(DUK_USE_MARK_AND_SWEEP) +#error unsupported config option used (option has been removed): DUK_USE_MARK_AND_SWEEP +#endif +#if defined(DUK_USE_MATH_FMAX) +#error unsupported config option used (option has been removed): DUK_USE_MATH_FMAX +#endif +#if defined(DUK_USE_MATH_FMIN) +#error unsupported config option used (option has been removed): DUK_USE_MATH_FMIN +#endif +#if defined(DUK_USE_MATH_ROUND) +#error unsupported config option used (option has been removed): DUK_USE_MATH_ROUND +#endif +#if defined(DUK_USE_MS_STRINGTABLE_RESIZE) +#error unsupported config option used (option has been removed): DUK_USE_MS_STRINGTABLE_RESIZE +#endif +#if defined(DUK_USE_NONSTD_ARRAY_CONCAT_TRAILER) +#error unsupported config option used (option has been removed): DUK_USE_NONSTD_ARRAY_CONCAT_TRAILER +#endif +#if defined(DUK_USE_NONSTD_ARRAY_MAP_TRAILER) +#error unsupported config option used (option has been removed): DUK_USE_NONSTD_ARRAY_MAP_TRAILER +#endif +#if defined(DUK_USE_NONSTD_REGEXP_DOLLAR_ESCAPE) +#error unsupported config option used (option has been removed): DUK_USE_NONSTD_REGEXP_DOLLAR_ESCAPE +#endif +#if defined(DUK_USE_NO_DOUBLE_ALIASING_SELFTEST) +#error unsupported config option used (option has been removed): DUK_USE_NO_DOUBLE_ALIASING_SELFTEST +#endif +#if defined(DUK_USE_OCTAL_SUPPORT) +#error unsupported config option used (option has been removed): DUK_USE_OCTAL_SUPPORT +#endif +#if defined(DUK_USE_PACKED_TVAL_POSSIBLE) +#error unsupported config option used (option has been removed): DUK_USE_PACKED_TVAL_POSSIBLE +#endif +#if defined(DUK_USE_PANIC_ABORT) +#error unsupported config option used (option has been removed): DUK_USE_PANIC_ABORT +#endif +#if defined(DUK_USE_PANIC_EXIT) +#error unsupported config option used (option has been removed): DUK_USE_PANIC_EXIT +#endif +#if defined(DUK_USE_PANIC_HANDLER) +#error unsupported config option used (option has been removed): DUK_USE_PANIC_HANDLER +#endif +#if defined(DUK_USE_PANIC_SEGFAULT) +#error unsupported config option used (option has been removed): DUK_USE_PANIC_SEGFAULT +#endif +#if defined(DUK_USE_POW_NETBSD_WORKAROUND) +#error unsupported config option used (option has been removed): DUK_USE_POW_NETBSD_WORKAROUND +#endif +#if defined(DUK_USE_RDTSC) +#error unsupported config option used (option has been removed): DUK_USE_RDTSC +#endif +#if defined(DUK_USE_REFZERO_FINALIZER_TORTURE) +#error unsupported config option used (option has been removed): DUK_USE_REFZERO_FINALIZER_TORTURE +#endif +#if defined(DUK_USE_ROM_GLOBAL_CLONE) && !defined(DUK_USE_ROM_STRINGS) +#error config option DUK_USE_ROM_GLOBAL_CLONE requires option DUK_USE_ROM_STRINGS (which is missing) +#endif +#if defined(DUK_USE_ROM_GLOBAL_CLONE) && !defined(DUK_USE_ROM_OBJECTS) +#error config option DUK_USE_ROM_GLOBAL_CLONE requires option DUK_USE_ROM_OBJECTS (which is missing) +#endif +#if defined(DUK_USE_ROM_GLOBAL_CLONE) && defined(DUK_USE_ROM_GLOBAL_INHERIT) +#error config option DUK_USE_ROM_GLOBAL_CLONE conflicts with option DUK_USE_ROM_GLOBAL_INHERIT (which is also defined) +#endif +#if defined(DUK_USE_ROM_GLOBAL_INHERIT) && !defined(DUK_USE_ROM_STRINGS) +#error config option DUK_USE_ROM_GLOBAL_INHERIT requires option DUK_USE_ROM_STRINGS (which is missing) +#endif +#if defined(DUK_USE_ROM_GLOBAL_INHERIT) && !defined(DUK_USE_ROM_OBJECTS) +#error config option DUK_USE_ROM_GLOBAL_INHERIT requires option DUK_USE_ROM_OBJECTS (which is missing) +#endif +#if defined(DUK_USE_ROM_GLOBAL_INHERIT) && defined(DUK_USE_ROM_GLOBAL_CLONE) +#error config option DUK_USE_ROM_GLOBAL_INHERIT conflicts with option DUK_USE_ROM_GLOBAL_CLONE (which is also defined) +#endif +#if defined(DUK_USE_ROM_OBJECTS) && !defined(DUK_USE_ROM_STRINGS) +#error config option DUK_USE_ROM_OBJECTS requires option DUK_USE_ROM_STRINGS (which is missing) +#endif +#if defined(DUK_USE_ROM_STRINGS) && !defined(DUK_USE_ROM_OBJECTS) +#error config option DUK_USE_ROM_STRINGS requires option DUK_USE_ROM_OBJECTS (which is missing) +#endif +#if defined(DUK_USE_SETJMP) +#error unsupported config option used (option has been removed): DUK_USE_SETJMP +#endif +#if defined(DUK_USE_SIGSETJMP) +#error unsupported config option used (option has been removed): DUK_USE_SIGSETJMP +#endif +#if defined(DUK_USE_STRTAB_CHAIN) +#error unsupported config option used (option has been removed): DUK_USE_STRTAB_CHAIN +#endif +#if defined(DUK_USE_STRTAB_CHAIN_SIZE) +#error unsupported config option used (option has been removed): DUK_USE_STRTAB_CHAIN_SIZE +#endif +#if defined(DUK_USE_STRTAB_CHAIN_SIZE) && !defined(DUK_USE_STRTAB_CHAIN) +#error config option DUK_USE_STRTAB_CHAIN_SIZE requires option DUK_USE_STRTAB_CHAIN (which is missing) +#endif +#if defined(DUK_USE_STRTAB_PROBE) +#error unsupported config option used (option has been removed): DUK_USE_STRTAB_PROBE +#endif +#if defined(DUK_USE_STRTAB_PTRCOMP) && !defined(DUK_USE_HEAPPTR16) +#error config option DUK_USE_STRTAB_PTRCOMP requires option DUK_USE_HEAPPTR16 (which is missing) +#endif +#if defined(DUK_USE_TAILCALL) && defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) +#error config option DUK_USE_TAILCALL conflicts with option DUK_USE_NONSTD_FUNC_CALLER_PROPERTY (which is also defined) +#endif +#if defined(DUK_USE_UNALIGNED_ACCESSES_POSSIBLE) +#error unsupported config option used (option has been removed): DUK_USE_UNALIGNED_ACCESSES_POSSIBLE +#endif +#if defined(DUK_USE_UNDERSCORE_SETJMP) +#error unsupported config option used (option has been removed): DUK_USE_UNDERSCORE_SETJMP +#endif +#if defined(DUK_USE_USER_DECLARE) +#error unsupported config option used (option has been removed): DUK_USE_USER_DECLARE +#endif +#if defined(DUK_USE_USER_INITJS) +#error unsupported config option used (option has been removed): DUK_USE_USER_INITJS +#endif + +#if defined(DUK_USE_CPP_EXCEPTIONS) && !defined(__cplusplus) +#error DUK_USE_CPP_EXCEPTIONS enabled but not compiling with a C++ compiler +#endif + +/* + * Convert DUK_USE_BYTEORDER, from whatever source, into currently used + * internal defines. If detection failed, #error out. + */ + +#if defined(DUK_USE_BYTEORDER) +#if (DUK_USE_BYTEORDER == 1) +#define DUK_USE_INTEGER_LE +#define DUK_USE_DOUBLE_LE +#elif (DUK_USE_BYTEORDER == 2) +#define DUK_USE_INTEGER_LE /* integer endianness is little on purpose */ +#define DUK_USE_DOUBLE_ME +#elif (DUK_USE_BYTEORDER == 3) +#define DUK_USE_INTEGER_BE +#define DUK_USE_DOUBLE_BE +#else +#error unsupported: byte order invalid +#endif /* byte order */ +#else +#error unsupported: byte order detection failed +#endif /* defined(DUK_USE_BYTEORDER) */ + +#endif /* DUK_CONFIG_H_INCLUDED */ diff --git a/source/engine/duktape.c b/source/engine/duktape.c new file mode 100644 index 00000000..573e70c2 --- /dev/null +++ b/source/engine/duktape.c @@ -0,0 +1,101351 @@ +/* + * Single source autogenerated distributable for Duktape 2.7.0. + * + * Git commit 03d4d728f8365021de6955c649e6dcd05dcca99f (03d4d72-dirty). + * Git branch HEAD. + * + * See Duktape AUTHORS.rst and LICENSE.txt for copyright and + * licensing information. + */ + +/* LICENSE.txt */ +/* +* =============== +* Duktape license +* =============== +* +* (http://opensource.org/licenses/MIT) +* +* Copyright (c) 2013-present by Duktape authors (see AUTHORS.rst) +* +* Permission is hereby granted, free of charge, to any person obtaining a copy +* of this software and associated documentation files (the "Software"), to deal +* in the Software without restriction, including without limitation the rights +* to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +* copies of the Software, and to permit persons to whom the Software is +* furnished to do so, subject to the following conditions: +* +* The above copyright notice and this permission notice shall be included in +* all copies or substantial portions of the Software. +* +* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +* AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +* OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +* THE SOFTWARE. +*/ + +/* AUTHORS.rst */ +/* +* =============== +* Duktape authors +* =============== +* +* Copyright +* ========= +* +* Duktape copyrights are held by its authors. Each author has a copyright +* to their contribution, and agrees to irrevocably license the contribution +* under the Duktape ``LICENSE.txt``. +* +* Authors +* ======= +* +* Please include an e-mail address, a link to your GitHub profile, or something +* similar to allow your contribution to be identified accurately. +* +* The following people have contributed code, website contents, or Wiki contents, +* and agreed to irrevocably license their contributions under the Duktape +* ``LICENSE.txt`` (in order of appearance): +* +* * Sami Vaarala +* * Niki Dobrev +* * Andreas \u00d6man +* * L\u00e1szl\u00f3 Lang\u00f3 +* * Legimet +* * Karl Skomski +* * Bruce Pascoe +* * Ren\u00e9 Hollander +* * Julien Hamaide (https://github.com/crazyjul) +* * Sebastian G\u00f6tte (https://github.com/jaseg) +* * Tomasz Magulski (https://github.com/magul) +* * \D. Bohdan (https://github.com/dbohdan) +* * Ond\u0159ej Jirman (https://github.com/megous) +* * Sa\u00fal Ibarra Corretg\u00e9 +* * Jeremy HU +* * Ole Andr\u00e9 Vadla Ravn\u00e5s (https://github.com/oleavr) +* * Harold Brenes (https://github.com/harold-b) +* * Oliver Crow (https://github.com/ocrow) +* * Jakub Ch\u0142api\u0144ski (https://github.com/jchlapinski) +* * Brett Vickers (https://github.com/beevik) +* * Dominik Okwieka (https://github.com/okitec) +* * Remko Tron\u00e7on (https://el-tramo.be) +* * Romero Malaquias (rbsm@ic.ufal.br) +* * Michael Drake +* * Steven Don (https://github.com/shdon) +* * Simon Stone (https://github.com/sstone1) +* * \J. McC. (https://github.com/jmhmccr) +* * Jakub Nowakowski (https://github.com/jimvonmoon) +* * Tommy Nguyen (https://github.com/tn0502) +* * Fabrice Fontaine (https://github.com/ffontaine) +* * Christopher Hiller (https://github.com/boneskull) +* * Gonzalo Diethelm (https://github.com/gonzus) +* * Michal Kasperek (https://github.com/michalkas) +* * Andrew Janke (https://github.com/apjanke) +* * Steve Fan (https://github.com/stevefan1999) +* * Edward Betts (https://github.com/edwardbetts) +* * Ozhan Duz (https://github.com/webfolderio) +* * Akos Kiss (https://github.com/akosthekiss) +* * TheBrokenRail (https://github.com/TheBrokenRail) +* * Jesse Doyle (https://github.com/jessedoyle) +* * Gero Kuehn (https://github.com/dc6jgk) +* * James Swift (https://github.com/phraemer) +* * Luis de Bethencourt (https://github.com/luisbg) +* * Ian Whyman (https://github.com/v00d00) +* * Rick Sayre (https://github.com/whorfin) +* * Craig Leres (https://github.com/leres) +* * Maurici Abad (https://github.com/mauriciabad) +* * Nancy Li (https://github.com/NancyLi1013) +* * William Parks (https://github.com/WilliamParks) +* * Sam Hellawell (https://github.com/samhellawell) +* * Vladislavs Sokurenko (https://github.com/sokurenko) +* +* Other contributions +* =================== +* +* The following people have contributed something other than code (e.g. reported +* bugs, provided ideas, etc; roughly in order of appearance): +* +* * Greg Burns +* * Anthony Rabine +* * Carlos Costa +* * Aur\u00e9lien Bouilland +* * Preet Desai (Pris Matic) +* * judofyr (http://www.reddit.com/user/judofyr) +* * Jason Woofenden +* * Micha\u0142 Przyby\u015b +* * Anthony Howe +* * Conrad Pankoff +* * Jim Schimpf +* * Rajaran Gaunker (https://github.com/zimbabao) +* * Andreas \u00d6man +* * Doug Sanden +* * Josh Engebretson (https://github.com/JoshEngebretson) +* * Remo Eichenberger (https://github.com/remoe) +* * Mamod Mehyar (https://github.com/mamod) +* * David Demelier (https://github.com/markand) +* * Tim Caswell (https://github.com/creationix) +* * Mitchell Blank Jr (https://github.com/mitchblank) +* * https://github.com/yushli +* * Seo Sanghyeon (https://github.com/sanxiyn) +* * Han ChoongWoo (https://github.com/tunz) +* * Joshua Peek (https://github.com/josh) +* * Bruce E. Pascoe (https://github.com/fatcerberus) +* * https://github.com/Kelledin +* * https://github.com/sstruchtrup +* * Michael Drake (https://github.com/tlsa) +* * https://github.com/chris-y +* * Laurent Zubiaur (https://github.com/lzubiaur) +* * Neil Kolban (https://github.com/nkolban) +* * Wilhelm Wanecek (https://github.com/wanecek) +* * Andrew Janke (https://github.com/apjanke) +* * Unamer (https://github.com/unamer) +* * Karl Dahlke (eklhad@gmail.com) +* +* If you are accidentally missing from this list, send me an e-mail +* (``sami.vaarala@iki.fi``) and I'll fix the omission. +*/ + +#line 1 "duk_replacements.c" +/* + * Replacements for missing platform functions. + * + * Unlike the originals, fpclassify() and signbit() replacements don't + * work on any floating point types, only doubles. The C typing here + * mimics the standard prototypes. + */ + +/* #include duk_internal.h */ +#line 1 "duk_internal.h" +/* + * Top-level include file to be used for all (internal) source files. + * + * Source files should not include individual header files, as they + * have not been designed to be individually included. + */ + +#if !defined(DUK_INTERNAL_H_INCLUDED) +#define DUK_INTERNAL_H_INCLUDED + +/* + * The 'duktape.h' header provides the public API, but also handles all + * compiler and platform specific feature detection, Duktape feature + * resolution, inclusion of system headers, etc. These have been merged + * because the public API is also dependent on e.g. detecting appropriate + * C types which is quite platform/compiler specific especially for a non-C99 + * build. The public API is also dependent on the resolved feature set. + * + * Some actions taken by the merged header (such as including system headers) + * are not appropriate for building a user application. The define + * DUK_COMPILING_DUKTAPE allows the merged header to skip/include some + * sections depending on what is being built. + */ + +#define DUK_COMPILING_DUKTAPE +#include "duktape.h" + +/* + * Duktape includes (other than duk_features.h) + * + * The header files expect to be included in an order which satisfies header + * dependencies correctly (the headers themselves don't include any other + * includes). Forward declarations are used to break circular struct/typedef + * dependencies. + */ + +/* #include duk_dblunion.h */ +#line 1 "duk_dblunion.h" +/* + * Union to access IEEE double memory representation, indexes for double + * memory representation, and some macros for double manipulation. + * + * Also used by packed duk_tval. Use a union for bit manipulation to + * minimize aliasing issues in practice. The C99 standard does not + * guarantee that this should work, but it's a very widely supported + * practice for low level manipulation. + * + * IEEE double format summary: + * + * seeeeeee eeeeffff ffffffff ffffffff ffffffff ffffffff ffffffff ffffffff + * A B C D E F G H + * + * s sign bit + * eee... exponent field + * fff... fraction + * + * See http://en.wikipedia.org/wiki/Double_precision_floating-point_format. + * + * NaNs are represented as exponent 0x7ff and mantissa != 0. The NaN is a + * signaling NaN when the highest bit of the mantissa is zero, and a quiet + * NaN when the highest bit is set. + * + * At least three memory layouts are relevant here: + * + * A B C D E F G H Big endian (e.g. 68k) DUK_USE_DOUBLE_BE + * H G F E D C B A Little endian (e.g. x86) DUK_USE_DOUBLE_LE + * D C B A H G F E Mixed endian (e.g. ARM FPA) DUK_USE_DOUBLE_ME + * + * Legacy ARM (FPA) is a special case: ARM double values are in mixed + * endian format while ARM duk_uint64_t values are in standard little endian + * format (H G F E D C B A). When a double is read as a duk_uint64_t + * from memory, the register will contain the (logical) value + * E F G H A B C D. This requires some special handling below. + * See http://infocenter.arm.com/help/index.jsp?topic=/com.arm.doc.dui0056d/Bcfhgcgd.html. + * + * Indexes of various types (8-bit, 16-bit, 32-bit) in memory relative to + * the logical (big endian) order: + * + * byte order duk_uint8_t duk_uint16_t duk_uint32_t + * BE 01234567 0123 01 + * LE 76543210 3210 10 + * ME (ARM) 32107654 1032 01 + * + * Some processors may alter NaN values in a floating point load+store. + * For instance, on X86 a FLD + FSTP may convert a signaling NaN to a + * quiet one. This is catastrophic when NaN space is used in packed + * duk_tval values. See: misc/clang_aliasing.c. + */ + +#if !defined(DUK_DBLUNION_H_INCLUDED) +#define DUK_DBLUNION_H_INCLUDED + +/* + * Union for accessing double parts, also serves as packed duk_tval + */ + +union duk_double_union { + double d; + float f[2]; +#if defined(DUK_USE_64BIT_OPS) + duk_uint64_t ull[1]; +#endif + duk_uint32_t ui[2]; + duk_uint16_t us[4]; + duk_uint8_t uc[8]; +#if defined(DUK_USE_PACKED_TVAL) + void *vp[2]; /* used by packed duk_tval, assumes sizeof(void *) == 4 */ +#endif +}; + +typedef union duk_double_union duk_double_union; + +/* + * Indexes of various types with respect to big endian (logical) layout + */ + +#if defined(DUK_USE_DOUBLE_LE) +#if defined(DUK_USE_64BIT_OPS) +#define DUK_DBL_IDX_ULL0 0 +#endif +#define DUK_DBL_IDX_UI0 1 +#define DUK_DBL_IDX_UI1 0 +#define DUK_DBL_IDX_US0 3 +#define DUK_DBL_IDX_US1 2 +#define DUK_DBL_IDX_US2 1 +#define DUK_DBL_IDX_US3 0 +#define DUK_DBL_IDX_UC0 7 +#define DUK_DBL_IDX_UC1 6 +#define DUK_DBL_IDX_UC2 5 +#define DUK_DBL_IDX_UC3 4 +#define DUK_DBL_IDX_UC4 3 +#define DUK_DBL_IDX_UC5 2 +#define DUK_DBL_IDX_UC6 1 +#define DUK_DBL_IDX_UC7 0 +#define DUK_DBL_IDX_VP0 DUK_DBL_IDX_UI0 /* packed tval */ +#define DUK_DBL_IDX_VP1 DUK_DBL_IDX_UI1 /* packed tval */ +#elif defined(DUK_USE_DOUBLE_BE) +#if defined(DUK_USE_64BIT_OPS) +#define DUK_DBL_IDX_ULL0 0 +#endif +#define DUK_DBL_IDX_UI0 0 +#define DUK_DBL_IDX_UI1 1 +#define DUK_DBL_IDX_US0 0 +#define DUK_DBL_IDX_US1 1 +#define DUK_DBL_IDX_US2 2 +#define DUK_DBL_IDX_US3 3 +#define DUK_DBL_IDX_UC0 0 +#define DUK_DBL_IDX_UC1 1 +#define DUK_DBL_IDX_UC2 2 +#define DUK_DBL_IDX_UC3 3 +#define DUK_DBL_IDX_UC4 4 +#define DUK_DBL_IDX_UC5 5 +#define DUK_DBL_IDX_UC6 6 +#define DUK_DBL_IDX_UC7 7 +#define DUK_DBL_IDX_VP0 DUK_DBL_IDX_UI0 /* packed tval */ +#define DUK_DBL_IDX_VP1 DUK_DBL_IDX_UI1 /* packed tval */ +#elif defined(DUK_USE_DOUBLE_ME) +#if defined(DUK_USE_64BIT_OPS) +#define DUK_DBL_IDX_ULL0 0 /* not directly applicable, byte order differs from a double */ +#endif +#define DUK_DBL_IDX_UI0 0 +#define DUK_DBL_IDX_UI1 1 +#define DUK_DBL_IDX_US0 1 +#define DUK_DBL_IDX_US1 0 +#define DUK_DBL_IDX_US2 3 +#define DUK_DBL_IDX_US3 2 +#define DUK_DBL_IDX_UC0 3 +#define DUK_DBL_IDX_UC1 2 +#define DUK_DBL_IDX_UC2 1 +#define DUK_DBL_IDX_UC3 0 +#define DUK_DBL_IDX_UC4 7 +#define DUK_DBL_IDX_UC5 6 +#define DUK_DBL_IDX_UC6 5 +#define DUK_DBL_IDX_UC7 4 +#define DUK_DBL_IDX_VP0 DUK_DBL_IDX_UI0 /* packed tval */ +#define DUK_DBL_IDX_VP1 DUK_DBL_IDX_UI1 /* packed tval */ +#else +#error internal error +#endif + +/* + * Helper macros for reading/writing memory representation parts, used + * by duk_numconv.c and duk_tval.h. + */ + +#define DUK_DBLUNION_SET_DOUBLE(u, v) \ + do { \ + (u)->d = (v); \ + } while (0) + +#define DUK_DBLUNION_SET_HIGH32(u, v) \ + do { \ + (u)->ui[DUK_DBL_IDX_UI0] = (duk_uint32_t) (v); \ + } while (0) + +#if defined(DUK_USE_64BIT_OPS) +#if defined(DUK_USE_DOUBLE_ME) +#define DUK_DBLUNION_SET_HIGH32_ZERO_LOW32(u, v) \ + do { \ + (u)->ull[DUK_DBL_IDX_ULL0] = (duk_uint64_t) (v); \ + } while (0) +#else +#define DUK_DBLUNION_SET_HIGH32_ZERO_LOW32(u, v) \ + do { \ + (u)->ull[DUK_DBL_IDX_ULL0] = ((duk_uint64_t) (v)) << 32; \ + } while (0) +#endif +#else /* DUK_USE_64BIT_OPS */ +#define DUK_DBLUNION_SET_HIGH32_ZERO_LOW32(u, v) \ + do { \ + (u)->ui[DUK_DBL_IDX_UI0] = (duk_uint32_t) (v); \ + (u)->ui[DUK_DBL_IDX_UI1] = (duk_uint32_t) 0; \ + } while (0) +#endif /* DUK_USE_64BIT_OPS */ + +#define DUK_DBLUNION_SET_LOW32(u, v) \ + do { \ + (u)->ui[DUK_DBL_IDX_UI1] = (duk_uint32_t) (v); \ + } while (0) + +#define DUK_DBLUNION_GET_DOUBLE(u) ((u)->d) +#define DUK_DBLUNION_GET_HIGH32(u) ((u)->ui[DUK_DBL_IDX_UI0]) +#define DUK_DBLUNION_GET_LOW32(u) ((u)->ui[DUK_DBL_IDX_UI1]) + +#if defined(DUK_USE_64BIT_OPS) +#if defined(DUK_USE_DOUBLE_ME) +#define DUK_DBLUNION_SET_UINT64(u, v) \ + do { \ + (u)->ui[DUK_DBL_IDX_UI0] = (duk_uint32_t) ((v) >> 32); \ + (u)->ui[DUK_DBL_IDX_UI1] = (duk_uint32_t) (v); \ + } while (0) +#define DUK_DBLUNION_GET_UINT64(u) ((((duk_uint64_t) (u)->ui[DUK_DBL_IDX_UI0]) << 32) | ((duk_uint64_t) (u)->ui[DUK_DBL_IDX_UI1])) +#else +#define DUK_DBLUNION_SET_UINT64(u, v) \ + do { \ + (u)->ull[DUK_DBL_IDX_ULL0] = (duk_uint64_t) (v); \ + } while (0) +#define DUK_DBLUNION_GET_UINT64(u) ((u)->ull[DUK_DBL_IDX_ULL0]) +#endif +#define DUK_DBLUNION_SET_INT64(u, v) DUK_DBLUNION_SET_UINT64((u), (duk_uint64_t) (v)) +#define DUK_DBLUNION_GET_INT64(u) ((duk_int64_t) DUK_DBLUNION_GET_UINT64((u))) +#endif /* DUK_USE_64BIT_OPS */ + +/* + * Double NaN manipulation macros related to NaN normalization needed when + * using the packed duk_tval representation. NaN normalization is necessary + * to keep double values compatible with the duk_tval format. + * + * When packed duk_tval is used, the NaN space is used to store pointers + * and other tagged values in addition to NaNs. Actual NaNs are normalized + * to a specific quiet NaN. The macros below are used by the implementation + * to check and normalize NaN values when they might be created. The macros + * are essentially NOPs when the non-packed duk_tval representation is used. + * + * A FULL check is exact and checks all bits. A NOTFULL check is used by + * the packed duk_tval and works correctly for all NaNs except those that + * begin with 0x7ff0. Since the 'normalized NaN' values used with packed + * duk_tval begin with 0x7ff8, the partial check is reliable when packed + * duk_tval is used. The 0x7ff8 prefix means the normalized NaN will be a + * quiet NaN regardless of its remaining lower bits. + * + * The ME variant below is specifically for ARM byte order, which has the + * feature that while doubles have a mixed byte order (32107654), unsigned + * long long values has a little endian byte order (76543210). When writing + * a logical double value through a ULL pointer, the 32-bit words need to be + * swapped; hence the #if defined()s below for ULL writes with DUK_USE_DOUBLE_ME. + * This is not full ARM support but suffices for some environments. + */ + +#if defined(DUK_USE_64BIT_OPS) +#if defined(DUK_USE_DOUBLE_ME) +/* Macros for 64-bit ops + mixed endian doubles. */ +#define DUK__DBLUNION_SET_NAN_FULL(u) \ + do { \ + (u)->ull[DUK_DBL_IDX_ULL0] = DUK_U64_CONSTANT(0x000000007ff80000); \ + } while (0) +#define DUK__DBLUNION_IS_NAN_FULL(u) \ + ((((u)->ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x000000007ff00000)) == DUK_U64_CONSTANT(0x000000007ff00000)) && \ + ((((u)->ull[DUK_DBL_IDX_ULL0]) & DUK_U64_CONSTANT(0xffffffff000fffff)) != 0)) +#define DUK__DBLUNION_IS_NORMALIZED_NAN_FULL(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0x000000007ff80000)) +#define DUK__DBLUNION_IS_ANYINF(u) \ + (((u)->ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0xffffffff7fffffff)) == DUK_U64_CONSTANT(0x000000007ff00000)) +#define DUK__DBLUNION_IS_POSINF(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0x000000007ff00000)) +#define DUK__DBLUNION_IS_NEGINF(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0x00000000fff00000)) +#define DUK__DBLUNION_IS_ANYZERO(u) \ + (((u)->ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0xffffffff7fffffff)) == DUK_U64_CONSTANT(0x0000000000000000)) +#define DUK__DBLUNION_IS_POSZERO(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0x0000000000000000)) +#define DUK__DBLUNION_IS_NEGZERO(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0x0000000080000000)) +#else +/* Macros for 64-bit ops + big/little endian doubles. */ +#define DUK__DBLUNION_SET_NAN_FULL(u) \ + do { \ + (u)->ull[DUK_DBL_IDX_ULL0] = DUK_U64_CONSTANT(0x7ff8000000000000); \ + } while (0) +#define DUK__DBLUNION_IS_NAN_FULL(u) \ + ((((u)->ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x7ff0000000000000)) == DUK_U64_CONSTANT(0x7ff0000000000000)) && \ + ((((u)->ull[DUK_DBL_IDX_ULL0]) & DUK_U64_CONSTANT(0x000fffffffffffff)) != 0)) +#define DUK__DBLUNION_IS_NORMALIZED_NAN_FULL(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0x7ff8000000000000)) +#define DUK__DBLUNION_IS_ANYINF(u) \ + (((u)->ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x7fffffffffffffff)) == DUK_U64_CONSTANT(0x7ff0000000000000)) +#define DUK__DBLUNION_IS_POSINF(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0x7ff0000000000000)) +#define DUK__DBLUNION_IS_NEGINF(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0xfff0000000000000)) +#define DUK__DBLUNION_IS_ANYZERO(u) \ + (((u)->ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x7fffffffffffffff)) == DUK_U64_CONSTANT(0x0000000000000000)) +#define DUK__DBLUNION_IS_POSZERO(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0x0000000000000000)) +#define DUK__DBLUNION_IS_NEGZERO(u) ((u)->ull[DUK_DBL_IDX_ULL0] == DUK_U64_CONSTANT(0x8000000000000000)) +#endif +#else /* DUK_USE_64BIT_OPS */ +/* Macros for no 64-bit ops, any endianness. */ +#define DUK__DBLUNION_SET_NAN_FULL(u) \ + do { \ + (u)->ui[DUK_DBL_IDX_UI0] = (duk_uint32_t) 0x7ff80000UL; \ + (u)->ui[DUK_DBL_IDX_UI1] = (duk_uint32_t) 0x00000000UL; \ + } while (0) +#define DUK__DBLUNION_IS_NAN_FULL(u) \ + ((((u)->ui[DUK_DBL_IDX_UI0] & 0x7ff00000UL) == 0x7ff00000UL) && \ + (((u)->ui[DUK_DBL_IDX_UI0] & 0x000fffffUL) != 0 || (u)->ui[DUK_DBL_IDX_UI1] != 0)) +#define DUK__DBLUNION_IS_NORMALIZED_NAN_FULL(u) \ + (((u)->ui[DUK_DBL_IDX_UI0] == 0x7ff80000UL) && ((u)->ui[DUK_DBL_IDX_UI1] == 0x00000000UL)) +#define DUK__DBLUNION_IS_ANYINF(u) \ + ((((u)->ui[DUK_DBL_IDX_UI0] & 0x7fffffffUL) == 0x7ff00000UL) && ((u)->ui[DUK_DBL_IDX_UI1] == 0x00000000UL)) +#define DUK__DBLUNION_IS_POSINF(u) (((u)->ui[DUK_DBL_IDX_UI0] == 0x7ff00000UL) && ((u)->ui[DUK_DBL_IDX_UI1] == 0x00000000UL)) +#define DUK__DBLUNION_IS_NEGINF(u) (((u)->ui[DUK_DBL_IDX_UI0] == 0xfff00000UL) && ((u)->ui[DUK_DBL_IDX_UI1] == 0x00000000UL)) +#define DUK__DBLUNION_IS_ANYZERO(u) \ + ((((u)->ui[DUK_DBL_IDX_UI0] & 0x7fffffffUL) == 0x00000000UL) && ((u)->ui[DUK_DBL_IDX_UI1] == 0x00000000UL)) +#define DUK__DBLUNION_IS_POSZERO(u) (((u)->ui[DUK_DBL_IDX_UI0] == 0x00000000UL) && ((u)->ui[DUK_DBL_IDX_UI1] == 0x00000000UL)) +#define DUK__DBLUNION_IS_NEGZERO(u) (((u)->ui[DUK_DBL_IDX_UI0] == 0x80000000UL) && ((u)->ui[DUK_DBL_IDX_UI1] == 0x00000000UL)) +#endif /* DUK_USE_64BIT_OPS */ + +#define DUK__DBLUNION_SET_NAN_NOTFULL(u) \ + do { \ + (u)->us[DUK_DBL_IDX_US0] = 0x7ff8UL; \ + } while (0) + +#define DUK__DBLUNION_IS_NAN_NOTFULL(u) \ + /* E == 0x7ff, topmost four bits of F != 0 => assume NaN */ \ + ((((u)->us[DUK_DBL_IDX_US0] & 0x7ff0UL) == 0x7ff0UL) && (((u)->us[DUK_DBL_IDX_US0] & 0x000fUL) != 0x0000UL)) + +#define DUK__DBLUNION_IS_NORMALIZED_NAN_NOTFULL(u) \ + /* E == 0x7ff, F == 8 => normalized NaN */ \ + ((u)->us[DUK_DBL_IDX_US0] == 0x7ff8UL) + +#define DUK__DBLUNION_NORMALIZE_NAN_CHECK_FULL(u) \ + do { \ + if (DUK__DBLUNION_IS_NAN_FULL((u))) { \ + DUK__DBLUNION_SET_NAN_FULL((u)); \ + } \ + } while (0) + +#define DUK__DBLUNION_NORMALIZE_NAN_CHECK_NOTFULL(u) \ + do { \ + /* Check must be full. */ \ + if (DUK__DBLUNION_IS_NAN_FULL((u))) { \ + DUK__DBLUNION_SET_NAN_NOTFULL((u)); \ + } \ + } while (0) + +/* Concrete macros for NaN handling used by the implementation internals. + * Chosen so that they match the duk_tval representation: with a packed + * duk_tval, ensure NaNs are properly normalized; with a non-packed duk_tval + * these are essentially NOPs. + */ + +#if defined(DUK_USE_PACKED_TVAL) +#define DUK_DBLUNION_NORMALIZE_NAN_CHECK(u) DUK__DBLUNION_NORMALIZE_NAN_CHECK_FULL((u)) +#define DUK_DBLUNION_IS_NAN(u) DUK__DBLUNION_IS_NAN_FULL((u)) +#define DUK_DBLUNION_IS_NORMALIZED_NAN(u) DUK__DBLUNION_IS_NORMALIZED_NAN_FULL((u)) +#define DUK_DBLUNION_SET_NAN(d) DUK__DBLUNION_SET_NAN_FULL((d)) +#if 0 +#define DUK_DBLUNION_NORMALIZE_NAN_CHECK(u) DUK__DBLUNION_NORMALIZE_NAN_CHECK_NOTFULL((u)) +#define DUK_DBLUNION_IS_NAN(u) DUK__DBLUNION_IS_NAN_NOTFULL((u)) +#define DUK_DBLUNION_IS_NORMALIZED_NAN(u) DUK__DBLUNION_IS_NORMALIZED_NAN_NOTFULL((u)) +#define DUK_DBLUNION_SET_NAN(d) DUK__DBLUNION_SET_NAN_NOTFULL((d)) +#endif +#define DUK_DBLUNION_IS_NORMALIZED(u) \ + (!DUK_DBLUNION_IS_NAN((u)) || /* either not a NaN */ \ + DUK_DBLUNION_IS_NORMALIZED_NAN((u))) /* or is a normalized NaN */ +#else /* DUK_USE_PACKED_TVAL */ +#define DUK_DBLUNION_NORMALIZE_NAN_CHECK(u) /* nop: no need to normalize */ +#define DUK_DBLUNION_IS_NAN(u) DUK__DBLUNION_IS_NAN_FULL((u)) /* (DUK_ISNAN((u)->d)) */ +#define DUK_DBLUNION_IS_NORMALIZED_NAN(u) DUK__DBLUNION_IS_NAN_FULL((u)) /* (DUK_ISNAN((u)->d)) */ +#define DUK_DBLUNION_IS_NORMALIZED(u) 1 /* all doubles are considered normalized */ +#define DUK_DBLUNION_SET_NAN(u) \ + do { \ + /* in non-packed representation we don't care about which NaN is used */ \ + (u)->d = DUK_DOUBLE_NAN; \ + } while (0) +#endif /* DUK_USE_PACKED_TVAL */ + +#define DUK_DBLUNION_IS_ANYINF(u) DUK__DBLUNION_IS_ANYINF((u)) +#define DUK_DBLUNION_IS_POSINF(u) DUK__DBLUNION_IS_POSINF((u)) +#define DUK_DBLUNION_IS_NEGINF(u) DUK__DBLUNION_IS_NEGINF((u)) + +#define DUK_DBLUNION_IS_ANYZERO(u) DUK__DBLUNION_IS_ANYZERO((u)) +#define DUK_DBLUNION_IS_POSZERO(u) DUK__DBLUNION_IS_POSZERO((u)) +#define DUK_DBLUNION_IS_NEGZERO(u) DUK__DBLUNION_IS_NEGZERO((u)) + +/* XXX: native 64-bit byteswaps when available */ + +/* 64-bit byteswap, same operation independent of target endianness. */ +#define DUK_DBLUNION_BSWAP64(u) \ + do { \ + duk_uint32_t duk__bswaptmp1, duk__bswaptmp2; \ + duk__bswaptmp1 = (u)->ui[0]; \ + duk__bswaptmp2 = (u)->ui[1]; \ + duk__bswaptmp1 = DUK_BSWAP32(duk__bswaptmp1); \ + duk__bswaptmp2 = DUK_BSWAP32(duk__bswaptmp2); \ + (u)->ui[0] = duk__bswaptmp2; \ + (u)->ui[1] = duk__bswaptmp1; \ + } while (0) + +/* Byteswap an IEEE double in the duk_double_union from host to network + * order. For a big endian target this is a no-op. + */ +#if defined(DUK_USE_DOUBLE_LE) +#define DUK_DBLUNION_DOUBLE_HTON(u) \ + do { \ + duk_uint32_t duk__bswaptmp1, duk__bswaptmp2; \ + duk__bswaptmp1 = (u)->ui[0]; \ + duk__bswaptmp2 = (u)->ui[1]; \ + duk__bswaptmp1 = DUK_BSWAP32(duk__bswaptmp1); \ + duk__bswaptmp2 = DUK_BSWAP32(duk__bswaptmp2); \ + (u)->ui[0] = duk__bswaptmp2; \ + (u)->ui[1] = duk__bswaptmp1; \ + } while (0) +#elif defined(DUK_USE_DOUBLE_ME) +#define DUK_DBLUNION_DOUBLE_HTON(u) \ + do { \ + duk_uint32_t duk__bswaptmp1, duk__bswaptmp2; \ + duk__bswaptmp1 = (u)->ui[0]; \ + duk__bswaptmp2 = (u)->ui[1]; \ + duk__bswaptmp1 = DUK_BSWAP32(duk__bswaptmp1); \ + duk__bswaptmp2 = DUK_BSWAP32(duk__bswaptmp2); \ + (u)->ui[0] = duk__bswaptmp1; \ + (u)->ui[1] = duk__bswaptmp2; \ + } while (0) +#elif defined(DUK_USE_DOUBLE_BE) +#define DUK_DBLUNION_DOUBLE_HTON(u) \ + do { \ + } while (0) +#else +#error internal error, double endianness insane +#endif + +/* Reverse operation is the same. */ +#define DUK_DBLUNION_DOUBLE_NTOH(u) DUK_DBLUNION_DOUBLE_HTON((u)) + +/* Some sign bit helpers. */ +#if defined(DUK_USE_64BIT_OPS) +#define DUK_DBLUNION_HAS_SIGNBIT(u) (((u)->ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x8000000000000000)) != 0) +#define DUK_DBLUNION_GET_SIGNBIT(u) (((u)->ull[DUK_DBL_IDX_ULL0] >> 63U)) +#else +#define DUK_DBLUNION_HAS_SIGNBIT(u) (((u)->ui[DUK_DBL_IDX_UI0] & 0x80000000UL) != 0) +#define DUK_DBLUNION_GET_SIGNBIT(u) (((u)->ui[DUK_DBL_IDX_UI0] >> 31U)) +#endif + +#endif /* DUK_DBLUNION_H_INCLUDED */ +/* #include duk_fltunion.h */ +#line 1 "duk_fltunion.h" +/* + * Union to access IEEE float memory representation. + */ + +#if !defined(DUK_FLTUNION_H_INCLUDED) +#define DUK_FLTUNION_H_INCLUDED + +/* #include duk_internal.h -> already included */ + +union duk_float_union { + float f; + duk_uint32_t ui[1]; + duk_uint16_t us[2]; + duk_uint8_t uc[4]; +}; + +typedef union duk_float_union duk_float_union; + +#if defined(DUK_USE_DOUBLE_LE) || defined(DUK_USE_DOUBLE_ME) +#define DUK_FLT_IDX_UI0 0 +#define DUK_FLT_IDX_US0 1 +#define DUK_FLT_IDX_US1 0 +#define DUK_FLT_IDX_UC0 3 +#define DUK_FLT_IDX_UC1 2 +#define DUK_FLT_IDX_UC2 1 +#define DUK_FLT_IDX_UC3 0 +#elif defined(DUK_USE_DOUBLE_BE) +#define DUK_FLT_IDX_UI0 0 +#define DUK_FLT_IDX_US0 0 +#define DUK_FLT_IDX_US1 1 +#define DUK_FLT_IDX_UC0 0 +#define DUK_FLT_IDX_UC1 1 +#define DUK_FLT_IDX_UC2 2 +#define DUK_FLT_IDX_UC3 3 +#else +#error internal error +#endif + +#endif /* DUK_FLTUNION_H_INCLUDED */ +/* #include duk_replacements.h */ +#line 1 "duk_replacements.h" +#if !defined(DUK_REPLACEMENTS_H_INCLUDED) +#define DUK_REPLACEMENTS_H_INCLUDED + +#if !defined(DUK_SINGLE_FILE) +#if defined(DUK_USE_COMPUTED_INFINITY) +DUK_INTERNAL_DECL double duk_computed_infinity; +#endif +#if defined(DUK_USE_COMPUTED_NAN) +DUK_INTERNAL_DECL double duk_computed_nan; +#endif +#endif /* !DUK_SINGLE_FILE */ + +#if defined(DUK_USE_REPL_FPCLASSIFY) +DUK_INTERNAL_DECL int duk_repl_fpclassify(double x); +#endif +#if defined(DUK_USE_REPL_SIGNBIT) +DUK_INTERNAL_DECL int duk_repl_signbit(double x); +#endif +#if defined(DUK_USE_REPL_ISFINITE) +DUK_INTERNAL_DECL int duk_repl_isfinite(double x); +#endif +#if defined(DUK_USE_REPL_ISNAN) +DUK_INTERNAL_DECL int duk_repl_isnan(double x); +#endif +#if defined(DUK_USE_REPL_ISINF) +DUK_INTERNAL_DECL int duk_repl_isinf(double x); +#endif + +#endif /* DUK_REPLACEMENTS_H_INCLUDED */ +/* #include duk_jmpbuf.h */ +#line 1 "duk_jmpbuf.h" +/* + * Wrapper for jmp_buf. + * + * This is used because jmp_buf is an array type for backward compatibility. + * Wrapping jmp_buf in a struct makes pointer references, sizeof, etc, + * behave more intuitively. + * + * http://en.wikipedia.org/wiki/Setjmp.h#Member_types + */ + +#if !defined(DUK_JMPBUF_H_INCLUDED) +#define DUK_JMPBUF_H_INCLUDED + +#if defined(DUK_USE_CPP_EXCEPTIONS) +struct duk_jmpbuf { + duk_small_int_t dummy; /* unused */ +}; +#else +struct duk_jmpbuf { + DUK_JMPBUF_TYPE jb; +}; +#endif + +#endif /* DUK_JMPBUF_H_INCLUDED */ +/* #include duk_exception.h */ +#line 1 "duk_exception.h" +/* + * Exceptions for Duktape internal throws when C++ exceptions are used + * for long control transfers. + */ + +#if !defined(DUK_EXCEPTION_H_INCLUDED) +#define DUK_EXCEPTION_H_INCLUDED + +#if defined(DUK_USE_CPP_EXCEPTIONS) +/* Internal exception used as a setjmp-longjmp replacement. User code should + * NEVER see or catch this exception, so it doesn't inherit from any base + * class which should minimize the chance of user code accidentally catching + * the exception. + */ +class duk_internal_exception { + /* intentionally empty */ +}; + +/* Fatal error, thrown as a specific C++ exception with C++ exceptions + * enabled. It is unsafe to continue; doing so may cause crashes or memory + * leaks. This is intended to be either uncaught, or caught by user code + * aware of the "unsafe to continue" semantics. + */ +class duk_fatal_exception : public virtual std::runtime_error { + public: + duk_fatal_exception(const char *message) : std::runtime_error(message) { + } +}; +#endif + +#endif /* DUK_EXCEPTION_H_INCLUDED */ +/* #include duk_forwdecl.h */ +#line 1 "duk_forwdecl.h" +/* + * Forward declarations for all Duktape structures. + */ + +#if !defined(DUK_FORWDECL_H_INCLUDED) +#define DUK_FORWDECL_H_INCLUDED + +/* + * Forward declarations + */ + +#if defined(DUK_USE_CPP_EXCEPTIONS) +class duk_internal_exception; +#else +struct duk_jmpbuf; +#endif + +/* duk_tval intentionally skipped */ +struct duk_heaphdr; +struct duk_heaphdr_string; +struct duk_harray; +struct duk_hstring; +struct duk_hstring_external; +struct duk_hobject; +struct duk_hcompfunc; +struct duk_hnatfunc; +struct duk_hboundfunc; +struct duk_hthread; +struct duk_hbufobj; +struct duk_hdecenv; +struct duk_hobjenv; +struct duk_hproxy; +struct duk_hbuffer; +struct duk_hbuffer_fixed; +struct duk_hbuffer_dynamic; +struct duk_hbuffer_external; + +struct duk_propaccessor; +union duk_propvalue; +struct duk_propdesc; + +struct duk_heap; +struct duk_breakpoint; + +struct duk_activation; +struct duk_catcher; +struct duk_ljstate; +struct duk_strcache_entry; +struct duk_litcache_entry; +struct duk_strtab_entry; + +#if defined(DUK_USE_DEBUG) +struct duk_fixedbuffer; +#endif + +struct duk_bitdecoder_ctx; +struct duk_bitencoder_ctx; +struct duk_bufwriter_ctx; + +struct duk_token; +struct duk_re_token; +struct duk_lexer_point; +struct duk_lexer_ctx; +struct duk_lexer_codepoint; + +struct duk_compiler_instr; +struct duk_compiler_func; +struct duk_compiler_ctx; + +struct duk_re_matcher_ctx; +struct duk_re_compiler_ctx; + +#if defined(DUK_USE_CPP_EXCEPTIONS) +/* no typedef */ +#else +typedef struct duk_jmpbuf duk_jmpbuf; +#endif + +/* duk_tval intentionally skipped */ +typedef struct duk_heaphdr duk_heaphdr; +typedef struct duk_heaphdr_string duk_heaphdr_string; +typedef struct duk_harray duk_harray; +typedef struct duk_hstring duk_hstring; +typedef struct duk_hstring_external duk_hstring_external; +typedef struct duk_hobject duk_hobject; +typedef struct duk_hcompfunc duk_hcompfunc; +typedef struct duk_hnatfunc duk_hnatfunc; +typedef struct duk_hboundfunc duk_hboundfunc; +typedef struct duk_hthread duk_hthread; +typedef struct duk_hbufobj duk_hbufobj; +typedef struct duk_hdecenv duk_hdecenv; +typedef struct duk_hobjenv duk_hobjenv; +typedef struct duk_hproxy duk_hproxy; +typedef struct duk_hbuffer duk_hbuffer; +typedef struct duk_hbuffer_fixed duk_hbuffer_fixed; +typedef struct duk_hbuffer_dynamic duk_hbuffer_dynamic; +typedef struct duk_hbuffer_external duk_hbuffer_external; + +typedef struct duk_propaccessor duk_propaccessor; +typedef union duk_propvalue duk_propvalue; +typedef struct duk_propdesc duk_propdesc; + +typedef struct duk_heap duk_heap; +typedef struct duk_breakpoint duk_breakpoint; + +typedef struct duk_activation duk_activation; +typedef struct duk_catcher duk_catcher; +typedef struct duk_ljstate duk_ljstate; +typedef struct duk_strcache_entry duk_strcache_entry; +typedef struct duk_litcache_entry duk_litcache_entry; +typedef struct duk_strtab_entry duk_strtab_entry; + +#if defined(DUK_USE_DEBUG) +typedef struct duk_fixedbuffer duk_fixedbuffer; +#endif + +typedef struct duk_bitdecoder_ctx duk_bitdecoder_ctx; +typedef struct duk_bitencoder_ctx duk_bitencoder_ctx; +typedef struct duk_bufwriter_ctx duk_bufwriter_ctx; + +typedef struct duk_token duk_token; +typedef struct duk_re_token duk_re_token; +typedef struct duk_lexer_point duk_lexer_point; +typedef struct duk_lexer_ctx duk_lexer_ctx; +typedef struct duk_lexer_codepoint duk_lexer_codepoint; + +typedef struct duk_compiler_instr duk_compiler_instr; +typedef struct duk_compiler_func duk_compiler_func; +typedef struct duk_compiler_ctx duk_compiler_ctx; + +typedef struct duk_re_matcher_ctx duk_re_matcher_ctx; +typedef struct duk_re_compiler_ctx duk_re_compiler_ctx; + +#endif /* DUK_FORWDECL_H_INCLUDED */ +/* #include duk_tval.h */ +#line 1 "duk_tval.h" +/* + * Tagged type definition (duk_tval) and accessor macros. + * + * Access all fields through the accessor macros, as the representation + * is quite tricky. + * + * There are two packed type alternatives: an 8-byte representation + * based on an IEEE double (preferred for compactness), and a 12-byte + * representation (portability). The latter is needed also in e.g. + * 64-bit environments (it usually pads to 16 bytes per value). + * + * Selecting the tagged type format involves many trade-offs (memory + * use, size and performance of generated code, portability, etc). + * + * NB: because macro arguments are often expressions, macros should + * avoid evaluating their argument more than once. + */ + +#if !defined(DUK_TVAL_H_INCLUDED) +#define DUK_TVAL_H_INCLUDED + +/* sanity */ +#if !defined(DUK_USE_DOUBLE_LE) && !defined(DUK_USE_DOUBLE_ME) && !defined(DUK_USE_DOUBLE_BE) +#error unsupported: cannot determine byte order variant +#endif + +#if defined(DUK_USE_PACKED_TVAL) +/* ======================================================================== */ + +/* + * Packed 8-byte representation + */ + +/* use duk_double_union as duk_tval directly */ +typedef union duk_double_union duk_tval; +typedef struct { + duk_uint16_t a; + duk_uint16_t b; + duk_uint16_t c; + duk_uint16_t d; +} duk_tval_unused; + +/* tags */ +#define DUK_TAG_NORMALIZED_NAN 0x7ff8UL /* the NaN variant we use */ +/* avoid tag 0xfff0, no risk of confusion with negative infinity */ +#define DUK_TAG_MIN 0xfff1UL +#if defined(DUK_USE_FASTINT) +#define DUK_TAG_FASTINT 0xfff1UL /* embed: integer value */ +#endif +#define DUK_TAG_UNUSED 0xfff2UL /* marker; not actual tagged value */ +#define DUK_TAG_UNDEFINED 0xfff3UL /* embed: nothing */ +#define DUK_TAG_NULL 0xfff4UL /* embed: nothing */ +#define DUK_TAG_BOOLEAN 0xfff5UL /* embed: 0 or 1 (false or true) */ +/* DUK_TAG_NUMBER would logically go here, but it has multiple 'tags' */ +#define DUK_TAG_POINTER 0xfff6UL /* embed: void ptr */ +#define DUK_TAG_LIGHTFUNC 0xfff7UL /* embed: func ptr */ +#define DUK_TAG_STRING 0xfff8UL /* embed: duk_hstring ptr */ +#define DUK_TAG_OBJECT 0xfff9UL /* embed: duk_hobject ptr */ +#define DUK_TAG_BUFFER 0xfffaUL /* embed: duk_hbuffer ptr */ +#define DUK_TAG_MAX 0xfffaUL + +/* for convenience */ +#define DUK_XTAG_BOOLEAN_FALSE 0xfff50000UL +#define DUK_XTAG_BOOLEAN_TRUE 0xfff50001UL + +#define DUK_TVAL_IS_VALID_TAG(tv) (DUK_TVAL_GET_TAG((tv)) - DUK_TAG_MIN <= DUK_TAG_MAX - DUK_TAG_MIN) + +/* DUK_TVAL_UNUSED initializer for duk_tval_unused, works for any endianness. */ +#define DUK_TVAL_UNUSED_INITIALIZER() \ + { DUK_TAG_UNUSED, DUK_TAG_UNUSED, DUK_TAG_UNUSED, DUK_TAG_UNUSED } + +/* two casts to avoid gcc warning: "warning: cast from pointer to integer of different size [-Wpointer-to-int-cast]" */ +#if defined(DUK_USE_64BIT_OPS) +#if defined(DUK_USE_DOUBLE_ME) +#define DUK__TVAL_SET_TAGGEDPOINTER(tv, h, tag) \ + do { \ + (tv)->ull[DUK_DBL_IDX_ULL0] = (((duk_uint64_t) (tag)) << 16) | (((duk_uint64_t) (duk_uint32_t) (h)) << 32); \ + } while (0) +#else +#define DUK__TVAL_SET_TAGGEDPOINTER(tv, h, tag) \ + do { \ + (tv)->ull[DUK_DBL_IDX_ULL0] = (((duk_uint64_t) (tag)) << 48) | ((duk_uint64_t) (duk_uint32_t) (h)); \ + } while (0) +#endif +#else /* DUK_USE_64BIT_OPS */ +#define DUK__TVAL_SET_TAGGEDPOINTER(tv, h, tag) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->ui[DUK_DBL_IDX_UI0] = ((duk_uint32_t) (tag)) << 16; \ + duk__tv->ui[DUK_DBL_IDX_UI1] = (duk_uint32_t) (h); \ + } while (0) +#endif /* DUK_USE_64BIT_OPS */ + +#if defined(DUK_USE_64BIT_OPS) +/* Double casting for pointer to avoid gcc warning (cast from pointer to integer of different size) */ +#if defined(DUK_USE_DOUBLE_ME) +#define DUK__TVAL_SET_LIGHTFUNC(tv, fp, flags) \ + do { \ + (tv)->ull[DUK_DBL_IDX_ULL0] = (((duk_uint64_t) DUK_TAG_LIGHTFUNC) << 16) | ((duk_uint64_t) (flags)) | \ + (((duk_uint64_t) (duk_uint32_t) (fp)) << 32); \ + } while (0) +#else +#define DUK__TVAL_SET_LIGHTFUNC(tv, fp, flags) \ + do { \ + (tv)->ull[DUK_DBL_IDX_ULL0] = (((duk_uint64_t) DUK_TAG_LIGHTFUNC) << 48) | (((duk_uint64_t) (flags)) << 32) | \ + ((duk_uint64_t) (duk_uint32_t) (fp)); \ + } while (0) +#endif +#else /* DUK_USE_64BIT_OPS */ +#define DUK__TVAL_SET_LIGHTFUNC(tv, fp, flags) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->ui[DUK_DBL_IDX_UI0] = (((duk_uint32_t) DUK_TAG_LIGHTFUNC) << 16) | ((duk_uint32_t) (flags)); \ + duk__tv->ui[DUK_DBL_IDX_UI1] = (duk_uint32_t) (fp); \ + } while (0) +#endif /* DUK_USE_64BIT_OPS */ + +#if defined(DUK_USE_FASTINT) +/* Note: masking is done for 'i' to deal with negative numbers correctly */ +#if defined(DUK_USE_DOUBLE_ME) +#define DUK__TVAL_SET_I48(tv, i) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->ui[DUK_DBL_IDX_UI0] = \ + ((duk_uint32_t) DUK_TAG_FASTINT) << 16 | (((duk_uint32_t) ((i) >> 32)) & 0x0000ffffUL); \ + duk__tv->ui[DUK_DBL_IDX_UI1] = (duk_uint32_t) (i); \ + } while (0) +#define DUK__TVAL_SET_U32(tv, i) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->ui[DUK_DBL_IDX_UI0] = ((duk_uint32_t) DUK_TAG_FASTINT) << 16; \ + duk__tv->ui[DUK_DBL_IDX_UI1] = (duk_uint32_t) (i); \ + } while (0) +#else +#define DUK__TVAL_SET_I48(tv, i) \ + do { \ + (tv)->ull[DUK_DBL_IDX_ULL0] = \ + (((duk_uint64_t) DUK_TAG_FASTINT) << 48) | (((duk_uint64_t) (i)) & DUK_U64_CONSTANT(0x0000ffffffffffff)); \ + } while (0) +#define DUK__TVAL_SET_U32(tv, i) \ + do { \ + (tv)->ull[DUK_DBL_IDX_ULL0] = (((duk_uint64_t) DUK_TAG_FASTINT) << 48) | (duk_uint64_t) (i); \ + } while (0) +#endif + +/* This needs to go through a cast because sign extension is needed. */ +#define DUK__TVAL_SET_I32(tv, i) \ + do { \ + duk_int64_t duk__tmp = (duk_int64_t) (i); \ + DUK_TVAL_SET_I48((tv), duk__tmp); \ + } while (0) + +/* XXX: Clumsy sign extend and masking of 16 topmost bits. */ +#if defined(DUK_USE_DOUBLE_ME) +#define DUK__TVAL_GET_FASTINT(tv) \ + (((duk_int64_t) ((((duk_uint64_t) (tv)->ui[DUK_DBL_IDX_UI0]) << 32) | ((duk_uint64_t) (tv)->ui[DUK_DBL_IDX_UI1]))) \ + << 16 >> \ + 16) +#else +#define DUK__TVAL_GET_FASTINT(tv) ((((duk_int64_t) (tv)->ull[DUK_DBL_IDX_ULL0]) << 16) >> 16) +#endif +#define DUK__TVAL_GET_FASTINT_U32(tv) ((tv)->ui[DUK_DBL_IDX_UI1]) +#define DUK__TVAL_GET_FASTINT_I32(tv) ((duk_int32_t) (tv)->ui[DUK_DBL_IDX_UI1]) +#endif /* DUK_USE_FASTINT */ + +#define DUK_TVAL_SET_UNDEFINED(tv) \ + do { \ + (tv)->us[DUK_DBL_IDX_US0] = (duk_uint16_t) DUK_TAG_UNDEFINED; \ + } while (0) +#define DUK_TVAL_SET_UNUSED(tv) \ + do { \ + (tv)->us[DUK_DBL_IDX_US0] = (duk_uint16_t) DUK_TAG_UNUSED; \ + } while (0) +#define DUK_TVAL_SET_NULL(tv) \ + do { \ + (tv)->us[DUK_DBL_IDX_US0] = (duk_uint16_t) DUK_TAG_NULL; \ + } while (0) + +#define DUK_TVAL_SET_BOOLEAN(tv, val) \ + DUK_DBLUNION_SET_HIGH32((tv), (((duk_uint32_t) DUK_TAG_BOOLEAN) << 16) | ((duk_uint32_t) (val))) + +#define DUK_TVAL_SET_NAN(tv) DUK_DBLUNION_SET_NAN_FULL((tv)) + +/* Assumes that caller has normalized NaNs, otherwise trouble ahead. */ +#if defined(DUK_USE_FASTINT) +#define DUK_TVAL_SET_DOUBLE(tv, d) \ + do { \ + duk_double_t duk__dblval; \ + duk__dblval = (d); \ + DUK_ASSERT_DOUBLE_IS_NORMALIZED(duk__dblval); \ + DUK_DBLUNION_SET_DOUBLE((tv), duk__dblval); \ + } while (0) +#define DUK_TVAL_SET_I48(tv, i) DUK__TVAL_SET_I48((tv), (i)) +#define DUK_TVAL_SET_I32(tv, i) DUK__TVAL_SET_I32((tv), (i)) +#define DUK_TVAL_SET_U32(tv, i) DUK__TVAL_SET_U32((tv), (i)) +#define DUK_TVAL_SET_NUMBER_CHKFAST_FAST(tv, d) duk_tval_set_number_chkfast_fast((tv), (d)) +#define DUK_TVAL_SET_NUMBER_CHKFAST_SLOW(tv, d) duk_tval_set_number_chkfast_slow((tv), (d)) +#define DUK_TVAL_SET_NUMBER(tv, d) DUK_TVAL_SET_DOUBLE((tv), (d)) +#define DUK_TVAL_CHKFAST_INPLACE_FAST(tv) \ + do { \ + duk_tval *duk__tv; \ + duk_double_t duk__d; \ + duk__tv = (tv); \ + if (DUK_TVAL_IS_DOUBLE(duk__tv)) { \ + duk__d = DUK_TVAL_GET_DOUBLE(duk__tv); \ + DUK_TVAL_SET_NUMBER_CHKFAST_FAST(duk__tv, duk__d); \ + } \ + } while (0) +#define DUK_TVAL_CHKFAST_INPLACE_SLOW(tv) \ + do { \ + duk_tval *duk__tv; \ + duk_double_t duk__d; \ + duk__tv = (tv); \ + if (DUK_TVAL_IS_DOUBLE(duk__tv)) { \ + duk__d = DUK_TVAL_GET_DOUBLE(duk__tv); \ + DUK_TVAL_SET_NUMBER_CHKFAST_SLOW(duk__tv, duk__d); \ + } \ + } while (0) +#else /* DUK_USE_FASTINT */ +#define DUK_TVAL_SET_DOUBLE(tv, d) \ + do { \ + duk_double_t duk__dblval; \ + duk__dblval = (d); \ + DUK_ASSERT_DOUBLE_IS_NORMALIZED(duk__dblval); \ + DUK_DBLUNION_SET_DOUBLE((tv), duk__dblval); \ + } while (0) +#define DUK_TVAL_SET_I48(tv, i) DUK_TVAL_SET_DOUBLE((tv), (duk_double_t) (i)) /* XXX: fast int-to-double */ +#define DUK_TVAL_SET_I32(tv, i) DUK_TVAL_SET_DOUBLE((tv), (duk_double_t) (i)) +#define DUK_TVAL_SET_U32(tv, i) DUK_TVAL_SET_DOUBLE((tv), (duk_double_t) (i)) +#define DUK_TVAL_SET_NUMBER_CHKFAST_FAST(tv, d) DUK_TVAL_SET_DOUBLE((tv), (d)) +#define DUK_TVAL_SET_NUMBER_CHKFAST_SLOW(tv, d) DUK_TVAL_SET_DOUBLE((tv), (d)) +#define DUK_TVAL_SET_NUMBER(tv, d) DUK_TVAL_SET_DOUBLE((tv), (d)) +#define DUK_TVAL_CHKFAST_INPLACE_FAST(tv) \ + do { \ + } while (0) +#define DUK_TVAL_CHKFAST_INPLACE_SLOW(tv) \ + do { \ + } while (0) +#endif /* DUK_USE_FASTINT */ + +#define DUK_TVAL_SET_FASTINT(tv, i) DUK_TVAL_SET_I48((tv), (i)) /* alias */ + +#define DUK_TVAL_SET_LIGHTFUNC(tv, fp, flags) DUK__TVAL_SET_LIGHTFUNC((tv), (fp), (flags)) +#define DUK_TVAL_SET_STRING(tv, h) DUK__TVAL_SET_TAGGEDPOINTER((tv), (h), DUK_TAG_STRING) +#define DUK_TVAL_SET_OBJECT(tv, h) DUK__TVAL_SET_TAGGEDPOINTER((tv), (h), DUK_TAG_OBJECT) +#define DUK_TVAL_SET_BUFFER(tv, h) DUK__TVAL_SET_TAGGEDPOINTER((tv), (h), DUK_TAG_BUFFER) +#define DUK_TVAL_SET_POINTER(tv, p) DUK__TVAL_SET_TAGGEDPOINTER((tv), (p), DUK_TAG_POINTER) + +#define DUK_TVAL_SET_TVAL(tv, x) \ + do { \ + *(tv) = *(x); \ + } while (0) + +/* getters */ +#define DUK_TVAL_GET_BOOLEAN(tv) ((duk_small_uint_t) (tv)->us[DUK_DBL_IDX_US1]) +#if defined(DUK_USE_FASTINT) +#define DUK_TVAL_GET_DOUBLE(tv) ((tv)->d) +#define DUK_TVAL_GET_FASTINT(tv) DUK__TVAL_GET_FASTINT((tv)) +#define DUK_TVAL_GET_FASTINT_U32(tv) DUK__TVAL_GET_FASTINT_U32((tv)) +#define DUK_TVAL_GET_FASTINT_I32(tv) DUK__TVAL_GET_FASTINT_I32((tv)) +#define DUK_TVAL_GET_NUMBER(tv) duk_tval_get_number_packed((tv)) +#else +#define DUK_TVAL_GET_NUMBER(tv) ((tv)->d) +#define DUK_TVAL_GET_DOUBLE(tv) ((tv)->d) +#endif +#define DUK_TVAL_GET_LIGHTFUNC(tv, out_fp, out_flags) \ + do { \ + (out_flags) = (tv)->ui[DUK_DBL_IDX_UI0] & 0xffffUL; \ + (out_fp) = (duk_c_function) (tv)->ui[DUK_DBL_IDX_UI1]; \ + } while (0) +#define DUK_TVAL_GET_LIGHTFUNC_FUNCPTR(tv) ((duk_c_function) ((tv)->ui[DUK_DBL_IDX_UI1])) +#define DUK_TVAL_GET_LIGHTFUNC_FLAGS(tv) (((duk_small_uint_t) (tv)->ui[DUK_DBL_IDX_UI0]) & 0xffffUL) +#define DUK_TVAL_GET_STRING(tv) ((duk_hstring *) (tv)->vp[DUK_DBL_IDX_VP1]) +#define DUK_TVAL_GET_OBJECT(tv) ((duk_hobject *) (tv)->vp[DUK_DBL_IDX_VP1]) +#define DUK_TVAL_GET_BUFFER(tv) ((duk_hbuffer *) (tv)->vp[DUK_DBL_IDX_VP1]) +#define DUK_TVAL_GET_POINTER(tv) ((void *) (tv)->vp[DUK_DBL_IDX_VP1]) +#define DUK_TVAL_GET_HEAPHDR(tv) ((duk_heaphdr *) (tv)->vp[DUK_DBL_IDX_VP1]) + +/* decoding */ +#define DUK_TVAL_GET_TAG(tv) ((duk_small_uint_t) (tv)->us[DUK_DBL_IDX_US0]) + +#define DUK_TVAL_IS_UNDEFINED(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_UNDEFINED) +#define DUK_TVAL_IS_UNUSED(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_UNUSED) +#define DUK_TVAL_IS_NULL(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_NULL) +#define DUK_TVAL_IS_BOOLEAN(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_BOOLEAN) +#define DUK_TVAL_IS_BOOLEAN_TRUE(tv) ((tv)->ui[DUK_DBL_IDX_UI0] == DUK_XTAG_BOOLEAN_TRUE) +#define DUK_TVAL_IS_BOOLEAN_FALSE(tv) ((tv)->ui[DUK_DBL_IDX_UI0] == DUK_XTAG_BOOLEAN_FALSE) +#define DUK_TVAL_IS_LIGHTFUNC(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_LIGHTFUNC) +#define DUK_TVAL_IS_STRING(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_STRING) +#define DUK_TVAL_IS_OBJECT(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_OBJECT) +#define DUK_TVAL_IS_BUFFER(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_BUFFER) +#define DUK_TVAL_IS_POINTER(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_POINTER) +#if defined(DUK_USE_FASTINT) +/* 0xfff0 is -Infinity */ +#define DUK_TVAL_IS_DOUBLE(tv) (DUK_TVAL_GET_TAG((tv)) <= 0xfff0UL) +#define DUK_TVAL_IS_FASTINT(tv) (DUK_TVAL_GET_TAG((tv)) == DUK_TAG_FASTINT) +#define DUK_TVAL_IS_NUMBER(tv) (DUK_TVAL_GET_TAG((tv)) <= 0xfff1UL) +#else +#define DUK_TVAL_IS_NUMBER(tv) (DUK_TVAL_GET_TAG((tv)) <= 0xfff0UL) +#define DUK_TVAL_IS_DOUBLE(tv) DUK_TVAL_IS_NUMBER((tv)) +#endif + +/* This is performance critical because it appears in every DECREF. */ +#define DUK_TVAL_IS_HEAP_ALLOCATED(tv) (DUK_TVAL_GET_TAG((tv)) >= DUK_TAG_STRING) + +#if defined(DUK_USE_FASTINT) +DUK_INTERNAL_DECL duk_double_t duk_tval_get_number_packed(duk_tval *tv); +#endif + +#else /* DUK_USE_PACKED_TVAL */ +/* ======================================================================== */ + +/* + * Portable 12-byte representation + */ + +/* Note: not initializing all bytes is normally not an issue: Duktape won't + * read or use the uninitialized bytes so valgrind won't issue warnings. + * In some special cases a harmless valgrind warning may be issued though. + * For example, the DumpHeap debugger command writes out a compiled function's + * 'data' area as is, including any uninitialized bytes, which causes a + * valgrind warning. + */ + +typedef struct duk_tval_struct duk_tval; + +struct duk_tval_struct { + duk_small_uint_t t; + duk_small_uint_t v_extra; + union { + duk_double_t d; + duk_small_int_t i; +#if defined(DUK_USE_FASTINT) + duk_int64_t fi; /* if present, forces 16-byte duk_tval */ +#endif + void *voidptr; + duk_hstring *hstring; + duk_hobject *hobject; + duk_hcompfunc *hcompfunc; + duk_hnatfunc *hnatfunc; + duk_hthread *hthread; + duk_hbuffer *hbuffer; + duk_heaphdr *heaphdr; + duk_c_function lightfunc; + } v; +}; + +typedef struct { + duk_small_uint_t t; + duk_small_uint_t v_extra; + /* The rest of the fields don't matter except for debug dumps and such + * for which a partial initializer may trigger out-ot-bounds memory + * reads. Include a double field which is usually as large or larger + * than pointers (not always however). + */ + duk_double_t d; +} duk_tval_unused; + +#define DUK_TVAL_UNUSED_INITIALIZER() \ + { DUK_TAG_UNUSED, 0, 0.0 } + +#define DUK_TAG_MIN 0 +#define DUK_TAG_NUMBER 0 /* DUK_TAG_NUMBER only defined for non-packed duk_tval */ +#if defined(DUK_USE_FASTINT) +#define DUK_TAG_FASTINT 1 +#endif +#define DUK_TAG_UNDEFINED 2 +#define DUK_TAG_NULL 3 +#define DUK_TAG_BOOLEAN 4 +#define DUK_TAG_POINTER 5 +#define DUK_TAG_LIGHTFUNC 6 +#define DUK_TAG_UNUSED 7 /* marker; not actual tagged type */ +#define DUK_TAG_STRING 8 /* first heap allocated, match bit boundary */ +#define DUK_TAG_OBJECT 9 +#define DUK_TAG_BUFFER 10 +#define DUK_TAG_MAX 10 + +#define DUK_TVAL_IS_VALID_TAG(tv) (DUK_TVAL_GET_TAG((tv)) - DUK_TAG_MIN <= DUK_TAG_MAX - DUK_TAG_MIN) + +/* DUK_TAG_NUMBER is intentionally first, as it is the default clause in code + * to support the 8-byte representation. Further, it is a non-heap-allocated + * type so it should come before DUK_TAG_STRING. Finally, it should not break + * the tag value ranges covered by case-clauses in a switch-case. + */ + +/* setters */ +#define DUK_TVAL_SET_UNDEFINED(tv) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_UNDEFINED; \ + } while (0) + +#define DUK_TVAL_SET_UNUSED(tv) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_UNUSED; \ + } while (0) + +#define DUK_TVAL_SET_NULL(tv) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_NULL; \ + } while (0) + +#define DUK_TVAL_SET_BOOLEAN(tv, val) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_BOOLEAN; \ + duk__tv->v.i = (duk_small_int_t) (val); \ + } while (0) + +#if defined(DUK_USE_FASTINT) +#define DUK_TVAL_SET_DOUBLE(tv, val) \ + do { \ + duk_tval *duk__tv; \ + duk_double_t duk__dblval; \ + duk__dblval = (val); \ + DUK_ASSERT_DOUBLE_IS_NORMALIZED(duk__dblval); /* nop for unpacked duk_tval */ \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_NUMBER; \ + duk__tv->v.d = duk__dblval; \ + } while (0) +#define DUK_TVAL_SET_I48(tv, val) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_FASTINT; \ + duk__tv->v.fi = (val); \ + } while (0) +#define DUK_TVAL_SET_U32(tv, val) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_FASTINT; \ + duk__tv->v.fi = (duk_int64_t) (val); \ + } while (0) +#define DUK_TVAL_SET_I32(tv, val) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_FASTINT; \ + duk__tv->v.fi = (duk_int64_t) (val); \ + } while (0) +#define DUK_TVAL_SET_NUMBER_CHKFAST_FAST(tv, d) duk_tval_set_number_chkfast_fast((tv), (d)) +#define DUK_TVAL_SET_NUMBER_CHKFAST_SLOW(tv, d) duk_tval_set_number_chkfast_slow((tv), (d)) +#define DUK_TVAL_SET_NUMBER(tv, val) DUK_TVAL_SET_DOUBLE((tv), (val)) +#define DUK_TVAL_CHKFAST_INPLACE_FAST(tv) \ + do { \ + duk_tval *duk__tv; \ + duk_double_t duk__d; \ + duk__tv = (tv); \ + if (DUK_TVAL_IS_DOUBLE(duk__tv)) { \ + duk__d = DUK_TVAL_GET_DOUBLE(duk__tv); \ + DUK_TVAL_SET_NUMBER_CHKFAST_FAST(duk__tv, duk__d); \ + } \ + } while (0) +#define DUK_TVAL_CHKFAST_INPLACE_SLOW(tv) \ + do { \ + duk_tval *duk__tv; \ + duk_double_t duk__d; \ + duk__tv = (tv); \ + if (DUK_TVAL_IS_DOUBLE(duk__tv)) { \ + duk__d = DUK_TVAL_GET_DOUBLE(duk__tv); \ + DUK_TVAL_SET_NUMBER_CHKFAST_SLOW(duk__tv, duk__d); \ + } \ + } while (0) +#else /* DUK_USE_FASTINT */ +#define DUK_TVAL_SET_DOUBLE(tv, d) DUK_TVAL_SET_NUMBER((tv), (d)) +#define DUK_TVAL_SET_I48(tv, val) DUK_TVAL_SET_NUMBER((tv), (duk_double_t) (val)) /* XXX: fast int-to-double */ +#define DUK_TVAL_SET_U32(tv, val) DUK_TVAL_SET_NUMBER((tv), (duk_double_t) (val)) +#define DUK_TVAL_SET_I32(tv, val) DUK_TVAL_SET_NUMBER((tv), (duk_double_t) (val)) +#define DUK_TVAL_SET_NUMBER(tv, val) \ + do { \ + duk_tval *duk__tv; \ + duk_double_t duk__dblval; \ + duk__dblval = (val); \ + DUK_ASSERT_DOUBLE_IS_NORMALIZED(duk__dblval); /* nop for unpacked duk_tval */ \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_NUMBER; \ + duk__tv->v.d = duk__dblval; \ + } while (0) +#define DUK_TVAL_SET_NUMBER_CHKFAST_FAST(tv, d) DUK_TVAL_SET_NUMBER((tv), (d)) +#define DUK_TVAL_SET_NUMBER_CHKFAST_SLOW(tv, d) DUK_TVAL_SET_NUMBER((tv), (d)) +#define DUK_TVAL_CHKFAST_INPLACE_FAST(tv) \ + do { \ + } while (0) +#define DUK_TVAL_CHKFAST_INPLACE_SLOW(tv) \ + do { \ + } while (0) +#endif /* DUK_USE_FASTINT */ + +#define DUK_TVAL_SET_FASTINT(tv, i) DUK_TVAL_SET_I48((tv), (i)) /* alias */ + +#define DUK_TVAL_SET_POINTER(tv, hptr) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_POINTER; \ + duk__tv->v.voidptr = (hptr); \ + } while (0) + +#define DUK_TVAL_SET_LIGHTFUNC(tv, fp, flags) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_LIGHTFUNC; \ + duk__tv->v_extra = (flags); \ + duk__tv->v.lightfunc = (duk_c_function) (fp); \ + } while (0) + +#define DUK_TVAL_SET_STRING(tv, hptr) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_STRING; \ + duk__tv->v.hstring = (hptr); \ + } while (0) + +#define DUK_TVAL_SET_OBJECT(tv, hptr) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_OBJECT; \ + duk__tv->v.hobject = (hptr); \ + } while (0) + +#define DUK_TVAL_SET_BUFFER(tv, hptr) \ + do { \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_BUFFER; \ + duk__tv->v.hbuffer = (hptr); \ + } while (0) + +#define DUK_TVAL_SET_NAN(tv) \ + do { \ + /* in non-packed representation we don't care about which NaN is used */ \ + duk_tval *duk__tv; \ + duk__tv = (tv); \ + duk__tv->t = DUK_TAG_NUMBER; \ + duk__tv->v.d = DUK_DOUBLE_NAN; \ + } while (0) + +#define DUK_TVAL_SET_TVAL(tv, x) \ + do { \ + *(tv) = *(x); \ + } while (0) + +/* getters */ +#define DUK_TVAL_GET_BOOLEAN(tv) ((duk_small_uint_t) (tv)->v.i) +#if defined(DUK_USE_FASTINT) +#define DUK_TVAL_GET_DOUBLE(tv) ((tv)->v.d) +#define DUK_TVAL_GET_FASTINT(tv) ((tv)->v.fi) +#define DUK_TVAL_GET_FASTINT_U32(tv) ((duk_uint32_t) ((tv)->v.fi)) +#define DUK_TVAL_GET_FASTINT_I32(tv) ((duk_int32_t) ((tv)->v.fi)) +#if 0 +#define DUK_TVAL_GET_NUMBER(tv) (DUK_TVAL_IS_FASTINT((tv)) ? (duk_double_t) DUK_TVAL_GET_FASTINT((tv)) : DUK_TVAL_GET_DOUBLE((tv))) +#define DUK_TVAL_GET_NUMBER(tv) duk_tval_get_number_unpacked((tv)) +#else +/* This seems reasonable overall. */ +#define DUK_TVAL_GET_NUMBER(tv) (DUK_TVAL_IS_FASTINT((tv)) ? duk_tval_get_number_unpacked_fastint((tv)) : DUK_TVAL_GET_DOUBLE((tv))) +#endif +#else +#define DUK_TVAL_GET_NUMBER(tv) ((tv)->v.d) +#define DUK_TVAL_GET_DOUBLE(tv) ((tv)->v.d) +#endif /* DUK_USE_FASTINT */ +#define DUK_TVAL_GET_POINTER(tv) ((tv)->v.voidptr) +#define DUK_TVAL_GET_LIGHTFUNC(tv, out_fp, out_flags) \ + do { \ + (out_flags) = (duk_uint32_t) (tv)->v_extra; \ + (out_fp) = (tv)->v.lightfunc; \ + } while (0) +#define DUK_TVAL_GET_LIGHTFUNC_FUNCPTR(tv) ((tv)->v.lightfunc) +#define DUK_TVAL_GET_LIGHTFUNC_FLAGS(tv) ((duk_small_uint_t) ((tv)->v_extra)) +#define DUK_TVAL_GET_STRING(tv) ((tv)->v.hstring) +#define DUK_TVAL_GET_OBJECT(tv) ((tv)->v.hobject) +#define DUK_TVAL_GET_BUFFER(tv) ((tv)->v.hbuffer) +#define DUK_TVAL_GET_HEAPHDR(tv) ((tv)->v.heaphdr) + +/* decoding */ +#define DUK_TVAL_GET_TAG(tv) ((tv)->t) +#define DUK_TVAL_IS_UNDEFINED(tv) ((tv)->t == DUK_TAG_UNDEFINED) +#define DUK_TVAL_IS_UNUSED(tv) ((tv)->t == DUK_TAG_UNUSED) +#define DUK_TVAL_IS_NULL(tv) ((tv)->t == DUK_TAG_NULL) +#define DUK_TVAL_IS_BOOLEAN(tv) ((tv)->t == DUK_TAG_BOOLEAN) +#define DUK_TVAL_IS_BOOLEAN_TRUE(tv) (((tv)->t == DUK_TAG_BOOLEAN) && ((tv)->v.i != 0)) +#define DUK_TVAL_IS_BOOLEAN_FALSE(tv) (((tv)->t == DUK_TAG_BOOLEAN) && ((tv)->v.i == 0)) +#if defined(DUK_USE_FASTINT) +#define DUK_TVAL_IS_DOUBLE(tv) ((tv)->t == DUK_TAG_NUMBER) +#define DUK_TVAL_IS_FASTINT(tv) ((tv)->t == DUK_TAG_FASTINT) +#define DUK_TVAL_IS_NUMBER(tv) ((tv)->t == DUK_TAG_NUMBER || (tv)->t == DUK_TAG_FASTINT) +#else +#define DUK_TVAL_IS_NUMBER(tv) ((tv)->t == DUK_TAG_NUMBER) +#define DUK_TVAL_IS_DOUBLE(tv) DUK_TVAL_IS_NUMBER((tv)) +#endif /* DUK_USE_FASTINT */ +#define DUK_TVAL_IS_POINTER(tv) ((tv)->t == DUK_TAG_POINTER) +#define DUK_TVAL_IS_LIGHTFUNC(tv) ((tv)->t == DUK_TAG_LIGHTFUNC) +#define DUK_TVAL_IS_STRING(tv) ((tv)->t == DUK_TAG_STRING) +#define DUK_TVAL_IS_OBJECT(tv) ((tv)->t == DUK_TAG_OBJECT) +#define DUK_TVAL_IS_BUFFER(tv) ((tv)->t == DUK_TAG_BUFFER) + +/* This is performance critical because it's needed for every DECREF. + * Take advantage of the fact that the first heap allocated tag is 8, + * so that bit 3 is set for all heap allocated tags (and never set for + * non-heap-allocated tags). + */ +#if 0 +#define DUK_TVAL_IS_HEAP_ALLOCATED(tv) ((tv)->t >= DUK_TAG_STRING) +#endif +#define DUK_TVAL_IS_HEAP_ALLOCATED(tv) ((tv)->t & 0x08) + +#if defined(DUK_USE_FASTINT) +#if 0 +DUK_INTERNAL_DECL duk_double_t duk_tval_get_number_unpacked(duk_tval *tv); +#endif +DUK_INTERNAL_DECL duk_double_t duk_tval_get_number_unpacked_fastint(duk_tval *tv); +#endif + +#endif /* DUK_USE_PACKED_TVAL */ + +/* + * Convenience (independent of representation) + */ + +#define DUK_TVAL_SET_BOOLEAN_TRUE(tv) DUK_TVAL_SET_BOOLEAN((tv), 1) +#define DUK_TVAL_SET_BOOLEAN_FALSE(tv) DUK_TVAL_SET_BOOLEAN((tv), 0) + +#define DUK_TVAL_STRING_IS_SYMBOL(tv) DUK_HSTRING_HAS_SYMBOL(DUK_TVAL_GET_STRING((tv))) + +/* Lightfunc flags packing and unpacking. */ +/* Sign extend: 0x0000##00 -> 0x##000000 -> sign extend to 0xssssss##. + * Avoid signed shifts due to portability limitations. + */ +#define DUK_LFUNC_FLAGS_GET_MAGIC(lf_flags) ((duk_int32_t) (duk_int8_t) (((duk_uint16_t) (lf_flags)) >> 8)) +#define DUK_LFUNC_FLAGS_GET_LENGTH(lf_flags) (((lf_flags) >> 4) & 0x0fU) +#define DUK_LFUNC_FLAGS_GET_NARGS(lf_flags) ((lf_flags) &0x0fU) +#define DUK_LFUNC_FLAGS_PACK(magic, length, nargs) ((((duk_small_uint_t) (magic)) & 0xffU) << 8) | ((length) << 4) | (nargs) + +#define DUK_LFUNC_NARGS_VARARGS 0x0f /* varargs marker */ +#define DUK_LFUNC_NARGS_MIN 0x00 +#define DUK_LFUNC_NARGS_MAX 0x0e /* max, excl. varargs marker */ +#define DUK_LFUNC_LENGTH_MIN 0x00 +#define DUK_LFUNC_LENGTH_MAX 0x0f +#define DUK_LFUNC_MAGIC_MIN (-0x80) +#define DUK_LFUNC_MAGIC_MAX 0x7f + +/* fastint constants etc */ +#if defined(DUK_USE_FASTINT) +#define DUK_FASTINT_MIN (DUK_I64_CONSTANT(-0x800000000000)) +#define DUK_FASTINT_MAX (DUK_I64_CONSTANT(0x7fffffffffff)) +#define DUK_FASTINT_BITS 48 + +DUK_INTERNAL_DECL void duk_tval_set_number_chkfast_fast(duk_tval *tv, duk_double_t x); +DUK_INTERNAL_DECL void duk_tval_set_number_chkfast_slow(duk_tval *tv, duk_double_t x); +#endif + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_tval_assert_valid(duk_tval *tv); +#define DUK_TVAL_ASSERT_VALID(tv) \ + do { \ + duk_tval_assert_valid((tv)); \ + } while (0) +#else +#define DUK_TVAL_ASSERT_VALID(tv) \ + do { \ + } while (0) +#endif + +#endif /* DUK_TVAL_H_INCLUDED */ +/* #include duk_builtins.h */ +#line 1 "duk_builtins.h" +/* + * Automatically generated by genbuiltins.py, do not edit! + */ + +#if !defined(DUK_BUILTINS_H_INCLUDED) +#define DUK_BUILTINS_H_INCLUDED + +#if defined(DUK_USE_ROM_STRINGS) +#error ROM support not enabled, rerun configure.py with --rom-support +#else /* DUK_USE_ROM_STRINGS */ +#define DUK_STRIDX_UC_UNDEFINED 0 /* 'Undefined' */ +#define DUK_HEAP_STRING_UC_UNDEFINED(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_UNDEFINED) +#define DUK_HTHREAD_STRING_UC_UNDEFINED(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_UNDEFINED) +#define DUK_STRIDX_UC_NULL 1 /* 'Null' */ +#define DUK_HEAP_STRING_UC_NULL(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_NULL) +#define DUK_HTHREAD_STRING_UC_NULL(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_NULL) +#define DUK_STRIDX_UC_SYMBOL 2 /* 'Symbol' */ +#define DUK_HEAP_STRING_UC_SYMBOL(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_SYMBOL) +#define DUK_HTHREAD_STRING_UC_SYMBOL(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_SYMBOL) +#define DUK_STRIDX_UC_ARGUMENTS 3 /* 'Arguments' */ +#define DUK_HEAP_STRING_UC_ARGUMENTS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_ARGUMENTS) +#define DUK_HTHREAD_STRING_UC_ARGUMENTS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_ARGUMENTS) +#define DUK_STRIDX_UC_OBJECT 4 /* 'Object' */ +#define DUK_HEAP_STRING_UC_OBJECT(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_OBJECT) +#define DUK_HTHREAD_STRING_UC_OBJECT(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_OBJECT) +#define DUK_STRIDX_UC_FUNCTION 5 /* 'Function' */ +#define DUK_HEAP_STRING_UC_FUNCTION(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_FUNCTION) +#define DUK_HTHREAD_STRING_UC_FUNCTION(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_FUNCTION) +#define DUK_STRIDX_UC_ARRAY 6 /* 'Array' */ +#define DUK_HEAP_STRING_UC_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_ARRAY) +#define DUK_HTHREAD_STRING_UC_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_ARRAY) +#define DUK_STRIDX_UC_STRING 7 /* 'String' */ +#define DUK_HEAP_STRING_UC_STRING(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_STRING) +#define DUK_HTHREAD_STRING_UC_STRING(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_STRING) +#define DUK_STRIDX_UC_BOOLEAN 8 /* 'Boolean' */ +#define DUK_HEAP_STRING_UC_BOOLEAN(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_BOOLEAN) +#define DUK_HTHREAD_STRING_UC_BOOLEAN(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_BOOLEAN) +#define DUK_STRIDX_UC_NUMBER 9 /* 'Number' */ +#define DUK_HEAP_STRING_UC_NUMBER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_NUMBER) +#define DUK_HTHREAD_STRING_UC_NUMBER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_NUMBER) +#define DUK_STRIDX_UC_DATE 10 /* 'Date' */ +#define DUK_HEAP_STRING_UC_DATE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_DATE) +#define DUK_HTHREAD_STRING_UC_DATE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_DATE) +#define DUK_STRIDX_REG_EXP 11 /* 'RegExp' */ +#define DUK_HEAP_STRING_REG_EXP(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_REG_EXP) +#define DUK_HTHREAD_STRING_REG_EXP(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_REG_EXP) +#define DUK_STRIDX_UC_ERROR 12 /* 'Error' */ +#define DUK_HEAP_STRING_UC_ERROR(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_ERROR) +#define DUK_HTHREAD_STRING_UC_ERROR(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_ERROR) +#define DUK_STRIDX_MATH 13 /* 'Math' */ +#define DUK_HEAP_STRING_MATH(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_MATH) +#define DUK_HTHREAD_STRING_MATH(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_MATH) +#define DUK_STRIDX_JSON 14 /* 'JSON' */ +#define DUK_HEAP_STRING_JSON(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JSON) +#define DUK_HTHREAD_STRING_JSON(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JSON) +#define DUK_STRIDX_EMPTY_STRING 15 /* '' */ +#define DUK_HEAP_STRING_EMPTY_STRING(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_EMPTY_STRING) +#define DUK_HTHREAD_STRING_EMPTY_STRING(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_EMPTY_STRING) +#define DUK_STRIDX_ARRAY_BUFFER 16 /* 'ArrayBuffer' */ +#define DUK_HEAP_STRING_ARRAY_BUFFER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_ARRAY_BUFFER) +#define DUK_HTHREAD_STRING_ARRAY_BUFFER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_ARRAY_BUFFER) +#define DUK_STRIDX_DATA_VIEW 17 /* 'DataView' */ +#define DUK_HEAP_STRING_DATA_VIEW(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_DATA_VIEW) +#define DUK_HTHREAD_STRING_DATA_VIEW(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_DATA_VIEW) +#define DUK_STRIDX_INT8_ARRAY 18 /* 'Int8Array' */ +#define DUK_HEAP_STRING_INT8_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT8_ARRAY) +#define DUK_HTHREAD_STRING_INT8_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT8_ARRAY) +#define DUK_STRIDX_UINT8_ARRAY 19 /* 'Uint8Array' */ +#define DUK_HEAP_STRING_UINT8_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UINT8_ARRAY) +#define DUK_HTHREAD_STRING_UINT8_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UINT8_ARRAY) +#define DUK_STRIDX_UINT8_CLAMPED_ARRAY 20 /* 'Uint8ClampedArray' */ +#define DUK_HEAP_STRING_UINT8_CLAMPED_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UINT8_CLAMPED_ARRAY) +#define DUK_HTHREAD_STRING_UINT8_CLAMPED_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UINT8_CLAMPED_ARRAY) +#define DUK_STRIDX_INT16_ARRAY 21 /* 'Int16Array' */ +#define DUK_HEAP_STRING_INT16_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT16_ARRAY) +#define DUK_HTHREAD_STRING_INT16_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT16_ARRAY) +#define DUK_STRIDX_UINT16_ARRAY 22 /* 'Uint16Array' */ +#define DUK_HEAP_STRING_UINT16_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UINT16_ARRAY) +#define DUK_HTHREAD_STRING_UINT16_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UINT16_ARRAY) +#define DUK_STRIDX_INT32_ARRAY 23 /* 'Int32Array' */ +#define DUK_HEAP_STRING_INT32_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT32_ARRAY) +#define DUK_HTHREAD_STRING_INT32_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT32_ARRAY) +#define DUK_STRIDX_UINT32_ARRAY 24 /* 'Uint32Array' */ +#define DUK_HEAP_STRING_UINT32_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UINT32_ARRAY) +#define DUK_HTHREAD_STRING_UINT32_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UINT32_ARRAY) +#define DUK_STRIDX_FLOAT32_ARRAY 25 /* 'Float32Array' */ +#define DUK_HEAP_STRING_FLOAT32_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_FLOAT32_ARRAY) +#define DUK_HTHREAD_STRING_FLOAT32_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_FLOAT32_ARRAY) +#define DUK_STRIDX_FLOAT64_ARRAY 26 /* 'Float64Array' */ +#define DUK_HEAP_STRING_FLOAT64_ARRAY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_FLOAT64_ARRAY) +#define DUK_HTHREAD_STRING_FLOAT64_ARRAY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_FLOAT64_ARRAY) +#define DUK_STRIDX_GLOBAL 27 /* 'global' */ +#define DUK_HEAP_STRING_GLOBAL(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_GLOBAL) +#define DUK_HTHREAD_STRING_GLOBAL(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_GLOBAL) +#define DUK_STRIDX_OBJ_ENV 28 /* 'ObjEnv' */ +#define DUK_HEAP_STRING_OBJ_ENV(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_OBJ_ENV) +#define DUK_HTHREAD_STRING_OBJ_ENV(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_OBJ_ENV) +#define DUK_STRIDX_DEC_ENV 29 /* 'DecEnv' */ +#define DUK_HEAP_STRING_DEC_ENV(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_DEC_ENV) +#define DUK_HTHREAD_STRING_DEC_ENV(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_DEC_ENV) +#define DUK_STRIDX_UC_BUFFER 30 /* 'Buffer' */ +#define DUK_HEAP_STRING_UC_BUFFER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_BUFFER) +#define DUK_HTHREAD_STRING_UC_BUFFER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_BUFFER) +#define DUK_STRIDX_UC_POINTER 31 /* 'Pointer' */ +#define DUK_HEAP_STRING_UC_POINTER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_POINTER) +#define DUK_HTHREAD_STRING_UC_POINTER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_POINTER) +#define DUK_STRIDX_UC_THREAD 32 /* 'Thread' */ +#define DUK_HEAP_STRING_UC_THREAD(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_UC_THREAD) +#define DUK_HTHREAD_STRING_UC_THREAD(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_UC_THREAD) +#define DUK_STRIDX_EVAL 33 /* 'eval' */ +#define DUK_HEAP_STRING_EVAL(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_EVAL) +#define DUK_HTHREAD_STRING_EVAL(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_EVAL) +#define DUK_STRIDX_VALUE 34 /* 'value' */ +#define DUK_HEAP_STRING_VALUE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_VALUE) +#define DUK_HTHREAD_STRING_VALUE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_VALUE) +#define DUK_STRIDX_WRITABLE 35 /* 'writable' */ +#define DUK_HEAP_STRING_WRITABLE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_WRITABLE) +#define DUK_HTHREAD_STRING_WRITABLE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_WRITABLE) +#define DUK_STRIDX_CONFIGURABLE 36 /* 'configurable' */ +#define DUK_HEAP_STRING_CONFIGURABLE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CONFIGURABLE) +#define DUK_HTHREAD_STRING_CONFIGURABLE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CONFIGURABLE) +#define DUK_STRIDX_ENUMERABLE 37 /* 'enumerable' */ +#define DUK_HEAP_STRING_ENUMERABLE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_ENUMERABLE) +#define DUK_HTHREAD_STRING_ENUMERABLE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_ENUMERABLE) +#define DUK_STRIDX_JOIN 38 /* 'join' */ +#define DUK_HEAP_STRING_JOIN(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JOIN) +#define DUK_HTHREAD_STRING_JOIN(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JOIN) +#define DUK_STRIDX_TO_LOCALE_STRING 39 /* 'toLocaleString' */ +#define DUK_HEAP_STRING_TO_LOCALE_STRING(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TO_LOCALE_STRING) +#define DUK_HTHREAD_STRING_TO_LOCALE_STRING(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TO_LOCALE_STRING) +#define DUK_STRIDX_VALUE_OF 40 /* 'valueOf' */ +#define DUK_HEAP_STRING_VALUE_OF(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_VALUE_OF) +#define DUK_HTHREAD_STRING_VALUE_OF(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_VALUE_OF) +#define DUK_STRIDX_TO_UTC_STRING 41 /* 'toUTCString' */ +#define DUK_HEAP_STRING_TO_UTC_STRING(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TO_UTC_STRING) +#define DUK_HTHREAD_STRING_TO_UTC_STRING(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TO_UTC_STRING) +#define DUK_STRIDX_TO_ISO_STRING 42 /* 'toISOString' */ +#define DUK_HEAP_STRING_TO_ISO_STRING(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TO_ISO_STRING) +#define DUK_HTHREAD_STRING_TO_ISO_STRING(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TO_ISO_STRING) +#define DUK_STRIDX_TO_GMT_STRING 43 /* 'toGMTString' */ +#define DUK_HEAP_STRING_TO_GMT_STRING(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TO_GMT_STRING) +#define DUK_HTHREAD_STRING_TO_GMT_STRING(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TO_GMT_STRING) +#define DUK_STRIDX_SOURCE 44 /* 'source' */ +#define DUK_HEAP_STRING_SOURCE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_SOURCE) +#define DUK_HTHREAD_STRING_SOURCE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_SOURCE) +#define DUK_STRIDX_IGNORE_CASE 45 /* 'ignoreCase' */ +#define DUK_HEAP_STRING_IGNORE_CASE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_IGNORE_CASE) +#define DUK_HTHREAD_STRING_IGNORE_CASE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_IGNORE_CASE) +#define DUK_STRIDX_MULTILINE 46 /* 'multiline' */ +#define DUK_HEAP_STRING_MULTILINE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_MULTILINE) +#define DUK_HTHREAD_STRING_MULTILINE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_MULTILINE) +#define DUK_STRIDX_LAST_INDEX 47 /* 'lastIndex' */ +#define DUK_HEAP_STRING_LAST_INDEX(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LAST_INDEX) +#define DUK_HTHREAD_STRING_LAST_INDEX(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LAST_INDEX) +#define DUK_STRIDX_FLAGS 48 /* 'flags' */ +#define DUK_HEAP_STRING_FLAGS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_FLAGS) +#define DUK_HTHREAD_STRING_FLAGS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_FLAGS) +#define DUK_STRIDX_INDEX 49 /* 'index' */ +#define DUK_HEAP_STRING_INDEX(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INDEX) +#define DUK_HTHREAD_STRING_INDEX(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INDEX) +#define DUK_STRIDX_PROTOTYPE 50 /* 'prototype' */ +#define DUK_HEAP_STRING_PROTOTYPE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_PROTOTYPE) +#define DUK_HTHREAD_STRING_PROTOTYPE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_PROTOTYPE) +#define DUK_STRIDX_CONSTRUCTOR 51 /* 'constructor' */ +#define DUK_HEAP_STRING_CONSTRUCTOR(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CONSTRUCTOR) +#define DUK_HTHREAD_STRING_CONSTRUCTOR(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CONSTRUCTOR) +#define DUK_STRIDX_MESSAGE 52 /* 'message' */ +#define DUK_HEAP_STRING_MESSAGE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_MESSAGE) +#define DUK_HTHREAD_STRING_MESSAGE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_MESSAGE) +#define DUK_STRIDX_LC_BOOLEAN 53 /* 'boolean' */ +#define DUK_HEAP_STRING_LC_BOOLEAN(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_BOOLEAN) +#define DUK_HTHREAD_STRING_LC_BOOLEAN(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_BOOLEAN) +#define DUK_STRIDX_LC_NUMBER 54 /* 'number' */ +#define DUK_HEAP_STRING_LC_NUMBER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_NUMBER) +#define DUK_HTHREAD_STRING_LC_NUMBER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_NUMBER) +#define DUK_STRIDX_LC_STRING 55 /* 'string' */ +#define DUK_HEAP_STRING_LC_STRING(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_STRING) +#define DUK_HTHREAD_STRING_LC_STRING(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_STRING) +#define DUK_STRIDX_LC_SYMBOL 56 /* 'symbol' */ +#define DUK_HEAP_STRING_LC_SYMBOL(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_SYMBOL) +#define DUK_HTHREAD_STRING_LC_SYMBOL(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_SYMBOL) +#define DUK_STRIDX_LC_OBJECT 57 /* 'object' */ +#define DUK_HEAP_STRING_LC_OBJECT(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_OBJECT) +#define DUK_HTHREAD_STRING_LC_OBJECT(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_OBJECT) +#define DUK_STRIDX_LC_UNDEFINED 58 /* 'undefined' */ +#define DUK_HEAP_STRING_LC_UNDEFINED(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_UNDEFINED) +#define DUK_HTHREAD_STRING_LC_UNDEFINED(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_UNDEFINED) +#define DUK_STRIDX_NAN 59 /* 'NaN' */ +#define DUK_HEAP_STRING_NAN(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_NAN) +#define DUK_HTHREAD_STRING_NAN(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_NAN) +#define DUK_STRIDX_INFINITY 60 /* 'Infinity' */ +#define DUK_HEAP_STRING_INFINITY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INFINITY) +#define DUK_HTHREAD_STRING_INFINITY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INFINITY) +#define DUK_STRIDX_MINUS_INFINITY 61 /* '-Infinity' */ +#define DUK_HEAP_STRING_MINUS_INFINITY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_MINUS_INFINITY) +#define DUK_HTHREAD_STRING_MINUS_INFINITY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_MINUS_INFINITY) +#define DUK_STRIDX_MINUS_ZERO 62 /* '-0' */ +#define DUK_HEAP_STRING_MINUS_ZERO(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_MINUS_ZERO) +#define DUK_HTHREAD_STRING_MINUS_ZERO(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_MINUS_ZERO) +#define DUK_STRIDX_COMMA 63 /* ',' */ +#define DUK_HEAP_STRING_COMMA(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_COMMA) +#define DUK_HTHREAD_STRING_COMMA(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_COMMA) +#define DUK_STRIDX_NEWLINE_4SPACE 64 /* '\n ' */ +#define DUK_HEAP_STRING_NEWLINE_4SPACE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_NEWLINE_4SPACE) +#define DUK_HTHREAD_STRING_NEWLINE_4SPACE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_NEWLINE_4SPACE) +#define DUK_STRIDX_BRACKETED_ELLIPSIS 65 /* '[...]' */ +#define DUK_HEAP_STRING_BRACKETED_ELLIPSIS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_BRACKETED_ELLIPSIS) +#define DUK_HTHREAD_STRING_BRACKETED_ELLIPSIS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_BRACKETED_ELLIPSIS) +#define DUK_STRIDX_INVALID_DATE 66 /* 'Invalid Date' */ +#define DUK_HEAP_STRING_INVALID_DATE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INVALID_DATE) +#define DUK_HTHREAD_STRING_INVALID_DATE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INVALID_DATE) +#define DUK_STRIDX_LC_ARGUMENTS 67 /* 'arguments' */ +#define DUK_HEAP_STRING_LC_ARGUMENTS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_ARGUMENTS) +#define DUK_HTHREAD_STRING_LC_ARGUMENTS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_ARGUMENTS) +#define DUK_STRIDX_CALLEE 68 /* 'callee' */ +#define DUK_HEAP_STRING_CALLEE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CALLEE) +#define DUK_HTHREAD_STRING_CALLEE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CALLEE) +#define DUK_STRIDX_CALLER 69 /* 'caller' */ +#define DUK_HEAP_STRING_CALLER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CALLER) +#define DUK_HTHREAD_STRING_CALLER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CALLER) +#define DUK_STRIDX_APPLY 70 /* 'apply' */ +#define DUK_HEAP_STRING_APPLY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_APPLY) +#define DUK_HTHREAD_STRING_APPLY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_APPLY) +#define DUK_STRIDX_CONSTRUCT 71 /* 'construct' */ +#define DUK_HEAP_STRING_CONSTRUCT(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CONSTRUCT) +#define DUK_HTHREAD_STRING_CONSTRUCT(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CONSTRUCT) +#define DUK_STRIDX_DELETE_PROPERTY 72 /* 'deleteProperty' */ +#define DUK_HEAP_STRING_DELETE_PROPERTY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_DELETE_PROPERTY) +#define DUK_HTHREAD_STRING_DELETE_PROPERTY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_DELETE_PROPERTY) +#define DUK_STRIDX_GET 73 /* 'get' */ +#define DUK_HEAP_STRING_GET(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_GET) +#define DUK_HTHREAD_STRING_GET(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_GET) +#define DUK_STRIDX_HAS 74 /* 'has' */ +#define DUK_HEAP_STRING_HAS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_HAS) +#define DUK_HTHREAD_STRING_HAS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_HAS) +#define DUK_STRIDX_OWN_KEYS 75 /* 'ownKeys' */ +#define DUK_HEAP_STRING_OWN_KEYS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_OWN_KEYS) +#define DUK_HTHREAD_STRING_OWN_KEYS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_OWN_KEYS) +#define DUK_STRIDX_WELLKNOWN_SYMBOL_TO_PRIMITIVE 76 /* '\x81Symbol.toPrimitive\xff' */ +#define DUK_HEAP_STRING_WELLKNOWN_SYMBOL_TO_PRIMITIVE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_WELLKNOWN_SYMBOL_TO_PRIMITIVE) +#define DUK_HTHREAD_STRING_WELLKNOWN_SYMBOL_TO_PRIMITIVE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_WELLKNOWN_SYMBOL_TO_PRIMITIVE) +#define DUK_STRIDX_WELLKNOWN_SYMBOL_HAS_INSTANCE 77 /* '\x81Symbol.hasInstance\xff' */ +#define DUK_HEAP_STRING_WELLKNOWN_SYMBOL_HAS_INSTANCE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_WELLKNOWN_SYMBOL_HAS_INSTANCE) +#define DUK_HTHREAD_STRING_WELLKNOWN_SYMBOL_HAS_INSTANCE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_WELLKNOWN_SYMBOL_HAS_INSTANCE) +#define DUK_STRIDX_WELLKNOWN_SYMBOL_TO_STRING_TAG 78 /* '\x81Symbol.toStringTag\xff' */ +#define DUK_HEAP_STRING_WELLKNOWN_SYMBOL_TO_STRING_TAG(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_WELLKNOWN_SYMBOL_TO_STRING_TAG) +#define DUK_HTHREAD_STRING_WELLKNOWN_SYMBOL_TO_STRING_TAG(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_WELLKNOWN_SYMBOL_TO_STRING_TAG) +#define DUK_STRIDX_WELLKNOWN_SYMBOL_IS_CONCAT_SPREADABLE 79 /* '\x81Symbol.isConcatSpreadable\xff' */ +#define DUK_HEAP_STRING_WELLKNOWN_SYMBOL_IS_CONCAT_SPREADABLE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_WELLKNOWN_SYMBOL_IS_CONCAT_SPREADABLE) +#define DUK_HTHREAD_STRING_WELLKNOWN_SYMBOL_IS_CONCAT_SPREADABLE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_WELLKNOWN_SYMBOL_IS_CONCAT_SPREADABLE) +#define DUK_STRIDX_SET_PROTOTYPE_OF 80 /* 'setPrototypeOf' */ +#define DUK_HEAP_STRING_SET_PROTOTYPE_OF(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_SET_PROTOTYPE_OF) +#define DUK_HTHREAD_STRING_SET_PROTOTYPE_OF(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_SET_PROTOTYPE_OF) +#define DUK_STRIDX___PROTO__ 81 /* '__proto__' */ +#define DUK_HEAP_STRING___PROTO__(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX___PROTO__) +#define DUK_HTHREAD_STRING___PROTO__(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX___PROTO__) +#define DUK_STRIDX_TO_STRING 82 /* 'toString' */ +#define DUK_HEAP_STRING_TO_STRING(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TO_STRING) +#define DUK_HTHREAD_STRING_TO_STRING(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TO_STRING) +#define DUK_STRIDX_TO_JSON 83 /* 'toJSON' */ +#define DUK_HEAP_STRING_TO_JSON(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TO_JSON) +#define DUK_HTHREAD_STRING_TO_JSON(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TO_JSON) +#define DUK_STRIDX_TYPE 84 /* 'type' */ +#define DUK_HEAP_STRING_TYPE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TYPE) +#define DUK_HTHREAD_STRING_TYPE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TYPE) +#define DUK_STRIDX_DATA 85 /* 'data' */ +#define DUK_HEAP_STRING_DATA(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_DATA) +#define DUK_HTHREAD_STRING_DATA(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_DATA) +#define DUK_STRIDX_LC_BUFFER 86 /* 'buffer' */ +#define DUK_HEAP_STRING_LC_BUFFER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_BUFFER) +#define DUK_HTHREAD_STRING_LC_BUFFER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_BUFFER) +#define DUK_STRIDX_LENGTH 87 /* 'length' */ +#define DUK_HEAP_STRING_LENGTH(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LENGTH) +#define DUK_HTHREAD_STRING_LENGTH(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LENGTH) +#define DUK_STRIDX_SET 88 /* 'set' */ +#define DUK_HEAP_STRING_SET(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_SET) +#define DUK_HTHREAD_STRING_SET(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_SET) +#define DUK_STRIDX_STACK 89 /* 'stack' */ +#define DUK_HEAP_STRING_STACK(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_STACK) +#define DUK_HTHREAD_STRING_STACK(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_STACK) +#define DUK_STRIDX_PC 90 /* 'pc' */ +#define DUK_HEAP_STRING_PC(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_PC) +#define DUK_HTHREAD_STRING_PC(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_PC) +#define DUK_STRIDX_LINE_NUMBER 91 /* 'lineNumber' */ +#define DUK_HEAP_STRING_LINE_NUMBER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LINE_NUMBER) +#define DUK_HTHREAD_STRING_LINE_NUMBER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LINE_NUMBER) +#define DUK_STRIDX_INT_TRACEDATA 92 /* '\x82Tracedata' */ +#define DUK_HEAP_STRING_INT_TRACEDATA(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_TRACEDATA) +#define DUK_HTHREAD_STRING_INT_TRACEDATA(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_TRACEDATA) +#define DUK_STRIDX_NAME 93 /* 'name' */ +#define DUK_HEAP_STRING_NAME(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_NAME) +#define DUK_HTHREAD_STRING_NAME(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_NAME) +#define DUK_STRIDX_FILE_NAME 94 /* 'fileName' */ +#define DUK_HEAP_STRING_FILE_NAME(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_FILE_NAME) +#define DUK_HTHREAD_STRING_FILE_NAME(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_FILE_NAME) +#define DUK_STRIDX_LC_POINTER 95 /* 'pointer' */ +#define DUK_HEAP_STRING_LC_POINTER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_POINTER) +#define DUK_HTHREAD_STRING_LC_POINTER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_POINTER) +#define DUK_STRIDX_INT_TARGET 96 /* '\x82Target' */ +#define DUK_HEAP_STRING_INT_TARGET(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_TARGET) +#define DUK_HTHREAD_STRING_INT_TARGET(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_TARGET) +#define DUK_STRIDX_INT_NEXT 97 /* '\x82Next' */ +#define DUK_HEAP_STRING_INT_NEXT(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_NEXT) +#define DUK_HTHREAD_STRING_INT_NEXT(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_NEXT) +#define DUK_STRIDX_INT_BYTECODE 98 /* '\x82Bytecode' */ +#define DUK_HEAP_STRING_INT_BYTECODE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_BYTECODE) +#define DUK_HTHREAD_STRING_INT_BYTECODE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_BYTECODE) +#define DUK_STRIDX_INT_FORMALS 99 /* '\x82Formals' */ +#define DUK_HEAP_STRING_INT_FORMALS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_FORMALS) +#define DUK_HTHREAD_STRING_INT_FORMALS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_FORMALS) +#define DUK_STRIDX_INT_VARMAP 100 /* '\x82Varmap' */ +#define DUK_HEAP_STRING_INT_VARMAP(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_VARMAP) +#define DUK_HTHREAD_STRING_INT_VARMAP(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_VARMAP) +#define DUK_STRIDX_INT_SOURCE 101 /* '\x82Source' */ +#define DUK_HEAP_STRING_INT_SOURCE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_SOURCE) +#define DUK_HTHREAD_STRING_INT_SOURCE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_SOURCE) +#define DUK_STRIDX_INT_PC2LINE 102 /* '\x82Pc2line' */ +#define DUK_HEAP_STRING_INT_PC2LINE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_PC2LINE) +#define DUK_HTHREAD_STRING_INT_PC2LINE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_PC2LINE) +#define DUK_STRIDX_INT_MAP 103 /* '\x82Map' */ +#define DUK_HEAP_STRING_INT_MAP(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_MAP) +#define DUK_HTHREAD_STRING_INT_MAP(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_MAP) +#define DUK_STRIDX_INT_VARENV 104 /* '\x82Varenv' */ +#define DUK_HEAP_STRING_INT_VARENV(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_VARENV) +#define DUK_HTHREAD_STRING_INT_VARENV(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_VARENV) +#define DUK_STRIDX_INT_FINALIZER 105 /* '\x82Finalizer' */ +#define DUK_HEAP_STRING_INT_FINALIZER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_FINALIZER) +#define DUK_HTHREAD_STRING_INT_FINALIZER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_FINALIZER) +#define DUK_STRIDX_INT_VALUE 106 /* '\x82Value' */ +#define DUK_HEAP_STRING_INT_VALUE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INT_VALUE) +#define DUK_HTHREAD_STRING_INT_VALUE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INT_VALUE) +#define DUK_STRIDX_COMPILE 107 /* 'compile' */ +#define DUK_HEAP_STRING_COMPILE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_COMPILE) +#define DUK_HTHREAD_STRING_COMPILE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_COMPILE) +#define DUK_STRIDX_INPUT 108 /* 'input' */ +#define DUK_HEAP_STRING_INPUT(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INPUT) +#define DUK_HTHREAD_STRING_INPUT(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INPUT) +#define DUK_STRIDX_ERR_CREATE 109 /* 'errCreate' */ +#define DUK_HEAP_STRING_ERR_CREATE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_ERR_CREATE) +#define DUK_HTHREAD_STRING_ERR_CREATE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_ERR_CREATE) +#define DUK_STRIDX_ERR_THROW 110 /* 'errThrow' */ +#define DUK_HEAP_STRING_ERR_THROW(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_ERR_THROW) +#define DUK_HTHREAD_STRING_ERR_THROW(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_ERR_THROW) +#define DUK_STRIDX_ENV 111 /* 'env' */ +#define DUK_HEAP_STRING_ENV(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_ENV) +#define DUK_HTHREAD_STRING_ENV(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_ENV) +#define DUK_STRIDX_HEX 112 /* 'hex' */ +#define DUK_HEAP_STRING_HEX(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_HEX) +#define DUK_HTHREAD_STRING_HEX(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_HEX) +#define DUK_STRIDX_BASE64 113 /* 'base64' */ +#define DUK_HEAP_STRING_BASE64(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_BASE64) +#define DUK_HTHREAD_STRING_BASE64(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_BASE64) +#define DUK_STRIDX_JX 114 /* 'jx' */ +#define DUK_HEAP_STRING_JX(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JX) +#define DUK_HTHREAD_STRING_JX(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JX) +#define DUK_STRIDX_JC 115 /* 'jc' */ +#define DUK_HEAP_STRING_JC(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JC) +#define DUK_HTHREAD_STRING_JC(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JC) +#define DUK_STRIDX_JSON_EXT_UNDEFINED 116 /* '{"_undef":true}' */ +#define DUK_HEAP_STRING_JSON_EXT_UNDEFINED(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JSON_EXT_UNDEFINED) +#define DUK_HTHREAD_STRING_JSON_EXT_UNDEFINED(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JSON_EXT_UNDEFINED) +#define DUK_STRIDX_JSON_EXT_NAN 117 /* '{"_nan":true}' */ +#define DUK_HEAP_STRING_JSON_EXT_NAN(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JSON_EXT_NAN) +#define DUK_HTHREAD_STRING_JSON_EXT_NAN(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JSON_EXT_NAN) +#define DUK_STRIDX_JSON_EXT_POSINF 118 /* '{"_inf":true}' */ +#define DUK_HEAP_STRING_JSON_EXT_POSINF(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JSON_EXT_POSINF) +#define DUK_HTHREAD_STRING_JSON_EXT_POSINF(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JSON_EXT_POSINF) +#define DUK_STRIDX_JSON_EXT_NEGINF 119 /* '{"_ninf":true}' */ +#define DUK_HEAP_STRING_JSON_EXT_NEGINF(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JSON_EXT_NEGINF) +#define DUK_HTHREAD_STRING_JSON_EXT_NEGINF(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JSON_EXT_NEGINF) +#define DUK_STRIDX_JSON_EXT_FUNCTION1 120 /* '{"_func":true}' */ +#define DUK_HEAP_STRING_JSON_EXT_FUNCTION1(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JSON_EXT_FUNCTION1) +#define DUK_HTHREAD_STRING_JSON_EXT_FUNCTION1(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JSON_EXT_FUNCTION1) +#define DUK_STRIDX_JSON_EXT_FUNCTION2 121 /* '{_func:true}' */ +#define DUK_HEAP_STRING_JSON_EXT_FUNCTION2(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_JSON_EXT_FUNCTION2) +#define DUK_HTHREAD_STRING_JSON_EXT_FUNCTION2(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_JSON_EXT_FUNCTION2) +#define DUK_STRIDX_BREAK 122 /* 'break' */ +#define DUK_HEAP_STRING_BREAK(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_BREAK) +#define DUK_HTHREAD_STRING_BREAK(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_BREAK) +#define DUK_STRIDX_CASE 123 /* 'case' */ +#define DUK_HEAP_STRING_CASE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CASE) +#define DUK_HTHREAD_STRING_CASE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CASE) +#define DUK_STRIDX_CATCH 124 /* 'catch' */ +#define DUK_HEAP_STRING_CATCH(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CATCH) +#define DUK_HTHREAD_STRING_CATCH(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CATCH) +#define DUK_STRIDX_CONTINUE 125 /* 'continue' */ +#define DUK_HEAP_STRING_CONTINUE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CONTINUE) +#define DUK_HTHREAD_STRING_CONTINUE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CONTINUE) +#define DUK_STRIDX_DEBUGGER 126 /* 'debugger' */ +#define DUK_HEAP_STRING_DEBUGGER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_DEBUGGER) +#define DUK_HTHREAD_STRING_DEBUGGER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_DEBUGGER) +#define DUK_STRIDX_DEFAULT 127 /* 'default' */ +#define DUK_HEAP_STRING_DEFAULT(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_DEFAULT) +#define DUK_HTHREAD_STRING_DEFAULT(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_DEFAULT) +#define DUK_STRIDX_DELETE 128 /* 'delete' */ +#define DUK_HEAP_STRING_DELETE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_DELETE) +#define DUK_HTHREAD_STRING_DELETE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_DELETE) +#define DUK_STRIDX_DO 129 /* 'do' */ +#define DUK_HEAP_STRING_DO(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_DO) +#define DUK_HTHREAD_STRING_DO(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_DO) +#define DUK_STRIDX_ELSE 130 /* 'else' */ +#define DUK_HEAP_STRING_ELSE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_ELSE) +#define DUK_HTHREAD_STRING_ELSE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_ELSE) +#define DUK_STRIDX_FINALLY 131 /* 'finally' */ +#define DUK_HEAP_STRING_FINALLY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_FINALLY) +#define DUK_HTHREAD_STRING_FINALLY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_FINALLY) +#define DUK_STRIDX_FOR 132 /* 'for' */ +#define DUK_HEAP_STRING_FOR(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_FOR) +#define DUK_HTHREAD_STRING_FOR(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_FOR) +#define DUK_STRIDX_LC_FUNCTION 133 /* 'function' */ +#define DUK_HEAP_STRING_LC_FUNCTION(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_FUNCTION) +#define DUK_HTHREAD_STRING_LC_FUNCTION(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_FUNCTION) +#define DUK_STRIDX_IF 134 /* 'if' */ +#define DUK_HEAP_STRING_IF(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_IF) +#define DUK_HTHREAD_STRING_IF(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_IF) +#define DUK_STRIDX_IN 135 /* 'in' */ +#define DUK_HEAP_STRING_IN(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_IN) +#define DUK_HTHREAD_STRING_IN(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_IN) +#define DUK_STRIDX_INSTANCEOF 136 /* 'instanceof' */ +#define DUK_HEAP_STRING_INSTANCEOF(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INSTANCEOF) +#define DUK_HTHREAD_STRING_INSTANCEOF(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INSTANCEOF) +#define DUK_STRIDX_NEW 137 /* 'new' */ +#define DUK_HEAP_STRING_NEW(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_NEW) +#define DUK_HTHREAD_STRING_NEW(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_NEW) +#define DUK_STRIDX_RETURN 138 /* 'return' */ +#define DUK_HEAP_STRING_RETURN(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_RETURN) +#define DUK_HTHREAD_STRING_RETURN(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_RETURN) +#define DUK_STRIDX_SWITCH 139 /* 'switch' */ +#define DUK_HEAP_STRING_SWITCH(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_SWITCH) +#define DUK_HTHREAD_STRING_SWITCH(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_SWITCH) +#define DUK_STRIDX_THIS 140 /* 'this' */ +#define DUK_HEAP_STRING_THIS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_THIS) +#define DUK_HTHREAD_STRING_THIS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_THIS) +#define DUK_STRIDX_THROW 141 /* 'throw' */ +#define DUK_HEAP_STRING_THROW(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_THROW) +#define DUK_HTHREAD_STRING_THROW(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_THROW) +#define DUK_STRIDX_TRY 142 /* 'try' */ +#define DUK_HEAP_STRING_TRY(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TRY) +#define DUK_HTHREAD_STRING_TRY(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TRY) +#define DUK_STRIDX_TYPEOF 143 /* 'typeof' */ +#define DUK_HEAP_STRING_TYPEOF(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TYPEOF) +#define DUK_HTHREAD_STRING_TYPEOF(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TYPEOF) +#define DUK_STRIDX_VAR 144 /* 'var' */ +#define DUK_HEAP_STRING_VAR(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_VAR) +#define DUK_HTHREAD_STRING_VAR(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_VAR) +#define DUK_STRIDX_CONST 145 /* 'const' */ +#define DUK_HEAP_STRING_CONST(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CONST) +#define DUK_HTHREAD_STRING_CONST(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CONST) +#define DUK_STRIDX_VOID 146 /* 'void' */ +#define DUK_HEAP_STRING_VOID(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_VOID) +#define DUK_HTHREAD_STRING_VOID(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_VOID) +#define DUK_STRIDX_WHILE 147 /* 'while' */ +#define DUK_HEAP_STRING_WHILE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_WHILE) +#define DUK_HTHREAD_STRING_WHILE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_WHILE) +#define DUK_STRIDX_WITH 148 /* 'with' */ +#define DUK_HEAP_STRING_WITH(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_WITH) +#define DUK_HTHREAD_STRING_WITH(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_WITH) +#define DUK_STRIDX_CLASS 149 /* 'class' */ +#define DUK_HEAP_STRING_CLASS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_CLASS) +#define DUK_HTHREAD_STRING_CLASS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_CLASS) +#define DUK_STRIDX_ENUM 150 /* 'enum' */ +#define DUK_HEAP_STRING_ENUM(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_ENUM) +#define DUK_HTHREAD_STRING_ENUM(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_ENUM) +#define DUK_STRIDX_EXPORT 151 /* 'export' */ +#define DUK_HEAP_STRING_EXPORT(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_EXPORT) +#define DUK_HTHREAD_STRING_EXPORT(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_EXPORT) +#define DUK_STRIDX_EXTENDS 152 /* 'extends' */ +#define DUK_HEAP_STRING_EXTENDS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_EXTENDS) +#define DUK_HTHREAD_STRING_EXTENDS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_EXTENDS) +#define DUK_STRIDX_IMPORT 153 /* 'import' */ +#define DUK_HEAP_STRING_IMPORT(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_IMPORT) +#define DUK_HTHREAD_STRING_IMPORT(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_IMPORT) +#define DUK_STRIDX_SUPER 154 /* 'super' */ +#define DUK_HEAP_STRING_SUPER(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_SUPER) +#define DUK_HTHREAD_STRING_SUPER(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_SUPER) +#define DUK_STRIDX_LC_NULL 155 /* 'null' */ +#define DUK_HEAP_STRING_LC_NULL(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LC_NULL) +#define DUK_HTHREAD_STRING_LC_NULL(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LC_NULL) +#define DUK_STRIDX_TRUE 156 /* 'true' */ +#define DUK_HEAP_STRING_TRUE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_TRUE) +#define DUK_HTHREAD_STRING_TRUE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_TRUE) +#define DUK_STRIDX_FALSE 157 /* 'false' */ +#define DUK_HEAP_STRING_FALSE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_FALSE) +#define DUK_HTHREAD_STRING_FALSE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_FALSE) +#define DUK_STRIDX_IMPLEMENTS 158 /* 'implements' */ +#define DUK_HEAP_STRING_IMPLEMENTS(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_IMPLEMENTS) +#define DUK_HTHREAD_STRING_IMPLEMENTS(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_IMPLEMENTS) +#define DUK_STRIDX_INTERFACE 159 /* 'interface' */ +#define DUK_HEAP_STRING_INTERFACE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_INTERFACE) +#define DUK_HTHREAD_STRING_INTERFACE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_INTERFACE) +#define DUK_STRIDX_LET 160 /* 'let' */ +#define DUK_HEAP_STRING_LET(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_LET) +#define DUK_HTHREAD_STRING_LET(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_LET) +#define DUK_STRIDX_PACKAGE 161 /* 'package' */ +#define DUK_HEAP_STRING_PACKAGE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_PACKAGE) +#define DUK_HTHREAD_STRING_PACKAGE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_PACKAGE) +#define DUK_STRIDX_PRIVATE 162 /* 'private' */ +#define DUK_HEAP_STRING_PRIVATE(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_PRIVATE) +#define DUK_HTHREAD_STRING_PRIVATE(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_PRIVATE) +#define DUK_STRIDX_PROTECTED 163 /* 'protected' */ +#define DUK_HEAP_STRING_PROTECTED(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_PROTECTED) +#define DUK_HTHREAD_STRING_PROTECTED(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_PROTECTED) +#define DUK_STRIDX_PUBLIC 164 /* 'public' */ +#define DUK_HEAP_STRING_PUBLIC(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_PUBLIC) +#define DUK_HTHREAD_STRING_PUBLIC(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_PUBLIC) +#define DUK_STRIDX_STATIC 165 /* 'static' */ +#define DUK_HEAP_STRING_STATIC(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_STATIC) +#define DUK_HTHREAD_STRING_STATIC(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_STATIC) +#define DUK_STRIDX_YIELD 166 /* 'yield' */ +#define DUK_HEAP_STRING_YIELD(heap) DUK_HEAP_GET_STRING((heap),DUK_STRIDX_YIELD) +#define DUK_HTHREAD_STRING_YIELD(thr) DUK_HTHREAD_GET_STRING((thr),DUK_STRIDX_YIELD) + +#define DUK_HEAP_NUM_STRINGS 167 +#define DUK_STRIDX_START_RESERVED 122 +#define DUK_STRIDX_START_STRICT_RESERVED 158 +#define DUK_STRIDX_END_RESERVED 167 /* exclusive endpoint */ + +/* To convert a heap stridx to a token number, subtract + * DUK_STRIDX_START_RESERVED and add DUK_TOK_START_RESERVED. + */ +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL const duk_uint8_t duk_strings_data[972]; +#endif /* !DUK_SINGLE_FILE */ +#define DUK_STRDATA_MAX_STRLEN 27 +#define DUK_STRDATA_DATA_LENGTH 972 +#endif /* DUK_USE_ROM_STRINGS */ + +#if defined(DUK_USE_ROM_OBJECTS) +#error RAM support not enabled, rerun configure.py with --ram-support +#else /* DUK_USE_ROM_OBJECTS */ +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_function_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_function_prototype(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_boolean_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_number_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_regexp_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_error_constructor_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_type_error_thrower(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_parse_int(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_parse_float(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_thread_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_pointer_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_proxy_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_symbol_constructor_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_arraybuffer_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_dataview_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_typedarray_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_textencoder_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_textdecoder_constructor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_eval(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_is_nan(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_is_finite(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_decode_uri(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_decode_uri_component(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_encode_uri(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_encode_uri_component(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_escape(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_global_object_unescape(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_getprototype_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_setprototype_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_get_own_property_descriptor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_keys_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_assign(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_create(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_define_property(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_define_properties(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_seal_freeze_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_prevent_extensions(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_is_sealed_frozen_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_is_extensible(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_constructor_is(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_prototype_to_string(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_prototype_to_locale_string(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_prototype_value_of(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_prototype_has_own_property(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_prototype_is_prototype_of(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_prototype_property_is_enumerable(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_prototype_defineaccessor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_prototype_lookupaccessor(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_function_prototype_to_string(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_function_prototype_apply(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_function_prototype_call(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_function_prototype_bind(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_function_prototype_hasinstance(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_native_function_length(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_native_function_name(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_constructor_is_array(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_to_string(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_join_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_concat(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_pop(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_push(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_reverse(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_shift(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_slice(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_sort(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_splice(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_unshift(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_indexof_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_iter_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_array_prototype_reduce_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_constructor_from_char_code(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_constructor_from_code_point(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_to_string(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_char_at(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_char_code_at(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_concat(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_indexof_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_locale_compare(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_match(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_replace(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_search(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_slice(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_split(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_substring(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_caseconv_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_trim(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_repeat(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_startswith_endswith(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_includes(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_string_prototype_substr(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_boolean_prototype_tostring_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_number_check_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_number_prototype_to_string(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_number_prototype_to_locale_string(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_number_prototype_value_of(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_number_prototype_to_fixed(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_number_prototype_to_exponential(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_number_prototype_to_precision(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_constructor_parse(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_constructor_utc(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_constructor_now(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_prototype_tostring_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_prototype_to_json(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_prototype_value_of(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_prototype_get_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_prototype_get_timezone_offset(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_prototype_set_time(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_prototype_set_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_date_prototype_toprimitive(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_regexp_prototype_exec(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_regexp_prototype_test(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_regexp_prototype_tostring(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_regexp_prototype_flags(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_regexp_prototype_shared_getter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_error_prototype_stack_getter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_error_prototype_stack_setter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_error_prototype_filename_getter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_error_prototype_filename_setter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_error_prototype_linenumber_getter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_error_prototype_linenumber_setter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_error_prototype_to_string(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_math_object_onearg_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_math_object_twoarg_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_math_object_clz32(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_math_object_hypot(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_math_object_imul(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_math_object_max(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_math_object_min(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_math_object_random(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_math_object_sign(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_json_object_parse(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_json_object_stringify(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_duktape_object_info(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_duktape_object_act(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_duktape_object_gc(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_duktape_object_fin(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_duktape_object_enc(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_duktape_object_dec(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_duktape_object_compact(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_thread_yield(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_thread_resume(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_thread_current(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_pointer_prototype_tostring_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_reflect_apply(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_reflect_construct(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_reflect_object_delete_property(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_reflect_object_get(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_reflect_object_has(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_reflect_object_set(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_symbol_key_for(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_symbol_tostring_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_symbol_toprimitive(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_arraybuffer_isview(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_typedarray_bytelength_getter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_buffer_slice_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_typedarray_byteoffset_getter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_typedarray_buffer_getter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_buffer_readfield(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_buffer_writefield(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_typedarray_set(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_uint8array_allocplain(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_uint8array_plainof(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_concat(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_is_encoding(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_is_buffer(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_byte_length(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_buffer_compare_shared(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_tostring(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_tojson(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_fill(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_copy(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_nodejs_buffer_write(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_cbor_encode(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_cbor_decode(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_textencoder_prototype_encoding_getter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_textencoder_prototype_encode(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_textdecoder_prototype_shared_getter(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_textdecoder_prototype_decode(duk_context *ctx); +DUK_INTERNAL_DECL duk_ret_t duk_bi_performance_now(duk_context *ctx); +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL const duk_c_function duk_bi_native_functions[185]; +#endif /* !DUK_SINGLE_FILE */ +#define DUK_BIDX_GLOBAL 0 +#define DUK_BIDX_GLOBAL_ENV 1 +#define DUK_BIDX_OBJECT_CONSTRUCTOR 2 +#define DUK_BIDX_OBJECT_PROTOTYPE 3 +#define DUK_BIDX_FUNCTION_CONSTRUCTOR 4 +#define DUK_BIDX_FUNCTION_PROTOTYPE 5 +#define DUK_BIDX_NATIVE_FUNCTION_PROTOTYPE 6 +#define DUK_BIDX_ARRAY_CONSTRUCTOR 7 +#define DUK_BIDX_ARRAY_PROTOTYPE 8 +#define DUK_BIDX_STRING_CONSTRUCTOR 9 +#define DUK_BIDX_STRING_PROTOTYPE 10 +#define DUK_BIDX_BOOLEAN_CONSTRUCTOR 11 +#define DUK_BIDX_BOOLEAN_PROTOTYPE 12 +#define DUK_BIDX_NUMBER_CONSTRUCTOR 13 +#define DUK_BIDX_NUMBER_PROTOTYPE 14 +#define DUK_BIDX_DATE_CONSTRUCTOR 15 +#define DUK_BIDX_DATE_PROTOTYPE 16 +#define DUK_BIDX_REGEXP_CONSTRUCTOR 17 +#define DUK_BIDX_REGEXP_PROTOTYPE 18 +#define DUK_BIDX_ERROR_CONSTRUCTOR 19 +#define DUK_BIDX_ERROR_PROTOTYPE 20 +#define DUK_BIDX_EVAL_ERROR_CONSTRUCTOR 21 +#define DUK_BIDX_EVAL_ERROR_PROTOTYPE 22 +#define DUK_BIDX_RANGE_ERROR_CONSTRUCTOR 23 +#define DUK_BIDX_RANGE_ERROR_PROTOTYPE 24 +#define DUK_BIDX_REFERENCE_ERROR_CONSTRUCTOR 25 +#define DUK_BIDX_REFERENCE_ERROR_PROTOTYPE 26 +#define DUK_BIDX_SYNTAX_ERROR_CONSTRUCTOR 27 +#define DUK_BIDX_SYNTAX_ERROR_PROTOTYPE 28 +#define DUK_BIDX_TYPE_ERROR_CONSTRUCTOR 29 +#define DUK_BIDX_TYPE_ERROR_PROTOTYPE 30 +#define DUK_BIDX_URI_ERROR_CONSTRUCTOR 31 +#define DUK_BIDX_URI_ERROR_PROTOTYPE 32 +#define DUK_BIDX_TYPE_ERROR_THROWER 33 +#define DUK_BIDX_DUKTAPE 34 +#define DUK_BIDX_THREAD_PROTOTYPE 35 +#define DUK_BIDX_POINTER_PROTOTYPE 36 +#define DUK_BIDX_DOUBLE_ERROR 37 +#define DUK_BIDX_SYMBOL_PROTOTYPE 38 +#define DUK_BIDX_ARRAYBUFFER_PROTOTYPE 39 +#define DUK_BIDX_DATAVIEW_PROTOTYPE 40 +#define DUK_BIDX_INT8ARRAY_PROTOTYPE 41 +#define DUK_BIDX_UINT8ARRAY_PROTOTYPE 42 +#define DUK_BIDX_UINT8CLAMPEDARRAY_PROTOTYPE 43 +#define DUK_BIDX_INT16ARRAY_PROTOTYPE 44 +#define DUK_BIDX_UINT16ARRAY_PROTOTYPE 45 +#define DUK_BIDX_INT32ARRAY_PROTOTYPE 46 +#define DUK_BIDX_UINT32ARRAY_PROTOTYPE 47 +#define DUK_BIDX_FLOAT32ARRAY_PROTOTYPE 48 +#define DUK_BIDX_FLOAT64ARRAY_PROTOTYPE 49 +#define DUK_BIDX_NODEJS_BUFFER_PROTOTYPE 50 +#define DUK_NUM_BUILTINS 51 +#define DUK_NUM_BIDX_BUILTINS 51 +#define DUK_NUM_ALL_BUILTINS 80 +#if defined(DUK_USE_DOUBLE_LE) +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL const duk_uint8_t duk_builtins_data[4281]; +#endif /* !DUK_SINGLE_FILE */ +#define DUK_BUILTINS_DATA_LENGTH 4281 +#elif defined(DUK_USE_DOUBLE_BE) +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL const duk_uint8_t duk_builtins_data[4281]; +#endif /* !DUK_SINGLE_FILE */ +#define DUK_BUILTINS_DATA_LENGTH 4281 +#elif defined(DUK_USE_DOUBLE_ME) +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL const duk_uint8_t duk_builtins_data[4281]; +#endif /* !DUK_SINGLE_FILE */ +#define DUK_BUILTINS_DATA_LENGTH 4281 +#else +#error invalid endianness defines +#endif +#endif /* DUK_USE_ROM_OBJECTS */ +#endif /* DUK_BUILTINS_H_INCLUDED */ +#line 45 "duk_internal.h" + +/* #include duk_util.h */ +#line 1 "duk_util.h" +/* + * Utilities + */ + +#if !defined(DUK_UTIL_H_INCLUDED) +#define DUK_UTIL_H_INCLUDED + +/* + * Some useful constants + */ + +#define DUK_DOUBLE_2TO32 4294967296.0 +#define DUK_DOUBLE_2TO31 2147483648.0 +#define DUK_DOUBLE_LOG2E 1.4426950408889634 +#define DUK_DOUBLE_LOG10E 0.4342944819032518 + +/* + * Endian conversion + */ + +#if defined(DUK_USE_INTEGER_LE) +#define DUK_HTON32(x) DUK_BSWAP32((x)) +#define DUK_NTOH32(x) DUK_BSWAP32((x)) +#define DUK_HTON16(x) DUK_BSWAP16((x)) +#define DUK_NTOH16(x) DUK_BSWAP16((x)) +#elif defined(DUK_USE_INTEGER_BE) +#define DUK_HTON32(x) (x) +#define DUK_NTOH32(x) (x) +#define DUK_HTON16(x) (x) +#define DUK_NTOH16(x) (x) +#else +#error internal error, endianness defines broken +#endif + +/* + * Bitstream decoder + */ + +struct duk_bitdecoder_ctx { + const duk_uint8_t *data; + duk_size_t offset; + duk_size_t length; + duk_uint32_t currval; + duk_small_int_t currbits; +}; + +#define DUK_BD_BITPACKED_STRING_MAXLEN 256 + +/* + * Bitstream encoder + */ + +struct duk_bitencoder_ctx { + duk_uint8_t *data; + duk_size_t offset; + duk_size_t length; + duk_uint32_t currval; + duk_small_int_t currbits; + duk_small_int_t truncated; +}; + +/* + * Raw write/read macros for big endian, unaligned basic values. + * Caller ensures there's enough space. The INC macro variants + * update the pointer argument automatically. + */ + +#define DUK_RAW_WRITE_U8(ptr, val) \ + do { \ + *(ptr) = (duk_uint8_t) (val); \ + } while (0) +#define DUK_RAW_WRITE_U16_BE(ptr, val) duk_raw_write_u16_be((ptr), (duk_uint16_t) (val)) +#define DUK_RAW_WRITE_U32_BE(ptr, val) duk_raw_write_u32_be((ptr), (duk_uint32_t) (val)) +#define DUK_RAW_WRITE_FLOAT_BE(ptr, val) duk_raw_write_float_be((ptr), (duk_float_t) (val)) +#define DUK_RAW_WRITE_DOUBLE_BE(ptr, val) duk_raw_write_double_be((ptr), (duk_double_t) (val)) +#define DUK_RAW_WRITE_XUTF8(ptr, val) duk_raw_write_xutf8((ptr), (duk_ucodepoint_t) (val)) + +#define DUK_RAW_WRITEINC_U8(ptr, val) \ + do { \ + *(ptr)++ = (duk_uint8_t) (val); \ + } while (0) +#define DUK_RAW_WRITEINC_U16_BE(ptr, val) duk_raw_writeinc_u16_be(&(ptr), (duk_uint16_t) (val)) +#define DUK_RAW_WRITEINC_U32_BE(ptr, val) duk_raw_writeinc_u32_be(&(ptr), (duk_uint32_t) (val)) +#define DUK_RAW_WRITEINC_FLOAT_BE(ptr, val) duk_raw_writeinc_float_be(&(ptr), (duk_float_t) (val)) +#define DUK_RAW_WRITEINC_DOUBLE_BE(ptr, val) duk_raw_writeinc_double_be(&(ptr), (duk_double_t) (val)) +#define DUK_RAW_WRITEINC_XUTF8(ptr, val) duk_raw_writeinc_xutf8(&(ptr), (duk_ucodepoint_t) (val)) +#define DUK_RAW_WRITEINC_CESU8(ptr, val) duk_raw_writeinc_cesu8(&(ptr), (duk_ucodepoint_t) (val)) + +#define DUK_RAW_READ_U8(ptr) ((duk_uint8_t) (*(ptr))) +#define DUK_RAW_READ_U16_BE(ptr) duk_raw_read_u16_be((ptr)); +#define DUK_RAW_READ_U32_BE(ptr) duk_raw_read_u32_be((ptr)); +#define DUK_RAW_READ_DOUBLE_BE(ptr) duk_raw_read_double_be((ptr)); + +#define DUK_RAW_READINC_U8(ptr) ((duk_uint8_t) (*(ptr)++)) +#define DUK_RAW_READINC_U16_BE(ptr) duk_raw_readinc_u16_be(&(ptr)); +#define DUK_RAW_READINC_U32_BE(ptr) duk_raw_readinc_u32_be(&(ptr)); +#define DUK_RAW_READINC_DOUBLE_BE(ptr) duk_raw_readinc_double_be(&(ptr)); + +/* + * Double and float byte order operations. + */ + +DUK_INTERNAL_DECL void duk_dblunion_host_to_little(duk_double_union *u); +DUK_INTERNAL_DECL void duk_dblunion_little_to_host(duk_double_union *u); +DUK_INTERNAL_DECL void duk_dblunion_host_to_big(duk_double_union *u); +DUK_INTERNAL_DECL void duk_dblunion_big_to_host(duk_double_union *u); +DUK_INTERNAL_DECL void duk_fltunion_host_to_big(duk_float_union *u); +DUK_INTERNAL_DECL void duk_fltunion_big_to_host(duk_float_union *u); + +/* + * Buffer writer (dynamic buffer only) + * + * Helper for writing to a dynamic buffer with a concept of a "slack" area + * to reduce resizes. You can ensure there is enough space beforehand and + * then write for a while without further checks, relying on a stable data + * pointer. Slack handling is automatic so call sites only indicate how + * much data they need right now. + * + * There are several ways to write using bufwriter. The best approach + * depends mainly on how much performance matters over code footprint. + * The key issues are (1) ensuring there is space and (2) keeping the + * pointers consistent. Fast code should ensure space for multiple writes + * with one ensure call. Fastest inner loop code can temporarily borrow + * the 'p' pointer but must write it back eventually. + * + * Be careful to ensure all macro arguments (other than static pointers like + * 'thr' and 'bw_ctx') are evaluated exactly once, using temporaries if + * necessary (if that's not possible, there should be a note near the macro). + * Buffer write arguments often contain arithmetic etc so this is + * particularly important here. + */ + +/* XXX: Migrate bufwriter and other read/write helpers to its own header? */ + +struct duk_bufwriter_ctx { + duk_uint8_t *p; + duk_uint8_t *p_base; + duk_uint8_t *p_limit; + duk_hbuffer_dynamic *buf; +}; + +#if defined(DUK_USE_PREFER_SIZE) +#define DUK_BW_SLACK_ADD 64 +#define DUK_BW_SLACK_SHIFT 4 /* 2^4 -> 1/16 = 6.25% slack */ +#else +#define DUK_BW_SLACK_ADD 64 +#define DUK_BW_SLACK_SHIFT 2 /* 2^2 -> 1/4 = 25% slack */ +#endif + +/* Initialization and finalization (compaction), converting to other types. */ + +#define DUK_BW_INIT_PUSHBUF(thr, bw_ctx, sz) \ + do { \ + duk_bw_init_pushbuf((thr), (bw_ctx), (sz)); \ + } while (0) +#define DUK_BW_INIT_WITHBUF(thr, bw_ctx, buf) \ + do { \ + duk_bw_init((thr), (bw_ctx), (buf)); \ + } while (0) +#define DUK_BW_COMPACT(thr, bw_ctx) \ + do { \ + /* Make underlying buffer compact to match DUK_BW_GET_SIZE(). */ \ + duk_bw_compact((thr), (bw_ctx)); \ + } while (0) +#define DUK_BW_PUSH_AS_STRING(thr, bw_ctx) \ + do { \ + duk_push_lstring((thr), (const char *) (bw_ctx)->p_base, (duk_size_t) ((bw_ctx)->p - (bw_ctx)->p_base)); \ + } while (0) + +/* Pointers may be NULL for a while when 'buf' size is zero and before any + * ENSURE calls have been made. Once an ENSURE has been made, the pointers + * are required to be non-NULL so that it's always valid to use memcpy() and + * memmove(), even for zero size. + */ +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_bw_assert_valid(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx); +#define DUK_BW_ASSERT_VALID_EXPR(thr, bw_ctx) (duk_bw_assert_valid((thr), (bw_ctx))) +#define DUK_BW_ASSERT_VALID(thr, bw_ctx) \ + do { \ + duk_bw_assert_valid((thr), (bw_ctx)); \ + } while (0) +#else +#define DUK_BW_ASSERT_VALID_EXPR(thr, bw_ctx) DUK_ASSERT_EXPR(1) +#define DUK_BW_ASSERT_VALID(thr, bw_ctx) \ + do { \ + } while (0) +#endif + +/* Working with the pointer and current size. */ + +#define DUK_BW_GET_PTR(thr, bw_ctx) ((bw_ctx)->p) +#define DUK_BW_SET_PTR(thr, bw_ctx, ptr) \ + do { \ + (bw_ctx)->p = (ptr); \ + } while (0) +#define DUK_BW_ADD_PTR(thr, bw_ctx, delta) \ + do { \ + (bw_ctx)->p += (delta); \ + } while (0) +#define DUK_BW_GET_BASEPTR(thr, bw_ctx) ((bw_ctx)->p_base) +#define DUK_BW_GET_LIMITPTR(thr, bw_ctx) ((bw_ctx)->p_limit) +#define DUK_BW_GET_SIZE(thr, bw_ctx) ((duk_size_t) ((bw_ctx)->p - (bw_ctx)->p_base)) +#define DUK_BW_SET_SIZE(thr, bw_ctx, sz) \ + do { \ + DUK_ASSERT((duk_size_t) (sz) <= (duk_size_t) ((bw_ctx)->p - (bw_ctx)->p_base)); \ + (bw_ctx)->p = (bw_ctx)->p_base + (sz); \ + } while (0) +#define DUK_BW_RESET_SIZE(thr, bw_ctx) \ + do { \ + /* Reset to zero size, keep current limit. */ \ + (bw_ctx)->p = (bw_ctx)->p_base; \ + } while (0) +#define DUK_BW_GET_BUFFER(thr, bw_ctx) ((bw_ctx)->buf) + +/* Ensuring (reserving) space. */ + +#define DUK_BW_ENSURE(thr, bw_ctx, sz) \ + do { \ + duk_size_t duk__sz, duk__space; \ + DUK_BW_ASSERT_VALID((thr), (bw_ctx)); \ + duk__sz = (sz); \ + duk__space = (duk_size_t) ((bw_ctx)->p_limit - (bw_ctx)->p); \ + if (duk__space < duk__sz) { \ + (void) duk_bw_resize((thr), (bw_ctx), duk__sz); \ + } \ + } while (0) +/* NOTE: Multiple evaluation of 'ptr' in this macro. */ +/* XXX: Rework to use an always-inline function? */ +#define DUK_BW_ENSURE_RAW(thr, bw_ctx, sz, ptr) \ + (((duk_size_t) ((bw_ctx)->p_limit - (ptr)) >= (sz)) ? (ptr) : ((bw_ctx)->p = (ptr), duk_bw_resize((thr), (bw_ctx), (sz)))) +#define DUK_BW_ENSURE_GETPTR(thr, bw_ctx, sz) DUK_BW_ENSURE_RAW((thr), (bw_ctx), (sz), (bw_ctx)->p) +#define DUK_BW_ASSERT_SPACE_EXPR(thr, bw_ctx, sz) \ + (DUK_BW_ASSERT_VALID_EXPR((thr), (bw_ctx)), \ + DUK_ASSERT_EXPR((duk_size_t) ((bw_ctx)->p_limit - (bw_ctx)->p) >= (duk_size_t) (sz))) +#define DUK_BW_ASSERT_SPACE(thr, bw_ctx, sz) \ + do { \ + DUK_BW_ASSERT_SPACE_EXPR((thr), (bw_ctx), (sz)); \ + } while (0) + +/* Miscellaneous. */ + +#define DUK_BW_SETPTR_AND_COMPACT(thr, bw_ctx, ptr) \ + do { \ + (bw_ctx)->p = (ptr); \ + duk_bw_compact((thr), (bw_ctx)); \ + } while (0) + +/* Fast write calls which assume you control the slack beforehand. + * Multibyte write variants exist and use a temporary write pointer + * because byte writes alias with anything: with a stored pointer + * explicit pointer load/stores get generated (e.g. gcc -Os). + */ + +#define DUK_BW_WRITE_RAW_U8(thr, bw_ctx, val) \ + do { \ + DUK_BW_ASSERT_SPACE((thr), (bw_ctx), 1); \ + *(bw_ctx)->p++ = (duk_uint8_t) (val); \ + } while (0) +#define DUK_BW_WRITE_RAW_U8_2(thr, bw_ctx, val1, val2) \ + do { \ + duk_uint8_t *duk__p; \ + DUK_BW_ASSERT_SPACE((thr), (bw_ctx), 2); \ + duk__p = (bw_ctx)->p; \ + *duk__p++ = (duk_uint8_t) (val1); \ + *duk__p++ = (duk_uint8_t) (val2); \ + (bw_ctx)->p = duk__p; \ + } while (0) +#define DUK_BW_WRITE_RAW_U8_3(thr, bw_ctx, val1, val2, val3) \ + do { \ + duk_uint8_t *duk__p; \ + DUK_BW_ASSERT_SPACE((thr), (bw_ctx), 3); \ + duk__p = (bw_ctx)->p; \ + *duk__p++ = (duk_uint8_t) (val1); \ + *duk__p++ = (duk_uint8_t) (val2); \ + *duk__p++ = (duk_uint8_t) (val3); \ + (bw_ctx)->p = duk__p; \ + } while (0) +#define DUK_BW_WRITE_RAW_U8_4(thr, bw_ctx, val1, val2, val3, val4) \ + do { \ + duk_uint8_t *duk__p; \ + DUK_BW_ASSERT_SPACE((thr), (bw_ctx), 4); \ + duk__p = (bw_ctx)->p; \ + *duk__p++ = (duk_uint8_t) (val1); \ + *duk__p++ = (duk_uint8_t) (val2); \ + *duk__p++ = (duk_uint8_t) (val3); \ + *duk__p++ = (duk_uint8_t) (val4); \ + (bw_ctx)->p = duk__p; \ + } while (0) +#define DUK_BW_WRITE_RAW_U8_5(thr, bw_ctx, val1, val2, val3, val4, val5) \ + do { \ + duk_uint8_t *duk__p; \ + DUK_BW_ASSERT_SPACE((thr), (bw_ctx), 5); \ + duk__p = (bw_ctx)->p; \ + *duk__p++ = (duk_uint8_t) (val1); \ + *duk__p++ = (duk_uint8_t) (val2); \ + *duk__p++ = (duk_uint8_t) (val3); \ + *duk__p++ = (duk_uint8_t) (val4); \ + *duk__p++ = (duk_uint8_t) (val5); \ + (bw_ctx)->p = duk__p; \ + } while (0) +#define DUK_BW_WRITE_RAW_U8_6(thr, bw_ctx, val1, val2, val3, val4, val5, val6) \ + do { \ + duk_uint8_t *duk__p; \ + DUK_BW_ASSERT_SPACE((thr), (bw_ctx), 6); \ + duk__p = (bw_ctx)->p; \ + *duk__p++ = (duk_uint8_t) (val1); \ + *duk__p++ = (duk_uint8_t) (val2); \ + *duk__p++ = (duk_uint8_t) (val3); \ + *duk__p++ = (duk_uint8_t) (val4); \ + *duk__p++ = (duk_uint8_t) (val5); \ + *duk__p++ = (duk_uint8_t) (val6); \ + (bw_ctx)->p = duk__p; \ + } while (0) +#define DUK_BW_WRITE_RAW_XUTF8(thr, bw_ctx, cp) \ + do { \ + duk_ucodepoint_t duk__cp; \ + duk_small_int_t duk__enc_len; \ + duk__cp = (duk_ucodepoint_t) (cp); \ + DUK_BW_ASSERT_SPACE((thr), (bw_ctx), duk_unicode_get_xutf8_length(duk__cp)); \ + duk__enc_len = duk_unicode_encode_xutf8(duk__cp, (bw_ctx)->p); \ + (bw_ctx)->p += duk__enc_len; \ + } while (0) +#define DUK_BW_WRITE_RAW_CESU8(thr, bw_ctx, cp) \ + do { \ + duk_ucodepoint_t duk__cp; \ + duk_small_int_t duk__enc_len; \ + duk__cp = (duk_ucodepoint_t) (cp); \ + DUK_BW_ASSERT_SPACE((thr), (bw_ctx), duk_unicode_get_cesu8_length(duk__cp)); \ + duk__enc_len = duk_unicode_encode_cesu8(duk__cp, (bw_ctx)->p); \ + (bw_ctx)->p += duk__enc_len; \ + } while (0) +/* XXX: add temporary duk__p pointer here too; sharing */ +/* XXX: avoid unsafe variants */ +#define DUK_BW_WRITE_RAW_BYTES(thr, bw_ctx, valptr, valsz) \ + do { \ + const void *duk__valptr; \ + duk_size_t duk__valsz; \ + duk__valptr = (const void *) (valptr); \ + duk__valsz = (duk_size_t) (valsz); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), duk__valptr, duk__valsz); \ + (bw_ctx)->p += duk__valsz; \ + } while (0) +#define DUK_BW_WRITE_RAW_CSTRING(thr, bw_ctx, val) \ + do { \ + const duk_uint8_t *duk__val; \ + duk_size_t duk__val_len; \ + duk__val = (const duk_uint8_t *) (val); \ + duk__val_len = DUK_STRLEN((const char *) duk__val); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), (const void *) duk__val, duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) +#define DUK_BW_WRITE_RAW_HSTRING(thr, bw_ctx, val) \ + do { \ + duk_size_t duk__val_len; \ + duk__val_len = DUK_HSTRING_GET_BYTELEN((val)); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), (const void *) DUK_HSTRING_GET_DATA((val)), duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) +#define DUK_BW_WRITE_RAW_HBUFFER(thr, bw_ctx, val) \ + do { \ + duk_size_t duk__val_len; \ + duk__val_len = DUK_HBUFFER_GET_SIZE((val)); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), \ + (const void *) DUK_HBUFFER_GET_DATA_PTR((thr)->heap, (val)), \ + duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) +#define DUK_BW_WRITE_RAW_HBUFFER_FIXED(thr, bw_ctx, val) \ + do { \ + duk_size_t duk__val_len; \ + duk__val_len = DUK_HBUFFER_FIXED_GET_SIZE((val)); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), \ + (const void *) DUK_HBUFFER_FIXED_GET_DATA_PTR((thr)->heap, (val)), \ + duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) +#define DUK_BW_WRITE_RAW_HBUFFER_DYNAMIC(thr, bw_ctx, val) \ + do { \ + duk_size_t duk__val_len; \ + duk__val_len = DUK_HBUFFER_DYNAMIC_GET_SIZE((val)); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), \ + (const void *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR((thr)->heap, (val)), \ + duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) + +/* Append bytes from a slice already in the buffer. */ +#define DUK_BW_WRITE_RAW_SLICE(thr, bw, dst_off, dst_len) duk_bw_write_raw_slice((thr), (bw), (dst_off), (dst_len)) + +/* Insert bytes in the middle of the buffer from an external buffer. */ +#define DUK_BW_INSERT_RAW_BYTES(thr, bw, dst_off, buf, len) duk_bw_insert_raw_bytes((thr), (bw), (dst_off), (buf), (len)) + +/* Insert bytes in the middle of the buffer from a slice already + * in the buffer. Source offset is interpreted "before" the operation. + */ +#define DUK_BW_INSERT_RAW_SLICE(thr, bw, dst_off, src_off, len) duk_bw_insert_raw_slice((thr), (bw), (dst_off), (src_off), (len)) + +/* Insert a reserved area somewhere in the buffer; caller fills it. + * Evaluates to a (duk_uint_t *) pointing to the start of the reserved + * area for convenience. + */ +#define DUK_BW_INSERT_RAW_AREA(thr, bw, off, len) duk_bw_insert_raw_area((thr), (bw), (off), (len)) + +/* Remove a slice from inside buffer. */ +#define DUK_BW_REMOVE_RAW_SLICE(thr, bw, off, len) duk_bw_remove_raw_slice((thr), (bw), (off), (len)) + +/* Safe write calls which will ensure space first. */ + +#define DUK_BW_WRITE_ENSURE_U8(thr, bw_ctx, val) \ + do { \ + DUK_BW_ENSURE((thr), (bw_ctx), 1); \ + DUK_BW_WRITE_RAW_U8((thr), (bw_ctx), (val)); \ + } while (0) +#define DUK_BW_WRITE_ENSURE_U8_2(thr, bw_ctx, val1, val2) \ + do { \ + DUK_BW_ENSURE((thr), (bw_ctx), 2); \ + DUK_BW_WRITE_RAW_U8_2((thr), (bw_ctx), (val1), (val2)); \ + } while (0) +#define DUK_BW_WRITE_ENSURE_U8_3(thr, bw_ctx, val1, val2, val3) \ + do { \ + DUK_BW_ENSURE((thr), (bw_ctx), 3); \ + DUK_BW_WRITE_RAW_U8_3((thr), (bw_ctx), (val1), (val2), (val3)); \ + } while (0) +#define DUK_BW_WRITE_ENSURE_U8_4(thr, bw_ctx, val1, val2, val3, val4) \ + do { \ + DUK_BW_ENSURE((thr), (bw_ctx), 4); \ + DUK_BW_WRITE_RAW_U8_4((thr), (bw_ctx), (val1), (val2), (val3), (val4)); \ + } while (0) +#define DUK_BW_WRITE_ENSURE_U8_5(thr, bw_ctx, val1, val2, val3, val4, val5) \ + do { \ + DUK_BW_ENSURE((thr), (bw_ctx), 5); \ + DUK_BW_WRITE_RAW_U8_5((thr), (bw_ctx), (val1), (val2), (val3), (val4), (val5)); \ + } while (0) +#define DUK_BW_WRITE_ENSURE_U8_6(thr, bw_ctx, val1, val2, val3, val4, val5, val6) \ + do { \ + DUK_BW_ENSURE((thr), (bw_ctx), 6); \ + DUK_BW_WRITE_RAW_U8_6((thr), (bw_ctx), (val1), (val2), (val3), (val4), (val5), (val6)); \ + } while (0) +#define DUK_BW_WRITE_ENSURE_XUTF8(thr, bw_ctx, cp) \ + do { \ + DUK_BW_ENSURE((thr), (bw_ctx), DUK_UNICODE_MAX_XUTF8_LENGTH); \ + DUK_BW_WRITE_RAW_XUTF8((thr), (bw_ctx), (cp)); \ + } while (0) +#define DUK_BW_WRITE_ENSURE_CESU8(thr, bw_ctx, cp) \ + do { \ + DUK_BW_ENSURE((thr), (bw_ctx), DUK_UNICODE_MAX_CESU8_LENGTH); \ + DUK_BW_WRITE_RAW_CESU8((thr), (bw_ctx), (cp)); \ + } while (0) +/* XXX: add temporary duk__p pointer here too; sharing */ +/* XXX: avoid unsafe */ +#define DUK_BW_WRITE_ENSURE_BYTES(thr, bw_ctx, valptr, valsz) \ + do { \ + const void *duk__valptr; \ + duk_size_t duk__valsz; \ + duk__valptr = (const void *) (valptr); \ + duk__valsz = (duk_size_t) (valsz); \ + DUK_BW_ENSURE((thr), (bw_ctx), duk__valsz); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), duk__valptr, duk__valsz); \ + (bw_ctx)->p += duk__valsz; \ + } while (0) +#define DUK_BW_WRITE_ENSURE_CSTRING(thr, bw_ctx, val) \ + do { \ + const duk_uint8_t *duk__val; \ + duk_size_t duk__val_len; \ + duk__val = (const duk_uint8_t *) (val); \ + duk__val_len = DUK_STRLEN((const char *) duk__val); \ + DUK_BW_ENSURE((thr), (bw_ctx), duk__val_len); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), (const void *) duk__val, duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) +#define DUK_BW_WRITE_ENSURE_HSTRING(thr, bw_ctx, val) \ + do { \ + duk_size_t duk__val_len; \ + duk__val_len = DUK_HSTRING_GET_BYTELEN((val)); \ + DUK_BW_ENSURE((thr), (bw_ctx), duk__val_len); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), (const void *) DUK_HSTRING_GET_DATA((val)), duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) +#define DUK_BW_WRITE_ENSURE_HBUFFER(thr, bw_ctx, val) \ + do { \ + duk_size_t duk__val_len; \ + duk__val_len = DUK_HBUFFER_GET_SIZE((val)); \ + DUK_BW_ENSURE((thr), (bw_ctx), duk__val_len); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), \ + (const void *) DUK_HBUFFER_GET_DATA_PTR((thr)->heap, (val)), \ + duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) +#define DUK_BW_WRITE_ENSURE_HBUFFER_FIXED(thr, bw_ctx, val) \ + do { \ + duk_size_t duk__val_len; \ + duk__val_len = DUK_HBUFFER_FIXED_GET_SIZE((val)); \ + DUK_BW_ENSURE((thr), (bw_ctx), duk__val_len); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), \ + (const void *) DUK_HBUFFER_FIXED_GET_DATA_PTR((thr)->heap, (val)), \ + duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) +#define DUK_BW_WRITE_ENSURE_HBUFFER_DYNAMIC(thr, bw_ctx, val) \ + do { \ + duk_size_t duk__val_len; \ + duk__val_len = DUK_HBUFFER_DYNAMIC_GET_SIZE((val)); \ + DUK_BW_ENSURE((thr), (bw_ctx), duk__val_len); \ + duk_memcpy_unsafe((void *) ((bw_ctx)->p), \ + (const void *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR((thr)->heap, (val)), \ + duk__val_len); \ + (bw_ctx)->p += duk__val_len; \ + } while (0) + +#define DUK_BW_WRITE_ENSURE_SLICE(thr, bw, dst_off, dst_len) duk_bw_write_ensure_slice((thr), (bw), (dst_off), (dst_len)) +#define DUK_BW_INSERT_ENSURE_BYTES(thr, bw, dst_off, buf, len) duk_bw_insert_ensure_bytes((thr), (bw), (dst_off), (buf), (len)) +#define DUK_BW_INSERT_ENSURE_SLICE(thr, bw, dst_off, src_off, len) \ + duk_bw_insert_ensure_slice((thr), (bw), (dst_off), (src_off), (len)) +#define DUK_BW_INSERT_ENSURE_AREA(thr, bw, off, len) \ + /* Evaluates to (duk_uint8_t *) pointing to start of area. */ \ + duk_bw_insert_ensure_area((thr), (bw), (off), (len)) +#define DUK_BW_REMOVE_ENSURE_SLICE(thr, bw, off, len) \ + /* No difference between raw/ensure because the buffer shrinks. */ \ + DUK_BW_REMOVE_RAW_SLICE((thr), (bw), (off), (len)) + +/* + * Externs and prototypes + */ + +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL const duk_uint8_t duk_lc_digits[36]; +DUK_INTERNAL_DECL const duk_uint8_t duk_uc_nybbles[16]; +DUK_INTERNAL_DECL const duk_int8_t duk_hex_dectab[256]; +#if defined(DUK_USE_HEX_FASTPATH) +DUK_INTERNAL_DECL const duk_int16_t duk_hex_dectab_shift4[256]; +DUK_INTERNAL_DECL const duk_uint16_t duk_hex_enctab[256]; +#endif +#endif /* !DUK_SINGLE_FILE */ + +/* Note: assumes that duk_util_probe_steps size is 32 */ +#if defined(DUK_USE_HOBJECT_HASH_PART) +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL duk_uint8_t duk_util_probe_steps[32]; +#endif /* !DUK_SINGLE_FILE */ +#endif + +#if defined(DUK_USE_STRHASH_DENSE) +DUK_INTERNAL_DECL duk_uint32_t duk_util_hashbytes(const duk_uint8_t *data, duk_size_t len, duk_uint32_t seed); +#endif + +DUK_INTERNAL_DECL duk_uint32_t duk_bd_decode(duk_bitdecoder_ctx *ctx, duk_small_int_t bits); +DUK_INTERNAL_DECL duk_small_uint_t duk_bd_decode_flag(duk_bitdecoder_ctx *ctx); +DUK_INTERNAL_DECL duk_uint32_t duk_bd_decode_flagged(duk_bitdecoder_ctx *ctx, duk_small_int_t bits, duk_uint32_t def_value); +DUK_INTERNAL_DECL duk_int32_t duk_bd_decode_flagged_signed(duk_bitdecoder_ctx *ctx, duk_small_int_t bits, duk_int32_t def_value); +DUK_INTERNAL_DECL duk_uint32_t duk_bd_decode_varuint(duk_bitdecoder_ctx *ctx); +DUK_INTERNAL_DECL duk_small_uint_t duk_bd_decode_bitpacked_string(duk_bitdecoder_ctx *bd, duk_uint8_t *out); + +DUK_INTERNAL_DECL void duk_be_encode(duk_bitencoder_ctx *ctx, duk_uint32_t data, duk_small_int_t bits); +DUK_INTERNAL_DECL void duk_be_finish(duk_bitencoder_ctx *ctx); + +#if !defined(DUK_USE_GET_RANDOM_DOUBLE) +DUK_INTERNAL_DECL duk_double_t duk_util_tinyrandom_get_double(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_util_tinyrandom_prepare_seed(duk_hthread *thr); +#endif + +DUK_INTERNAL_DECL void duk_bw_init(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx, duk_hbuffer_dynamic *h_buf); +DUK_INTERNAL_DECL void duk_bw_init_pushbuf(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx, duk_size_t buf_size); +DUK_INTERNAL_DECL duk_uint8_t *duk_bw_resize(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx, duk_size_t sz); +DUK_INTERNAL_DECL void duk_bw_compact(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx); +DUK_INTERNAL_DECL void duk_bw_write_raw_slice(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t src_off, duk_size_t len); +DUK_INTERNAL_DECL void duk_bw_write_ensure_slice(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t src_off, duk_size_t len); +DUK_INTERNAL_DECL void duk_bw_insert_raw_bytes(duk_hthread *thr, + duk_bufwriter_ctx *bw, + duk_size_t dst_off, + const duk_uint8_t *buf, + duk_size_t len); +DUK_INTERNAL_DECL void duk_bw_insert_ensure_bytes(duk_hthread *thr, + duk_bufwriter_ctx *bw, + duk_size_t dst_off, + const duk_uint8_t *buf, + duk_size_t len); +DUK_INTERNAL_DECL void duk_bw_insert_raw_slice(duk_hthread *thr, + duk_bufwriter_ctx *bw, + duk_size_t dst_off, + duk_size_t src_off, + duk_size_t len); +DUK_INTERNAL_DECL void duk_bw_insert_ensure_slice(duk_hthread *thr, + duk_bufwriter_ctx *bw, + duk_size_t dst_off, + duk_size_t src_off, + duk_size_t len); +DUK_INTERNAL_DECL duk_uint8_t *duk_bw_insert_raw_area(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t off, duk_size_t len); +DUK_INTERNAL_DECL duk_uint8_t *duk_bw_insert_ensure_area(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t off, duk_size_t len); +DUK_INTERNAL_DECL void duk_bw_remove_raw_slice(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t off, duk_size_t len); +/* No duk_bw_remove_ensure_slice(), functionality would be identical. */ + +DUK_INTERNAL_DECL duk_uint16_t duk_raw_read_u16_be(const duk_uint8_t *p); +DUK_INTERNAL_DECL duk_uint32_t duk_raw_read_u32_be(const duk_uint8_t *p); +DUK_INTERNAL_DECL duk_float_t duk_raw_read_float_be(const duk_uint8_t *p); +DUK_INTERNAL_DECL duk_double_t duk_raw_read_double_be(const duk_uint8_t *p); +DUK_INTERNAL_DECL duk_uint16_t duk_raw_readinc_u16_be(const duk_uint8_t **p); +DUK_INTERNAL_DECL duk_uint32_t duk_raw_readinc_u32_be(const duk_uint8_t **p); +DUK_INTERNAL_DECL duk_float_t duk_raw_readinc_float_be(const duk_uint8_t **p); +DUK_INTERNAL_DECL duk_double_t duk_raw_readinc_double_be(const duk_uint8_t **p); +DUK_INTERNAL_DECL void duk_raw_write_u16_be(duk_uint8_t *p, duk_uint16_t val); +DUK_INTERNAL_DECL void duk_raw_write_u32_be(duk_uint8_t *p, duk_uint32_t val); +DUK_INTERNAL_DECL void duk_raw_write_float_be(duk_uint8_t *p, duk_float_t val); +DUK_INTERNAL_DECL void duk_raw_write_double_be(duk_uint8_t *p, duk_double_t val); +DUK_INTERNAL_DECL duk_small_int_t duk_raw_write_xutf8(duk_uint8_t *p, duk_ucodepoint_t val); +DUK_INTERNAL_DECL duk_small_int_t duk_raw_write_cesu8(duk_uint8_t *p, duk_ucodepoint_t val); +DUK_INTERNAL_DECL void duk_raw_writeinc_u16_be(duk_uint8_t **p, duk_uint16_t val); +DUK_INTERNAL_DECL void duk_raw_writeinc_u32_be(duk_uint8_t **p, duk_uint32_t val); +DUK_INTERNAL_DECL void duk_raw_writeinc_float_be(duk_uint8_t **p, duk_float_t val); +DUK_INTERNAL_DECL void duk_raw_writeinc_double_be(duk_uint8_t **p, duk_double_t val); +DUK_INTERNAL_DECL void duk_raw_writeinc_xutf8(duk_uint8_t **p, duk_ucodepoint_t val); +DUK_INTERNAL_DECL void duk_raw_writeinc_cesu8(duk_uint8_t **p, duk_ucodepoint_t val); + +#if defined(DUK_USE_DEBUGGER_SUPPORT) /* For now only needed by the debugger. */ +DUK_INTERNAL_DECL void duk_byteswap_bytes(duk_uint8_t *p, duk_small_uint_t len); +#endif + +DUK_INTERNAL_DECL duk_double_t duk_util_get_random_double(duk_hthread *thr); + +/* memcpy(), memmove() etc wrappers. The plain variants like duk_memcpy() + * assume C99+ and 'src' and 'dst' pointers must be non-NULL even when the + * operation size is zero. The unsafe variants like duk_memcpy_safe() deal + * with the zero size case explicitly, and allow NULL pointers in that case + * (which is undefined behavior in C99+). For the majority of actual targets + * a NULL pointer with a zero length is fine in practice. These wrappers are + * macros to force inlining; because there are hundreds of call sites, even a + * few extra bytes per call site adds up to ~1kB footprint. + */ +#if defined(DUK_USE_ALLOW_UNDEFINED_BEHAVIOR) +#define duk_memcpy(dst, src, len) \ + do { \ + void *duk__dst = (dst); \ + const void *duk__src = (src); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL || duk__len == 0U); \ + DUK_ASSERT(duk__src != NULL || duk__len == 0U); \ + (void) DUK_MEMCPY(duk__dst, duk__src, (size_t) duk__len); \ + } while (0) +#define duk_memcpy_unsafe(dst, src, len) duk_memcpy((dst), (src), (len)) +#define duk_memmove(dst, src, len) \ + do { \ + void *duk__dst = (dst); \ + const void *duk__src = (src); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL || duk__len == 0U); \ + DUK_ASSERT(duk__src != NULL || duk__len == 0U); \ + (void) DUK_MEMMOVE(duk__dst, duk__src, (size_t) duk__len); \ + } while (0) +#define duk_memmove_unsafe(dst, src, len) duk_memmove((dst), (src), (len)) +#define duk_memset(dst, val, len) \ + do { \ + void *duk__dst = (dst); \ + duk_small_int_t duk__val = (val); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL || duk__len == 0U); \ + (void) DUK_MEMSET(duk__dst, duk__val, (size_t) duk__len); \ + } while (0) +#define duk_memset_unsafe(dst, val, len) duk_memset((dst), (val), (len)) +#define duk_memzero(dst, len) \ + do { \ + void *duk__dst = (dst); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL || duk__len == 0U); \ + (void) DUK_MEMZERO(duk__dst, (size_t) duk__len); \ + } while (0) +#define duk_memzero_unsafe(dst, len) duk_memzero((dst), (len)) +#else /* DUK_USE_ALLOW_UNDEFINED_BEHAVIOR */ +#define duk_memcpy(dst, src, len) \ + do { \ + void *duk__dst = (dst); \ + const void *duk__src = (src); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL); \ + DUK_ASSERT(duk__src != NULL); \ + (void) DUK_MEMCPY(duk__dst, duk__src, (size_t) duk__len); \ + } while (0) +#define duk_memcpy_unsafe(dst, src, len) \ + do { \ + void *duk__dst = (dst); \ + const void *duk__src = (src); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL || duk__len == 0U); \ + DUK_ASSERT(duk__src != NULL || duk__len == 0U); \ + if (DUK_LIKELY(duk__len > 0U)) { \ + DUK_ASSERT(duk__dst != NULL); \ + DUK_ASSERT(duk__src != NULL); \ + (void) DUK_MEMCPY(duk__dst, duk__src, (size_t) duk__len); \ + } \ + } while (0) +#define duk_memmove(dst, src, len) \ + do { \ + void *duk__dst = (dst); \ + const void *duk__src = (src); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL); \ + DUK_ASSERT(duk__src != NULL); \ + (void) DUK_MEMMOVE(duk__dst, duk__src, (size_t) duk__len); \ + } while (0) +#define duk_memmove_unsafe(dst, src, len) \ + do { \ + void *duk__dst = (dst); \ + const void *duk__src = (src); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL || duk__len == 0U); \ + DUK_ASSERT(duk__src != NULL || duk__len == 0U); \ + if (DUK_LIKELY(duk__len > 0U)) { \ + DUK_ASSERT(duk__dst != NULL); \ + DUK_ASSERT(duk__src != NULL); \ + (void) DUK_MEMMOVE(duk__dst, duk__src, (size_t) duk__len); \ + } \ + } while (0) +#define duk_memset(dst, val, len) \ + do { \ + void *duk__dst = (dst); \ + duk_small_int_t duk__val = (val); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL); \ + (void) DUK_MEMSET(duk__dst, duk__val, (size_t) duk__len); \ + } while (0) +#define duk_memset_unsafe(dst, val, len) \ + do { \ + void *duk__dst = (dst); \ + duk_small_int_t duk__val = (val); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL || duk__len == 0U); \ + if (DUK_LIKELY(duk__len > 0U)) { \ + DUK_ASSERT(duk__dst != NULL); \ + (void) DUK_MEMSET(duk__dst, duk__val, (size_t) duk__len); \ + } \ + } while (0) +#define duk_memzero(dst, len) \ + do { \ + void *duk__dst = (dst); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL); \ + (void) DUK_MEMZERO(duk__dst, (size_t) duk__len); \ + } while (0) +#define duk_memzero_unsafe(dst, len) \ + do { \ + void *duk__dst = (dst); \ + duk_size_t duk__len = (len); \ + DUK_ASSERT(duk__dst != NULL || duk__len == 0U); \ + if (DUK_LIKELY(duk__len > 0U)) { \ + DUK_ASSERT(duk__dst != NULL); \ + (void) DUK_MEMZERO(duk__dst, (size_t) duk__len); \ + } \ + } while (0) +#endif /* DUK_USE_ALLOW_UNDEFINED_BEHAVIOR */ + +DUK_INTERNAL_DECL duk_small_int_t duk_memcmp(const void *s1, const void *s2, duk_size_t len); +DUK_INTERNAL_DECL duk_small_int_t duk_memcmp_unsafe(const void *s1, const void *s2, duk_size_t len); + +DUK_INTERNAL_DECL duk_bool_t duk_is_whole_get_int32_nonegzero(duk_double_t x, duk_int32_t *ival); +DUK_INTERNAL_DECL duk_bool_t duk_is_whole_get_int32(duk_double_t x, duk_int32_t *ival); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_anyinf(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_posinf(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_neginf(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_nan(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_nan_or_zero(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_nan_or_inf(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_nan_zero_inf(duk_double_t x); +DUK_INTERNAL_DECL duk_small_uint_t duk_double_signbit(duk_double_t x); +DUK_INTERNAL_DECL duk_double_t duk_double_trunc_towards_zero(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_same_sign(duk_double_t x, duk_double_t y); +DUK_INTERNAL_DECL duk_double_t duk_double_fmin(duk_double_t x, duk_double_t y); +DUK_INTERNAL_DECL duk_double_t duk_double_fmax(duk_double_t x, duk_double_t y); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_finite(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_integer(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_is_safe_integer(duk_double_t x); + +DUK_INTERNAL_DECL duk_double_t duk_double_div(duk_double_t x, duk_double_t y); +DUK_INTERNAL_DECL duk_int_t duk_double_to_int_t(duk_double_t x); +DUK_INTERNAL_DECL duk_uint_t duk_double_to_uint_t(duk_double_t x); +DUK_INTERNAL_DECL duk_int32_t duk_double_to_int32_t(duk_double_t x); +DUK_INTERNAL_DECL duk_uint32_t duk_double_to_uint32_t(duk_double_t x); +DUK_INTERNAL_DECL duk_float_t duk_double_to_float_t(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_double_equals(duk_double_t x, duk_double_t y); +DUK_INTERNAL_DECL duk_bool_t duk_float_equals(duk_float_t x, duk_float_t y); + +/* + * Miscellaneous + */ + +/* Example: x = 0x10 = 0b00010000 + * x - 1 = 0x0f = 0b00001111 + * x & (x - 1) == 0 + * + * x = 0x07 = 0b00000111 + * x - 1 = 0x06 = 0b00000110 + * x & (x - 1) != 0 + * + * However, incorrectly true for x == 0 so check for that explicitly. + */ +#define DUK_IS_POWER_OF_TWO(x) ((x) != 0U && ((x) & ((x) -1U)) == 0U) + +#endif /* DUK_UTIL_H_INCLUDED */ +/* #include duk_strings.h */ +#line 1 "duk_strings.h" +/* + * Shared string macros. + * + * Using shared macros helps minimize strings data size because it's easy + * to check if an existing string could be used. String constants don't + * need to be all defined here; defining a string here makes sense if there's + * a high chance the string could be reused. Also, using macros allows + * a call site express the exact string needed, but the macro may map to an + * approximate string to reduce unique string count. Macros can also be + * more easily tuned for low memory targets than #if defined()s throughout + * the code base. + * + * Because format strings behave differently in the call site (they need to + * be followed by format arguments), they use a special prefix DUK_STR_FMT_. + * + * On some compilers using explicit shared strings is preferable; on others + * it may be better to use straight literals because the compiler will combine + * them anyway, and such strings won't end up unnecessarily in a symbol table. + */ + +#if !defined(DUK_ERRMSG_H_INCLUDED) +#define DUK_ERRMSG_H_INCLUDED + +/* Mostly API and built-in method related */ +#define DUK_STR_INTERNAL_ERROR "internal error" +#define DUK_STR_UNSUPPORTED "unsupported" +#define DUK_STR_INVALID_COUNT "invalid count" +#define DUK_STR_INVALID_ARGS "invalid args" +#define DUK_STR_INVALID_STATE "invalid state" +#define DUK_STR_INVALID_INPUT "invalid input" +#define DUK_STR_INVALID_LENGTH "invalid length" +#define DUK_STR_NOT_CONSTRUCTABLE "not constructable" +#define DUK_STR_CONSTRUCT_ONLY "constructor requires 'new'" +#define DUK_STR_NOT_CALLABLE "not callable" +#define DUK_STR_NOT_EXTENSIBLE "not extensible" +#define DUK_STR_NOT_WRITABLE "not writable" +#define DUK_STR_NOT_CONFIGURABLE "not configurable" +#define DUK_STR_INVALID_CONTEXT "invalid context" +#define DUK_STR_INVALID_INDEX "invalid args" +#define DUK_STR_PUSH_BEYOND_ALLOC_STACK "cannot push beyond allocated stack" +#define DUK_STR_NOT_UNDEFINED "unexpected type" +#define DUK_STR_NOT_NULL "unexpected type" +#define DUK_STR_NOT_BOOLEAN "unexpected type" +#define DUK_STR_NOT_NUMBER "unexpected type" +#define DUK_STR_NOT_STRING "unexpected type" +#define DUK_STR_NOT_OBJECT "unexpected type" +#define DUK_STR_NOT_POINTER "unexpected type" +#define DUK_STR_NOT_BUFFER "not buffer" /* still in use with verbose messages */ +#define DUK_STR_UNEXPECTED_TYPE "unexpected type" +#define DUK_STR_NOT_THREAD "unexpected type" +#define DUK_STR_NOT_COMPFUNC "unexpected type" +#define DUK_STR_NOT_NATFUNC "unexpected type" +#define DUK_STR_NOT_C_FUNCTION "unexpected type" +#define DUK_STR_NOT_FUNCTION "unexpected type" +#define DUK_STR_NOT_REGEXP "unexpected type" +#define DUK_STR_TOPRIMITIVE_FAILED "coercion to primitive failed" +#define DUK_STR_NUMBER_OUTSIDE_RANGE "number outside range" +#define DUK_STR_NOT_OBJECT_COERCIBLE "not object coercible" +#define DUK_STR_CANNOT_NUMBER_COERCE_SYMBOL "cannot number coerce Symbol" +#define DUK_STR_CANNOT_STRING_COERCE_SYMBOL "cannot string coerce Symbol" +#define DUK_STR_STRING_TOO_LONG "string too long" +#define DUK_STR_BUFFER_TOO_LONG "buffer too long" +#define DUK_STR_ALLOC_FAILED "alloc failed" +#define DUK_STR_WRONG_BUFFER_TYPE "wrong buffer type" +#define DUK_STR_BASE64_ENCODE_FAILED "base64 encode failed" +#define DUK_STR_SOURCE_DECODE_FAILED "source decode failed" +#define DUK_STR_UTF8_DECODE_FAILED "utf-8 decode failed" +#define DUK_STR_BASE64_DECODE_FAILED "base64 decode failed" +#define DUK_STR_HEX_DECODE_FAILED "hex decode failed" +#define DUK_STR_INVALID_BYTECODE "invalid bytecode" +#define DUK_STR_NO_SOURCECODE "no sourcecode" +#define DUK_STR_RESULT_TOO_LONG "result too long" +#define DUK_STR_INVALID_CFUNC_RC "invalid C function rc" +#define DUK_STR_INVALID_INSTANCEOF_RVAL "invalid instanceof rval" +#define DUK_STR_INVALID_INSTANCEOF_RVAL_NOPROTO "instanceof rval has no .prototype" + +/* JSON */ +#define DUK_STR_FMT_PTR "%p" +#define DUK_STR_FMT_INVALID_JSON "invalid json (at offset %ld)" +#define DUK_STR_CYCLIC_INPUT "cyclic input" + +/* Generic codec */ +#define DUK_STR_DEC_RECLIMIT "decode recursion limit" +#define DUK_STR_ENC_RECLIMIT "encode recursion limit" + +/* Object property access */ +#define DUK_STR_INVALID_BASE "invalid base value" +#define DUK_STR_STRICT_CALLER_READ "cannot read strict 'caller'" +#define DUK_STR_PROXY_REJECTED "proxy rejected" +#define DUK_STR_INVALID_ARRAY_LENGTH "invalid array length" +#define DUK_STR_SETTER_UNDEFINED "setter undefined" +#define DUK_STR_INVALID_DESCRIPTOR "invalid descriptor" + +/* Proxy */ +#define DUK_STR_PROXY_REVOKED "proxy revoked" +#define DUK_STR_INVALID_TRAP_RESULT "invalid trap result" + +/* Variables */ + +/* Lexer */ +#define DUK_STR_INVALID_ESCAPE "invalid escape" +#define DUK_STR_UNTERMINATED_STRING "unterminated string" +#define DUK_STR_UNTERMINATED_COMMENT "unterminated comment" +#define DUK_STR_UNTERMINATED_REGEXP "unterminated regexp" +#define DUK_STR_TOKEN_LIMIT "token limit" +#define DUK_STR_REGEXP_SUPPORT_DISABLED "regexp support disabled" +#define DUK_STR_INVALID_NUMBER_LITERAL "invalid number literal" +#define DUK_STR_INVALID_TOKEN "invalid token" + +/* Compiler */ +#define DUK_STR_PARSE_ERROR "parse error" +#define DUK_STR_DUPLICATE_LABEL "duplicate label" +#define DUK_STR_INVALID_LABEL "invalid label" +#define DUK_STR_INVALID_ARRAY_LITERAL "invalid array literal" +#define DUK_STR_INVALID_OBJECT_LITERAL "invalid object literal" +#define DUK_STR_INVALID_VAR_DECLARATION "invalid variable declaration" +#define DUK_STR_CANNOT_DELETE_IDENTIFIER "cannot delete identifier" +#define DUK_STR_INVALID_EXPRESSION "invalid expression" +#define DUK_STR_INVALID_LVALUE "invalid lvalue" +#define DUK_STR_INVALID_NEWTARGET "invalid new.target" +#define DUK_STR_EXPECTED_IDENTIFIER "expected identifier" +#define DUK_STR_EMPTY_EXPR_NOT_ALLOWED "empty expression not allowed" +#define DUK_STR_INVALID_FOR "invalid for statement" +#define DUK_STR_INVALID_SWITCH "invalid switch statement" +#define DUK_STR_INVALID_BREAK_CONT_LABEL "invalid break/continue label" +#define DUK_STR_INVALID_RETURN "invalid return" +#define DUK_STR_INVALID_TRY "invalid try" +#define DUK_STR_INVALID_THROW "invalid throw" +#define DUK_STR_WITH_IN_STRICT_MODE "with in strict mode" +#define DUK_STR_FUNC_STMT_NOT_ALLOWED "function statement not allowed" +#define DUK_STR_UNTERMINATED_STMT "unterminated statement" +#define DUK_STR_INVALID_ARG_NAME "invalid argument name" +#define DUK_STR_INVALID_FUNC_NAME "invalid function name" +#define DUK_STR_INVALID_GETSET_NAME "invalid getter/setter name" +#define DUK_STR_FUNC_NAME_REQUIRED "function name required" + +/* RegExp */ +#define DUK_STR_INVALID_QUANTIFIER "invalid regexp quantifier" +#define DUK_STR_INVALID_QUANTIFIER_NO_ATOM "quantifier without preceding atom" +#define DUK_STR_INVALID_QUANTIFIER_VALUES "quantifier values invalid (qmin > qmax)" +#define DUK_STR_QUANTIFIER_TOO_MANY_COPIES "quantifier requires too many atom copies" +#define DUK_STR_UNEXPECTED_CLOSING_PAREN "unexpected closing parenthesis" +#define DUK_STR_UNEXPECTED_END_OF_PATTERN "unexpected end of pattern" +#define DUK_STR_UNEXPECTED_REGEXP_TOKEN "unexpected token in regexp" +#define DUK_STR_INVALID_REGEXP_FLAGS "invalid regexp flags" +#define DUK_STR_INVALID_REGEXP_ESCAPE "invalid regexp escape" +#define DUK_STR_INVALID_BACKREFS "invalid backreference(s)" +#define DUK_STR_INVALID_REGEXP_CHARACTER "invalid regexp character" +#define DUK_STR_INVALID_REGEXP_GROUP "invalid regexp group" +#define DUK_STR_UNTERMINATED_CHARCLASS "unterminated character class" +#define DUK_STR_INVALID_RANGE "invalid range" + +/* Limits */ +#define DUK_STR_VALSTACK_LIMIT "valstack limit" +#define DUK_STR_CALLSTACK_LIMIT "callstack limit" +#define DUK_STR_PROTOTYPE_CHAIN_LIMIT "prototype chain limit" +#define DUK_STR_BOUND_CHAIN_LIMIT "function call bound chain limit" +#define DUK_STR_NATIVE_STACK_LIMIT "C stack depth limit" +#define DUK_STR_COMPILER_RECURSION_LIMIT "compiler recursion limit" +#define DUK_STR_BYTECODE_LIMIT "bytecode limit" +#define DUK_STR_REG_LIMIT "register limit" +#define DUK_STR_TEMP_LIMIT "temp limit" +#define DUK_STR_CONST_LIMIT "const limit" +#define DUK_STR_FUNC_LIMIT "function limit" +#define DUK_STR_REGEXP_COMPILER_RECURSION_LIMIT "regexp compiler recursion limit" +#define DUK_STR_REGEXP_EXECUTOR_RECURSION_LIMIT "regexp executor recursion limit" +#define DUK_STR_REGEXP_EXECUTOR_STEP_LIMIT "regexp step limit" + +#endif /* DUK_ERRMSG_H_INCLUDED */ +/* #include duk_js_bytecode.h */ +#line 1 "duk_js_bytecode.h" +/* + * ECMAScript bytecode + */ + +#if !defined(DUK_JS_BYTECODE_H_INCLUDED) +#define DUK_JS_BYTECODE_H_INCLUDED + +/* + * Bytecode instruction layout + * =========================== + * + * Instructions are unsigned 32-bit integers divided as follows: + * + * !3!3!2!2!2!2!2!2!2!2!2!2!1!1!1!1!1!1!1!1!1!1! ! ! ! ! ! ! ! ! ! ! + * !1!0!9!8!7!6!5!4!3!2!1!0!9!8!7!6!5!4!3!2!1!0!9!8!7!6!5!4!3!2!1!0! + * +-----------------------------------------------+---------------+ + * ! C ! B ! A ! OP ! + * +-----------------------------------------------+---------------+ + * + * OP (8 bits): opcode (DUK_OP_*), access should be fastest + * consecutive opcodes allocated when opcode needs flags + * A (8 bits): typically a target register number + * B (8 bits): typically first source register/constant number + * C (8 bits): typically second source register/constant number + * + * Some instructions combine BC or ABC together for larger parameter values. + * Signed integers (e.g. jump offsets) are encoded as unsigned, with an + * opcode specific bias. + * + * Some opcodes have flags which are handled by allocating consecutive + * opcodes to make space for 1-N flags. Flags can also be e.g. in the 'A' + * field when there's room for the specific opcode. + * + * For example, if three flags were needed, they could be allocated from + * the opcode field as follows: + * + * !3!3!2!2!2!2!2!2!2!2!2!2!1!1!1!1!1!1!1!1!1!1! ! ! ! ! ! ! ! ! ! ! + * !1!0!9!8!7!6!5!4!3!2!1!0!9!8!7!6!5!4!3!2!1!0!9!8!7!6!5!4!3!2!1!0! + * +-----------------------------------------------+---------------+ + * ! C ! B ! A ! OP !Z!Y!X! + * +-----------------------------------------------+---------------+ + * + * Some opcodes accept a reg/const argument which is handled by allocating + * flags in the OP field, see DUK_BC_ISREG() and DUK_BC_ISCONST(). The + * following convention is shared by most opcodes, so that the compiler + * can handle reg/const flagging without opcode specific code paths: + * + * !3!3!2!2!2!2!2!2!2!2!2!2!1!1!1!1!1!1!1!1!1!1! ! ! ! ! ! ! ! ! ! ! + * !1!0!9!8!7!6!5!4!3!2!1!0!9!8!7!6!5!4!3!2!1!0!9!8!7!6!5!4!3!2!1!0! + * +-----------------------------------------------+---------------+ + * ! C ! B ! A ! OP !Y!X! + * +-----------------------------------------------+---------------+ + * + * X 1=B is const, 0=B is reg + * Y 1=C is const, 0=C is reg + * + * In effect OP, OP + 1, OP + 2, and OP + 3 are allocated from the + * 8-bit opcode space for a single logical opcode. The base opcode + * number should be divisible by 4. If the opcode is called 'FOO' + * the following opcode constants would be defined: + * + * DUK_OP_FOO 100 // base opcode number + * DUK_OP_FOO_RR 100 // FOO, B=reg, C=reg + * DUK_OP_FOO_CR 101 // FOO, B=const, C=reg + * DUK_OP_FOO_RC 102 // FOO, B=reg, C=const + * DUK_OP_FOO_CC 103 // FOO, B=const, C=const + * + * If only B or C is a reg/const, the unused opcode combinations can be + * used for other opcodes (which take no reg/const argument). However, + * such opcode values are initially reserved, at least while opcode space + * is available. For example, if 'BAR' uses B for a register field and + * C is a reg/const: + * + * DUK_OP_BAR 116 // base opcode number + * DUK_OP_BAR_RR 116 // BAR, B=reg, C=reg + * DUK_OP_BAR_CR_UNUSED 117 // unused, could be repurposed + * DUK_OP_BAR_RC 118 // BAR, B=reg, C=const + * DUK_OP_BAR_CC_UNUSED 119 // unused, could be repurposed + * + * Macro naming is a bit misleading, e.g. "ABC" in macro name but the + * field layout is concretely "CBA" in the register. + */ + +typedef duk_uint32_t duk_instr_t; + +#define DUK_BC_SHIFT_OP 0 +#define DUK_BC_SHIFT_A 8 +#define DUK_BC_SHIFT_B 16 +#define DUK_BC_SHIFT_C 24 +#define DUK_BC_SHIFT_BC DUK_BC_SHIFT_B +#define DUK_BC_SHIFT_ABC DUK_BC_SHIFT_A + +#define DUK_BC_UNSHIFTED_MASK_OP 0xffUL +#define DUK_BC_UNSHIFTED_MASK_A 0xffUL +#define DUK_BC_UNSHIFTED_MASK_B 0xffUL +#define DUK_BC_UNSHIFTED_MASK_C 0xffUL +#define DUK_BC_UNSHIFTED_MASK_BC 0xffffUL +#define DUK_BC_UNSHIFTED_MASK_ABC 0xffffffUL + +#define DUK_BC_SHIFTED_MASK_OP (DUK_BC_UNSHIFTED_MASK_OP << DUK_BC_SHIFT_OP) +#define DUK_BC_SHIFTED_MASK_A (DUK_BC_UNSHIFTED_MASK_A << DUK_BC_SHIFT_A) +#define DUK_BC_SHIFTED_MASK_B (DUK_BC_UNSHIFTED_MASK_B << DUK_BC_SHIFT_B) +#define DUK_BC_SHIFTED_MASK_C (DUK_BC_UNSHIFTED_MASK_C << DUK_BC_SHIFT_C) +#define DUK_BC_SHIFTED_MASK_BC (DUK_BC_UNSHIFTED_MASK_BC << DUK_BC_SHIFT_BC) +#define DUK_BC_SHIFTED_MASK_ABC (DUK_BC_UNSHIFTED_MASK_ABC << DUK_BC_SHIFT_ABC) + +#define DUK_DEC_OP(x) ((x) &0xffUL) +#define DUK_DEC_A(x) (((x) >> 8) & 0xffUL) +#define DUK_DEC_B(x) (((x) >> 16) & 0xffUL) +#define DUK_DEC_C(x) (((x) >> 24) & 0xffUL) +#define DUK_DEC_BC(x) (((x) >> 16) & 0xffffUL) +#define DUK_DEC_ABC(x) (((x) >> 8) & 0xffffffUL) + +#define DUK_ENC_OP(op) ((duk_instr_t) (op)) +#define DUK_ENC_OP_ABC(op, abc) ((duk_instr_t) ((((duk_instr_t) (abc)) << 8) | ((duk_instr_t) (op)))) +#define DUK_ENC_OP_A_BC(op, a, bc) \ + ((duk_instr_t) ((((duk_instr_t) (bc)) << 16) | (((duk_instr_t) (a)) << 8) | ((duk_instr_t) (op)))) +#define DUK_ENC_OP_A_B_C(op, a, b, c) \ + ((duk_instr_t) ((((duk_instr_t) (c)) << 24) | (((duk_instr_t) (b)) << 16) | (((duk_instr_t) (a)) << 8) | \ + ((duk_instr_t) (op)))) +#define DUK_ENC_OP_A_B(op, a, b) DUK_ENC_OP_A_B_C((op), (a), (b), 0) +#define DUK_ENC_OP_A(op, a) DUK_ENC_OP_A_B_C((op), (a), 0, 0) +#define DUK_ENC_OP_BC(op, bc) DUK_ENC_OP_A_BC((op), 0, (bc)) + +/* Get opcode base value with B/C reg/const flags cleared. */ +#define DUK_BC_NOREGCONST_OP(op) ((op) &0xfc) + +/* Constants should be signed so that signed arithmetic involving them + * won't cause values to be coerced accidentally to unsigned. + */ +#define DUK_BC_OP_MIN 0 +#define DUK_BC_OP_MAX 0xffL +#define DUK_BC_A_MIN 0 +#define DUK_BC_A_MAX 0xffL +#define DUK_BC_B_MIN 0 +#define DUK_BC_B_MAX 0xffL +#define DUK_BC_C_MIN 0 +#define DUK_BC_C_MAX 0xffL +#define DUK_BC_BC_MIN 0 +#define DUK_BC_BC_MAX 0xffffL +#define DUK_BC_ABC_MIN 0 +#define DUK_BC_ABC_MAX 0xffffffL + +/* Masks for B/C reg/const indicator in opcode field. */ +#define DUK_BC_REGCONST_B (0x01UL) +#define DUK_BC_REGCONST_C (0x02UL) + +/* Misc. masks for opcode field. */ +#define DUK_BC_INCDECP_FLAG_DEC (0x04UL) +#define DUK_BC_INCDECP_FLAG_POST (0x08UL) + +/* Opcodes. */ +#define DUK_OP_LDREG 0 +#define DUK_OP_STREG 1 +#define DUK_OP_JUMP 2 +#define DUK_OP_LDCONST 3 +#define DUK_OP_LDINT 4 +#define DUK_OP_LDINTX 5 +#define DUK_OP_LDTHIS 6 +#define DUK_OP_LDUNDEF 7 +#define DUK_OP_LDNULL 8 +#define DUK_OP_LDTRUE 9 +#define DUK_OP_LDFALSE 10 +#define DUK_OP_GETVAR 11 +#define DUK_OP_BNOT 12 +#define DUK_OP_LNOT 13 +#define DUK_OP_UNM 14 +#define DUK_OP_UNP 15 +#define DUK_OP_EQ 16 +#define DUK_OP_EQ_RR 16 +#define DUK_OP_EQ_CR 17 +#define DUK_OP_EQ_RC 18 +#define DUK_OP_EQ_CC 19 +#define DUK_OP_NEQ 20 +#define DUK_OP_NEQ_RR 20 +#define DUK_OP_NEQ_CR 21 +#define DUK_OP_NEQ_RC 22 +#define DUK_OP_NEQ_CC 23 +#define DUK_OP_SEQ 24 +#define DUK_OP_SEQ_RR 24 +#define DUK_OP_SEQ_CR 25 +#define DUK_OP_SEQ_RC 26 +#define DUK_OP_SEQ_CC 27 +#define DUK_OP_SNEQ 28 +#define DUK_OP_SNEQ_RR 28 +#define DUK_OP_SNEQ_CR 29 +#define DUK_OP_SNEQ_RC 30 +#define DUK_OP_SNEQ_CC 31 +#define DUK_OP_GT 32 +#define DUK_OP_GT_RR 32 +#define DUK_OP_GT_CR 33 +#define DUK_OP_GT_RC 34 +#define DUK_OP_GT_CC 35 +#define DUK_OP_GE 36 +#define DUK_OP_GE_RR 36 +#define DUK_OP_GE_CR 37 +#define DUK_OP_GE_RC 38 +#define DUK_OP_GE_CC 39 +#define DUK_OP_LT 40 +#define DUK_OP_LT_RR 40 +#define DUK_OP_LT_CR 41 +#define DUK_OP_LT_RC 42 +#define DUK_OP_LT_CC 43 +#define DUK_OP_LE 44 +#define DUK_OP_LE_RR 44 +#define DUK_OP_LE_CR 45 +#define DUK_OP_LE_RC 46 +#define DUK_OP_LE_CC 47 +#define DUK_OP_IFTRUE 48 +#define DUK_OP_IFTRUE_R 48 +#define DUK_OP_IFTRUE_C 49 +#define DUK_OP_IFFALSE 50 +#define DUK_OP_IFFALSE_R 50 +#define DUK_OP_IFFALSE_C 51 +#define DUK_OP_ADD 52 +#define DUK_OP_ADD_RR 52 +#define DUK_OP_ADD_CR 53 +#define DUK_OP_ADD_RC 54 +#define DUK_OP_ADD_CC 55 +#define DUK_OP_SUB 56 +#define DUK_OP_SUB_RR 56 +#define DUK_OP_SUB_CR 57 +#define DUK_OP_SUB_RC 58 +#define DUK_OP_SUB_CC 59 +#define DUK_OP_MUL 60 +#define DUK_OP_MUL_RR 60 +#define DUK_OP_MUL_CR 61 +#define DUK_OP_MUL_RC 62 +#define DUK_OP_MUL_CC 63 +#define DUK_OP_DIV 64 +#define DUK_OP_DIV_RR 64 +#define DUK_OP_DIV_CR 65 +#define DUK_OP_DIV_RC 66 +#define DUK_OP_DIV_CC 67 +#define DUK_OP_MOD 68 +#define DUK_OP_MOD_RR 68 +#define DUK_OP_MOD_CR 69 +#define DUK_OP_MOD_RC 70 +#define DUK_OP_MOD_CC 71 +#define DUK_OP_EXP 72 +#define DUK_OP_EXP_RR 72 +#define DUK_OP_EXP_CR 73 +#define DUK_OP_EXP_RC 74 +#define DUK_OP_EXP_CC 75 +#define DUK_OP_BAND 76 +#define DUK_OP_BAND_RR 76 +#define DUK_OP_BAND_CR 77 +#define DUK_OP_BAND_RC 78 +#define DUK_OP_BAND_CC 79 +#define DUK_OP_BOR 80 +#define DUK_OP_BOR_RR 80 +#define DUK_OP_BOR_CR 81 +#define DUK_OP_BOR_RC 82 +#define DUK_OP_BOR_CC 83 +#define DUK_OP_BXOR 84 +#define DUK_OP_BXOR_RR 84 +#define DUK_OP_BXOR_CR 85 +#define DUK_OP_BXOR_RC 86 +#define DUK_OP_BXOR_CC 87 +#define DUK_OP_BASL 88 +#define DUK_OP_BASL_RR 88 +#define DUK_OP_BASL_CR 89 +#define DUK_OP_BASL_RC 90 +#define DUK_OP_BASL_CC 91 +#define DUK_OP_BLSR 92 +#define DUK_OP_BLSR_RR 92 +#define DUK_OP_BLSR_CR 93 +#define DUK_OP_BLSR_RC 94 +#define DUK_OP_BLSR_CC 95 +#define DUK_OP_BASR 96 +#define DUK_OP_BASR_RR 96 +#define DUK_OP_BASR_CR 97 +#define DUK_OP_BASR_RC 98 +#define DUK_OP_BASR_CC 99 +#define DUK_OP_INSTOF 100 +#define DUK_OP_INSTOF_RR 100 +#define DUK_OP_INSTOF_CR 101 +#define DUK_OP_INSTOF_RC 102 +#define DUK_OP_INSTOF_CC 103 +#define DUK_OP_IN 104 +#define DUK_OP_IN_RR 104 +#define DUK_OP_IN_CR 105 +#define DUK_OP_IN_RC 106 +#define DUK_OP_IN_CC 107 +#define DUK_OP_GETPROP 108 +#define DUK_OP_GETPROP_RR 108 +#define DUK_OP_GETPROP_CR 109 +#define DUK_OP_GETPROP_RC 110 +#define DUK_OP_GETPROP_CC 111 +#define DUK_OP_PUTPROP 112 +#define DUK_OP_PUTPROP_RR 112 +#define DUK_OP_PUTPROP_CR 113 +#define DUK_OP_PUTPROP_RC 114 +#define DUK_OP_PUTPROP_CC 115 +#define DUK_OP_DELPROP 116 +#define DUK_OP_DELPROP_RR 116 +#define DUK_OP_DELPROP_CR_UNUSED 117 /* unused now */ +#define DUK_OP_DELPROP_RC 118 +#define DUK_OP_DELPROP_CC_UNUSED 119 /* unused now */ +#define DUK_OP_PREINCR 120 /* pre/post opcode values have constraints, */ +#define DUK_OP_PREDECR 121 /* see duk_js_executor.c and duk_js_compiler.c. */ +#define DUK_OP_POSTINCR 122 +#define DUK_OP_POSTDECR 123 +#define DUK_OP_PREINCV 124 +#define DUK_OP_PREDECV 125 +#define DUK_OP_POSTINCV 126 +#define DUK_OP_POSTDECV 127 +#define DUK_OP_PREINCP 128 /* pre/post inc/dec prop opcodes have constraints */ +#define DUK_OP_PREINCP_RR 128 +#define DUK_OP_PREINCP_CR 129 +#define DUK_OP_PREINCP_RC 130 +#define DUK_OP_PREINCP_CC 131 +#define DUK_OP_PREDECP 132 +#define DUK_OP_PREDECP_RR 132 +#define DUK_OP_PREDECP_CR 133 +#define DUK_OP_PREDECP_RC 134 +#define DUK_OP_PREDECP_CC 135 +#define DUK_OP_POSTINCP 136 +#define DUK_OP_POSTINCP_RR 136 +#define DUK_OP_POSTINCP_CR 137 +#define DUK_OP_POSTINCP_RC 138 +#define DUK_OP_POSTINCP_CC 139 +#define DUK_OP_POSTDECP 140 +#define DUK_OP_POSTDECP_RR 140 +#define DUK_OP_POSTDECP_CR 141 +#define DUK_OP_POSTDECP_RC 142 +#define DUK_OP_POSTDECP_CC 143 +#define DUK_OP_DECLVAR 144 +#define DUK_OP_DECLVAR_RR 144 +#define DUK_OP_DECLVAR_CR 145 +#define DUK_OP_DECLVAR_RC 146 +#define DUK_OP_DECLVAR_CC 147 +#define DUK_OP_REGEXP 148 +#define DUK_OP_REGEXP_RR 148 +#define DUK_OP_REGEXP_CR 149 +#define DUK_OP_REGEXP_RC 150 +#define DUK_OP_REGEXP_CC 151 +#define DUK_OP_CLOSURE 152 +#define DUK_OP_TYPEOF 153 +#define DUK_OP_TYPEOFID 154 +#define DUK_OP_PUTVAR 155 +#define DUK_OP_DELVAR 156 +#define DUK_OP_RETREG 157 +#define DUK_OP_RETUNDEF 158 +#define DUK_OP_RETCONST 159 +#define DUK_OP_RETCONSTN 160 /* return const without incref (e.g. number) */ +#define DUK_OP_LABEL 161 +#define DUK_OP_ENDLABEL 162 +#define DUK_OP_BREAK 163 +#define DUK_OP_CONTINUE 164 +#define DUK_OP_TRYCATCH 165 +#define DUK_OP_ENDTRY 166 +#define DUK_OP_ENDCATCH 167 +#define DUK_OP_ENDFIN 168 +#define DUK_OP_THROW 169 +#define DUK_OP_INVLHS 170 +#define DUK_OP_CSREG 171 +#define DUK_OP_CSVAR 172 +#define DUK_OP_CSVAR_RR 172 +#define DUK_OP_CSVAR_CR 173 +#define DUK_OP_CSVAR_RC 174 +#define DUK_OP_CSVAR_CC 175 +#define DUK_OP_CALL0 176 /* DUK_OP_CALL0 & 0x0F must be zero. */ +#define DUK_OP_CALL1 177 +#define DUK_OP_CALL2 178 +#define DUK_OP_CALL3 179 +#define DUK_OP_CALL4 180 +#define DUK_OP_CALL5 181 +#define DUK_OP_CALL6 182 +#define DUK_OP_CALL7 183 +#define DUK_OP_CALL8 184 +#define DUK_OP_CALL9 185 +#define DUK_OP_CALL10 186 +#define DUK_OP_CALL11 187 +#define DUK_OP_CALL12 188 +#define DUK_OP_CALL13 189 +#define DUK_OP_CALL14 190 +#define DUK_OP_CALL15 191 +#define DUK_OP_NEWOBJ 192 +#define DUK_OP_NEWARR 193 +#define DUK_OP_MPUTOBJ 194 +#define DUK_OP_MPUTOBJI 195 +#define DUK_OP_INITSET 196 +#define DUK_OP_INITGET 197 +#define DUK_OP_MPUTARR 198 +#define DUK_OP_MPUTARRI 199 +#define DUK_OP_SETALEN 200 +#define DUK_OP_INITENUM 201 +#define DUK_OP_NEXTENUM 202 +#define DUK_OP_NEWTARGET 203 +#define DUK_OP_DEBUGGER 204 +#define DUK_OP_NOP 205 +#define DUK_OP_INVALID 206 +#define DUK_OP_UNUSED207 207 +#define DUK_OP_GETPROPC 208 +#define DUK_OP_GETPROPC_RR 208 +#define DUK_OP_GETPROPC_CR 209 +#define DUK_OP_GETPROPC_RC 210 +#define DUK_OP_GETPROPC_CC 211 +#define DUK_OP_UNUSED212 212 +#define DUK_OP_UNUSED213 213 +#define DUK_OP_UNUSED214 214 +#define DUK_OP_UNUSED215 215 +#define DUK_OP_UNUSED216 216 +#define DUK_OP_UNUSED217 217 +#define DUK_OP_UNUSED218 218 +#define DUK_OP_UNUSED219 219 +#define DUK_OP_UNUSED220 220 +#define DUK_OP_UNUSED221 221 +#define DUK_OP_UNUSED222 222 +#define DUK_OP_UNUSED223 223 +#define DUK_OP_UNUSED224 224 +#define DUK_OP_UNUSED225 225 +#define DUK_OP_UNUSED226 226 +#define DUK_OP_UNUSED227 227 +#define DUK_OP_UNUSED228 228 +#define DUK_OP_UNUSED229 229 +#define DUK_OP_UNUSED230 230 +#define DUK_OP_UNUSED231 231 +#define DUK_OP_UNUSED232 232 +#define DUK_OP_UNUSED233 233 +#define DUK_OP_UNUSED234 234 +#define DUK_OP_UNUSED235 235 +#define DUK_OP_UNUSED236 236 +#define DUK_OP_UNUSED237 237 +#define DUK_OP_UNUSED238 238 +#define DUK_OP_UNUSED239 239 +#define DUK_OP_UNUSED240 240 +#define DUK_OP_UNUSED241 241 +#define DUK_OP_UNUSED242 242 +#define DUK_OP_UNUSED243 243 +#define DUK_OP_UNUSED244 244 +#define DUK_OP_UNUSED245 245 +#define DUK_OP_UNUSED246 246 +#define DUK_OP_UNUSED247 247 +#define DUK_OP_UNUSED248 248 +#define DUK_OP_UNUSED249 249 +#define DUK_OP_UNUSED250 250 +#define DUK_OP_UNUSED251 251 +#define DUK_OP_UNUSED252 252 +#define DUK_OP_UNUSED253 253 +#define DUK_OP_UNUSED254 254 +#define DUK_OP_UNUSED255 255 +#define DUK_OP_NONE 256 /* dummy value used as marker (doesn't fit in 8-bit field) */ + +/* XXX: Allocate flags from opcode field? Would take 16 opcode slots + * but avoids shuffling in more cases. Maybe not worth it. + */ +/* DUK_OP_TRYCATCH flags in A. */ +#define DUK_BC_TRYCATCH_FLAG_HAVE_CATCH (1U << 0) +#define DUK_BC_TRYCATCH_FLAG_HAVE_FINALLY (1U << 1) +#define DUK_BC_TRYCATCH_FLAG_CATCH_BINDING (1U << 2) +#define DUK_BC_TRYCATCH_FLAG_WITH_BINDING (1U << 3) + +/* DUK_OP_DECLVAR flags in A; bottom bits are reserved for propdesc flags + * (DUK_PROPDESC_FLAG_XXX). + */ +#define DUK_BC_DECLVAR_FLAG_FUNC_DECL (1U << 4) /* function declaration */ + +/* DUK_OP_CALLn flags, part of opcode field. Three lowest bits must match + * DUK_CALL_FLAG_xxx directly. + */ +#define DUK_BC_CALL_FLAG_TAILCALL (1U << 0) +#define DUK_BC_CALL_FLAG_CONSTRUCT (1U << 1) +#define DUK_BC_CALL_FLAG_CALLED_AS_EVAL (1U << 2) +#define DUK_BC_CALL_FLAG_INDIRECT (1U << 3) + +/* Misc constants and helper macros. */ +#define DUK_BC_LDINT_BIAS (1L << 15) +#define DUK_BC_LDINTX_SHIFT 16 +#define DUK_BC_JUMP_BIAS (1L << 23) + +#endif /* DUK_JS_BYTECODE_H_INCLUDED */ +/* #include duk_lexer.h */ +#line 1 "duk_lexer.h" +/* + * Lexer defines. + */ + +#if !defined(DUK_LEXER_H_INCLUDED) +#define DUK_LEXER_H_INCLUDED + +typedef void (*duk_re_range_callback)(void *user, duk_codepoint_t r1, duk_codepoint_t r2, duk_bool_t direct); + +/* + * A token is interpreted as any possible production of InputElementDiv + * and InputElementRegExp, see E5 Section 7 in its entirety. Note that + * the E5 "Token" production does not cover all actual tokens of the + * language (which is explicitly stated in the specification, Section 7.5). + * Null and boolean literals are defined as part of both ReservedWord + * (E5 Section 7.6.1) and Literal (E5 Section 7.8) productions. Here, + * null and boolean values have literal tokens, and are not reserved + * words. + * + * Decimal literal negative/positive sign is -not- part of DUK_TOK_NUMBER. + * The number tokens always have a non-negative value. The unary minus + * operator in "-1.0" is optimized during compilation to yield a single + * negative constant. + * + * Token numbering is free except that reserved words are required to be + * in a continuous range and in a particular order. See genstrings.py. + */ + +#define DUK_LEXER_INITCTX(ctx) duk_lexer_initctx((ctx)) + +#define DUK_LEXER_SETPOINT(ctx, pt) duk_lexer_setpoint((ctx), (pt)) + +#define DUK_LEXER_GETPOINT(ctx, pt) duk_lexer_getpoint((ctx), (pt)) + +/* Currently 6 characters of lookup are actually needed (duk_lexer.c). */ +#define DUK_LEXER_WINDOW_SIZE 6 +#if defined(DUK_USE_LEXER_SLIDING_WINDOW) +#define DUK_LEXER_BUFFER_SIZE 64 +#endif + +#define DUK_TOK_MINVAL 0 + +/* returned after EOF (infinite amount) */ +#define DUK_TOK_EOF 0 + +/* identifier names (E5 Section 7.6) */ +#define DUK_TOK_IDENTIFIER 1 + +/* reserved words: keywords */ +#define DUK_TOK_START_RESERVED 2 +#define DUK_TOK_BREAK 2 +#define DUK_TOK_CASE 3 +#define DUK_TOK_CATCH 4 +#define DUK_TOK_CONTINUE 5 +#define DUK_TOK_DEBUGGER 6 +#define DUK_TOK_DEFAULT 7 +#define DUK_TOK_DELETE 8 +#define DUK_TOK_DO 9 +#define DUK_TOK_ELSE 10 +#define DUK_TOK_FINALLY 11 +#define DUK_TOK_FOR 12 +#define DUK_TOK_FUNCTION 13 +#define DUK_TOK_IF 14 +#define DUK_TOK_IN 15 +#define DUK_TOK_INSTANCEOF 16 +#define DUK_TOK_NEW 17 +#define DUK_TOK_RETURN 18 +#define DUK_TOK_SWITCH 19 +#define DUK_TOK_THIS 20 +#define DUK_TOK_THROW 21 +#define DUK_TOK_TRY 22 +#define DUK_TOK_TYPEOF 23 +#define DUK_TOK_VAR 24 +#define DUK_TOK_CONST 25 +#define DUK_TOK_VOID 26 +#define DUK_TOK_WHILE 27 +#define DUK_TOK_WITH 28 + +/* reserved words: future reserved words */ +#define DUK_TOK_CLASS 29 +#define DUK_TOK_ENUM 30 +#define DUK_TOK_EXPORT 31 +#define DUK_TOK_EXTENDS 32 +#define DUK_TOK_IMPORT 33 +#define DUK_TOK_SUPER 34 + +/* "null", "true", and "false" are always reserved words. + * Note that "get" and "set" are not! + */ +#define DUK_TOK_NULL 35 +#define DUK_TOK_TRUE 36 +#define DUK_TOK_FALSE 37 + +/* reserved words: additional future reserved words in strict mode */ +#define DUK_TOK_START_STRICT_RESERVED 38 /* inclusive */ +#define DUK_TOK_IMPLEMENTS 38 +#define DUK_TOK_INTERFACE 39 +#define DUK_TOK_LET 40 +#define DUK_TOK_PACKAGE 41 +#define DUK_TOK_PRIVATE 42 +#define DUK_TOK_PROTECTED 43 +#define DUK_TOK_PUBLIC 44 +#define DUK_TOK_STATIC 45 +#define DUK_TOK_YIELD 46 + +#define DUK_TOK_END_RESERVED 47 /* exclusive */ + +/* "get" and "set" are tokens but NOT ReservedWords. They are currently + * parsed and identifiers and these defines are actually now unused. + */ +#define DUK_TOK_GET 47 +#define DUK_TOK_SET 48 + +/* punctuators (unlike the spec, also includes "/" and "/=") */ +#define DUK_TOK_LCURLY 49 +#define DUK_TOK_RCURLY 50 +#define DUK_TOK_LBRACKET 51 +#define DUK_TOK_RBRACKET 52 +#define DUK_TOK_LPAREN 53 +#define DUK_TOK_RPAREN 54 +#define DUK_TOK_PERIOD 55 +#define DUK_TOK_SEMICOLON 56 +#define DUK_TOK_COMMA 57 +#define DUK_TOK_LT 58 +#define DUK_TOK_GT 59 +#define DUK_TOK_LE 60 +#define DUK_TOK_GE 61 +#define DUK_TOK_EQ 62 +#define DUK_TOK_NEQ 63 +#define DUK_TOK_SEQ 64 +#define DUK_TOK_SNEQ 65 +#define DUK_TOK_ADD 66 +#define DUK_TOK_SUB 67 +#define DUK_TOK_MUL 68 +#define DUK_TOK_DIV 69 +#define DUK_TOK_MOD 70 +#define DUK_TOK_EXP 71 +#define DUK_TOK_INCREMENT 72 +#define DUK_TOK_DECREMENT 73 +#define DUK_TOK_ALSHIFT 74 /* named "arithmetic" because result is signed */ +#define DUK_TOK_ARSHIFT 75 +#define DUK_TOK_RSHIFT 76 +#define DUK_TOK_BAND 77 +#define DUK_TOK_BOR 78 +#define DUK_TOK_BXOR 79 +#define DUK_TOK_LNOT 80 +#define DUK_TOK_BNOT 81 +#define DUK_TOK_LAND 82 +#define DUK_TOK_LOR 83 +#define DUK_TOK_QUESTION 84 +#define DUK_TOK_COLON 85 +#define DUK_TOK_EQUALSIGN 86 +#define DUK_TOK_ADD_EQ 87 +#define DUK_TOK_SUB_EQ 88 +#define DUK_TOK_MUL_EQ 89 +#define DUK_TOK_DIV_EQ 90 +#define DUK_TOK_MOD_EQ 91 +#define DUK_TOK_EXP_EQ 92 +#define DUK_TOK_ALSHIFT_EQ 93 +#define DUK_TOK_ARSHIFT_EQ 94 +#define DUK_TOK_RSHIFT_EQ 95 +#define DUK_TOK_BAND_EQ 96 +#define DUK_TOK_BOR_EQ 97 +#define DUK_TOK_BXOR_EQ 98 + +/* literals (E5 Section 7.8), except null, true, false, which are treated + * like reserved words (above). + */ +#define DUK_TOK_NUMBER 99 +#define DUK_TOK_STRING 100 +#define DUK_TOK_REGEXP 101 + +#define DUK_TOK_MAXVAL 101 /* inclusive */ + +#define DUK_TOK_INVALID DUK_SMALL_UINT_MAX + +/* Convert heap string index to a token (reserved words) */ +#define DUK_STRIDX_TO_TOK(x) ((x) -DUK_STRIDX_START_RESERVED + DUK_TOK_START_RESERVED) + +/* Sanity check */ +#if (DUK_TOK_MAXVAL > 255) +#error DUK_TOK_MAXVAL too large, code assumes it fits into 8 bits +#endif + +/* Sanity checks for string and token defines */ +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_BREAK) != DUK_TOK_BREAK) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_CASE) != DUK_TOK_CASE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_CATCH) != DUK_TOK_CATCH) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_CONTINUE) != DUK_TOK_CONTINUE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_DEBUGGER) != DUK_TOK_DEBUGGER) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_DEFAULT) != DUK_TOK_DEFAULT) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_DELETE) != DUK_TOK_DELETE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_DO) != DUK_TOK_DO) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_ELSE) != DUK_TOK_ELSE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_FINALLY) != DUK_TOK_FINALLY) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_FOR) != DUK_TOK_FOR) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_LC_FUNCTION) != DUK_TOK_FUNCTION) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_IF) != DUK_TOK_IF) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_IN) != DUK_TOK_IN) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_INSTANCEOF) != DUK_TOK_INSTANCEOF) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_NEW) != DUK_TOK_NEW) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_RETURN) != DUK_TOK_RETURN) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_SWITCH) != DUK_TOK_SWITCH) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_THIS) != DUK_TOK_THIS) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_THROW) != DUK_TOK_THROW) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_TRY) != DUK_TOK_TRY) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_TYPEOF) != DUK_TOK_TYPEOF) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_VAR) != DUK_TOK_VAR) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_VOID) != DUK_TOK_VOID) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_WHILE) != DUK_TOK_WHILE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_WITH) != DUK_TOK_WITH) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_CLASS) != DUK_TOK_CLASS) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_CONST) != DUK_TOK_CONST) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_ENUM) != DUK_TOK_ENUM) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_EXPORT) != DUK_TOK_EXPORT) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_EXTENDS) != DUK_TOK_EXTENDS) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_IMPORT) != DUK_TOK_IMPORT) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_SUPER) != DUK_TOK_SUPER) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_LC_NULL) != DUK_TOK_NULL) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_TRUE) != DUK_TOK_TRUE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_FALSE) != DUK_TOK_FALSE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_IMPLEMENTS) != DUK_TOK_IMPLEMENTS) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_INTERFACE) != DUK_TOK_INTERFACE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_LET) != DUK_TOK_LET) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_PACKAGE) != DUK_TOK_PACKAGE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_PRIVATE) != DUK_TOK_PRIVATE) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_PROTECTED) != DUK_TOK_PROTECTED) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_PUBLIC) != DUK_TOK_PUBLIC) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_STATIC) != DUK_TOK_STATIC) +#error mismatch in token defines +#endif +#if (DUK_STRIDX_TO_TOK(DUK_STRIDX_YIELD) != DUK_TOK_YIELD) +#error mismatch in token defines +#endif + +/* Regexp tokens */ +#define DUK_RETOK_EOF 0 +#define DUK_RETOK_DISJUNCTION 1 +#define DUK_RETOK_QUANTIFIER 2 +#define DUK_RETOK_ASSERT_START 3 +#define DUK_RETOK_ASSERT_END 4 +#define DUK_RETOK_ASSERT_WORD_BOUNDARY 5 +#define DUK_RETOK_ASSERT_NOT_WORD_BOUNDARY 6 +#define DUK_RETOK_ASSERT_START_POS_LOOKAHEAD 7 +#define DUK_RETOK_ASSERT_START_NEG_LOOKAHEAD 8 +#define DUK_RETOK_ATOM_PERIOD 9 +#define DUK_RETOK_ATOM_CHAR 10 +#define DUK_RETOK_ATOM_DIGIT 11 /* assumptions in regexp compiler */ +#define DUK_RETOK_ATOM_NOT_DIGIT 12 /* -""- */ +#define DUK_RETOK_ATOM_WHITE 13 /* -""- */ +#define DUK_RETOK_ATOM_NOT_WHITE 14 /* -""- */ +#define DUK_RETOK_ATOM_WORD_CHAR 15 /* -""- */ +#define DUK_RETOK_ATOM_NOT_WORD_CHAR 16 /* -""- */ +#define DUK_RETOK_ATOM_BACKREFERENCE 17 +#define DUK_RETOK_ATOM_START_CAPTURE_GROUP 18 +#define DUK_RETOK_ATOM_START_NONCAPTURE_GROUP 19 +#define DUK_RETOK_ATOM_START_CHARCLASS 20 +#define DUK_RETOK_ATOM_START_CHARCLASS_INVERTED 21 +#define DUK_RETOK_ATOM_END_GROUP 22 + +/* Constants for duk_lexer_ctx.buf. */ +#define DUK_LEXER_TEMP_BUF_LIMIT 256 + +/* A token value. Can be memcpy()'d, but note that slot1/slot2 values are on the valstack. + * Some fields (like num, str1, str2) are only valid for specific token types and may have + * stale values otherwise. + */ +struct duk_token { + duk_small_uint_t t; /* token type (with reserved word identification) */ + duk_small_uint_t t_nores; /* token type (with reserved words as DUK_TOK_IDENTIFER) */ + duk_double_t num; /* numeric value of token */ + duk_hstring *str1; /* string 1 of token (borrowed, stored to ctx->slot1_idx) */ + duk_hstring *str2; /* string 2 of token (borrowed, stored to ctx->slot2_idx) */ + duk_size_t start_offset; /* start byte offset of token in lexer input */ + duk_int_t start_line; /* start line of token (first char) */ + duk_int_t num_escapes; /* number of escapes and line continuations (for directive prologue) */ + duk_bool_t lineterm; /* token was preceded by a lineterm */ + duk_bool_t allow_auto_semi; /* token allows automatic semicolon insertion (eof or preceded by newline) */ +}; + +#define DUK_RE_QUANTIFIER_INFINITE ((duk_uint32_t) 0xffffffffUL) + +/* A regexp token value. */ +struct duk_re_token { + duk_small_uint_t t; /* token type */ + duk_small_uint_t greedy; + duk_uint32_t num; /* numeric value (character, count) */ + duk_uint32_t qmin; + duk_uint32_t qmax; +}; + +/* A structure for 'snapshotting' a point for rewinding */ +struct duk_lexer_point { + duk_size_t offset; + duk_int_t line; +}; + +/* Lexer codepoint with additional info like offset/line number */ +struct duk_lexer_codepoint { + duk_codepoint_t codepoint; + duk_size_t offset; + duk_int_t line; +}; + +/* Lexer context. Same context is used for ECMAScript and Regexp parsing. */ +struct duk_lexer_ctx { +#if defined(DUK_USE_LEXER_SLIDING_WINDOW) + duk_lexer_codepoint *window; /* unicode code points, window[0] is always next, points to 'buffer' */ + duk_lexer_codepoint buffer[DUK_LEXER_BUFFER_SIZE]; +#else + duk_lexer_codepoint window[DUK_LEXER_WINDOW_SIZE]; /* unicode code points, window[0] is always next */ +#endif + + duk_hthread *thr; /* thread; minimizes argument passing */ + + const duk_uint8_t *input; /* input string (may be a user pointer) */ + duk_size_t input_length; /* input byte length */ + duk_size_t input_offset; /* input offset for window leading edge (not window[0]) */ + duk_int_t input_line; /* input linenumber at input_offset (not window[0]), init to 1 */ + + duk_idx_t slot1_idx; /* valstack slot for 1st token value */ + duk_idx_t slot2_idx; /* valstack slot for 2nd token value */ + duk_idx_t buf_idx; /* valstack slot for temp buffer */ + duk_hbuffer_dynamic *buf; /* temp accumulation buffer */ + duk_bufwriter_ctx bw; /* bufwriter for temp accumulation */ + + duk_int_t token_count; /* number of tokens parsed */ + duk_int_t token_limit; /* maximum token count before error (sanity backstop) */ + + duk_small_uint_t flags; /* lexer flags, use compiler flag defines for now */ +}; + +/* + * Prototypes + */ + +DUK_INTERNAL_DECL void duk_lexer_initctx(duk_lexer_ctx *lex_ctx); + +DUK_INTERNAL_DECL void duk_lexer_getpoint(duk_lexer_ctx *lex_ctx, duk_lexer_point *pt); +DUK_INTERNAL_DECL void duk_lexer_setpoint(duk_lexer_ctx *lex_ctx, duk_lexer_point *pt); + +DUK_INTERNAL_DECL +void duk_lexer_parse_js_input_element(duk_lexer_ctx *lex_ctx, duk_token *out_token, duk_bool_t strict_mode, duk_bool_t regexp_mode); +#if defined(DUK_USE_REGEXP_SUPPORT) +DUK_INTERNAL_DECL void duk_lexer_parse_re_token(duk_lexer_ctx *lex_ctx, duk_re_token *out_token); +DUK_INTERNAL_DECL void duk_lexer_parse_re_ranges(duk_lexer_ctx *lex_ctx, duk_re_range_callback gen_range, void *userdata); +#endif /* DUK_USE_REGEXP_SUPPORT */ + +#endif /* DUK_LEXER_H_INCLUDED */ +/* #include duk_js_compiler.h */ +#line 1 "duk_js_compiler.h" +/* + * ECMAScript compiler. + */ + +#if !defined(DUK_JS_COMPILER_H_INCLUDED) +#define DUK_JS_COMPILER_H_INCLUDED + +/* ECMAScript compiler limits */ +#define DUK_COMPILER_TOKEN_LIMIT 100000000L /* 1e8: protects against deeply nested inner functions */ + +/* maximum loopcount for peephole optimization */ +#define DUK_COMPILER_PEEPHOLE_MAXITER 3 + +/* maximum bytecode length in instructions */ +#define DUK_COMPILER_MAX_BYTECODE_LENGTH (256L * 1024L * 1024L) /* 1 GB */ + +/* + * Compiler intermediate values + * + * Intermediate values describe either plain values (e.g. strings or + * numbers) or binary operations which have not yet been coerced into + * either a left-hand-side or right-hand-side role (e.g. object property). + */ + +#define DUK_IVAL_NONE 0 /* no value */ +#define DUK_IVAL_PLAIN 1 /* register, constant, or value */ +#define DUK_IVAL_ARITH 2 /* binary arithmetic; DUK_OP_ADD, DUK_OP_EQ, other binary ops */ +#define DUK_IVAL_PROP 3 /* property access */ +#define DUK_IVAL_VAR 4 /* variable access */ + +#define DUK_ISPEC_NONE 0 /* no value */ +#define DUK_ISPEC_VALUE 1 /* value resides in 'valstack_idx' */ +#define DUK_ISPEC_REGCONST 2 /* value resides in a register or constant */ + +/* Bit mask which indicates that a regconst is a constant instead of a register. + * Chosen so that when a regconst is cast to duk_int32_t, all consts are + * negative values. + */ +#define DUK_REGCONST_CONST_MARKER DUK_INT32_MIN /* = -0x80000000 */ + +/* Type to represent a reg/const reference during compilation, with <0 + * indicating a constant. Some call sites also use -1 to indicate 'none'. + */ +typedef duk_int32_t duk_regconst_t; + +typedef struct { + duk_small_uint_t t; /* DUK_ISPEC_XXX */ + duk_regconst_t regconst; + duk_idx_t valstack_idx; /* always set; points to a reserved valstack slot */ +} duk_ispec; + +typedef struct { + /* + * PLAIN: x1 + * ARITH: x1 x2 + * PROP: x1.x2 + * VAR: x1 (name) + */ + + /* XXX: can be optimized for smaller footprint esp. on 32-bit environments */ + duk_small_uint_t t; /* DUK_IVAL_XXX */ + duk_small_uint_t op; /* bytecode opcode for binary ops */ + duk_ispec x1; + duk_ispec x2; +} duk_ivalue; + +/* + * Bytecode instruction representation during compilation + * + * Contains the actual instruction and (optionally) debug info. + */ + +struct duk_compiler_instr { + duk_instr_t ins; +#if defined(DUK_USE_PC2LINE) + duk_uint32_t line; +#endif +}; + +/* + * Compiler state + */ + +#define DUK_LABEL_FLAG_ALLOW_BREAK (1U << 0) +#define DUK_LABEL_FLAG_ALLOW_CONTINUE (1U << 1) + +#define DUK_DECL_TYPE_VAR 0 +#define DUK_DECL_TYPE_FUNC 1 + +/* XXX: optimize to 16 bytes */ +typedef struct { + duk_small_uint_t flags; + duk_int_t label_id; /* numeric label_id (-1 reserved as marker) */ + duk_hstring *h_label; /* borrowed label name */ + duk_int_t catch_depth; /* catch depth at point of definition */ + duk_int_t pc_label; /* pc of label statement: + * pc+1: break jump site + * pc+2: continue jump site + */ + + /* Fast jumps (which avoid longjmp) jump directly to the jump sites + * which are always known even while the iteration/switch statement + * is still being parsed. A final peephole pass "straightens out" + * the jumps. + */ +} duk_labelinfo; + +/* Compiling state of one function, eventually converted to duk_hcompfunc */ +struct duk_compiler_func { + /* These pointers are at the start of the struct so that they pack + * nicely. Mixing pointers and integer values is bad on some + * platforms (e.g. if int is 32 bits and pointers are 64 bits). + */ + + duk_bufwriter_ctx bw_code; /* bufwriter for code */ + + duk_hstring *h_name; /* function name (borrowed reference), ends up in _name */ + /* h_code: held in bw_code */ + duk_hobject *h_consts; /* array */ + duk_hobject *h_funcs; /* array of function templates: [func1, offset1, line1, func2, offset2, line2] + * offset/line points to closing brace to allow skipping on pass 2 + */ + duk_hobject *h_decls; /* array of declarations: [ name1, val1, name2, val2, ... ] + * valN = (typeN) | (fnum << 8), where fnum is inner func number (0 for vars) + * record function and variable declarations in pass 1 + */ + duk_hobject *h_labelnames; /* array of active label names */ + duk_hbuffer_dynamic *h_labelinfos; /* C array of duk_labelinfo */ + duk_hobject *h_argnames; /* array of formal argument names (-> _Formals) */ + duk_hobject *h_varmap; /* variable map for pass 2 (identifier -> register number or null (unmapped)) */ + + /* Value stack indices for tracking objects. */ + /* code_idx: not needed */ + duk_idx_t consts_idx; + duk_idx_t funcs_idx; + duk_idx_t decls_idx; + duk_idx_t labelnames_idx; + duk_idx_t labelinfos_idx; + duk_idx_t argnames_idx; + duk_idx_t varmap_idx; + + /* Temp reg handling. */ + duk_regconst_t temp_first; /* first register that is a temporary (below: variables) */ + duk_regconst_t temp_next; /* next temporary register to allocate */ + duk_regconst_t temp_max; /* highest value of temp_reg (temp_max - 1 is highest used reg) */ + + /* Shuffle registers if large number of regs/consts. */ + duk_regconst_t shuffle1; + duk_regconst_t shuffle2; + duk_regconst_t shuffle3; + + /* Stats for current expression being parsed. */ + duk_int_t nud_count; + duk_int_t led_count; + duk_int_t paren_level; /* parenthesis count, 0 = top level */ + duk_bool_t expr_lhs; /* expression is left-hand-side compatible */ + duk_bool_t allow_in; /* current paren level allows 'in' token */ + + /* Misc. */ + duk_int_t stmt_next; /* statement id allocation (running counter) */ + duk_int_t label_next; /* label id allocation (running counter) */ + duk_int_t catch_depth; /* catch stack depth */ + duk_int_t with_depth; /* with stack depth (affects identifier lookups) */ + duk_int_t fnum_next; /* inner function numbering */ + duk_int_t num_formals; /* number of formal arguments */ + duk_regconst_t + reg_stmt_value; /* register for writing value of 'non-empty' statements (global or eval code), -1 is marker */ +#if defined(DUK_USE_DEBUGGER_SUPPORT) + duk_int_t min_line; /* XXX: typing (duk_hcompfunc has duk_uint32_t) */ + duk_int_t max_line; +#endif + + /* Status booleans. */ + duk_uint8_t is_function; /* is an actual function (not global/eval code) */ + duk_uint8_t is_eval; /* is eval code */ + duk_uint8_t is_global; /* is global code */ + duk_uint8_t is_namebinding; /* needs a name binding */ + duk_uint8_t is_constructable; /* result is constructable */ + duk_uint8_t is_setget; /* is a setter/getter */ + duk_uint8_t is_strict; /* function is strict */ + duk_uint8_t is_notail; /* function must not be tail called */ + duk_uint8_t in_directive_prologue; /* parsing in "directive prologue", recognize directives */ + duk_uint8_t in_scanning; /* parsing in "scanning" phase (first pass) */ + duk_uint8_t may_direct_eval; /* function may call direct eval */ + duk_uint8_t id_access_arguments; /* function refers to 'arguments' identifier */ + duk_uint8_t id_access_slow; /* function makes one or more slow path accesses that won't match own static variables */ + duk_uint8_t id_access_slow_own; /* function makes one or more slow path accesses that may match own static variables */ + duk_uint8_t is_arguments_shadowed; /* argument/function declaration shadows 'arguments' */ + duk_uint8_t needs_shuffle; /* function needs shuffle registers */ + duk_uint8_t + reject_regexp_in_adv; /* reject RegExp literal on next advance() call; needed for handling IdentifierName productions */ + duk_uint8_t allow_regexp_in_adv; /* allow RegExp literal on next advance() call */ +}; + +struct duk_compiler_ctx { + duk_hthread *thr; + + /* filename being compiled (ends up in functions' '_filename' property) */ + duk_hstring *h_filename; /* borrowed reference */ + + /* lexing (tokenization) state (contains two valstack slot indices) */ + duk_lexer_ctx lex; + + /* current and previous token for parsing */ + duk_token prev_token; + duk_token curr_token; + duk_idx_t tok11_idx; /* curr_token slot1 (matches 'lex' slot1_idx) */ + duk_idx_t tok12_idx; /* curr_token slot2 (matches 'lex' slot2_idx) */ + duk_idx_t tok21_idx; /* prev_token slot1 */ + duk_idx_t tok22_idx; /* prev_token slot2 */ + + /* recursion limit */ + duk_int_t recursion_depth; + duk_int_t recursion_limit; + + /* code emission temporary */ + duk_int_t emit_jumpslot_pc; + + /* current function being compiled (embedded instead of pointer for more compact access) */ + duk_compiler_func curr_func; +}; + +/* + * Prototypes + */ + +DUK_INTERNAL_DECL void duk_js_compile(duk_hthread *thr, + const duk_uint8_t *src_buffer, + duk_size_t src_length, + duk_small_uint_t flags); + +#endif /* DUK_JS_COMPILER_H_INCLUDED */ +/* #include duk_regexp.h */ +#line 1 "duk_regexp.h" +/* + * Regular expression structs, constants, and bytecode defines. + */ + +#if !defined(DUK_REGEXP_H_INCLUDED) +#define DUK_REGEXP_H_INCLUDED + +/* maximum bytecode copies for {n,m} quantifiers */ +#define DUK_RE_MAX_ATOM_COPIES 1000 + +/* regexp compilation limits */ +#define DUK_RE_COMPILE_TOKEN_LIMIT 100000000L /* 1e8 */ + +/* regexp execution limits */ +#define DUK_RE_EXECUTE_STEPS_LIMIT 1000000000L /* 1e9 */ + +/* regexp opcodes */ +#define DUK_REOP_MATCH 1 +#define DUK_REOP_CHAR 2 +#define DUK_REOP_PERIOD 3 +#define DUK_REOP_RANGES 4 +#define DUK_REOP_INVRANGES 5 +#define DUK_REOP_JUMP 6 +#define DUK_REOP_SPLIT1 7 +#define DUK_REOP_SPLIT2 8 +#define DUK_REOP_SQMINIMAL 9 +#define DUK_REOP_SQGREEDY 10 +#define DUK_REOP_SAVE 11 +#define DUK_REOP_WIPERANGE 12 +#define DUK_REOP_LOOKPOS 13 +#define DUK_REOP_LOOKNEG 14 +#define DUK_REOP_BACKREFERENCE 15 +#define DUK_REOP_ASSERT_START 16 +#define DUK_REOP_ASSERT_END 17 +#define DUK_REOP_ASSERT_WORD_BOUNDARY 18 +#define DUK_REOP_ASSERT_NOT_WORD_BOUNDARY 19 + +/* flags */ +#define DUK_RE_FLAG_GLOBAL (1U << 0) +#define DUK_RE_FLAG_IGNORE_CASE (1U << 1) +#define DUK_RE_FLAG_MULTILINE (1U << 2) + +struct duk_re_matcher_ctx { + duk_hthread *thr; + + duk_uint32_t re_flags; + const duk_uint8_t *input; + const duk_uint8_t *input_end; + const duk_uint8_t *bytecode; + const duk_uint8_t *bytecode_end; + const duk_uint8_t **saved; /* allocated from valstack (fixed buffer) */ + duk_uint32_t nsaved; + duk_uint32_t recursion_depth; + duk_uint32_t recursion_limit; + duk_uint32_t steps_count; + duk_uint32_t steps_limit; +}; + +struct duk_re_compiler_ctx { + duk_hthread *thr; + + duk_uint32_t re_flags; + duk_lexer_ctx lex; + duk_re_token curr_token; + duk_bufwriter_ctx bw; + duk_uint32_t captures; /* highest capture number emitted so far (used as: ++captures) */ + duk_uint32_t highest_backref; + duk_uint32_t recursion_depth; + duk_uint32_t recursion_limit; + duk_uint32_t nranges; /* internal temporary value, used for char classes */ +}; + +/* + * Prototypes + */ + +#if defined(DUK_USE_REGEXP_SUPPORT) +DUK_INTERNAL_DECL void duk_regexp_compile(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_regexp_create_instance(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_regexp_match(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_regexp_match_force_global(duk_hthread *thr); /* hacky helper for String.prototype.split() */ +#endif + +#endif /* DUK_REGEXP_H_INCLUDED */ +/* #include duk_heaphdr.h */ +#line 1 "duk_heaphdr.h" +/* + * Heap header definition and assorted macros, including ref counting. + * Access all fields through the accessor macros. + */ + +#if !defined(DUK_HEAPHDR_H_INCLUDED) +#define DUK_HEAPHDR_H_INCLUDED + +/* + * Common heap header + * + * All heap objects share the same flags and refcount fields. Objects other + * than strings also need to have a single or double linked list pointers + * for insertion into the "heap allocated" list. Strings have single linked + * list pointers for string table chaining. + * + * Technically, 'h_refcount' must be wide enough to guarantee that it cannot + * wrap; otherwise objects might be freed incorrectly after wrapping. The + * default refcount field is 32 bits even on 64-bit systems: while that's in + * theory incorrect, the Duktape heap needs to be larger than 64GB for the + * count to actually wrap (assuming 16-byte duk_tvals). This is very unlikely + * to ever be an issue, but if it is, disabling DUK_USE_REFCOUNT32 causes + * Duktape to use size_t for refcounts which should always be safe. + * + * Heap header size on 32-bit platforms: 8 bytes without reference counting, + * 16 bytes with reference counting. + * + * Note that 'raw' macros such as DUK_HEAPHDR_GET_REFCOUNT() are not + * defined without DUK_USE_REFERENCE_COUNTING, so caller must #if defined() + * around them. + */ + +/* XXX: macro for shared header fields (avoids some padding issues) */ + +struct duk_heaphdr { + duk_uint32_t h_flags; + +#if defined(DUK_USE_REFERENCE_COUNTING) +#if defined(DUK_USE_ASSERTIONS) + /* When assertions enabled, used by mark-and-sweep for refcount + * validation. Largest reasonable type; also detects overflows. + */ + duk_size_t h_assert_refcount; +#endif +#if defined(DUK_USE_REFCOUNT16) + duk_uint16_t h_refcount; +#elif defined(DUK_USE_REFCOUNT32) + duk_uint32_t h_refcount; +#else + duk_size_t h_refcount; +#endif +#endif /* DUK_USE_REFERENCE_COUNTING */ + +#if defined(DUK_USE_HEAPPTR16) + duk_uint16_t h_next16; +#else + duk_heaphdr *h_next; +#endif + +#if defined(DUK_USE_DOUBLE_LINKED_HEAP) + /* refcounting requires direct heap frees, which in turn requires a dual linked heap */ +#if defined(DUK_USE_HEAPPTR16) + duk_uint16_t h_prev16; +#else + duk_heaphdr *h_prev; +#endif +#endif + + /* When DUK_USE_HEAPPTR16 (and DUK_USE_REFCOUNT16) is in use, the + * struct won't align nicely to 4 bytes. This 16-bit extra field + * is added to make the alignment clean; the field can be used by + * heap objects when 16-bit packing is used. This field is now + * conditional to DUK_USE_HEAPPTR16 only, but it is intended to be + * used with DUK_USE_REFCOUNT16 and DUK_USE_DOUBLE_LINKED_HEAP; + * this only matter to low memory environments anyway. + */ +#if defined(DUK_USE_HEAPPTR16) + duk_uint16_t h_extra16; +#endif +}; + +struct duk_heaphdr_string { + /* 16 bits would be enough for shared heaphdr flags and duk_hstring + * flags. The initial parts of duk_heaphdr_string and duk_heaphdr + * must match so changing the flags field size here would be quite + * awkward. However, to minimize struct size, we can pack at least + * 16 bits of duk_hstring data into the flags field. + */ + duk_uint32_t h_flags; + +#if defined(DUK_USE_REFERENCE_COUNTING) +#if defined(DUK_USE_ASSERTIONS) + /* When assertions enabled, used by mark-and-sweep for refcount + * validation. Largest reasonable type; also detects overflows. + */ + duk_size_t h_assert_refcount; +#endif +#if defined(DUK_USE_REFCOUNT16) + duk_uint16_t h_refcount; + duk_uint16_t h_strextra16; /* round out to 8 bytes */ +#elif defined(DUK_USE_REFCOUNT32) + duk_uint32_t h_refcount; +#else + duk_size_t h_refcount; +#endif +#else + duk_uint16_t h_strextra16; +#endif /* DUK_USE_REFERENCE_COUNTING */ + + duk_hstring *h_next; + /* No 'h_prev' pointer for strings. */ +}; + +#define DUK_HEAPHDR_FLAGS_TYPE_MASK 0x00000003UL +#define DUK_HEAPHDR_FLAGS_FLAG_MASK (~DUK_HEAPHDR_FLAGS_TYPE_MASK) + +/* 2 bits for heap type */ +#define DUK_HEAPHDR_FLAGS_HEAP_START 2 /* 5 heap flags */ +#define DUK_HEAPHDR_FLAGS_USER_START 7 /* 25 user flags */ + +#define DUK_HEAPHDR_HEAP_FLAG_NUMBER(n) (DUK_HEAPHDR_FLAGS_HEAP_START + (n)) +#define DUK_HEAPHDR_USER_FLAG_NUMBER(n) (DUK_HEAPHDR_FLAGS_USER_START + (n)) +#define DUK_HEAPHDR_HEAP_FLAG(n) (1UL << (DUK_HEAPHDR_FLAGS_HEAP_START + (n))) +#define DUK_HEAPHDR_USER_FLAG(n) (1UL << (DUK_HEAPHDR_FLAGS_USER_START + (n))) + +#define DUK_HEAPHDR_FLAG_REACHABLE DUK_HEAPHDR_HEAP_FLAG(0) /* mark-and-sweep: reachable */ +#define DUK_HEAPHDR_FLAG_TEMPROOT DUK_HEAPHDR_HEAP_FLAG(1) /* mark-and-sweep: children not processed */ +#define DUK_HEAPHDR_FLAG_FINALIZABLE DUK_HEAPHDR_HEAP_FLAG(2) /* mark-and-sweep: finalizable (on current pass) */ +#define DUK_HEAPHDR_FLAG_FINALIZED DUK_HEAPHDR_HEAP_FLAG(3) /* mark-and-sweep: finalized (on previous pass) */ +#define DUK_HEAPHDR_FLAG_READONLY DUK_HEAPHDR_HEAP_FLAG(4) /* read-only object, in code section */ + +#define DUK_HTYPE_MIN 0 +#define DUK_HTYPE_STRING 0 +#define DUK_HTYPE_OBJECT 1 +#define DUK_HTYPE_BUFFER 2 +#define DUK_HTYPE_MAX 2 + +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HEAPHDR_GET_NEXT(heap, h) ((duk_heaphdr *) DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (h)->h_next16)) +#define DUK_HEAPHDR_SET_NEXT(heap, h, val) \ + do { \ + (h)->h_next16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) val); \ + } while (0) +#else +#define DUK_HEAPHDR_GET_NEXT(heap, h) ((h)->h_next) +#define DUK_HEAPHDR_SET_NEXT(heap, h, val) \ + do { \ + (h)->h_next = (val); \ + } while (0) +#endif + +#if defined(DUK_USE_DOUBLE_LINKED_HEAP) +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HEAPHDR_GET_PREV(heap, h) ((duk_heaphdr *) DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (h)->h_prev16)) +#define DUK_HEAPHDR_SET_PREV(heap, h, val) \ + do { \ + (h)->h_prev16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) (val)); \ + } while (0) +#else +#define DUK_HEAPHDR_GET_PREV(heap, h) ((h)->h_prev) +#define DUK_HEAPHDR_SET_PREV(heap, h, val) \ + do { \ + (h)->h_prev = (val); \ + } while (0) +#endif +#endif + +#if defined(DUK_USE_REFERENCE_COUNTING) +#define DUK_HEAPHDR_GET_REFCOUNT(h) ((h)->h_refcount) +#define DUK_HEAPHDR_SET_REFCOUNT(h, val) \ + do { \ + (h)->h_refcount = (val); \ + DUK_ASSERT((h)->h_refcount == (val)); /* No truncation. */ \ + } while (0) +#define DUK_HEAPHDR_PREINC_REFCOUNT(h) (++(h)->h_refcount) /* result: updated refcount */ +#define DUK_HEAPHDR_PREDEC_REFCOUNT(h) (--(h)->h_refcount) /* result: updated refcount */ +#else +/* refcount macros not defined without refcounting, caller must #if defined() now */ +#endif /* DUK_USE_REFERENCE_COUNTING */ + +/* + * Note: type is treated as a field separate from flags, so some masking is + * involved in the macros below. + */ + +#define DUK_HEAPHDR_GET_FLAGS_RAW(h) ((h)->h_flags) +#define DUK_HEAPHDR_SET_FLAGS_RAW(h, val) \ + do { \ + (h)->h_flags = (val); \ + } \ + } +#define DUK_HEAPHDR_GET_FLAGS(h) ((h)->h_flags & DUK_HEAPHDR_FLAGS_FLAG_MASK) +#define DUK_HEAPHDR_SET_FLAGS(h, val) \ + do { \ + (h)->h_flags = ((h)->h_flags & ~(DUK_HEAPHDR_FLAGS_FLAG_MASK)) | (val); \ + } while (0) +#define DUK_HEAPHDR_GET_TYPE(h) ((h)->h_flags & DUK_HEAPHDR_FLAGS_TYPE_MASK) +#define DUK_HEAPHDR_SET_TYPE(h, val) \ + do { \ + (h)->h_flags = ((h)->h_flags & ~(DUK_HEAPHDR_FLAGS_TYPE_MASK)) | (val); \ + } while (0) + +/* Comparison for type >= DUK_HTYPE_MIN skipped; because DUK_HTYPE_MIN is zero + * and the comparison is unsigned, it's always true and generates warnings. + */ +#define DUK_HEAPHDR_HTYPE_VALID(h) (DUK_HEAPHDR_GET_TYPE((h)) <= DUK_HTYPE_MAX) + +#define DUK_HEAPHDR_SET_TYPE_AND_FLAGS(h, tval, fval) \ + do { \ + (h)->h_flags = ((tval) &DUK_HEAPHDR_FLAGS_TYPE_MASK) | ((fval) &DUK_HEAPHDR_FLAGS_FLAG_MASK); \ + } while (0) + +#define DUK_HEAPHDR_SET_FLAG_BITS(h, bits) \ + do { \ + DUK_ASSERT(((bits) & ~(DUK_HEAPHDR_FLAGS_FLAG_MASK)) == 0); \ + (h)->h_flags |= (bits); \ + } while (0) + +#define DUK_HEAPHDR_CLEAR_FLAG_BITS(h, bits) \ + do { \ + DUK_ASSERT(((bits) & ~(DUK_HEAPHDR_FLAGS_FLAG_MASK)) == 0); \ + (h)->h_flags &= ~((bits)); \ + } while (0) + +#define DUK_HEAPHDR_CHECK_FLAG_BITS(h, bits) (((h)->h_flags & (bits)) != 0) + +#define DUK_HEAPHDR_SET_REACHABLE(h) DUK_HEAPHDR_SET_FLAG_BITS((h), DUK_HEAPHDR_FLAG_REACHABLE) +#define DUK_HEAPHDR_CLEAR_REACHABLE(h) DUK_HEAPHDR_CLEAR_FLAG_BITS((h), DUK_HEAPHDR_FLAG_REACHABLE) +#define DUK_HEAPHDR_HAS_REACHABLE(h) DUK_HEAPHDR_CHECK_FLAG_BITS((h), DUK_HEAPHDR_FLAG_REACHABLE) + +#define DUK_HEAPHDR_SET_TEMPROOT(h) DUK_HEAPHDR_SET_FLAG_BITS((h), DUK_HEAPHDR_FLAG_TEMPROOT) +#define DUK_HEAPHDR_CLEAR_TEMPROOT(h) DUK_HEAPHDR_CLEAR_FLAG_BITS((h), DUK_HEAPHDR_FLAG_TEMPROOT) +#define DUK_HEAPHDR_HAS_TEMPROOT(h) DUK_HEAPHDR_CHECK_FLAG_BITS((h), DUK_HEAPHDR_FLAG_TEMPROOT) + +#define DUK_HEAPHDR_SET_FINALIZABLE(h) DUK_HEAPHDR_SET_FLAG_BITS((h), DUK_HEAPHDR_FLAG_FINALIZABLE) +#define DUK_HEAPHDR_CLEAR_FINALIZABLE(h) DUK_HEAPHDR_CLEAR_FLAG_BITS((h), DUK_HEAPHDR_FLAG_FINALIZABLE) +#define DUK_HEAPHDR_HAS_FINALIZABLE(h) DUK_HEAPHDR_CHECK_FLAG_BITS((h), DUK_HEAPHDR_FLAG_FINALIZABLE) + +#define DUK_HEAPHDR_SET_FINALIZED(h) DUK_HEAPHDR_SET_FLAG_BITS((h), DUK_HEAPHDR_FLAG_FINALIZED) +#define DUK_HEAPHDR_CLEAR_FINALIZED(h) DUK_HEAPHDR_CLEAR_FLAG_BITS((h), DUK_HEAPHDR_FLAG_FINALIZED) +#define DUK_HEAPHDR_HAS_FINALIZED(h) DUK_HEAPHDR_CHECK_FLAG_BITS((h), DUK_HEAPHDR_FLAG_FINALIZED) + +#define DUK_HEAPHDR_SET_READONLY(h) DUK_HEAPHDR_SET_FLAG_BITS((h), DUK_HEAPHDR_FLAG_READONLY) +#define DUK_HEAPHDR_CLEAR_READONLY(h) DUK_HEAPHDR_CLEAR_FLAG_BITS((h), DUK_HEAPHDR_FLAG_READONLY) +#define DUK_HEAPHDR_HAS_READONLY(h) DUK_HEAPHDR_CHECK_FLAG_BITS((h), DUK_HEAPHDR_FLAG_READONLY) + +/* get or set a range of flags; m=first bit number, n=number of bits */ +#define DUK_HEAPHDR_GET_FLAG_RANGE(h, m, n) (((h)->h_flags >> (m)) & ((1UL << (n)) - 1UL)) + +#define DUK_HEAPHDR_SET_FLAG_RANGE(h, m, n, v) \ + do { \ + (h)->h_flags = ((h)->h_flags & (~(((1UL << (n)) - 1UL) << (m)))) | ((v) << (m)); \ + } while (0) + +/* init pointer fields to null */ +#if defined(DUK_USE_DOUBLE_LINKED_HEAP) +#define DUK_HEAPHDR_INIT_NULLS(h) \ + do { \ + DUK_HEAPHDR_SET_NEXT((h), (void *) NULL); \ + DUK_HEAPHDR_SET_PREV((h), (void *) NULL); \ + } while (0) +#else +#define DUK_HEAPHDR_INIT_NULLS(h) \ + do { \ + DUK_HEAPHDR_SET_NEXT((h), (void *) NULL); \ + } while (0) +#endif + +#define DUK_HEAPHDR_STRING_INIT_NULLS(h) \ + do { \ + (h)->h_next = NULL; \ + } while (0) + +/* + * Type tests + */ + +/* Take advantage of the fact that for DUK_HTYPE_xxx numbers the lowest bit + * is only set for DUK_HTYPE_OBJECT (= 1). + */ +#if 0 +#define DUK_HEAPHDR_IS_OBJECT(h) (DUK_HEAPHDR_GET_TYPE((h)) == DUK_HTYPE_OBJECT) +#endif +#define DUK_HEAPHDR_IS_OBJECT(h) ((h)->h_flags & 0x01UL) +#define DUK_HEAPHDR_IS_STRING(h) (DUK_HEAPHDR_GET_TYPE((h)) == DUK_HTYPE_STRING) +#define DUK_HEAPHDR_IS_BUFFER(h) (DUK_HEAPHDR_GET_TYPE((h)) == DUK_HTYPE_BUFFER) + +/* + * Assert helpers + */ + +/* Check that prev/next links are consistent: if e.g. h->prev is != NULL, + * h->prev->next should point back to h. + */ +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_heaphdr_assert_valid_subclassed(duk_heaphdr *h); +DUK_INTERNAL_DECL void duk_heaphdr_assert_links(duk_heap *heap, duk_heaphdr *h); +DUK_INTERNAL_DECL void duk_heaphdr_assert_valid(duk_heaphdr *h); +#define DUK_HEAPHDR_ASSERT_LINKS(heap, h) \ + do { \ + duk_heaphdr_assert_links((heap), (h)); \ + } while (0) +#define DUK_HEAPHDR_ASSERT_VALID(h) \ + do { \ + duk_heaphdr_assert_valid((h)); \ + } while (0) +#else +#define DUK_HEAPHDR_ASSERT_LINKS(heap, h) \ + do { \ + } while (0) +#define DUK_HEAPHDR_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +#endif /* DUK_HEAPHDR_H_INCLUDED */ +/* #include duk_refcount.h */ +#line 1 "duk_refcount.h" +/* + * Reference counting helper macros. The macros take a thread argument + * and must thus always be executed in a specific thread context. The + * thread argument is not really needed anymore: DECREF can operate with + * a heap pointer only, and INCREF needs neither. + */ + +#if !defined(DUK_REFCOUNT_H_INCLUDED) +#define DUK_REFCOUNT_H_INCLUDED + +#if defined(DUK_USE_REFERENCE_COUNTING) + +#if defined(DUK_USE_ROM_OBJECTS) +/* With ROM objects "needs refcount update" is true when the value is + * heap allocated and is not a ROM object. + */ +/* XXX: double evaluation for 'tv' argument. */ +#define DUK_TVAL_NEEDS_REFCOUNT_UPDATE(tv) \ + (DUK_TVAL_IS_HEAP_ALLOCATED((tv)) && !DUK_HEAPHDR_HAS_READONLY(DUK_TVAL_GET_HEAPHDR((tv)))) +#define DUK_HEAPHDR_NEEDS_REFCOUNT_UPDATE(h) (!DUK_HEAPHDR_HAS_READONLY((h))) +#else /* DUK_USE_ROM_OBJECTS */ +/* Without ROM objects "needs refcount update" == is heap allocated. */ +#define DUK_TVAL_NEEDS_REFCOUNT_UPDATE(tv) DUK_TVAL_IS_HEAP_ALLOCATED((tv)) +#define DUK_HEAPHDR_NEEDS_REFCOUNT_UPDATE(h) 1 +#endif /* DUK_USE_ROM_OBJECTS */ + +/* Fast variants, inline refcount operations except for refzero handling. + * Can be used explicitly when speed is always more important than size. + * For a good compiler and a single file build, these are basically the + * same as a forced inline. + */ +#define DUK_TVAL_INCREF_FAST(thr, tv) \ + do { \ + duk_tval *duk__tv = (tv); \ + DUK_ASSERT(duk__tv != NULL); \ + if (DUK_TVAL_NEEDS_REFCOUNT_UPDATE(duk__tv)) { \ + duk_heaphdr *duk__h = DUK_TVAL_GET_HEAPHDR(duk__tv); \ + DUK_ASSERT(duk__h != NULL); \ + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(duk__h)); \ + DUK_HEAPHDR_PREINC_REFCOUNT(duk__h); \ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(duk__h) != 0); /* No wrapping. */ \ + } \ + } while (0) +#define DUK_TVAL_DECREF_FAST(thr, tv) \ + do { \ + duk_tval *duk__tv = (tv); \ + DUK_ASSERT(duk__tv != NULL); \ + if (DUK_TVAL_NEEDS_REFCOUNT_UPDATE(duk__tv)) { \ + duk_heaphdr *duk__h = DUK_TVAL_GET_HEAPHDR(duk__tv); \ + DUK_ASSERT(duk__h != NULL); \ + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(duk__h)); \ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(duk__h) > 0); \ + if (DUK_HEAPHDR_PREDEC_REFCOUNT(duk__h) == 0) { \ + duk_heaphdr_refzero((thr), duk__h); \ + } \ + } \ + } while (0) +#define DUK_TVAL_DECREF_NORZ_FAST(thr, tv) \ + do { \ + duk_tval *duk__tv = (tv); \ + DUK_ASSERT(duk__tv != NULL); \ + if (DUK_TVAL_NEEDS_REFCOUNT_UPDATE(duk__tv)) { \ + duk_heaphdr *duk__h = DUK_TVAL_GET_HEAPHDR(duk__tv); \ + DUK_ASSERT(duk__h != NULL); \ + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(duk__h)); \ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(duk__h) > 0); \ + if (DUK_HEAPHDR_PREDEC_REFCOUNT(duk__h) == 0) { \ + duk_heaphdr_refzero_norz((thr), duk__h); \ + } \ + } \ + } while (0) +#define DUK_HEAPHDR_INCREF_FAST(thr, h) \ + do { \ + duk_heaphdr *duk__h = (duk_heaphdr *) (h); \ + DUK_ASSERT(duk__h != NULL); \ + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(duk__h)); \ + if (DUK_HEAPHDR_NEEDS_REFCOUNT_UPDATE(duk__h)) { \ + DUK_HEAPHDR_PREINC_REFCOUNT(duk__h); \ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(duk__h) != 0); /* No wrapping. */ \ + } \ + } while (0) +#define DUK_HEAPHDR_DECREF_FAST_RAW(thr, h, rzcall, rzcast) \ + do { \ + duk_heaphdr *duk__h = (duk_heaphdr *) (h); \ + DUK_ASSERT(duk__h != NULL); \ + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(duk__h)); \ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(duk__h) > 0); \ + if (DUK_HEAPHDR_NEEDS_REFCOUNT_UPDATE(duk__h)) { \ + if (DUK_HEAPHDR_PREDEC_REFCOUNT(duk__h) == 0) { \ + (rzcall)((thr), (rzcast) duk__h); \ + } \ + } \ + } while (0) +#define DUK_HEAPHDR_DECREF_FAST(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_heaphdr_refzero, duk_heaphdr *) +#define DUK_HEAPHDR_DECREF_NORZ_FAST(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_heaphdr_refzero_norz, duk_heaphdr *) + +/* Slow variants, call to a helper to reduce code size. + * Can be used explicitly when size is always more important than speed. + */ +#define DUK_TVAL_INCREF_SLOW(thr, tv) \ + do { \ + duk_tval_incref((tv)); \ + } while (0) +#define DUK_TVAL_DECREF_SLOW(thr, tv) \ + do { \ + duk_tval_decref((thr), (tv)); \ + } while (0) +#define DUK_TVAL_DECREF_NORZ_SLOW(thr, tv) \ + do { \ + duk_tval_decref_norz((thr), (tv)); \ + } while (0) +#define DUK_HEAPHDR_INCREF_SLOW(thr, h) \ + do { \ + duk_heaphdr_incref((duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HEAPHDR_DECREF_SLOW(thr, h) \ + do { \ + duk_heaphdr_decref((thr), (duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HEAPHDR_DECREF_NORZ_SLOW(thr, h) \ + do { \ + duk_heaphdr_decref_norz((thr), (duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HSTRING_INCREF_SLOW(thr, h) \ + do { \ + duk_heaphdr_incref((duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HSTRING_DECREF_SLOW(thr, h) \ + do { \ + duk_heaphdr_decref((thr), (duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HSTRING_DECREF_NORZ_SLOW(thr, h) \ + do { \ + duk_heaphdr_decref_norz((thr), (duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HBUFFER_INCREF_SLOW(thr, h) \ + do { \ + duk_heaphdr_incref((duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HBUFFER_DECREF_SLOW(thr, h) \ + do { \ + duk_heaphdr_decref((thr), (duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HBUFFER_DECREF_NORZ_SLOW(thr, h) \ + do { \ + duk_heaphdr_decref_norz((thr), (duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HOBJECT_INCREF_SLOW(thr, h) \ + do { \ + duk_heaphdr_incref((duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HOBJECT_DECREF_SLOW(thr, h) \ + do { \ + duk_heaphdr_decref((thr), (duk_heaphdr *) (h)); \ + } while (0) +#define DUK_HOBJECT_DECREF_NORZ_SLOW(thr, h) \ + do { \ + duk_heaphdr_decref_norz((thr), (duk_heaphdr *) (h)); \ + } while (0) + +/* Default variants. Selection depends on speed/size preference. + * Concretely: with gcc 4.8.1 -Os x64 the difference in final binary + * is about +1kB for _FAST variants. + */ +#if defined(DUK_USE_FAST_REFCOUNT_DEFAULT) +/* XXX: It would be nice to specialize for specific duk_hobject subtypes + * but current refzero queue handling prevents that. + */ +#define DUK_TVAL_INCREF(thr, tv) DUK_TVAL_INCREF_FAST((thr), (tv)) +#define DUK_TVAL_DECREF(thr, tv) DUK_TVAL_DECREF_FAST((thr), (tv)) +#define DUK_TVAL_DECREF_NORZ(thr, tv) DUK_TVAL_DECREF_NORZ_FAST((thr), (tv)) +#define DUK_HEAPHDR_INCREF(thr, h) DUK_HEAPHDR_INCREF_FAST((thr), (h)) +#define DUK_HEAPHDR_DECREF(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_heaphdr_refzero, duk_heaphdr *) +#define DUK_HEAPHDR_DECREF_NORZ(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_heaphdr_refzero_norz, duk_heaphdr *) +#define DUK_HSTRING_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) (h)) +#define DUK_HSTRING_DECREF(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hstring_refzero, duk_hstring *) +#define DUK_HSTRING_DECREF_NORZ(thr, h) \ + DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hstring_refzero, duk_hstring *) /* no 'norz' variant */ +#define DUK_HOBJECT_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) (h)) +#define DUK_HOBJECT_DECREF(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero, duk_hobject *) +#define DUK_HOBJECT_DECREF_NORZ(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero_norz, duk_hobject *) +#define DUK_HBUFFER_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) (h)) +#define DUK_HBUFFER_DECREF(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hbuffer_refzero, duk_hbuffer *) +#define DUK_HBUFFER_DECREF_NORZ(thr, h) \ + DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hbuffer_refzero, duk_hbuffer *) /* no 'norz' variant */ +#define DUK_HCOMPFUNC_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) &(h)->obj) +#define DUK_HCOMPFUNC_DECREF(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero, duk_hobject *) +#define DUK_HCOMPFUNC_DECREF_NORZ(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero_norz, duk_hobject *) +#define DUK_HNATFUNC_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) &(h)->obj) +#define DUK_HNATFUNC_DECREF(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero, duk_hobject *) +#define DUK_HNATFUNC_DECREF_NORZ(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero_norz, duk_hobject *) +#define DUK_HBUFOBJ_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) &(h)->obj) +#define DUK_HBUFOBJ_DECREF(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero, duk_hobject *) +#define DUK_HBUFOBJ_DECREF_NORZ(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero_norz, duk_hobject *) +#define DUK_HTHREAD_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) &(h)->obj) +#define DUK_HTHREAD_DECREF(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero, duk_hobject *) +#define DUK_HTHREAD_DECREF_NORZ(thr, h) DUK_HEAPHDR_DECREF_FAST_RAW((thr), (h), duk_hobject_refzero_norz, duk_hobject *) +#else +#define DUK_TVAL_INCREF(thr, tv) DUK_TVAL_INCREF_SLOW((thr), (tv)) +#define DUK_TVAL_DECREF(thr, tv) DUK_TVAL_DECREF_SLOW((thr), (tv)) +#define DUK_TVAL_DECREF_NORZ(thr, tv) DUK_TVAL_DECREF_NORZ_SLOW((thr), (tv)) +#define DUK_HEAPHDR_INCREF(thr, h) DUK_HEAPHDR_INCREF_SLOW((thr), (h)) +#define DUK_HEAPHDR_DECREF(thr, h) DUK_HEAPHDR_DECREF_SLOW((thr), (h)) +#define DUK_HEAPHDR_DECREF_NORZ(thr, h) DUK_HEAPHDR_DECREF_NORZ_SLOW((thr), (h)) +#define DUK_HSTRING_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) (h)) +#define DUK_HSTRING_DECREF(thr, h) DUK_HSTRING_DECREF_SLOW((thr), (h)) +#define DUK_HSTRING_DECREF_NORZ(thr, h) DUK_HSTRING_DECREF_NORZ_SLOW((thr), (h)) +#define DUK_HOBJECT_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) (h)) +#define DUK_HOBJECT_DECREF(thr, h) DUK_HOBJECT_DECREF_SLOW((thr), (h)) +#define DUK_HOBJECT_DECREF_NORZ(thr, h) DUK_HOBJECT_DECREF_NORZ_SLOW((thr), (h)) +#define DUK_HBUFFER_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) (h)) +#define DUK_HBUFFER_DECREF(thr, h) DUK_HBUFFER_DECREF_SLOW((thr), (h)) +#define DUK_HBUFFER_DECREF_NORZ(thr, h) DUK_HBUFFER_DECREF_NORZ_SLOW((thr), (h)) +#define DUK_HCOMPFUNC_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) &(h)->obj) +#define DUK_HCOMPFUNC_DECREF(thr, h) DUK_HOBJECT_DECREF_SLOW((thr), (duk_hobject *) &(h)->obj) +#define DUK_HCOMPFUNC_DECREF_NORZ(thr, h) DUK_HOBJECT_DECREF_NORZ_SLOW((thr), (duk_hobject *) &(h)->obj) +#define DUK_HNATFUNC_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) &(h)->obj) +#define DUK_HNATFUNC_DECREF(thr, h) DUK_HOBJECT_DECREF_SLOW((thr), (duk_hobject *) &(h)->obj) +#define DUK_HNATFUNC_DECREF_NORZ(thr, h) DUK_HOBJECT_DECREF_NORZ_SLOW((thr), (duk_hobject *) &(h)->obj) +#define DUK_HBUFOBJ_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) &(h)->obj) +#define DUK_HBUFOBJ_DECREF(thr, h) DUK_HOBJECT_DECREF_SLOW((thr), (duk_hobject *) &(h)->obj) +#define DUK_HBUFOB_DECREF_NORZ(thr, h) DUK_HOBJECT_DECREF_NORZ_SLOW((thr), (duk_hobject *) &(h)->obj) +#define DUK_HTHREAD_INCREF(thr, h) DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) &(h)->obj) +#define DUK_HTHREAD_DECREF(thr, h) DUK_HOBJECT_DECREF_SLOW((thr), (duk_hobject *) &(h)->obj) +#define DUK_HTHREAD_DECREF_NORZ(thr, h) DUK_HOBJECT_DECREF_NORZ_SLOW((thr), (duk_hobject *) &(h)->obj) +#endif + +/* Convenience for some situations; the above macros don't allow NULLs + * for performance reasons. Macros cover only actually needed cases. + */ +#define DUK_HEAPHDR_INCREF_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HEAPHDR_INCREF((thr), (duk_heaphdr *) (h)); \ + } \ + } while (0) +#define DUK_HEAPHDR_DECREF_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HEAPHDR_DECREF((thr), (duk_heaphdr *) (h)); \ + } \ + } while (0) +#define DUK_HEAPHDR_DECREF_NORZ_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HEAPHDR_DECREF_NORZ((thr), (duk_heaphdr *) (h)); \ + } \ + } while (0) +#define DUK_HOBJECT_INCREF_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HOBJECT_INCREF((thr), (h)); \ + } \ + } while (0) +#define DUK_HOBJECT_DECREF_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HOBJECT_DECREF((thr), (h)); \ + } \ + } while (0) +#define DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HOBJECT_DECREF_NORZ((thr), (h)); \ + } \ + } while (0) +#define DUK_HBUFFER_INCREF_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HBUFFER_INCREF((thr), (h)); \ + } \ + } while (0) +#define DUK_HBUFFER_DECREF_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HBUFFER_DECREF((thr), (h)); \ + } \ + } while (0) +#define DUK_HBUFFER_DECREF_NORZ_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HBUFFER_DECREF_NORZ((thr), (h)); \ + } \ + } while (0) +#define DUK_HTHREAD_INCREF_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HTHREAD_INCREF((thr), (h)); \ + } \ + } while (0) +#define DUK_HTHREAD_DECREF_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HTHREAD_DECREF((thr), (h)); \ + } \ + } while (0) +#define DUK_HTHREAD_DECREF_NORZ_ALLOWNULL(thr, h) \ + do { \ + if ((h) != NULL) { \ + DUK_HTHREAD_DECREF_NORZ((thr), (h)); \ + } \ + } while (0) + +/* Called after one or more DECREF NORZ calls to handle pending side effects. + * At present DECREF NORZ does freeing inline but doesn't execute finalizers, + * so these macros check for pending finalizers and execute them. The FAST + * variant is performance critical. + */ +#if defined(DUK_USE_FINALIZER_SUPPORT) +#define DUK_REFZERO_CHECK_FAST(thr) \ + do { \ + duk_refzero_check_fast((thr)); \ + } while (0) +#define DUK_REFZERO_CHECK_SLOW(thr) \ + do { \ + duk_refzero_check_slow((thr)); \ + } while (0) +#else /* DUK_USE_FINALIZER_SUPPORT */ +#define DUK_REFZERO_CHECK_FAST(thr) \ + do { \ + } while (0) +#define DUK_REFZERO_CHECK_SLOW(thr) \ + do { \ + } while (0) +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +/* + * Macros to set a duk_tval and update refcount of the target (decref the + * old value and incref the new value if necessary). This is both performance + * and footprint critical; any changes made should be measured for size/speed. + */ + +#define DUK_TVAL_SET_UNDEFINED_UPDREF_ALT0(thr, tvptr_dst) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_UNDEFINED(tv__dst); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +#define DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ_ALT0(thr, tvptr_dst) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_UNDEFINED(tv__dst); \ + DUK_TVAL_DECREF_NORZ((thr), &tv__tmp); \ + } while (0) + +#define DUK_TVAL_SET_UNUSED_UPDREF_ALT0(thr, tvptr_dst) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_UNUSED(tv__dst); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +#define DUK_TVAL_SET_NULL_UPDREF_ALT0(thr, tvptr_dst) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_NULL(tv__dst); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +#define DUK_TVAL_SET_BOOLEAN_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_BOOLEAN(tv__dst, (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +#define DUK_TVAL_SET_NUMBER_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_NUMBER(tv__dst, (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) +#define DUK_TVAL_SET_NUMBER_CHKFAST_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_NUMBER_CHKFAST_FAST(tv__dst, (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) +#define DUK_TVAL_SET_DOUBLE_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_DOUBLE(tv__dst, (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) +#define DUK_TVAL_SET_NAN_UPDREF_ALT0(thr, tvptr_dst) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_NAN(tv__dst); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) +#if defined(DUK_USE_FASTINT) +#define DUK_TVAL_SET_I48_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_I48(tv__dst, (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) +#define DUK_TVAL_SET_I32_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_I32(tv__dst, (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) +#define DUK_TVAL_SET_U32_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_U32(tv__dst, (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) +#else +#define DUK_TVAL_SET_DOUBLE_CAST_UPDREF(thr, tvptr_dst, newval) \ + DUK_TVAL_SET_DOUBLE_UPDREF((thr), (tvptr_dst), (duk_double_t) (newval)) +#endif /* DUK_USE_FASTINT */ + +#define DUK_TVAL_SET_LIGHTFUNC_UPDREF_ALT0(thr, tvptr_dst, lf_v, lf_fp, lf_flags) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_LIGHTFUNC(tv__dst, (lf_v), (lf_fp), (lf_flags)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +#define DUK_TVAL_SET_STRING_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_STRING(tv__dst, (newval)); \ + DUK_HSTRING_INCREF((thr), (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +#define DUK_TVAL_SET_OBJECT_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_OBJECT(tv__dst, (newval)); \ + DUK_HOBJECT_INCREF((thr), (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +#define DUK_TVAL_SET_BUFFER_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_BUFFER(tv__dst, (newval)); \ + DUK_HBUFFER_INCREF((thr), (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +#define DUK_TVAL_SET_POINTER_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_POINTER(tv__dst, (newval)); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +/* DUK_TVAL_SET_TVAL_UPDREF() is used a lot in executor, property lookups, + * etc, so it's very important for performance. Measure when changing. + * + * NOTE: the source and destination duk_tval pointers may be the same, and + * the macros MUST deal with that correctly. + */ + +/* Original idiom used, minimal code size. */ +#define DUK_TVAL_SET_TVAL_UPDREF_ALT0(thr, tvptr_dst, tvptr_src) \ + do { \ + duk_tval *tv__dst, *tv__src; \ + duk_tval tv__tmp; \ + tv__dst = (tvptr_dst); \ + tv__src = (tvptr_src); \ + DUK_TVAL_SET_TVAL(&tv__tmp, tv__dst); \ + DUK_TVAL_SET_TVAL(tv__dst, tv__src); \ + DUK_TVAL_INCREF((thr), tv__src); \ + DUK_TVAL_DECREF((thr), &tv__tmp); /* side effects */ \ + } while (0) + +/* Faster alternative: avoid making a temporary copy of tvptr_dst and use + * fast incref/decref macros. + */ +#define DUK_TVAL_SET_TVAL_UPDREF_ALT1(thr, tvptr_dst, tvptr_src) \ + do { \ + duk_tval *tv__dst, *tv__src; \ + duk_heaphdr *h__obj; \ + tv__dst = (tvptr_dst); \ + tv__src = (tvptr_src); \ + DUK_TVAL_INCREF_FAST((thr), tv__src); \ + if (DUK_TVAL_NEEDS_REFCOUNT_UPDATE(tv__dst)) { \ + h__obj = DUK_TVAL_GET_HEAPHDR(tv__dst); \ + DUK_ASSERT(h__obj != NULL); \ + DUK_TVAL_SET_TVAL(tv__dst, tv__src); \ + DUK_HEAPHDR_DECREF_FAST((thr), h__obj); /* side effects */ \ + } else { \ + DUK_TVAL_SET_TVAL(tv__dst, tv__src); \ + } \ + } while (0) + +/* XXX: no optimized variants yet */ +#define DUK_TVAL_SET_UNDEFINED_UPDREF DUK_TVAL_SET_UNDEFINED_UPDREF_ALT0 +#define DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ_ALT0 +#define DUK_TVAL_SET_UNUSED_UPDREF DUK_TVAL_SET_UNUSED_UPDREF_ALT0 +#define DUK_TVAL_SET_NULL_UPDREF DUK_TVAL_SET_NULL_UPDREF_ALT0 +#define DUK_TVAL_SET_BOOLEAN_UPDREF DUK_TVAL_SET_BOOLEAN_UPDREF_ALT0 +#define DUK_TVAL_SET_NUMBER_UPDREF DUK_TVAL_SET_NUMBER_UPDREF_ALT0 +#define DUK_TVAL_SET_NUMBER_CHKFAST_UPDREF DUK_TVAL_SET_NUMBER_CHKFAST_UPDREF_ALT0 +#define DUK_TVAL_SET_DOUBLE_UPDREF DUK_TVAL_SET_DOUBLE_UPDREF_ALT0 +#define DUK_TVAL_SET_NAN_UPDREF DUK_TVAL_SET_NAN_UPDREF_ALT0 +#if defined(DUK_USE_FASTINT) +#define DUK_TVAL_SET_I48_UPDREF DUK_TVAL_SET_I48_UPDREF_ALT0 +#define DUK_TVAL_SET_I32_UPDREF DUK_TVAL_SET_I32_UPDREF_ALT0 +#define DUK_TVAL_SET_U32_UPDREF DUK_TVAL_SET_U32_UPDREF_ALT0 +#else +#define DUK_TVAL_SET_I48_UPDREF DUK_TVAL_SET_DOUBLE_CAST_UPDREF /* XXX: fast int-to-double */ +#define DUK_TVAL_SET_I32_UPDREF DUK_TVAL_SET_DOUBLE_CAST_UPDREF +#define DUK_TVAL_SET_U32_UPDREF DUK_TVAL_SET_DOUBLE_CAST_UPDREF +#endif /* DUK_USE_FASTINT */ +#define DUK_TVAL_SET_FASTINT_UPDREF DUK_TVAL_SET_I48_UPDREF /* convenience */ +#define DUK_TVAL_SET_LIGHTFUNC_UPDREF DUK_TVAL_SET_LIGHTFUNC_UPDREF_ALT0 +#define DUK_TVAL_SET_STRING_UPDREF DUK_TVAL_SET_STRING_UPDREF_ALT0 +#define DUK_TVAL_SET_OBJECT_UPDREF DUK_TVAL_SET_OBJECT_UPDREF_ALT0 +#define DUK_TVAL_SET_BUFFER_UPDREF DUK_TVAL_SET_BUFFER_UPDREF_ALT0 +#define DUK_TVAL_SET_POINTER_UPDREF DUK_TVAL_SET_POINTER_UPDREF_ALT0 + +#if defined(DUK_USE_FAST_REFCOUNT_DEFAULT) +/* Optimized for speed. */ +#define DUK_TVAL_SET_TVAL_UPDREF DUK_TVAL_SET_TVAL_UPDREF_ALT1 +#define DUK_TVAL_SET_TVAL_UPDREF_FAST DUK_TVAL_SET_TVAL_UPDREF_ALT1 +#define DUK_TVAL_SET_TVAL_UPDREF_SLOW DUK_TVAL_SET_TVAL_UPDREF_ALT0 +#else +/* Optimized for size. */ +#define DUK_TVAL_SET_TVAL_UPDREF DUK_TVAL_SET_TVAL_UPDREF_ALT0 +#define DUK_TVAL_SET_TVAL_UPDREF_FAST DUK_TVAL_SET_TVAL_UPDREF_ALT0 +#define DUK_TVAL_SET_TVAL_UPDREF_SLOW DUK_TVAL_SET_TVAL_UPDREF_ALT0 +#endif + +#else /* DUK_USE_REFERENCE_COUNTING */ + +#define DUK_TVAL_NEEDS_REFCOUNT_UPDATE(tv) 0 +#define DUK_HEAPHDR_NEEDS_REFCOUNT_UPDATE(h) 0 + +#define DUK_TVAL_INCREF_FAST(thr, v) \ + do { \ + } while (0) /* nop */ +#define DUK_TVAL_DECREF_FAST(thr, v) \ + do { \ + } while (0) /* nop */ +#define DUK_TVAL_DECREF_NORZ_FAST(thr, v) \ + do { \ + } while (0) /* nop */ +#define DUK_TVAL_INCREF_SLOW(thr, v) \ + do { \ + } while (0) /* nop */ +#define DUK_TVAL_DECREF_SLOW(thr, v) \ + do { \ + } while (0) /* nop */ +#define DUK_TVAL_DECREF_NORZ_SLOW(thr, v) \ + do { \ + } while (0) /* nop */ +#define DUK_TVAL_INCREF(thr, v) \ + do { \ + } while (0) /* nop */ +#define DUK_TVAL_DECREF(thr, v) \ + do { \ + } while (0) /* nop */ +#define DUK_TVAL_DECREF_NORZ(thr, v) \ + do { \ + } while (0) /* nop */ +#define DUK_HEAPHDR_INCREF_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HEAPHDR_DECREF_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HEAPHDR_DECREF_NORZ_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HEAPHDR_INCREF_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HEAPHDR_DECREF_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HEAPHDR_DECREF_NORZ_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HEAPHDR_INCREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HEAPHDR_DECREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HEAPHDR_DECREF_NORZ(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HSTRING_INCREF_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HSTRING_DECREF_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HSTRING_DECREF_NORZ_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HSTRING_INCREF_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HSTRING_DECREF_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HSTRING_DECREF_NORZ_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HSTRING_INCREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HSTRING_DECREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HSTRING_DECREF_NORZ(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_INCREF_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_DECREF_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_DECREF_NORZ_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_INCREF_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_DECREF_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_DECREF_NORZ_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_INCREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_DECREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_DECREF_NORZ(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_INCREF_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_DECREF_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_DECREF_NORZ_FAST(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_INCREF_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_DECREF_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_DECREF_NORZ_SLOW(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_INCREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_DECREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_DECREF_NORZ(thr, h) \ + do { \ + } while (0) /* nop */ + +#define DUK_HCOMPFUNC_INCREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HCOMPFUNC_DECREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HCOMPFUNC_DECREF_NORZ(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HNATFUNC_INCREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HNATFUNC_DECREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HNATFUNC_DECREF_NORZ(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFOBJ_INCREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFOBJ_DECREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFOBJ_DECREF_NORZ(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HTHREAD_INCREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HTHREAD_DECREF(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HTHREAD_DECREF_NORZ(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_INCREF_ALLOWNULL(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_DECREF_ALLOWNULL(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_INCREF_ALLOWNULL(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_DECREF_ALLOWNULL(thr, h) \ + do { \ + } while (0) /* nop */ +#define DUK_HBUFFER_DECREF_NORZ_ALLOWNULL(thr, h) \ + do { \ + } while (0) /* nop */ + +#define DUK_REFZERO_CHECK_FAST(thr) \ + do { \ + } while (0) /* nop */ +#define DUK_REFZERO_CHECK_SLOW(thr) \ + do { \ + } while (0) /* nop */ + +#define DUK_TVAL_SET_UNDEFINED_UPDREF_ALT0(thr, tvptr_dst) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_UNDEFINED(tv__dst); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_UNUSED_UPDREF_ALT0(thr, tvptr_dst) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_UNUSED(tv__dst); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_NULL_UPDREF_ALT0(thr, tvptr_dst) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_NULL(tv__dst); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_BOOLEAN_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_BOOLEAN(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_NUMBER_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_NUMBER(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) +#define DUK_TVAL_SET_NUMBER_CHKFAST_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_NUMBER_CHKFAST_FAST(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) +#define DUK_TVAL_SET_DOUBLE_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_DOUBLE(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) +#define DUK_TVAL_SET_NAN_UPDREF_ALT0(thr, tvptr_dst) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_NAN(tv__dst); \ + DUK_UNREF((thr)); \ + } while (0) +#if defined(DUK_USE_FASTINT) +#define DUK_TVAL_SET_I48_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_I48(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) +#define DUK_TVAL_SET_I32_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_I32(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) +#define DUK_TVAL_SET_U32_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_U32(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) +#else +#define DUK_TVAL_SET_DOUBLE_CAST_UPDREF(thr, tvptr_dst, newval) \ + DUK_TVAL_SET_DOUBLE_UPDREF((thr), (tvptr_dst), (duk_double_t) (newval)) +#endif /* DUK_USE_FASTINT */ + +#define DUK_TVAL_SET_LIGHTFUNC_UPDREF_ALT0(thr, tvptr_dst, lf_v, lf_fp, lf_flags) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_LIGHTFUNC(tv__dst, (lf_v), (lf_fp), (lf_flags)); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_STRING_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_STRING(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_OBJECT_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_OBJECT(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_BUFFER_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_BUFFER(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_POINTER_UPDREF_ALT0(thr, tvptr_dst, newval) \ + do { \ + duk_tval *tv__dst; \ + tv__dst = (tvptr_dst); \ + DUK_TVAL_SET_POINTER(tv__dst, (newval)); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_TVAL_UPDREF_ALT0(thr, tvptr_dst, tvptr_src) \ + do { \ + duk_tval *tv__dst, *tv__src; \ + tv__dst = (tvptr_dst); \ + tv__src = (tvptr_src); \ + DUK_TVAL_SET_TVAL(tv__dst, tv__src); \ + DUK_UNREF((thr)); \ + } while (0) + +#define DUK_TVAL_SET_UNDEFINED_UPDREF DUK_TVAL_SET_UNDEFINED_UPDREF_ALT0 +#define DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ DUK_TVAL_SET_UNDEFINED_UPDREF_ALT0 +#define DUK_TVAL_SET_UNUSED_UPDREF DUK_TVAL_SET_UNUSED_UPDREF_ALT0 +#define DUK_TVAL_SET_NULL_UPDREF DUK_TVAL_SET_NULL_UPDREF_ALT0 +#define DUK_TVAL_SET_BOOLEAN_UPDREF DUK_TVAL_SET_BOOLEAN_UPDREF_ALT0 +#define DUK_TVAL_SET_NUMBER_UPDREF DUK_TVAL_SET_NUMBER_UPDREF_ALT0 +#define DUK_TVAL_SET_NUMBER_CHKFAST_UPDREF DUK_TVAL_SET_NUMBER_CHKFAST_UPDREF_ALT0 +#define DUK_TVAL_SET_DOUBLE_UPDREF DUK_TVAL_SET_DOUBLE_UPDREF_ALT0 +#define DUK_TVAL_SET_NAN_UPDREF DUK_TVAL_SET_NAN_UPDREF_ALT0 +#if defined(DUK_USE_FASTINT) +#define DUK_TVAL_SET_I48_UPDREF DUK_TVAL_SET_I48_UPDREF_ALT0 +#define DUK_TVAL_SET_I32_UPDREF DUK_TVAL_SET_I32_UPDREF_ALT0 +#define DUK_TVAL_SET_U32_UPDREF DUK_TVAL_SET_U32_UPDREF_ALT0 +#else +#define DUK_TVAL_SET_I48_UPDREF DUK_TVAL_SET_DOUBLE_CAST_UPDREF /* XXX: fast-int-to-double */ +#define DUK_TVAL_SET_I32_UPDREF DUK_TVAL_SET_DOUBLE_CAST_UPDREF +#define DUK_TVAL_SET_U32_UPDREF DUK_TVAL_SET_DOUBLE_CAST_UPDREF +#endif /* DUK_USE_FASTINT */ +#define DUK_TVAL_SET_FASTINT_UPDREF DUK_TVAL_SET_I48_UPDREF /* convenience */ +#define DUK_TVAL_SET_LIGHTFUNC_UPDREF DUK_TVAL_SET_LIGHTFUNC_UPDREF_ALT0 +#define DUK_TVAL_SET_STRING_UPDREF DUK_TVAL_SET_STRING_UPDREF_ALT0 +#define DUK_TVAL_SET_OBJECT_UPDREF DUK_TVAL_SET_OBJECT_UPDREF_ALT0 +#define DUK_TVAL_SET_BUFFER_UPDREF DUK_TVAL_SET_BUFFER_UPDREF_ALT0 +#define DUK_TVAL_SET_POINTER_UPDREF DUK_TVAL_SET_POINTER_UPDREF_ALT0 + +#define DUK_TVAL_SET_TVAL_UPDREF DUK_TVAL_SET_TVAL_UPDREF_ALT0 +#define DUK_TVAL_SET_TVAL_UPDREF_FAST DUK_TVAL_SET_TVAL_UPDREF_ALT0 +#define DUK_TVAL_SET_TVAL_UPDREF_SLOW DUK_TVAL_SET_TVAL_UPDREF_ALT0 + +#endif /* DUK_USE_REFERENCE_COUNTING */ + +/* + * Some convenience macros that don't have optimized implementations now. + */ + +#define DUK_TVAL_SET_TVAL_UPDREF_NORZ(thr, tv_dst, tv_src) \ + do { \ + duk_hthread *duk__thr = (thr); \ + duk_tval *duk__dst = (tv_dst); \ + duk_tval *duk__src = (tv_src); \ + DUK_UNREF(duk__thr); \ + DUK_TVAL_DECREF_NORZ(thr, duk__dst); \ + DUK_TVAL_SET_TVAL(duk__dst, duk__src); \ + DUK_TVAL_INCREF(thr, duk__dst); \ + } while (0) + +#define DUK_TVAL_SET_U32_UPDREF_NORZ(thr, tv_dst, val) \ + do { \ + duk_hthread *duk__thr = (thr); \ + duk_tval *duk__dst = (tv_dst); \ + duk_uint32_t duk__val = (duk_uint32_t) (val); \ + DUK_UNREF(duk__thr); \ + DUK_TVAL_DECREF_NORZ(thr, duk__dst); \ + DUK_TVAL_SET_U32(duk__dst, duk__val); \ + } while (0) + +/* + * Prototypes + */ + +#if defined(DUK_USE_REFERENCE_COUNTING) +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_INTERNAL_DECL void duk_refzero_check_slow(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_refzero_check_fast(duk_hthread *thr); +#endif +DUK_INTERNAL_DECL void duk_heaphdr_refcount_finalize_norz(duk_heap *heap, duk_heaphdr *hdr); +DUK_INTERNAL_DECL void duk_hobject_refcount_finalize_norz(duk_heap *heap, duk_hobject *h); +#if 0 /* Not needed: fast path handles inline; slow path uses duk_heaphdr_decref() which is needed anyway. */ +DUK_INTERNAL_DECL void duk_hstring_decref(duk_hthread *thr, duk_hstring *h); +DUK_INTERNAL_DECL void duk_hstring_decref_norz(duk_hthread *thr, duk_hstring *h); +DUK_INTERNAL_DECL void duk_hbuffer_decref(duk_hthread *thr, duk_hbuffer *h); +DUK_INTERNAL_DECL void duk_hbuffer_decref_norz(duk_hthread *thr, duk_hbuffer *h); +DUK_INTERNAL_DECL void duk_hobject_decref(duk_hthread *thr, duk_hobject *h); +DUK_INTERNAL_DECL void duk_hobject_decref_norz(duk_hthread *thr, duk_hobject *h); +#endif +DUK_INTERNAL_DECL void duk_heaphdr_refzero(duk_hthread *thr, duk_heaphdr *h); +DUK_INTERNAL_DECL void duk_heaphdr_refzero_norz(duk_hthread *thr, duk_heaphdr *h); +#if defined(DUK_USE_FAST_REFCOUNT_DEFAULT) +DUK_INTERNAL_DECL void duk_hstring_refzero(duk_hthread *thr, duk_hstring *h); /* no 'norz' variant */ +DUK_INTERNAL_DECL void duk_hbuffer_refzero(duk_hthread *thr, duk_hbuffer *h); /* no 'norz' variant */ +DUK_INTERNAL_DECL void duk_hobject_refzero(duk_hthread *thr, duk_hobject *h); +DUK_INTERNAL_DECL void duk_hobject_refzero_norz(duk_hthread *thr, duk_hobject *h); +#else +DUK_INTERNAL_DECL void duk_tval_incref(duk_tval *tv); +DUK_INTERNAL_DECL void duk_tval_decref(duk_hthread *thr, duk_tval *tv); +DUK_INTERNAL_DECL void duk_tval_decref_norz(duk_hthread *thr, duk_tval *tv); +DUK_INTERNAL_DECL void duk_heaphdr_incref(duk_heaphdr *h); +DUK_INTERNAL_DECL void duk_heaphdr_decref(duk_hthread *thr, duk_heaphdr *h); +DUK_INTERNAL_DECL void duk_heaphdr_decref_norz(duk_hthread *thr, duk_heaphdr *h); +#endif +#else /* DUK_USE_REFERENCE_COUNTING */ +/* no refcounting */ +#endif /* DUK_USE_REFERENCE_COUNTING */ + +#endif /* DUK_REFCOUNT_H_INCLUDED */ +/* #include duk_api_internal.h */ +#line 1 "duk_api_internal.h" +/* + * Internal API calls which have (stack and other) semantics similar + * to the public API. + */ + +#if !defined(DUK_API_INTERNAL_H_INCLUDED) +#define DUK_API_INTERNAL_H_INCLUDED + +/* Inline macro helpers. */ +#if defined(DUK_USE_PREFER_SIZE) +#define DUK_INLINE_PERF +#define DUK_ALWAYS_INLINE_PERF +#define DUK_NOINLINE_PERF +#else +#define DUK_INLINE_PERF DUK_INLINE +#define DUK_ALWAYS_INLINE_PERF DUK_ALWAYS_INLINE +#define DUK_NOINLINE_PERF DUK_NOINLINE +#endif + +/* Inline macro helpers, for bytecode executor. */ +#if defined(DUK_USE_EXEC_PREFER_SIZE) +#define DUK_EXEC_INLINE_PERF +#define DUK_EXEC_ALWAYS_INLINE_PERF +#define DUK_EXEC_NOINLINE_PERF +#else +#define DUK_EXEC_INLINE_PERF DUK_INLINE +#define DUK_EXEC_ALWAYS_INLINE_PERF DUK_ALWAYS_INLINE +#define DUK_EXEC_NOINLINE_PERF DUK_NOINLINE +#endif + +/* duk_push_sprintf constants */ +#define DUK_PUSH_SPRINTF_INITIAL_SIZE 256L +#define DUK_PUSH_SPRINTF_SANITY_LIMIT (1L * 1024L * 1024L * 1024L) + +/* Flag ORed to err_code to indicate __FILE__ / __LINE__ is not + * blamed as source of error for error fileName / lineNumber. + */ +#define DUK_ERRCODE_FLAG_NOBLAME_FILELINE (1L << 24) + +/* Current convention is to use duk_size_t for value stack sizes and global indices, + * and duk_idx_t for local frame indices. + */ +DUK_INTERNAL_DECL void duk_valstack_grow_check_throw(duk_hthread *thr, duk_size_t min_bytes); +DUK_INTERNAL_DECL duk_bool_t duk_valstack_grow_check_nothrow(duk_hthread *thr, duk_size_t min_bytes); +DUK_INTERNAL_DECL void duk_valstack_shrink_check_nothrow(duk_hthread *thr, duk_bool_t snug); + +DUK_INTERNAL_DECL void duk_copy_tvals_incref(duk_hthread *thr, duk_tval *tv_dst, duk_tval *tv_src, duk_size_t count); + +DUK_INTERNAL_DECL duk_tval *duk_reserve_gap(duk_hthread *thr, duk_idx_t idx_base, duk_idx_t count); + +DUK_INTERNAL_DECL void duk_set_top_unsafe(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL void duk_set_top_and_wipe(duk_hthread *thr, duk_idx_t top, duk_idx_t idx_wipe_start); + +DUK_INTERNAL_DECL void duk_dup_0(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_dup_1(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_dup_2(duk_hthread *thr); +/* duk_dup_m1() would be same as duk_dup_top() */ +DUK_INTERNAL_DECL void duk_dup_m2(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_dup_m3(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_dup_m4(duk_hthread *thr); + +DUK_INTERNAL_DECL void duk_remove_unsafe(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL void duk_remove_m2(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_remove_n(duk_hthread *thr, duk_idx_t idx, duk_idx_t count); +DUK_INTERNAL_DECL void duk_remove_n_unsafe(duk_hthread *thr, duk_idx_t idx, duk_idx_t count); + +DUK_INTERNAL_DECL duk_int_t duk_get_type_tval(duk_tval *tv); +DUK_INTERNAL_DECL duk_uint_t duk_get_type_mask_tval(duk_tval *tv); + +#if defined(DUK_USE_VERBOSE_ERRORS) && defined(DUK_USE_PARANOID_ERRORS) +DUK_INTERNAL_DECL const char *duk_get_type_name(duk_hthread *thr, duk_idx_t idx); +#endif +DUK_INTERNAL_DECL duk_small_uint_t duk_get_class_number(duk_hthread *thr, duk_idx_t idx); + +DUK_INTERNAL_DECL duk_tval *duk_get_tval(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_tval *duk_get_tval_or_unused(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_tval *duk_require_tval(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL void duk_push_tval(duk_hthread *thr, duk_tval *tv); + +/* Push the current 'this' binding; throw TypeError if binding is not object + * coercible (CheckObjectCoercible). + */ +DUK_INTERNAL_DECL void duk_push_this_check_object_coercible(duk_hthread *thr); + +/* duk_push_this() + CheckObjectCoercible() + duk_to_object() */ +DUK_INTERNAL_DECL duk_hobject *duk_push_this_coercible_to_object(duk_hthread *thr); + +/* duk_push_this() + CheckObjectCoercible() + duk_to_string() */ +DUK_INTERNAL_DECL duk_hstring *duk_push_this_coercible_to_string(duk_hthread *thr); + +DUK_INTERNAL_DECL duk_hstring *duk_push_uint_to_hstring(duk_hthread *thr, duk_uint_t i); + +/* Get a borrowed duk_tval pointer to the current 'this' binding. Caller must + * make sure there's an active callstack entry. Note that the returned pointer + * is unstable with regards to side effects. + */ +DUK_INTERNAL_DECL duk_tval *duk_get_borrowed_this_tval(duk_hthread *thr); + +/* XXX: add fastint support? */ +#define duk_push_u64(thr, val) duk_push_number((thr), (duk_double_t) (val)) +#define duk_push_i64(thr, val) duk_push_number((thr), (duk_double_t) (val)) + +/* duk_push_(u)int() is guaranteed to support at least (un)signed 32-bit range */ +#define duk_push_u32(thr, val) duk_push_uint((thr), (duk_uint_t) (val)) +#define duk_push_i32(thr, val) duk_push_int((thr), (duk_int_t) (val)) + +/* sometimes stack and array indices need to go on the stack */ +#define duk_push_idx(thr, val) duk_push_int((thr), (duk_int_t) (val)) +#define duk_push_uarridx(thr, val) duk_push_uint((thr), (duk_uint_t) (val)) +#define duk_push_size_t(thr, val) duk_push_uint((thr), (duk_uint_t) (val)) /* XXX: assumed to fit for now */ + +DUK_INTERNAL_DECL duk_bool_t duk_is_string_notsymbol(duk_hthread *thr, duk_idx_t idx); + +DUK_INTERNAL_DECL duk_bool_t duk_is_callable_tval(duk_hthread *thr, duk_tval *tv); + +DUK_INTERNAL_DECL duk_bool_t duk_is_bare_object(duk_hthread *thr, duk_idx_t idx); + +DUK_INTERNAL_DECL duk_hstring *duk_get_hstring(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hstring *duk_get_hstring_notsymbol(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL const char *duk_get_string_notsymbol(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hobject *duk_get_hobject(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hbuffer *duk_get_hbuffer(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hthread *duk_get_hthread(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hcompfunc *duk_get_hcompfunc(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hnatfunc *duk_get_hnatfunc(duk_hthread *thr, duk_idx_t idx); + +DUK_INTERNAL_DECL void *duk_get_buffer_data_raw(duk_hthread *thr, + duk_idx_t idx, + duk_size_t *out_size, + void *def_ptr, + duk_size_t def_len, + duk_bool_t throw_flag, + duk_bool_t *out_isbuffer); + +DUK_INTERNAL_DECL duk_hobject *duk_get_hobject_with_class(duk_hthread *thr, duk_idx_t idx, duk_small_uint_t classnum); + +DUK_INTERNAL_DECL duk_hobject *duk_get_hobject_promote_mask(duk_hthread *thr, duk_idx_t idx, duk_uint_t type_mask); +DUK_INTERNAL_DECL duk_hobject *duk_require_hobject_promote_mask(duk_hthread *thr, duk_idx_t idx, duk_uint_t type_mask); +DUK_INTERNAL_DECL duk_hobject *duk_require_hobject_accept_mask(duk_hthread *thr, duk_idx_t idx, duk_uint_t type_mask); +#define duk_require_hobject_promote_lfunc(thr, idx) duk_require_hobject_promote_mask((thr), (idx), DUK_TYPE_MASK_LIGHTFUNC) +#define duk_get_hobject_promote_lfunc(thr, idx) duk_get_hobject_promote_mask((thr), (idx), DUK_TYPE_MASK_LIGHTFUNC) + +#if 0 /*unused*/ +DUK_INTERNAL_DECL void *duk_get_voidptr(duk_hthread *thr, duk_idx_t idx); +#endif + +DUK_INTERNAL_DECL duk_hstring *duk_known_hstring(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hobject *duk_known_hobject(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hbuffer *duk_known_hbuffer(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hcompfunc *duk_known_hcompfunc(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hnatfunc *duk_known_hnatfunc(duk_hthread *thr, duk_idx_t idx); + +DUK_INTERNAL_DECL duk_double_t duk_to_number_tval(duk_hthread *thr, duk_tval *tv); + +DUK_INTERNAL_DECL duk_hstring *duk_to_hstring(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hstring *duk_to_hstring_m1(duk_hthread *thr); +DUK_INTERNAL_DECL duk_hstring *duk_to_hstring_acceptsymbol(duk_hthread *thr, duk_idx_t idx); + +DUK_INTERNAL_DECL duk_hobject *duk_to_hobject(duk_hthread *thr, duk_idx_t idx); + +DUK_INTERNAL_DECL duk_double_t duk_to_number_m1(duk_hthread *thr); +DUK_INTERNAL_DECL duk_double_t duk_to_number_m2(duk_hthread *thr); + +DUK_INTERNAL_DECL duk_bool_t duk_to_boolean_top_pop(duk_hthread *thr); + +#if defined(DUK_USE_DEBUGGER_SUPPORT) /* only needed by debugger for now */ +DUK_INTERNAL_DECL duk_hstring *duk_safe_to_hstring(duk_hthread *thr, duk_idx_t idx); +#endif +DUK_INTERNAL_DECL void duk_push_class_string_tval(duk_hthread *thr, duk_tval *tv, duk_bool_t avoid_side_effects); + +DUK_INTERNAL_DECL duk_int_t duk_to_int_clamped_raw(duk_hthread *thr, + duk_idx_t idx, + duk_int_t minval, + duk_int_t maxval, + duk_bool_t *out_clamped); /* out_clamped=NULL, RangeError if outside range */ +DUK_INTERNAL_DECL duk_int_t duk_to_int_clamped(duk_hthread *thr, duk_idx_t idx, duk_int_t minval, duk_int_t maxval); +DUK_INTERNAL_DECL duk_int_t duk_to_int_check_range(duk_hthread *thr, duk_idx_t idx, duk_int_t minval, duk_int_t maxval); +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL_DECL duk_uint8_t duk_to_uint8clamped(duk_hthread *thr, duk_idx_t idx); +#endif +DUK_INTERNAL_DECL duk_hstring *duk_to_property_key_hstring(duk_hthread *thr, duk_idx_t idx); + +DUK_INTERNAL_DECL duk_hstring *duk_require_hstring(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hstring *duk_require_hstring_notsymbol(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL const char *duk_require_lstring_notsymbol(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_len); +DUK_INTERNAL_DECL const char *duk_require_string_notsymbol(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hobject *duk_require_hobject(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hbuffer *duk_require_hbuffer(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hthread *duk_require_hthread(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hcompfunc *duk_require_hcompfunc(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL duk_hnatfunc *duk_require_hnatfunc(duk_hthread *thr, duk_idx_t idx); + +DUK_INTERNAL_DECL duk_hobject *duk_require_hobject_with_class(duk_hthread *thr, duk_idx_t idx, duk_small_uint_t classnum); + +DUK_INTERNAL_DECL void duk_push_hstring(duk_hthread *thr, duk_hstring *h); +DUK_INTERNAL_DECL void duk_push_hstring_stridx(duk_hthread *thr, duk_small_uint_t stridx); +DUK_INTERNAL_DECL void duk_push_hstring_empty(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_push_hobject(duk_hthread *thr, duk_hobject *h); +DUK_INTERNAL_DECL void duk_push_hbuffer(duk_hthread *thr, duk_hbuffer *h); +#define duk_push_hthread(thr, h) duk_push_hobject((thr), (duk_hobject *) (h)) +#define duk_push_hnatfunc(thr, h) duk_push_hobject((thr), (duk_hobject *) (h)) +DUK_INTERNAL_DECL void duk_push_hobject_bidx(duk_hthread *thr, duk_small_int_t builtin_idx); +DUK_INTERNAL_DECL duk_hobject *duk_push_object_helper(duk_hthread *thr, + duk_uint_t hobject_flags_and_class, + duk_small_int_t prototype_bidx); +DUK_INTERNAL_DECL duk_hobject *duk_push_object_helper_proto(duk_hthread *thr, + duk_uint_t hobject_flags_and_class, + duk_hobject *proto); +DUK_INTERNAL_DECL duk_hcompfunc *duk_push_hcompfunc(duk_hthread *thr); +DUK_INTERNAL_DECL duk_hboundfunc *duk_push_hboundfunc(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_push_c_function_builtin(duk_hthread *thr, duk_c_function func, duk_int_t nargs); +DUK_INTERNAL_DECL void duk_push_c_function_builtin_noconstruct(duk_hthread *thr, duk_c_function func, duk_int_t nargs); + +/* XXX: duk_push_harray() and duk_push_hcompfunc() are inconsistent with + * duk_push_hobject() etc which don't create a new value. + */ +DUK_INTERNAL_DECL duk_harray *duk_push_harray(duk_hthread *thr); +DUK_INTERNAL_DECL duk_harray *duk_push_harray_with_size(duk_hthread *thr, duk_uint32_t size); +DUK_INTERNAL_DECL duk_tval *duk_push_harray_with_size_outptr(duk_hthread *thr, duk_uint32_t size); + +DUK_INTERNAL_DECL void duk_push_string_funcptr(duk_hthread *thr, duk_uint8_t *ptr, duk_size_t sz); +DUK_INTERNAL_DECL void duk_push_lightfunc_name_raw(duk_hthread *thr, duk_c_function func, duk_small_uint_t lf_flags); +DUK_INTERNAL_DECL void duk_push_lightfunc_name(duk_hthread *thr, duk_tval *tv); +DUK_INTERNAL_DECL void duk_push_lightfunc_tostring(duk_hthread *thr, duk_tval *tv); +#if 0 /* not used yet */ +DUK_INTERNAL_DECL void duk_push_hnatfunc_name(duk_hthread *thr, duk_hnatfunc *h); +#endif +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL_DECL duk_hbufobj *duk_push_bufobj_raw(duk_hthread *thr, + duk_uint_t hobject_flags_and_class, + duk_small_int_t prototype_bidx); +#endif + +DUK_INTERNAL_DECL void *duk_push_fixed_buffer_nozero(duk_hthread *thr, duk_size_t len); +DUK_INTERNAL_DECL void *duk_push_fixed_buffer_zero(duk_hthread *thr, duk_size_t len); + +DUK_INTERNAL_DECL const char *duk_push_string_readable(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL const char *duk_push_string_tval_readable(duk_hthread *thr, duk_tval *tv); +DUK_INTERNAL_DECL const char *duk_push_string_tval_readable_error(duk_hthread *thr, duk_tval *tv); + +/* The duk_xxx_prop_stridx_short() variants expect their arguments to be short + * enough to be packed into a single 32-bit integer argument. Argument limits + * vary per call; typically 16 bits are assigned to the signed value stack index + * and the stridx. In practice these work well for footprint with constant + * arguments and such call sites are also easiest to verify to be correct. + */ + +DUK_INTERNAL_DECL duk_bool_t duk_get_prop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx); /* [] -> [val] */ +DUK_INTERNAL_DECL duk_bool_t duk_get_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args); +#define duk_get_prop_stridx_short(thr, obj_idx, stridx) \ + (DUK_ASSERT_EXPR((duk_int_t) (obj_idx) >= -0x8000L && (duk_int_t) (obj_idx) <= 0x7fffL), \ + DUK_ASSERT_EXPR((duk_int_t) (stridx) >= 0 && (duk_int_t) (stridx) <= 0xffffL), \ + duk_get_prop_stridx_short_raw((thr), (((duk_uint_t) (obj_idx)) << 16) + ((duk_uint_t) (stridx)))) +DUK_INTERNAL_DECL duk_bool_t duk_get_prop_stridx_boolean(duk_hthread *thr, + duk_idx_t obj_idx, + duk_small_uint_t stridx, + duk_bool_t *out_has_prop); /* [] -> [] */ + +DUK_INTERNAL_DECL duk_bool_t duk_xget_owndataprop(duk_hthread *thr, duk_idx_t obj_idx); +DUK_INTERNAL_DECL duk_bool_t duk_xget_owndataprop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx); +DUK_INTERNAL_DECL duk_bool_t duk_xget_owndataprop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args); +#define duk_xget_owndataprop_stridx_short(thr, obj_idx, stridx) \ + (DUK_ASSERT_EXPR((duk_int_t) (obj_idx) >= -0x8000L && (duk_int_t) (obj_idx) <= 0x7fffL), \ + DUK_ASSERT_EXPR((duk_int_t) (stridx) >= 0 && (duk_int_t) (stridx) <= 0xffffL), \ + duk_xget_owndataprop_stridx_short_raw((thr), (((duk_uint_t) (obj_idx)) << 16) + ((duk_uint_t) (stridx)))) + +DUK_INTERNAL_DECL duk_bool_t duk_put_prop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx); /* [val] -> [] */ +DUK_INTERNAL_DECL duk_bool_t duk_put_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args); +#define duk_put_prop_stridx_short(thr, obj_idx, stridx) \ + (DUK_ASSERT_EXPR((duk_int_t) (obj_idx) >= -0x8000L && (duk_int_t) (obj_idx) <= 0x7fffL), \ + DUK_ASSERT_EXPR((duk_int_t) (stridx) >= 0 && (duk_int_t) (stridx) <= 0xffffL), \ + duk_put_prop_stridx_short_raw((thr), (((duk_uint_t) (obj_idx)) << 16) + ((duk_uint_t) (stridx)))) + +DUK_INTERNAL_DECL duk_bool_t duk_del_prop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx); /* [] -> [] */ +#if 0 /* Too few call sites to be useful. */ +DUK_INTERNAL_DECL duk_bool_t duk_del_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args); +#define duk_del_prop_stridx_short(thr, obj_idx, stridx) \ + (DUK_ASSERT_EXPR((obj_idx) >= -0x8000L && (obj_idx) <= 0x7fffL), \ + DUK_ASSERT_EXPR((stridx) >= 0 && (stridx) <= 0xffffL), \ + duk_del_prop_stridx_short_raw((thr), (((duk_uint_t) (obj_idx)) << 16) + ((duk_uint_t) (stridx)))) +#endif +#define duk_del_prop_stridx_short(thr, obj_idx, stridx) duk_del_prop_stridx((thr), (obj_idx), (stridx)) + +DUK_INTERNAL_DECL duk_bool_t duk_has_prop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx); /* [] -> [] */ +#if 0 /* Too few call sites to be useful. */ +DUK_INTERNAL_DECL duk_bool_t duk_has_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args); +#define duk_has_prop_stridx_short(thr, obj_idx, stridx) \ + (DUK_ASSERT_EXPR((obj_idx) >= -0x8000L && (obj_idx) <= 0x7fffL), \ + DUK_ASSERT_EXPR((stridx) >= 0 && (stridx) <= 0xffffL), \ + duk_has_prop_stridx_short_raw((thr), (((duk_uint_t) (obj_idx)) << 16) + ((duk_uint_t) (stridx)))) +#endif +#define duk_has_prop_stridx_short(thr, obj_idx, stridx) duk_has_prop_stridx((thr), (obj_idx), (stridx)) + +DUK_INTERNAL_DECL void duk_xdef_prop(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t desc_flags); /* [key val] -> [] */ + +DUK_INTERNAL_DECL void duk_xdef_prop_index(duk_hthread *thr, + duk_idx_t obj_idx, + duk_uarridx_t arr_idx, + duk_small_uint_t desc_flags); /* [val] -> [] */ + +/* XXX: Because stridx and desc_flags have a limited range, this call could + * always pack stridx and desc_flags into a single argument. + */ +DUK_INTERNAL_DECL void duk_xdef_prop_stridx(duk_hthread *thr, + duk_idx_t obj_idx, + duk_small_uint_t stridx, + duk_small_uint_t desc_flags); /* [val] -> [] */ +DUK_INTERNAL_DECL void duk_xdef_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args); +#define duk_xdef_prop_stridx_short(thr, obj_idx, stridx, desc_flags) \ + (DUK_ASSERT_EXPR((duk_int_t) (obj_idx) >= -0x80L && (duk_int_t) (obj_idx) <= 0x7fL), \ + DUK_ASSERT_EXPR((duk_int_t) (stridx) >= 0 && (duk_int_t) (stridx) <= 0xffffL), \ + DUK_ASSERT_EXPR((duk_int_t) (desc_flags) >= 0 && (duk_int_t) (desc_flags) <= 0xffL), \ + duk_xdef_prop_stridx_short_raw((thr), \ + (((duk_uint_t) (obj_idx)) << 24) + (((duk_uint_t) (stridx)) << 8) + \ + (duk_uint_t) (desc_flags))) + +#define duk_xdef_prop_wec(thr, obj_idx) duk_xdef_prop((thr), (obj_idx), DUK_PROPDESC_FLAGS_WEC) +#define duk_xdef_prop_index_wec(thr, obj_idx, arr_idx) duk_xdef_prop_index((thr), (obj_idx), (arr_idx), DUK_PROPDESC_FLAGS_WEC) +#define duk_xdef_prop_stridx_wec(thr, obj_idx, stridx) duk_xdef_prop_stridx((thr), (obj_idx), (stridx), DUK_PROPDESC_FLAGS_WEC) +#define duk_xdef_prop_stridx_short_wec(thr, obj_idx, stridx) \ + duk_xdef_prop_stridx_short((thr), (obj_idx), (stridx), DUK_PROPDESC_FLAGS_WEC) + +#if 0 /*unused*/ +DUK_INTERNAL_DECL void duk_xdef_prop_stridx_builtin(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx, duk_small_int_t builtin_idx, duk_small_uint_t desc_flags); /* [] -> [] */ +#endif + +DUK_INTERNAL_DECL void duk_xdef_prop_stridx_thrower(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx); /* [] -> [] */ + +DUK_INTERNAL_DECL duk_bool_t duk_get_method_stridx(duk_hthread *thr, duk_idx_t idx, duk_small_uint_t stridx); + +DUK_INTERNAL_DECL void duk_pack(duk_hthread *thr, duk_idx_t count); +DUK_INTERNAL_DECL duk_idx_t duk_unpack_array_like(duk_hthread *thr, duk_idx_t idx); +#if 0 +DUK_INTERNAL_DECL void duk_unpack(duk_hthread *thr); +#endif + +DUK_INTERNAL_DECL void duk_push_symbol_descriptive_string(duk_hthread *thr, duk_hstring *h); + +DUK_INTERNAL_DECL void duk_resolve_nonbound_function(duk_hthread *thr); + +DUK_INTERNAL_DECL duk_idx_t duk_get_top_require_min(duk_hthread *thr, duk_idx_t min_top); +DUK_INTERNAL_DECL duk_idx_t duk_get_top_index_unsafe(duk_hthread *thr); + +DUK_INTERNAL_DECL void duk_pop_n_unsafe(duk_hthread *thr, duk_idx_t count); +DUK_INTERNAL_DECL void duk_pop_unsafe(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_pop_2_unsafe(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_pop_3_unsafe(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_pop_n_nodecref_unsafe(duk_hthread *thr, duk_idx_t count); +DUK_INTERNAL_DECL void duk_pop_nodecref_unsafe(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_pop_2_nodecref_unsafe(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_pop_3_nodecref_unsafe(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_pop_undefined(duk_hthread *thr); + +DUK_INTERNAL_DECL void duk_compact_m1(duk_hthread *thr); + +DUK_INTERNAL_DECL void duk_seal_freeze_raw(duk_hthread *thr, duk_idx_t obj_idx, duk_bool_t is_freeze); + +DUK_INTERNAL_DECL void duk_insert_undefined(duk_hthread *thr, duk_idx_t idx); +DUK_INTERNAL_DECL void duk_insert_undefined_n(duk_hthread *thr, duk_idx_t idx, duk_idx_t count); + +DUK_INTERNAL_DECL void duk_concat_2(duk_hthread *thr); + +DUK_INTERNAL_DECL duk_int_t duk_pcall_method_flags(duk_hthread *thr, duk_idx_t nargs, duk_small_uint_t call_flags); + +#if defined(DUK_USE_SYMBOL_BUILTIN) +DUK_INTERNAL_DECL void duk_to_primitive_ordinary(duk_hthread *thr, duk_idx_t idx, duk_int_t hint); +#endif + +DUK_INTERNAL_DECL void duk_clear_prototype(duk_hthread *thr, duk_idx_t idx); + +/* Raw internal valstack access macros: access is unsafe so call site + * must have a guarantee that the index is valid. When that is the case, + * using these macro results in faster and smaller code than duk_get_tval(). + * Both 'ctx' and 'idx' are evaluted multiple times, but only for asserts. + */ +#define DUK_ASSERT_VALID_NEGIDX(thr, idx) \ + (DUK_ASSERT_EXPR((duk_int_t) (idx) < 0), DUK_ASSERT_EXPR(duk_is_valid_index((thr), (idx)))) +#define DUK_ASSERT_VALID_POSIDX(thr, idx) \ + (DUK_ASSERT_EXPR((duk_int_t) (idx) >= 0), DUK_ASSERT_EXPR(duk_is_valid_index((thr), (idx)))) +#define DUK_GET_TVAL_NEGIDX(thr, idx) (DUK_ASSERT_VALID_NEGIDX((thr), (idx)), ((duk_hthread *) (thr))->valstack_top + (idx)) +#define DUK_GET_TVAL_POSIDX(thr, idx) (DUK_ASSERT_VALID_POSIDX((thr), (idx)), ((duk_hthread *) (thr))->valstack_bottom + (idx)) +#define DUK_GET_HOBJECT_NEGIDX(thr, idx) \ + (DUK_ASSERT_VALID_NEGIDX((thr), (idx)), DUK_TVAL_GET_OBJECT(((duk_hthread *) (thr))->valstack_top + (idx))) +#define DUK_GET_HOBJECT_POSIDX(thr, idx) \ + (DUK_ASSERT_VALID_POSIDX((thr), (idx)), DUK_TVAL_GET_OBJECT(((duk_hthread *) (thr))->valstack_bottom + (idx))) + +#define DUK_GET_THIS_TVAL_PTR(thr) (DUK_ASSERT_EXPR((thr)->valstack_bottom > (thr)->valstack), (thr)->valstack_bottom - 1) + +DUK_INTERNAL_DECL duk_double_t duk_time_get_ecmascript_time(duk_hthread *thr); +DUK_INTERNAL_DECL duk_double_t duk_time_get_ecmascript_time_nofrac(duk_hthread *thr); +DUK_INTERNAL_DECL duk_double_t duk_time_get_monotonic_time(duk_hthread *thr); + +#endif /* DUK_API_INTERNAL_H_INCLUDED */ +/* #include duk_hstring.h */ +#line 1 "duk_hstring.h" +/* + * Heap string representation. + * + * Strings are byte sequences ordinarily stored in extended UTF-8 format, + * allowing values larger than the official UTF-8 range (used internally) + * and also allowing UTF-8 encoding of surrogate pairs (CESU-8 format). + * Strings may also be invalid UTF-8 altogether which is the case e.g. with + * strings used as internal property names and raw buffers converted to + * strings. In such cases the 'clen' field contains an inaccurate value. + * + * ECMAScript requires support for 32-bit long strings. However, since each + * 16-bit codepoint can take 3 bytes in CESU-8, this representation can only + * support about 1.4G codepoint long strings in extreme cases. This is not + * really a practical issue. + */ + +#if !defined(DUK_HSTRING_H_INCLUDED) +#define DUK_HSTRING_H_INCLUDED + +/* Impose a maximum string length for now. Restricted artificially to + * ensure adding a heap header length won't overflow size_t. The limit + * should be synchronized with DUK_HBUFFER_MAX_BYTELEN. + * + * E5.1 makes provisions to support strings longer than 4G characters. + * This limit should be eliminated on 64-bit platforms (and increased + * closer to maximum support on 32-bit platforms). + */ + +#if defined(DUK_USE_STRLEN16) +#define DUK_HSTRING_MAX_BYTELEN (0x0000ffffUL) +#else +#define DUK_HSTRING_MAX_BYTELEN (0x7fffffffUL) +#endif + +/* XXX: could add flags for "is valid CESU-8" (ECMAScript compatible strings), + * "is valid UTF-8", "is valid extended UTF-8" (internal strings are not, + * regexp bytecode is), and "contains non-BMP characters". These are not + * needed right now. + */ + +/* With lowmem builds the high 16 bits of duk_heaphdr are used for other + * purposes, so this leaves 7 duk_heaphdr flags and 9 duk_hstring flags. + */ +#define DUK_HSTRING_FLAG_ASCII DUK_HEAPHDR_USER_FLAG(0) /* string is ASCII, clen == blen */ +#define DUK_HSTRING_FLAG_ARRIDX DUK_HEAPHDR_USER_FLAG(1) /* string is a valid array index */ +#define DUK_HSTRING_FLAG_SYMBOL DUK_HEAPHDR_USER_FLAG(2) /* string is a symbol (invalid utf-8) */ +#define DUK_HSTRING_FLAG_HIDDEN \ + DUK_HEAPHDR_USER_FLAG(3) /* string is a hidden symbol (implies symbol, Duktape 1.x internal string) */ +#define DUK_HSTRING_FLAG_RESERVED_WORD DUK_HEAPHDR_USER_FLAG(4) /* string is a reserved word (non-strict) */ +#define DUK_HSTRING_FLAG_STRICT_RESERVED_WORD DUK_HEAPHDR_USER_FLAG(5) /* string is a reserved word (strict) */ +#define DUK_HSTRING_FLAG_EVAL_OR_ARGUMENTS DUK_HEAPHDR_USER_FLAG(6) /* string is 'eval' or 'arguments' */ +#define DUK_HSTRING_FLAG_EXTDATA DUK_HEAPHDR_USER_FLAG(7) /* string data is external (duk_hstring_external) */ +#define DUK_HSTRING_FLAG_PINNED_LITERAL DUK_HEAPHDR_USER_FLAG(8) /* string is a literal, and pinned */ + +#define DUK_HSTRING_HAS_ASCII(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_ASCII) +#define DUK_HSTRING_HAS_ARRIDX(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_ARRIDX) +#define DUK_HSTRING_HAS_SYMBOL(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_SYMBOL) +#define DUK_HSTRING_HAS_HIDDEN(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_HIDDEN) +#define DUK_HSTRING_HAS_RESERVED_WORD(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_RESERVED_WORD) +#define DUK_HSTRING_HAS_STRICT_RESERVED_WORD(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_STRICT_RESERVED_WORD) +#define DUK_HSTRING_HAS_EVAL_OR_ARGUMENTS(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_EVAL_OR_ARGUMENTS) +#define DUK_HSTRING_HAS_EXTDATA(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_EXTDATA) +#define DUK_HSTRING_HAS_PINNED_LITERAL(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_PINNED_LITERAL) + +#define DUK_HSTRING_SET_ASCII(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_ASCII) +#define DUK_HSTRING_SET_ARRIDX(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_ARRIDX) +#define DUK_HSTRING_SET_SYMBOL(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_SYMBOL) +#define DUK_HSTRING_SET_HIDDEN(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_HIDDEN) +#define DUK_HSTRING_SET_RESERVED_WORD(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_RESERVED_WORD) +#define DUK_HSTRING_SET_STRICT_RESERVED_WORD(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_STRICT_RESERVED_WORD) +#define DUK_HSTRING_SET_EVAL_OR_ARGUMENTS(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_EVAL_OR_ARGUMENTS) +#define DUK_HSTRING_SET_EXTDATA(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_EXTDATA) +#define DUK_HSTRING_SET_PINNED_LITERAL(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_PINNED_LITERAL) + +#define DUK_HSTRING_CLEAR_ASCII(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_ASCII) +#define DUK_HSTRING_CLEAR_ARRIDX(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_ARRIDX) +#define DUK_HSTRING_CLEAR_SYMBOL(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_SYMBOL) +#define DUK_HSTRING_CLEAR_HIDDEN(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_HIDDEN) +#define DUK_HSTRING_CLEAR_RESERVED_WORD(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_RESERVED_WORD) +#define DUK_HSTRING_CLEAR_STRICT_RESERVED_WORD(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_STRICT_RESERVED_WORD) +#define DUK_HSTRING_CLEAR_EVAL_OR_ARGUMENTS(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_EVAL_OR_ARGUMENTS) +#define DUK_HSTRING_CLEAR_EXTDATA(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_EXTDATA) +#define DUK_HSTRING_CLEAR_PINNED_LITERAL(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HSTRING_FLAG_PINNED_LITERAL) + +#if 0 /* Slightly smaller code without explicit flag, but explicit flag \ + * is very useful when 'clen' is dropped. \ + */ +#define DUK_HSTRING_IS_ASCII(x) (DUK_HSTRING_GET_BYTELEN((x)) == DUK_HSTRING_GET_CHARLEN((x))) +#endif +#define DUK_HSTRING_IS_ASCII(x) DUK_HSTRING_HAS_ASCII((x)) /* lazily set! */ +#define DUK_HSTRING_IS_EMPTY(x) (DUK_HSTRING_GET_BYTELEN((x)) == 0) + +#if defined(DUK_USE_STRHASH16) +#define DUK_HSTRING_GET_HASH(x) ((x)->hdr.h_flags >> 16) +#define DUK_HSTRING_SET_HASH(x, v) \ + do { \ + (x)->hdr.h_flags = ((x)->hdr.h_flags & 0x0000ffffUL) | ((v) << 16); \ + } while (0) +#else +#define DUK_HSTRING_GET_HASH(x) ((x)->hash) +#define DUK_HSTRING_SET_HASH(x, v) \ + do { \ + (x)->hash = (v); \ + } while (0) +#endif + +#if defined(DUK_USE_STRLEN16) +#define DUK_HSTRING_GET_BYTELEN(x) ((x)->hdr.h_strextra16) +#define DUK_HSTRING_SET_BYTELEN(x, v) \ + do { \ + (x)->hdr.h_strextra16 = (v); \ + } while (0) +#if defined(DUK_USE_HSTRING_CLEN) +#define DUK_HSTRING_GET_CHARLEN(x) duk_hstring_get_charlen((x)) +#define DUK_HSTRING_SET_CHARLEN(x, v) \ + do { \ + (x)->clen16 = (v); \ + } while (0) +#else +#define DUK_HSTRING_GET_CHARLEN(x) duk_hstring_get_charlen((x)) +#define DUK_HSTRING_SET_CHARLEN(x, v) \ + do { \ + DUK_ASSERT(0); /* should never be called */ \ + } while (0) +#endif +#else +#define DUK_HSTRING_GET_BYTELEN(x) ((x)->blen) +#define DUK_HSTRING_SET_BYTELEN(x, v) \ + do { \ + (x)->blen = (v); \ + } while (0) +#define DUK_HSTRING_GET_CHARLEN(x) duk_hstring_get_charlen((x)) +#define DUK_HSTRING_SET_CHARLEN(x, v) \ + do { \ + (x)->clen = (v); \ + } while (0) +#endif + +#if defined(DUK_USE_HSTRING_EXTDATA) +#define DUK_HSTRING_GET_EXTDATA(x) ((x)->extdata) +#define DUK_HSTRING_GET_DATA(x) \ + (DUK_HSTRING_HAS_EXTDATA((x)) ? DUK_HSTRING_GET_EXTDATA((const duk_hstring_external *) (x)) : \ + ((const duk_uint8_t *) ((x) + 1))) +#else +#define DUK_HSTRING_GET_DATA(x) ((const duk_uint8_t *) ((x) + 1)) +#endif + +#define DUK_HSTRING_GET_DATA_END(x) (DUK_HSTRING_GET_DATA((x)) + (x)->blen) + +/* Marker value; in E5 2^32-1 is not a valid array index (2^32-2 is highest + * valid). + */ +#define DUK_HSTRING_NO_ARRAY_INDEX (0xffffffffUL) + +#if defined(DUK_USE_HSTRING_ARRIDX) +#define DUK_HSTRING_GET_ARRIDX_FAST(h) ((h)->arridx) +#define DUK_HSTRING_GET_ARRIDX_SLOW(h) ((h)->arridx) +#else +/* Get array index related to string (or return DUK_HSTRING_NO_ARRAY_INDEX); + * avoids helper call if string has no array index value. + */ +#define DUK_HSTRING_GET_ARRIDX_FAST(h) \ + (DUK_HSTRING_HAS_ARRIDX((h)) ? duk_js_to_arrayindex_hstring_fast_known((h)) : DUK_HSTRING_NO_ARRAY_INDEX) + +/* Slower but more compact variant. */ +#define DUK_HSTRING_GET_ARRIDX_SLOW(h) (duk_js_to_arrayindex_hstring_fast((h))) +#endif + +/* XXX: these actually fit into duk_hstring */ +#define DUK_SYMBOL_TYPE_HIDDEN 0 +#define DUK_SYMBOL_TYPE_GLOBAL 1 +#define DUK_SYMBOL_TYPE_LOCAL 2 +#define DUK_SYMBOL_TYPE_WELLKNOWN 3 + +/* Assertion for duk_hstring validity. */ +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_hstring_assert_valid(duk_hstring *h); +#define DUK_HSTRING_ASSERT_VALID(h) \ + do { \ + duk_hstring_assert_valid((h)); \ + } while (0) +#else +#define DUK_HSTRING_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +/* + * Misc + */ + +struct duk_hstring { + /* Smaller heaphdr than for other objects, because strings are held + * in string intern table which requires no link pointers. Much of + * the 32-bit flags field is unused by flags, so we can stuff a 16-bit + * field in there. + */ + duk_heaphdr_string hdr; + + /* String hash. */ +#if defined(DUK_USE_STRHASH16) + /* If 16-bit hash is in use, stuff it into duk_heaphdr_string flags. */ +#else + duk_uint32_t hash; +#endif + + /* Precomputed array index (or DUK_HSTRING_NO_ARRAY_INDEX). */ +#if defined(DUK_USE_HSTRING_ARRIDX) + duk_uarridx_t arridx; +#endif + + /* Length in bytes (not counting NUL term). */ +#if defined(DUK_USE_STRLEN16) + /* placed in duk_heaphdr_string */ +#else + duk_uint32_t blen; +#endif + + /* Length in codepoints (must be E5 compatible). */ +#if defined(DUK_USE_STRLEN16) +#if defined(DUK_USE_HSTRING_CLEN) + duk_uint16_t clen16; +#else + /* computed live */ +#endif +#else + duk_uint32_t clen; +#endif + + /* + * String data of 'blen+1' bytes follows (+1 for NUL termination + * convenience for C API). No alignment needs to be guaranteed + * for strings, but fields above should guarantee alignment-by-4 + * (but not alignment-by-8). + */ +}; + +/* The external string struct is defined even when the feature is inactive. */ +struct duk_hstring_external { + duk_hstring str; + + /* + * For an external string, the NUL-terminated string data is stored + * externally. The user must guarantee that data behind this pointer + * doesn't change while it's used. + */ + + const duk_uint8_t *extdata; +}; + +/* + * Prototypes + */ + +DUK_INTERNAL_DECL duk_ucodepoint_t duk_hstring_char_code_at_raw(duk_hthread *thr, + duk_hstring *h, + duk_uint_t pos, + duk_bool_t surrogate_aware); +DUK_INTERNAL_DECL duk_bool_t duk_hstring_equals_ascii_cstring(duk_hstring *h, const char *cstr); +DUK_INTERNAL_DECL duk_size_t duk_hstring_get_charlen(duk_hstring *h); +#if !defined(DUK_USE_HSTRING_LAZY_CLEN) +DUK_INTERNAL_DECL void duk_hstring_init_charlen(duk_hstring *h); +#endif + +#endif /* DUK_HSTRING_H_INCLUDED */ +/* #include duk_hobject.h */ +#line 1 "duk_hobject.h" +/* + * Heap object representation. + * + * Heap objects are used for ECMAScript objects, arrays, and functions, + * but also for internal control like declarative and object environment + * records. Compiled functions, native functions, and threads are also + * objects but with an extended C struct. + * + * Objects provide the required ECMAScript semantics and exotic behaviors + * especially for property access. + * + * Properties are stored in three conceptual parts: + * + * 1. A linear 'entry part' contains ordered key-value-attributes triples + * and is the main method of string properties. + * + * 2. An optional linear 'array part' is used for array objects to store a + * (dense) range of [0,N[ array indexed entries with default attributes + * (writable, enumerable, configurable). If the array part would become + * sparse or non-default attributes are required, the array part is + * abandoned and moved to the 'entry part'. + * + * 3. An optional 'hash part' is used to optimize lookups of the entry + * part; it is used only for objects with sufficiently many properties + * and can be abandoned without loss of information. + * + * These three conceptual parts are stored in a single memory allocated area. + * This minimizes memory allocation overhead but also means that all three + * parts are resized together, and makes property access a bit complicated. + */ + +#if !defined(DUK_HOBJECT_H_INCLUDED) +#define DUK_HOBJECT_H_INCLUDED + +/* Object flags. Make sure this stays in sync with debugger object + * inspection code. + */ + +/* XXX: some flags are object subtype specific (e.g. common to all function + * subtypes, duk_harray, etc) and could be reused for different subtypes. + */ +#define DUK_HOBJECT_FLAG_EXTENSIBLE DUK_HEAPHDR_USER_FLAG(0) /* object is extensible */ +#define DUK_HOBJECT_FLAG_CONSTRUCTABLE DUK_HEAPHDR_USER_FLAG(1) /* object is constructable */ +#define DUK_HOBJECT_FLAG_CALLABLE DUK_HEAPHDR_USER_FLAG(2) /* object is callable */ +#define DUK_HOBJECT_FLAG_BOUNDFUNC DUK_HEAPHDR_USER_FLAG(3) /* object established using Function.prototype.bind() */ +#define DUK_HOBJECT_FLAG_COMPFUNC DUK_HEAPHDR_USER_FLAG(4) /* object is a compiled function (duk_hcompfunc) */ +#define DUK_HOBJECT_FLAG_NATFUNC DUK_HEAPHDR_USER_FLAG(5) /* object is a native function (duk_hnatfunc) */ +#define DUK_HOBJECT_FLAG_BUFOBJ DUK_HEAPHDR_USER_FLAG(6) /* object is a buffer object (duk_hbufobj) (always exotic) */ +#define DUK_HOBJECT_FLAG_FASTREFS \ + DUK_HEAPHDR_USER_FLAG(7) /* object has no fields needing DECREF/marking beyond base duk_hobject header */ +#define DUK_HOBJECT_FLAG_ARRAY_PART DUK_HEAPHDR_USER_FLAG(8) /* object has an array part (a_size may still be 0) */ +#define DUK_HOBJECT_FLAG_STRICT DUK_HEAPHDR_USER_FLAG(9) /* function: function object is strict */ +#define DUK_HOBJECT_FLAG_NOTAIL DUK_HEAPHDR_USER_FLAG(10) /* function: function must not be tail called */ +#define DUK_HOBJECT_FLAG_NEWENV DUK_HEAPHDR_USER_FLAG(11) /* function: create new environment when called (see duk_hcompfunc) */ +#define DUK_HOBJECT_FLAG_NAMEBINDING \ + DUK_HEAPHDR_USER_FLAG( \ + 12) /* function: create binding for func name (function templates only, used for named function expressions) */ +#define DUK_HOBJECT_FLAG_CREATEARGS DUK_HEAPHDR_USER_FLAG(13) /* function: create an arguments object on function call */ +#define DUK_HOBJECT_FLAG_HAVE_FINALIZER DUK_HEAPHDR_USER_FLAG(14) /* object has a callable (own) finalizer property */ +#define DUK_HOBJECT_FLAG_EXOTIC_ARRAY DUK_HEAPHDR_USER_FLAG(15) /* 'Array' object, array length and index exotic behavior */ +#define DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ DUK_HEAPHDR_USER_FLAG(16) /* 'String' object, array index exotic behavior */ +#define DUK_HOBJECT_FLAG_EXOTIC_ARGUMENTS \ + DUK_HEAPHDR_USER_FLAG(17) /* 'Arguments' object and has arguments exotic behavior (non-strict callee) */ +#define DUK_HOBJECT_FLAG_EXOTIC_PROXYOBJ DUK_HEAPHDR_USER_FLAG(18) /* 'Proxy' object */ +#define DUK_HOBJECT_FLAG_SPECIAL_CALL DUK_HEAPHDR_USER_FLAG(19) /* special casing in call behavior, for .call(), .apply(), etc. */ + +#define DUK_HOBJECT_FLAG_CLASS_BASE DUK_HEAPHDR_USER_FLAG_NUMBER(20) +#define DUK_HOBJECT_FLAG_CLASS_BITS 5 + +#define DUK_HOBJECT_GET_CLASS_NUMBER(h) \ + DUK_HEAPHDR_GET_FLAG_RANGE(&(h)->hdr, DUK_HOBJECT_FLAG_CLASS_BASE, DUK_HOBJECT_FLAG_CLASS_BITS) +#define DUK_HOBJECT_SET_CLASS_NUMBER(h, v) \ + DUK_HEAPHDR_SET_FLAG_RANGE(&(h)->hdr, DUK_HOBJECT_FLAG_CLASS_BASE, DUK_HOBJECT_FLAG_CLASS_BITS, (v)) + +#define DUK_HOBJECT_GET_CLASS_MASK(h) \ + (1UL << DUK_HEAPHDR_GET_FLAG_RANGE(&(h)->hdr, DUK_HOBJECT_FLAG_CLASS_BASE, DUK_HOBJECT_FLAG_CLASS_BITS)) + +/* Macro for creating flag initializer from a class number. + * Unsigned type cast is needed to avoid warnings about coercing + * a signed integer to an unsigned one; the largest class values + * have the highest bit (bit 31) set which causes this. + */ +#define DUK_HOBJECT_CLASS_AS_FLAGS(v) (((duk_uint_t) (v)) << DUK_HOBJECT_FLAG_CLASS_BASE) + +/* E5 Section 8.6.2 + custom classes */ +#define DUK_HOBJECT_CLASS_NONE 0 +#define DUK_HOBJECT_CLASS_OBJECT 1 +#define DUK_HOBJECT_CLASS_ARRAY 2 +#define DUK_HOBJECT_CLASS_FUNCTION 3 +#define DUK_HOBJECT_CLASS_ARGUMENTS 4 +#define DUK_HOBJECT_CLASS_BOOLEAN 5 +#define DUK_HOBJECT_CLASS_DATE 6 +#define DUK_HOBJECT_CLASS_ERROR 7 +#define DUK_HOBJECT_CLASS_JSON 8 +#define DUK_HOBJECT_CLASS_MATH 9 +#define DUK_HOBJECT_CLASS_NUMBER 10 +#define DUK_HOBJECT_CLASS_REGEXP 11 +#define DUK_HOBJECT_CLASS_STRING 12 +#define DUK_HOBJECT_CLASS_GLOBAL 13 +#define DUK_HOBJECT_CLASS_SYMBOL 14 +#define DUK_HOBJECT_CLASS_OBJENV 15 /* custom */ +#define DUK_HOBJECT_CLASS_DECENV 16 /* custom */ +#define DUK_HOBJECT_CLASS_POINTER 17 /* custom */ +#define DUK_HOBJECT_CLASS_THREAD 18 /* custom; implies DUK_HOBJECT_IS_THREAD */ +#define DUK_HOBJECT_CLASS_BUFOBJ_MIN 19 +#define DUK_HOBJECT_CLASS_ARRAYBUFFER 19 /* implies DUK_HOBJECT_IS_BUFOBJ */ +#define DUK_HOBJECT_CLASS_DATAVIEW 20 +#define DUK_HOBJECT_CLASS_INT8ARRAY 21 +#define DUK_HOBJECT_CLASS_UINT8ARRAY 22 +#define DUK_HOBJECT_CLASS_UINT8CLAMPEDARRAY 23 +#define DUK_HOBJECT_CLASS_INT16ARRAY 24 +#define DUK_HOBJECT_CLASS_UINT16ARRAY 25 +#define DUK_HOBJECT_CLASS_INT32ARRAY 26 +#define DUK_HOBJECT_CLASS_UINT32ARRAY 27 +#define DUK_HOBJECT_CLASS_FLOAT32ARRAY 28 +#define DUK_HOBJECT_CLASS_FLOAT64ARRAY 29 +#define DUK_HOBJECT_CLASS_BUFOBJ_MAX 29 +#define DUK_HOBJECT_CLASS_MAX 29 + +/* Class masks. */ +#define DUK_HOBJECT_CMASK_ALL ((1UL << (DUK_HOBJECT_CLASS_MAX + 1)) - 1UL) +#define DUK_HOBJECT_CMASK_NONE (1UL << DUK_HOBJECT_CLASS_NONE) +#define DUK_HOBJECT_CMASK_ARGUMENTS (1UL << DUK_HOBJECT_CLASS_ARGUMENTS) +#define DUK_HOBJECT_CMASK_ARRAY (1UL << DUK_HOBJECT_CLASS_ARRAY) +#define DUK_HOBJECT_CMASK_BOOLEAN (1UL << DUK_HOBJECT_CLASS_BOOLEAN) +#define DUK_HOBJECT_CMASK_DATE (1UL << DUK_HOBJECT_CLASS_DATE) +#define DUK_HOBJECT_CMASK_ERROR (1UL << DUK_HOBJECT_CLASS_ERROR) +#define DUK_HOBJECT_CMASK_FUNCTION (1UL << DUK_HOBJECT_CLASS_FUNCTION) +#define DUK_HOBJECT_CMASK_JSON (1UL << DUK_HOBJECT_CLASS_JSON) +#define DUK_HOBJECT_CMASK_MATH (1UL << DUK_HOBJECT_CLASS_MATH) +#define DUK_HOBJECT_CMASK_NUMBER (1UL << DUK_HOBJECT_CLASS_NUMBER) +#define DUK_HOBJECT_CMASK_OBJECT (1UL << DUK_HOBJECT_CLASS_OBJECT) +#define DUK_HOBJECT_CMASK_REGEXP (1UL << DUK_HOBJECT_CLASS_REGEXP) +#define DUK_HOBJECT_CMASK_STRING (1UL << DUK_HOBJECT_CLASS_STRING) +#define DUK_HOBJECT_CMASK_GLOBAL (1UL << DUK_HOBJECT_CLASS_GLOBAL) +#define DUK_HOBJECT_CMASK_SYMBOL (1UL << DUK_HOBJECT_CLASS_SYMBOL) +#define DUK_HOBJECT_CMASK_OBJENV (1UL << DUK_HOBJECT_CLASS_OBJENV) +#define DUK_HOBJECT_CMASK_DECENV (1UL << DUK_HOBJECT_CLASS_DECENV) +#define DUK_HOBJECT_CMASK_POINTER (1UL << DUK_HOBJECT_CLASS_POINTER) +#define DUK_HOBJECT_CMASK_ARRAYBUFFER (1UL << DUK_HOBJECT_CLASS_ARRAYBUFFER) +#define DUK_HOBJECT_CMASK_DATAVIEW (1UL << DUK_HOBJECT_CLASS_DATAVIEW) +#define DUK_HOBJECT_CMASK_INT8ARRAY (1UL << DUK_HOBJECT_CLASS_INT8ARRAY) +#define DUK_HOBJECT_CMASK_UINT8ARRAY (1UL << DUK_HOBJECT_CLASS_UINT8ARRAY) +#define DUK_HOBJECT_CMASK_UINT8CLAMPEDARRAY (1UL << DUK_HOBJECT_CLASS_UINT8CLAMPEDARRAY) +#define DUK_HOBJECT_CMASK_INT16ARRAY (1UL << DUK_HOBJECT_CLASS_INT16ARRAY) +#define DUK_HOBJECT_CMASK_UINT16ARRAY (1UL << DUK_HOBJECT_CLASS_UINT16ARRAY) +#define DUK_HOBJECT_CMASK_INT32ARRAY (1UL << DUK_HOBJECT_CLASS_INT32ARRAY) +#define DUK_HOBJECT_CMASK_UINT32ARRAY (1UL << DUK_HOBJECT_CLASS_UINT32ARRAY) +#define DUK_HOBJECT_CMASK_FLOAT32ARRAY (1UL << DUK_HOBJECT_CLASS_FLOAT32ARRAY) +#define DUK_HOBJECT_CMASK_FLOAT64ARRAY (1UL << DUK_HOBJECT_CLASS_FLOAT64ARRAY) + +#define DUK_HOBJECT_CMASK_ALL_BUFOBJS \ + (DUK_HOBJECT_CMASK_ARRAYBUFFER | DUK_HOBJECT_CMASK_DATAVIEW | DUK_HOBJECT_CMASK_INT8ARRAY | DUK_HOBJECT_CMASK_UINT8ARRAY | \ + DUK_HOBJECT_CMASK_UINT8CLAMPEDARRAY | DUK_HOBJECT_CMASK_INT16ARRAY | DUK_HOBJECT_CMASK_UINT16ARRAY | \ + DUK_HOBJECT_CMASK_INT32ARRAY | DUK_HOBJECT_CMASK_UINT32ARRAY | DUK_HOBJECT_CMASK_FLOAT32ARRAY | \ + DUK_HOBJECT_CMASK_FLOAT64ARRAY) + +#define DUK_HOBJECT_IS_OBJENV(h) (DUK_HOBJECT_GET_CLASS_NUMBER((h)) == DUK_HOBJECT_CLASS_OBJENV) +#define DUK_HOBJECT_IS_DECENV(h) (DUK_HOBJECT_GET_CLASS_NUMBER((h)) == DUK_HOBJECT_CLASS_DECENV) +#define DUK_HOBJECT_IS_ENV(h) (DUK_HOBJECT_IS_OBJENV((h)) || DUK_HOBJECT_IS_DECENV((h))) +#define DUK_HOBJECT_IS_ARRAY(h) DUK_HOBJECT_HAS_EXOTIC_ARRAY((h)) /* Rely on class Array <=> exotic Array */ +#define DUK_HOBJECT_IS_BOUNDFUNC(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_BOUNDFUNC) +#define DUK_HOBJECT_IS_COMPFUNC(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_COMPFUNC) +#define DUK_HOBJECT_IS_NATFUNC(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NATFUNC) +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +#define DUK_HOBJECT_IS_BUFOBJ(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_BUFOBJ) +#else +#define DUK_HOBJECT_IS_BUFOBJ(h) 0 +#endif +#define DUK_HOBJECT_IS_THREAD(h) (DUK_HOBJECT_GET_CLASS_NUMBER((h)) == DUK_HOBJECT_CLASS_THREAD) +#if defined(DUK_USE_ES6_PROXY) +#define DUK_HOBJECT_IS_PROXY(h) DUK_HOBJECT_HAS_EXOTIC_PROXYOBJ((h)) +#else +#define DUK_HOBJECT_IS_PROXY(h) 0 +#endif + +#define DUK_HOBJECT_IS_NONBOUND_FUNCTION(h) \ + DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_COMPFUNC | DUK_HOBJECT_FLAG_NATFUNC) + +#define DUK_HOBJECT_IS_FUNCTION(h) \ + DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_BOUNDFUNC | DUK_HOBJECT_FLAG_COMPFUNC | DUK_HOBJECT_FLAG_NATFUNC) + +#define DUK_HOBJECT_IS_CALLABLE(h) DUK_HOBJECT_HAS_CALLABLE((h)) + +/* Object has any exotic behavior(s). */ +#define DUK_HOBJECT_EXOTIC_BEHAVIOR_FLAGS \ + (DUK_HOBJECT_FLAG_EXOTIC_ARRAY | DUK_HOBJECT_FLAG_EXOTIC_ARGUMENTS | DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ | \ + DUK_HOBJECT_FLAG_BUFOBJ | DUK_HOBJECT_FLAG_EXOTIC_PROXYOBJ) +#define DUK_HOBJECT_HAS_EXOTIC_BEHAVIOR(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_EXOTIC_BEHAVIOR_FLAGS) + +/* Object has any virtual properties (not counting Proxy behavior). */ +#define DUK_HOBJECT_VIRTUAL_PROPERTY_FLAGS \ + (DUK_HOBJECT_FLAG_EXOTIC_ARRAY | DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ | DUK_HOBJECT_FLAG_BUFOBJ) +#define DUK_HOBJECT_HAS_VIRTUAL_PROPERTIES(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_VIRTUAL_PROPERTY_FLAGS) + +#define DUK_HOBJECT_HAS_EXTENSIBLE(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXTENSIBLE) +#define DUK_HOBJECT_HAS_CONSTRUCTABLE(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_CONSTRUCTABLE) +#define DUK_HOBJECT_HAS_CALLABLE(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_CALLABLE) +#define DUK_HOBJECT_HAS_BOUNDFUNC(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_BOUNDFUNC) +#define DUK_HOBJECT_HAS_COMPFUNC(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_COMPFUNC) +#define DUK_HOBJECT_HAS_NATFUNC(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NATFUNC) +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +#define DUK_HOBJECT_HAS_BUFOBJ(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_BUFOBJ) +#else +#define DUK_HOBJECT_HAS_BUFOBJ(h) 0 +#endif +#define DUK_HOBJECT_HAS_FASTREFS(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_FASTREFS) +#define DUK_HOBJECT_HAS_ARRAY_PART(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_ARRAY_PART) +#define DUK_HOBJECT_HAS_STRICT(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_STRICT) +#define DUK_HOBJECT_HAS_NOTAIL(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NOTAIL) +#define DUK_HOBJECT_HAS_NEWENV(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NEWENV) +#define DUK_HOBJECT_HAS_NAMEBINDING(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NAMEBINDING) +#define DUK_HOBJECT_HAS_CREATEARGS(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_CREATEARGS) +#define DUK_HOBJECT_HAS_HAVE_FINALIZER(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_HAVE_FINALIZER) +#define DUK_HOBJECT_HAS_EXOTIC_ARRAY(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_ARRAY) +#define DUK_HOBJECT_HAS_EXOTIC_STRINGOBJ(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ) +#define DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_ARGUMENTS) +#if defined(DUK_USE_ES6_PROXY) +#define DUK_HOBJECT_HAS_EXOTIC_PROXYOBJ(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_PROXYOBJ) +#else +#define DUK_HOBJECT_HAS_EXOTIC_PROXYOBJ(h) 0 +#endif +#define DUK_HOBJECT_HAS_SPECIAL_CALL(h) DUK_HEAPHDR_CHECK_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_SPECIAL_CALL) + +#define DUK_HOBJECT_SET_EXTENSIBLE(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXTENSIBLE) +#define DUK_HOBJECT_SET_CONSTRUCTABLE(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_CONSTRUCTABLE) +#define DUK_HOBJECT_SET_CALLABLE(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_CALLABLE) +#define DUK_HOBJECT_SET_BOUNDFUNC(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_BOUNDFUNC) +#define DUK_HOBJECT_SET_COMPFUNC(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_COMPFUNC) +#define DUK_HOBJECT_SET_NATFUNC(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NATFUNC) +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +#define DUK_HOBJECT_SET_BUFOBJ(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_BUFOBJ) +#endif +#define DUK_HOBJECT_SET_FASTREFS(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_FASTREFS) +#define DUK_HOBJECT_SET_ARRAY_PART(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_ARRAY_PART) +#define DUK_HOBJECT_SET_STRICT(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_STRICT) +#define DUK_HOBJECT_SET_NOTAIL(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NOTAIL) +#define DUK_HOBJECT_SET_NEWENV(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NEWENV) +#define DUK_HOBJECT_SET_NAMEBINDING(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NAMEBINDING) +#define DUK_HOBJECT_SET_CREATEARGS(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_CREATEARGS) +#define DUK_HOBJECT_SET_HAVE_FINALIZER(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_HAVE_FINALIZER) +#define DUK_HOBJECT_SET_EXOTIC_ARRAY(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_ARRAY) +#define DUK_HOBJECT_SET_EXOTIC_STRINGOBJ(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ) +#define DUK_HOBJECT_SET_EXOTIC_ARGUMENTS(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_ARGUMENTS) +#if defined(DUK_USE_ES6_PROXY) +#define DUK_HOBJECT_SET_EXOTIC_PROXYOBJ(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_PROXYOBJ) +#endif +#define DUK_HOBJECT_SET_SPECIAL_CALL(h) DUK_HEAPHDR_SET_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_SPECIAL_CALL) + +#define DUK_HOBJECT_CLEAR_EXTENSIBLE(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXTENSIBLE) +#define DUK_HOBJECT_CLEAR_CONSTRUCTABLE(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_CONSTRUCTABLE) +#define DUK_HOBJECT_CLEAR_CALLABLE(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_CALLABLE) +#define DUK_HOBJECT_CLEAR_BOUNDFUNC(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_BOUNDFUNC) +#define DUK_HOBJECT_CLEAR_COMPFUNC(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_COMPFUNC) +#define DUK_HOBJECT_CLEAR_NATFUNC(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NATFUNC) +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +#define DUK_HOBJECT_CLEAR_BUFOBJ(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_BUFOBJ) +#endif +#define DUK_HOBJECT_CLEAR_FASTREFS(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_FASTREFS) +#define DUK_HOBJECT_CLEAR_ARRAY_PART(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_ARRAY_PART) +#define DUK_HOBJECT_CLEAR_STRICT(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_STRICT) +#define DUK_HOBJECT_CLEAR_NOTAIL(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NOTAIL) +#define DUK_HOBJECT_CLEAR_NEWENV(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NEWENV) +#define DUK_HOBJECT_CLEAR_NAMEBINDING(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_NAMEBINDING) +#define DUK_HOBJECT_CLEAR_CREATEARGS(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_CREATEARGS) +#define DUK_HOBJECT_CLEAR_HAVE_FINALIZER(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_HAVE_FINALIZER) +#define DUK_HOBJECT_CLEAR_EXOTIC_ARRAY(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_ARRAY) +#define DUK_HOBJECT_CLEAR_EXOTIC_STRINGOBJ(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ) +#define DUK_HOBJECT_CLEAR_EXOTIC_ARGUMENTS(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_ARGUMENTS) +#if defined(DUK_USE_ES6_PROXY) +#define DUK_HOBJECT_CLEAR_EXOTIC_PROXYOBJ(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_EXOTIC_PROXYOBJ) +#endif +#define DUK_HOBJECT_CLEAR_SPECIAL_CALL(h) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(h)->hdr, DUK_HOBJECT_FLAG_SPECIAL_CALL) + +/* Object can/cannot use FASTREFS, i.e. has no strong reference fields beyond + * duk_hobject base header. This is used just for asserts so doesn't need to + * be optimized. + */ +#define DUK_HOBJECT_PROHIBITS_FASTREFS(h) \ + (DUK_HOBJECT_IS_COMPFUNC((h)) || DUK_HOBJECT_IS_DECENV((h)) || DUK_HOBJECT_IS_OBJENV((h)) || DUK_HOBJECT_IS_BUFOBJ((h)) || \ + DUK_HOBJECT_IS_THREAD((h)) || DUK_HOBJECT_IS_PROXY((h)) || DUK_HOBJECT_IS_BOUNDFUNC((h))) +#define DUK_HOBJECT_ALLOWS_FASTREFS(h) (!DUK_HOBJECT_PROHIBITS_FASTREFS((h))) + +/* Flags used for property attributes in duk_propdesc and packed flags. + * Must fit into 8 bits. + */ +#define DUK_PROPDESC_FLAG_WRITABLE (1U << 0) /* E5 Section 8.6.1 */ +#define DUK_PROPDESC_FLAG_ENUMERABLE (1U << 1) /* E5 Section 8.6.1 */ +#define DUK_PROPDESC_FLAG_CONFIGURABLE (1U << 2) /* E5 Section 8.6.1 */ +#define DUK_PROPDESC_FLAG_ACCESSOR (1U << 3) /* accessor */ +#define DUK_PROPDESC_FLAG_VIRTUAL \ + (1U << 4) /* property is virtual: used in duk_propdesc, never stored \ + * (used by e.g. buffer virtual properties) \ + */ +#define DUK_PROPDESC_FLAGS_MASK \ + (DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_ENUMERABLE | DUK_PROPDESC_FLAG_CONFIGURABLE | DUK_PROPDESC_FLAG_ACCESSOR) + +/* Additional flags which are passed in the same flags argument as property + * flags but are not stored in object properties. + */ +#define DUK_PROPDESC_FLAG_NO_OVERWRITE (1U << 4) /* internal define property: skip write silently if exists */ + +/* Convenience defines for property attributes. */ +#define DUK_PROPDESC_FLAGS_NONE 0 +#define DUK_PROPDESC_FLAGS_W (DUK_PROPDESC_FLAG_WRITABLE) +#define DUK_PROPDESC_FLAGS_E (DUK_PROPDESC_FLAG_ENUMERABLE) +#define DUK_PROPDESC_FLAGS_C (DUK_PROPDESC_FLAG_CONFIGURABLE) +#define DUK_PROPDESC_FLAGS_WE (DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_ENUMERABLE) +#define DUK_PROPDESC_FLAGS_WC (DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_CONFIGURABLE) +#define DUK_PROPDESC_FLAGS_EC (DUK_PROPDESC_FLAG_ENUMERABLE | DUK_PROPDESC_FLAG_CONFIGURABLE) +#define DUK_PROPDESC_FLAGS_WEC (DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_ENUMERABLE | DUK_PROPDESC_FLAG_CONFIGURABLE) + +/* Flags for duk_hobject_get_own_propdesc() and variants. */ +#define DUK_GETDESC_FLAG_PUSH_VALUE (1U << 0) /* push value to stack */ +#define DUK_GETDESC_FLAG_IGNORE_PROTOLOOP (1U << 1) /* don't throw for prototype loop */ + +/* + * Macro for object validity check + * + * Assert for currently guaranteed relations between flags, for instance. + */ + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_hobject_assert_valid(duk_hobject *h); +#define DUK_HOBJECT_ASSERT_VALID(h) \ + do { \ + duk_hobject_assert_valid((h)); \ + } while (0) +#else +#define DUK_HOBJECT_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +/* + * Macros to access the 'props' allocation. + */ + +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HOBJECT_GET_PROPS(heap, h) ((duk_uint8_t *) DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, ((duk_heaphdr *) (h))->h_extra16)) +#define DUK_HOBJECT_SET_PROPS(heap, h, x) \ + do { \ + ((duk_heaphdr *) (h))->h_extra16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) (x)); \ + } while (0) +#else +#define DUK_HOBJECT_GET_PROPS(heap, h) ((h)->props) +#define DUK_HOBJECT_SET_PROPS(heap, h, x) \ + do { \ + (h)->props = (duk_uint8_t *) (x); \ + } while (0) +#endif + +#if defined(DUK_USE_HOBJECT_LAYOUT_1) +/* LAYOUT 1 */ +#define DUK_HOBJECT_E_GET_KEY_BASE(heap, h) ((duk_hstring **) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)))) +#define DUK_HOBJECT_E_GET_VALUE_BASE(heap, h) \ + ((duk_propvalue *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + DUK_HOBJECT_GET_ESIZE((h)) * sizeof(duk_hstring *))) +#define DUK_HOBJECT_E_GET_FLAGS_BASE(heap, h) \ + ((duk_uint8_t *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + \ + DUK_HOBJECT_GET_ESIZE((h)) * (sizeof(duk_hstring *) + sizeof(duk_propvalue)))) +#define DUK_HOBJECT_A_GET_BASE(heap, h) \ + ((duk_tval *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + \ + DUK_HOBJECT_GET_ESIZE((h)) * \ + (sizeof(duk_hstring *) + sizeof(duk_propvalue) + sizeof(duk_uint8_t)))) +#define DUK_HOBJECT_H_GET_BASE(heap, h) \ + ((duk_uint32_t *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + \ + DUK_HOBJECT_GET_ESIZE((h)) * \ + (sizeof(duk_hstring *) + sizeof(duk_propvalue) + sizeof(duk_uint8_t)) + \ + DUK_HOBJECT_GET_ASIZE((h)) * sizeof(duk_tval))) +#define DUK_HOBJECT_P_COMPUTE_SIZE(n_ent, n_arr, n_hash) \ + ((n_ent) * (sizeof(duk_hstring *) + sizeof(duk_propvalue) + sizeof(duk_uint8_t)) + (n_arr) * sizeof(duk_tval) + \ + (n_hash) * sizeof(duk_uint32_t)) +#define DUK_HOBJECT_P_SET_REALLOC_PTRS(p_base, set_e_k, set_e_pv, set_e_f, set_a, set_h, n_ent, n_arr, n_hash) \ + do { \ + (set_e_k) = (duk_hstring **) (void *) (p_base); \ + (set_e_pv) = (duk_propvalue *) (void *) ((set_e_k) + (n_ent)); \ + (set_e_f) = (duk_uint8_t *) (void *) ((set_e_pv) + (n_ent)); \ + (set_a) = (duk_tval *) (void *) ((set_e_f) + (n_ent)); \ + (set_h) = (duk_uint32_t *) (void *) ((set_a) + (n_arr)); \ + } while (0) +#elif defined(DUK_USE_HOBJECT_LAYOUT_2) +/* LAYOUT 2 */ +#if (DUK_USE_ALIGN_BY == 4) +#define DUK_HOBJECT_E_FLAG_PADDING(e_sz) ((4 - (e_sz)) & 0x03) +#elif (DUK_USE_ALIGN_BY == 8) +#define DUK_HOBJECT_E_FLAG_PADDING(e_sz) ((8 - (e_sz)) & 0x07) +#elif (DUK_USE_ALIGN_BY == 1) +#define DUK_HOBJECT_E_FLAG_PADDING(e_sz) 0 +#else +#error invalid DUK_USE_ALIGN_BY +#endif +#define DUK_HOBJECT_E_GET_KEY_BASE(heap, h) \ + ((duk_hstring **) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + DUK_HOBJECT_GET_ESIZE((h)) * sizeof(duk_propvalue))) +#define DUK_HOBJECT_E_GET_VALUE_BASE(heap, h) ((duk_propvalue *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)))) +#define DUK_HOBJECT_E_GET_FLAGS_BASE(heap, h) \ + ((duk_uint8_t *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + \ + DUK_HOBJECT_GET_ESIZE((h)) * (sizeof(duk_hstring *) + sizeof(duk_propvalue)))) +#define DUK_HOBJECT_A_GET_BASE(heap, h) \ + ((duk_tval *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + \ + DUK_HOBJECT_GET_ESIZE((h)) * \ + (sizeof(duk_hstring *) + sizeof(duk_propvalue) + sizeof(duk_uint8_t)) + \ + DUK_HOBJECT_E_FLAG_PADDING(DUK_HOBJECT_GET_ESIZE((h))))) +#define DUK_HOBJECT_H_GET_BASE(heap, h) \ + ((duk_uint32_t *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + \ + DUK_HOBJECT_GET_ESIZE((h)) * \ + (sizeof(duk_hstring *) + sizeof(duk_propvalue) + sizeof(duk_uint8_t)) + \ + DUK_HOBJECT_E_FLAG_PADDING(DUK_HOBJECT_GET_ESIZE((h))) + \ + DUK_HOBJECT_GET_ASIZE((h)) * sizeof(duk_tval))) +#define DUK_HOBJECT_P_COMPUTE_SIZE(n_ent, n_arr, n_hash) \ + ((n_ent) * (sizeof(duk_hstring *) + sizeof(duk_propvalue) + sizeof(duk_uint8_t)) + DUK_HOBJECT_E_FLAG_PADDING((n_ent)) + \ + (n_arr) * sizeof(duk_tval) + (n_hash) * sizeof(duk_uint32_t)) +#define DUK_HOBJECT_P_SET_REALLOC_PTRS(p_base, set_e_k, set_e_pv, set_e_f, set_a, set_h, n_ent, n_arr, n_hash) \ + do { \ + (set_e_pv) = (duk_propvalue *) (void *) (p_base); \ + (set_e_k) = (duk_hstring **) (void *) ((set_e_pv) + (n_ent)); \ + (set_e_f) = (duk_uint8_t *) (void *) ((set_e_k) + (n_ent)); \ + (set_a) = (duk_tval *) (void *) (((duk_uint8_t *) (set_e_f)) + sizeof(duk_uint8_t) * (n_ent) + \ + DUK_HOBJECT_E_FLAG_PADDING((n_ent))); \ + (set_h) = (duk_uint32_t *) (void *) ((set_a) + (n_arr)); \ + } while (0) +#elif defined(DUK_USE_HOBJECT_LAYOUT_3) +/* LAYOUT 3 */ +#define DUK_HOBJECT_E_GET_KEY_BASE(heap, h) \ + ((duk_hstring **) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + DUK_HOBJECT_GET_ESIZE((h)) * sizeof(duk_propvalue) + \ + DUK_HOBJECT_GET_ASIZE((h)) * sizeof(duk_tval))) +#define DUK_HOBJECT_E_GET_VALUE_BASE(heap, h) ((duk_propvalue *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)))) +#define DUK_HOBJECT_E_GET_FLAGS_BASE(heap, h) \ + ((duk_uint8_t *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + \ + DUK_HOBJECT_GET_ESIZE((h)) * (sizeof(duk_propvalue) + sizeof(duk_hstring *)) + \ + DUK_HOBJECT_GET_ASIZE((h)) * sizeof(duk_tval) + \ + DUK_HOBJECT_GET_HSIZE((h)) * sizeof(duk_uint32_t))) +#define DUK_HOBJECT_A_GET_BASE(heap, h) \ + ((duk_tval *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + DUK_HOBJECT_GET_ESIZE((h)) * sizeof(duk_propvalue))) +#define DUK_HOBJECT_H_GET_BASE(heap, h) \ + ((duk_uint32_t *) (void *) (DUK_HOBJECT_GET_PROPS((heap), (h)) + \ + DUK_HOBJECT_GET_ESIZE((h)) * (sizeof(duk_propvalue) + sizeof(duk_hstring *)) + \ + DUK_HOBJECT_GET_ASIZE((h)) * sizeof(duk_tval))) +#define DUK_HOBJECT_P_COMPUTE_SIZE(n_ent, n_arr, n_hash) \ + ((n_ent) * (sizeof(duk_propvalue) + sizeof(duk_hstring *) + sizeof(duk_uint8_t)) + (n_arr) * sizeof(duk_tval) + \ + (n_hash) * sizeof(duk_uint32_t)) +#define DUK_HOBJECT_P_SET_REALLOC_PTRS(p_base, set_e_k, set_e_pv, set_e_f, set_a, set_h, n_ent, n_arr, n_hash) \ + do { \ + (set_e_pv) = (duk_propvalue *) (void *) (p_base); \ + (set_a) = (duk_tval *) (void *) ((set_e_pv) + (n_ent)); \ + (set_e_k) = (duk_hstring **) (void *) ((set_a) + (n_arr)); \ + (set_h) = (duk_uint32_t *) (void *) ((set_e_k) + (n_ent)); \ + (set_e_f) = (duk_uint8_t *) (void *) ((set_h) + (n_hash)); \ + } while (0) +#else +#error invalid hobject layout defines +#endif /* hobject property layout */ + +#define DUK_HOBJECT_P_ALLOC_SIZE(h) \ + DUK_HOBJECT_P_COMPUTE_SIZE(DUK_HOBJECT_GET_ESIZE((h)), DUK_HOBJECT_GET_ASIZE((h)), DUK_HOBJECT_GET_HSIZE((h))) + +#define DUK_HOBJECT_E_GET_KEY(heap, h, i) (DUK_HOBJECT_E_GET_KEY_BASE((heap), (h))[(i)]) +#define DUK_HOBJECT_E_GET_KEY_PTR(heap, h, i) (&DUK_HOBJECT_E_GET_KEY_BASE((heap), (h))[(i)]) +#define DUK_HOBJECT_E_GET_VALUE(heap, h, i) (DUK_HOBJECT_E_GET_VALUE_BASE((heap), (h))[(i)]) +#define DUK_HOBJECT_E_GET_VALUE_PTR(heap, h, i) (&DUK_HOBJECT_E_GET_VALUE_BASE((heap), (h))[(i)]) +#define DUK_HOBJECT_E_GET_VALUE_TVAL(heap, h, i) (DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)).v) +#define DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(heap, h, i) (&DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)).v) +#define DUK_HOBJECT_E_GET_VALUE_GETTER(heap, h, i) (DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)).a.get) +#define DUK_HOBJECT_E_GET_VALUE_GETTER_PTR(heap, h, i) (&DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)).a.get) +#define DUK_HOBJECT_E_GET_VALUE_SETTER(heap, h, i) (DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)).a.set) +#define DUK_HOBJECT_E_GET_VALUE_SETTER_PTR(heap, h, i) (&DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)).a.set) +#define DUK_HOBJECT_E_GET_FLAGS(heap, h, i) (DUK_HOBJECT_E_GET_FLAGS_BASE((heap), (h))[(i)]) +#define DUK_HOBJECT_E_GET_FLAGS_PTR(heap, h, i) (&DUK_HOBJECT_E_GET_FLAGS_BASE((heap), (h))[(i)]) +#define DUK_HOBJECT_A_GET_VALUE(heap, h, i) (DUK_HOBJECT_A_GET_BASE((heap), (h))[(i)]) +#define DUK_HOBJECT_A_GET_VALUE_PTR(heap, h, i) (&DUK_HOBJECT_A_GET_BASE((heap), (h))[(i)]) +#define DUK_HOBJECT_H_GET_INDEX(heap, h, i) (DUK_HOBJECT_H_GET_BASE((heap), (h))[(i)]) +#define DUK_HOBJECT_H_GET_INDEX_PTR(heap, h, i) (&DUK_HOBJECT_H_GET_BASE((heap), (h))[(i)]) + +#define DUK_HOBJECT_E_SET_KEY(heap, h, i, k) \ + do { \ + DUK_HOBJECT_E_GET_KEY((heap), (h), (i)) = (k); \ + } while (0) +#define DUK_HOBJECT_E_SET_VALUE(heap, h, i, v) \ + do { \ + DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)) = (v); \ + } while (0) +#define DUK_HOBJECT_E_SET_VALUE_TVAL(heap, h, i, v) \ + do { \ + DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)).v = (v); \ + } while (0) +#define DUK_HOBJECT_E_SET_VALUE_GETTER(heap, h, i, v) \ + do { \ + DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)).a.get = (v); \ + } while (0) +#define DUK_HOBJECT_E_SET_VALUE_SETTER(heap, h, i, v) \ + do { \ + DUK_HOBJECT_E_GET_VALUE((heap), (h), (i)).a.set = (v); \ + } while (0) +#define DUK_HOBJECT_E_SET_FLAGS(heap, h, i, f) \ + do { \ + DUK_HOBJECT_E_GET_FLAGS((heap), (h), (i)) = (duk_uint8_t) (f); \ + } while (0) +#define DUK_HOBJECT_A_SET_VALUE(heap, h, i, v) \ + do { \ + DUK_HOBJECT_A_GET_VALUE((heap), (h), (i)) = (v); \ + } while (0) +#define DUK_HOBJECT_A_SET_VALUE_TVAL(heap, h, i, v) DUK_HOBJECT_A_SET_VALUE((heap), (h), (i), (v)) /* alias for above */ +#define DUK_HOBJECT_H_SET_INDEX(heap, h, i, v) \ + do { \ + DUK_HOBJECT_H_GET_INDEX((heap), (h), (i)) = (v); \ + } while (0) + +#define DUK_HOBJECT_E_SET_FLAG_BITS(heap, h, i, mask) \ + do { \ + DUK_HOBJECT_E_GET_FLAGS_BASE((heap), (h))[(i)] |= (mask); \ + } while (0) + +#define DUK_HOBJECT_E_CLEAR_FLAG_BITS(heap, h, i, mask) \ + do { \ + DUK_HOBJECT_E_GET_FLAGS_BASE((heap), (h))[(i)] &= ~(mask); \ + } while (0) + +#define DUK_HOBJECT_E_SLOT_IS_WRITABLE(heap, h, i) ((DUK_HOBJECT_E_GET_FLAGS((heap), (h), (i)) & DUK_PROPDESC_FLAG_WRITABLE) != 0) +#define DUK_HOBJECT_E_SLOT_IS_ENUMERABLE(heap, h, i) \ + ((DUK_HOBJECT_E_GET_FLAGS((heap), (h), (i)) & DUK_PROPDESC_FLAG_ENUMERABLE) != 0) +#define DUK_HOBJECT_E_SLOT_IS_CONFIGURABLE(heap, h, i) \ + ((DUK_HOBJECT_E_GET_FLAGS((heap), (h), (i)) & DUK_PROPDESC_FLAG_CONFIGURABLE) != 0) +#define DUK_HOBJECT_E_SLOT_IS_ACCESSOR(heap, h, i) ((DUK_HOBJECT_E_GET_FLAGS((heap), (h), (i)) & DUK_PROPDESC_FLAG_ACCESSOR) != 0) + +#define DUK_HOBJECT_E_SLOT_SET_WRITABLE(heap, h, i) DUK_HOBJECT_E_SET_FLAG_BITS((heap), (h), (i), DUK_PROPDESC_FLAG_WRITABLE) +#define DUK_HOBJECT_E_SLOT_SET_ENUMERABLE(heap, h, i) DUK_HOBJECT_E_SET_FLAG_BITS((heap), (h), (i), DUK_PROPDESC_FLAG_ENUMERABLE) +#define DUK_HOBJECT_E_SLOT_SET_CONFIGURABLE(heap, h, i) \ + DUK_HOBJECT_E_SET_FLAG_BITS((heap), (h), (i), DUK_PROPDESC_FLAG_CONFIGURABLE) +#define DUK_HOBJECT_E_SLOT_SET_ACCESSOR(heap, h, i) DUK_HOBJECT_E_SET_FLAG_BITS((heap), (h), (i), DUK_PROPDESC_FLAG_ACCESSOR) + +#define DUK_HOBJECT_E_SLOT_CLEAR_WRITABLE(heap, h, i) DUK_HOBJECT_E_CLEAR_FLAG_BITS((heap), (h), (i), DUK_PROPDESC_FLAG_WRITABLE) +#define DUK_HOBJECT_E_SLOT_CLEAR_ENUMERABLE(heap, h, i) \ + DUK_HOBJECT_E_CLEAR_FLAG_BITS((heap), (h), (i), DUK_PROPDESC_FLAG_ENUMERABLE) +#define DUK_HOBJECT_E_SLOT_CLEAR_CONFIGURABLE(heap, h, i) \ + DUK_HOBJECT_E_CLEAR_FLAG_BITS((heap), (h), (i), DUK_PROPDESC_FLAG_CONFIGURABLE) +#define DUK_HOBJECT_E_SLOT_CLEAR_ACCESSOR(heap, h, i) DUK_HOBJECT_E_CLEAR_FLAG_BITS((heap), (h), (i), DUK_PROPDESC_FLAG_ACCESSOR) + +#define DUK_PROPDESC_IS_WRITABLE(p) (((p)->flags & DUK_PROPDESC_FLAG_WRITABLE) != 0) +#define DUK_PROPDESC_IS_ENUMERABLE(p) (((p)->flags & DUK_PROPDESC_FLAG_ENUMERABLE) != 0) +#define DUK_PROPDESC_IS_CONFIGURABLE(p) (((p)->flags & DUK_PROPDESC_FLAG_CONFIGURABLE) != 0) +#define DUK_PROPDESC_IS_ACCESSOR(p) (((p)->flags & DUK_PROPDESC_FLAG_ACCESSOR) != 0) + +#define DUK_HOBJECT_HASHIDX_UNUSED 0xffffffffUL +#define DUK_HOBJECT_HASHIDX_DELETED 0xfffffffeUL + +/* + * Macros for accessing size fields + */ + +#if defined(DUK_USE_OBJSIZES16) +#define DUK_HOBJECT_GET_ESIZE(h) ((h)->e_size16) +#define DUK_HOBJECT_SET_ESIZE(h, v) \ + do { \ + (h)->e_size16 = (v); \ + } while (0) +#define DUK_HOBJECT_GET_ENEXT(h) ((h)->e_next16) +#define DUK_HOBJECT_SET_ENEXT(h, v) \ + do { \ + (h)->e_next16 = (v); \ + } while (0) +#define DUK_HOBJECT_POSTINC_ENEXT(h) ((h)->e_next16++) +#define DUK_HOBJECT_GET_ASIZE(h) ((h)->a_size16) +#define DUK_HOBJECT_SET_ASIZE(h, v) \ + do { \ + (h)->a_size16 = (v); \ + } while (0) +#if defined(DUK_USE_HOBJECT_HASH_PART) +#define DUK_HOBJECT_GET_HSIZE(h) ((h)->h_size16) +#define DUK_HOBJECT_SET_HSIZE(h, v) \ + do { \ + (h)->h_size16 = (v); \ + } while (0) +#else +#define DUK_HOBJECT_GET_HSIZE(h) 0 +#define DUK_HOBJECT_SET_HSIZE(h, v) \ + do { \ + DUK_ASSERT((v) == 0); \ + } while (0) +#endif +#else +#define DUK_HOBJECT_GET_ESIZE(h) ((h)->e_size) +#define DUK_HOBJECT_SET_ESIZE(h, v) \ + do { \ + (h)->e_size = (v); \ + } while (0) +#define DUK_HOBJECT_GET_ENEXT(h) ((h)->e_next) +#define DUK_HOBJECT_SET_ENEXT(h, v) \ + do { \ + (h)->e_next = (v); \ + } while (0) +#define DUK_HOBJECT_POSTINC_ENEXT(h) ((h)->e_next++) +#define DUK_HOBJECT_GET_ASIZE(h) ((h)->a_size) +#define DUK_HOBJECT_SET_ASIZE(h, v) \ + do { \ + (h)->a_size = (v); \ + } while (0) +#if defined(DUK_USE_HOBJECT_HASH_PART) +#define DUK_HOBJECT_GET_HSIZE(h) ((h)->h_size) +#define DUK_HOBJECT_SET_HSIZE(h, v) \ + do { \ + (h)->h_size = (v); \ + } while (0) +#else +#define DUK_HOBJECT_GET_HSIZE(h) 0 +#define DUK_HOBJECT_SET_HSIZE(h, v) \ + do { \ + DUK_ASSERT((v) == 0); \ + } while (0) +#endif +#endif + +/* + * Misc + */ + +/* Maximum prototype traversal depth. Sanity limit which handles e.g. + * prototype loops (even complex ones like 1->2->3->4->2->3->4->2->3->4). + */ +#define DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY 10000L + +/* + * ECMAScript [[Class]] + */ + +/* range check not necessary because all 4-bit values are mapped */ +#define DUK_HOBJECT_CLASS_NUMBER_TO_STRIDX(n) duk_class_number_to_stridx[(n)] + +#define DUK_HOBJECT_GET_CLASS_STRING(heap, h) \ + DUK_HEAP_GET_STRING((heap), DUK_HOBJECT_CLASS_NUMBER_TO_STRIDX(DUK_HOBJECT_GET_CLASS_NUMBER((h)))) + +/* + * Macros for property handling + */ + +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HOBJECT_GET_PROTOTYPE(heap, h) ((duk_hobject *) DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (h)->prototype16)) +#define DUK_HOBJECT_SET_PROTOTYPE(heap, h, x) \ + do { \ + (h)->prototype16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) (x)); \ + } while (0) +#else +#define DUK_HOBJECT_GET_PROTOTYPE(heap, h) ((h)->prototype) +#define DUK_HOBJECT_SET_PROTOTYPE(heap, h, x) \ + do { \ + (h)->prototype = (x); \ + } while (0) +#endif + +/* Set prototype, DECREF earlier value, INCREF new value (tolerating NULLs). */ +#define DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, h, p) duk_hobject_set_prototype_updref((thr), (h), (p)) + +/* Set initial prototype, assume NULL previous prototype, INCREF new value, + * tolerate NULL. + */ +#define DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, h, proto) \ + do { \ + duk_hthread *duk__thr = (thr); \ + duk_hobject *duk__obj = (h); \ + duk_hobject *duk__proto = (proto); \ + DUK_UNREF(duk__thr); \ + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(duk__thr->heap, duk__obj) == NULL); \ + DUK_HOBJECT_SET_PROTOTYPE(duk__thr->heap, duk__obj, duk__proto); \ + DUK_HOBJECT_INCREF_ALLOWNULL(duk__thr, duk__proto); \ + } while (0) + +/* + * Finalizer check + */ + +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HOBJECT_HAS_FINALIZER_FAST(heap, h) duk_hobject_has_finalizer_fast_raw((heap), (h)) +#else +#define DUK_HOBJECT_HAS_FINALIZER_FAST(heap, h) duk_hobject_has_finalizer_fast_raw((h)) +#endif + +/* + * Resizing and hash behavior + */ + +/* Sanity limit on max number of properties (allocated, not necessarily used). + * This is somewhat arbitrary, but if we're close to 2**32 properties some + * algorithms will fail (e.g. hash size selection, next prime selection). + * Also, we use negative array/entry table indices to indicate 'not found', + * so anything above 0x80000000 will cause trouble now. + */ +#if defined(DUK_USE_OBJSIZES16) +#define DUK_HOBJECT_MAX_PROPERTIES 0x0000ffffUL +#else +#define DUK_HOBJECT_MAX_PROPERTIES 0x3fffffffUL /* 2**30-1 ~= 1G properties */ +#endif + +/* internal align target for props allocation, must be 2*n for some n */ +#if (DUK_USE_ALIGN_BY == 4) +#define DUK_HOBJECT_ALIGN_TARGET 4 +#elif (DUK_USE_ALIGN_BY == 8) +#define DUK_HOBJECT_ALIGN_TARGET 8 +#elif (DUK_USE_ALIGN_BY == 1) +#define DUK_HOBJECT_ALIGN_TARGET 1 +#else +#error invalid DUK_USE_ALIGN_BY +#endif + +/* + * PC-to-line constants + */ + +#define DUK_PC2LINE_SKIP 64 + +/* maximum length for a SKIP-1 diffstream: 35 bits per entry, rounded up to bytes */ +#define DUK_PC2LINE_MAX_DIFF_LENGTH (((DUK_PC2LINE_SKIP - 1) * 35 + 7) / 8) + +/* + * Struct defs + */ + +struct duk_propaccessor { + duk_hobject *get; + duk_hobject *set; +}; + +union duk_propvalue { + /* The get/set pointers could be 16-bit pointer compressed but it + * would make no difference on 32-bit platforms because duk_tval is + * 8 bytes or more anyway. + */ + duk_tval v; + duk_propaccessor a; +}; + +struct duk_propdesc { + /* read-only values 'lifted' for ease of use */ + duk_small_uint_t flags; + duk_hobject *get; + duk_hobject *set; + + /* for updating (all are set to < 0 for virtual properties) */ + duk_int_t e_idx; /* prop index in 'entry part', < 0 if not there */ + duk_int_t h_idx; /* prop index in 'hash part', < 0 if not there */ + duk_int_t a_idx; /* prop index in 'array part', < 0 if not there */ +}; + +struct duk_hobject { + duk_heaphdr hdr; + + /* + * 'props' contains {key,value,flags} entries, optional array entries, and + * an optional hash lookup table for non-array entries in a single 'sliced' + * allocation. There are several layout options, which differ slightly in + * generated code size/speed and alignment/padding; duk_features.h selects + * the layout used. + * + * Layout 1 (DUK_USE_HOBJECT_LAYOUT_1): + * + * e_size * sizeof(duk_hstring *) bytes of entry keys (e_next gc reachable) + * e_size * sizeof(duk_propvalue) bytes of entry values (e_next gc reachable) + * e_size * sizeof(duk_uint8_t) bytes of entry flags (e_next gc reachable) + * a_size * sizeof(duk_tval) bytes of (opt) array values (plain only) (all gc reachable) + * h_size * sizeof(duk_uint32_t) bytes of (opt) hash indexes to entries (e_size), + * 0xffffffffUL = unused, 0xfffffffeUL = deleted + * + * Layout 2 (DUK_USE_HOBJECT_LAYOUT_2): + * + * e_size * sizeof(duk_propvalue) bytes of entry values (e_next gc reachable) + * e_size * sizeof(duk_hstring *) bytes of entry keys (e_next gc reachable) + * e_size * sizeof(duk_uint8_t) + pad bytes of entry flags (e_next gc reachable) + * a_size * sizeof(duk_tval) bytes of (opt) array values (plain only) (all gc reachable) + * h_size * sizeof(duk_uint32_t) bytes of (opt) hash indexes to entries (e_size), + * 0xffffffffUL = unused, 0xfffffffeUL = deleted + * + * Layout 3 (DUK_USE_HOBJECT_LAYOUT_3): + * + * e_size * sizeof(duk_propvalue) bytes of entry values (e_next gc reachable) + * a_size * sizeof(duk_tval) bytes of (opt) array values (plain only) (all gc reachable) + * e_size * sizeof(duk_hstring *) bytes of entry keys (e_next gc reachable) + * h_size * sizeof(duk_uint32_t) bytes of (opt) hash indexes to entries (e_size), + * 0xffffffffUL = unused, 0xfffffffeUL = deleted + * e_size * sizeof(duk_uint8_t) bytes of entry flags (e_next gc reachable) + * + * In layout 1, the 'e_next' count is rounded to 4 or 8 on platforms + * requiring 4 or 8 byte alignment. This ensures proper alignment + * for the entries, at the cost of memory footprint. However, it's + * probably preferable to use another layout on such platforms instead. + * + * In layout 2, the key and value parts are swapped to avoid padding + * the key array on platforms requiring alignment by 8. The flags part + * is padded to get alignment for array entries. The 'e_next' count does + * not need to be rounded as in layout 1. + * + * In layout 3, entry values and array values are always aligned properly, + * and assuming pointers are at most 8 bytes, so are the entry keys. Hash + * indices will be properly aligned (assuming pointers are at least 4 bytes). + * Finally, flags don't need additional alignment. This layout provides + * compact allocations without padding (even on platforms with alignment + * requirements) at the cost of a bit slower lookups. + * + * Objects with few keys don't have a hash index; keys are looked up linearly, + * which is cache efficient because the keys are consecutive. Larger objects + * have a hash index part which contains integer indexes to the entries part. + * + * A single allocation reduces memory allocation overhead but requires more + * work when any part needs to be resized. A sliced allocation for entries + * makes linear key matching faster on most platforms (more locality) and + * skimps on flags size (which would be followed by 3 bytes of padding in + * most architectures if entries were placed in a struct). + * + * 'props' also contains internal properties distinguished with a non-BMP + * prefix. Often used properties should be placed early in 'props' whenever + * possible to make accessing them as fast a possible. + */ + +#if defined(DUK_USE_HEAPPTR16) + /* Located in duk_heaphdr h_extra16. Subclasses of duk_hobject (like + * duk_hcompfunc) are not free to use h_extra16 for this reason. + */ +#else + duk_uint8_t *props; +#endif + + /* prototype: the only internal property lifted outside 'e' as it is so central */ +#if defined(DUK_USE_HEAPPTR16) + duk_uint16_t prototype16; +#else + duk_hobject *prototype; +#endif + +#if defined(DUK_USE_OBJSIZES16) + duk_uint16_t e_size16; + duk_uint16_t e_next16; + duk_uint16_t a_size16; +#if defined(DUK_USE_HOBJECT_HASH_PART) + duk_uint16_t h_size16; +#endif +#else + duk_uint32_t e_size; /* entry part size */ + duk_uint32_t e_next; /* index for next new key ([0,e_next[ are gc reachable) */ + duk_uint32_t a_size; /* array part size (entirely gc reachable) */ +#if defined(DUK_USE_HOBJECT_HASH_PART) + duk_uint32_t h_size; /* hash part size or 0 if unused */ +#endif +#endif +}; + +/* + * Exposed data + */ + +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL duk_uint8_t duk_class_number_to_stridx[32]; +#endif /* !DUK_SINGLE_FILE */ + +/* + * Prototypes + */ + +/* alloc and init */ +DUK_INTERNAL_DECL duk_hobject *duk_hobject_alloc_unchecked(duk_heap *heap, duk_uint_t hobject_flags); +DUK_INTERNAL_DECL duk_hobject *duk_hobject_alloc(duk_hthread *thr, duk_uint_t hobject_flags); +DUK_INTERNAL_DECL duk_harray *duk_harray_alloc(duk_hthread *thr, duk_uint_t hobject_flags); +DUK_INTERNAL_DECL duk_hcompfunc *duk_hcompfunc_alloc(duk_hthread *thr, duk_uint_t hobject_flags); +DUK_INTERNAL_DECL duk_hnatfunc *duk_hnatfunc_alloc(duk_hthread *thr, duk_uint_t hobject_flags); +DUK_INTERNAL_DECL duk_hboundfunc *duk_hboundfunc_alloc(duk_heap *heap, duk_uint_t hobject_flags); +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL_DECL duk_hbufobj *duk_hbufobj_alloc(duk_hthread *thr, duk_uint_t hobject_flags); +#endif +DUK_INTERNAL_DECL duk_hthread *duk_hthread_alloc_unchecked(duk_heap *heap, duk_uint_t hobject_flags); +DUK_INTERNAL_DECL duk_hthread *duk_hthread_alloc(duk_hthread *thr, duk_uint_t hobject_flags); +DUK_INTERNAL_DECL duk_hdecenv *duk_hdecenv_alloc(duk_hthread *thr, duk_uint_t hobject_flags); +DUK_INTERNAL_DECL duk_hobjenv *duk_hobjenv_alloc(duk_hthread *thr, duk_uint_t hobject_flags); +DUK_INTERNAL_DECL duk_hproxy *duk_hproxy_alloc(duk_hthread *thr, duk_uint_t hobject_flags); + +/* resize */ +DUK_INTERNAL_DECL void duk_hobject_realloc_props(duk_hthread *thr, + duk_hobject *obj, + duk_uint32_t new_e_size, + duk_uint32_t new_a_size, + duk_uint32_t new_h_size, + duk_bool_t abandon_array); +DUK_INTERNAL_DECL void duk_hobject_resize_entrypart(duk_hthread *thr, duk_hobject *obj, duk_uint32_t new_e_size); +#if 0 /*unused*/ +DUK_INTERNAL_DECL void duk_hobject_resize_arraypart(duk_hthread *thr, + duk_hobject *obj, + duk_uint32_t new_a_size); +#endif + +/* low-level property functions */ +DUK_INTERNAL_DECL duk_bool_t +duk_hobject_find_entry(duk_heap *heap, duk_hobject *obj, duk_hstring *key, duk_int_t *e_idx, duk_int_t *h_idx); +DUK_INTERNAL_DECL duk_tval *duk_hobject_find_entry_tval_ptr(duk_heap *heap, duk_hobject *obj, duk_hstring *key); +DUK_INTERNAL_DECL duk_tval *duk_hobject_find_entry_tval_ptr_stridx(duk_heap *heap, duk_hobject *obj, duk_small_uint_t stridx); +DUK_INTERNAL_DECL duk_tval *duk_hobject_find_entry_tval_ptr_and_attrs(duk_heap *heap, + duk_hobject *obj, + duk_hstring *key, + duk_uint_t *out_attrs); +DUK_INTERNAL_DECL duk_tval *duk_hobject_find_array_entry_tval_ptr(duk_heap *heap, duk_hobject *obj, duk_uarridx_t i); +DUK_INTERNAL_DECL duk_bool_t +duk_hobject_get_own_propdesc(duk_hthread *thr, duk_hobject *obj, duk_hstring *key, duk_propdesc *out_desc, duk_small_uint_t flags); + +/* core property functions */ +DUK_INTERNAL_DECL duk_bool_t duk_hobject_getprop(duk_hthread *thr, duk_tval *tv_obj, duk_tval *tv_key); +DUK_INTERNAL_DECL duk_bool_t +duk_hobject_putprop(duk_hthread *thr, duk_tval *tv_obj, duk_tval *tv_key, duk_tval *tv_val, duk_bool_t throw_flag); +DUK_INTERNAL_DECL duk_bool_t duk_hobject_delprop(duk_hthread *thr, duk_tval *tv_obj, duk_tval *tv_key, duk_bool_t throw_flag); +DUK_INTERNAL_DECL duk_bool_t duk_hobject_hasprop(duk_hthread *thr, duk_tval *tv_obj, duk_tval *tv_key); + +/* internal property functions */ +#define DUK_DELPROP_FLAG_THROW (1U << 0) +#define DUK_DELPROP_FLAG_FORCE (1U << 1) +DUK_INTERNAL_DECL duk_bool_t duk_hobject_delprop_raw(duk_hthread *thr, duk_hobject *obj, duk_hstring *key, duk_small_uint_t flags); +DUK_INTERNAL_DECL duk_bool_t duk_hobject_hasprop_raw(duk_hthread *thr, duk_hobject *obj, duk_hstring *key); +DUK_INTERNAL_DECL void duk_hobject_define_property_internal(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_small_uint_t flags); +DUK_INTERNAL_DECL void duk_hobject_define_property_internal_arridx(duk_hthread *thr, + duk_hobject *obj, + duk_uarridx_t arr_idx, + duk_small_uint_t flags); +DUK_INTERNAL_DECL duk_size_t duk_hobject_get_length(duk_hthread *thr, duk_hobject *obj); +#if defined(DUK_USE_HEAPPTR16) +DUK_INTERNAL_DECL duk_bool_t duk_hobject_has_finalizer_fast_raw(duk_heap *heap, duk_hobject *obj); +#else +DUK_INTERNAL_DECL duk_bool_t duk_hobject_has_finalizer_fast_raw(duk_hobject *obj); +#endif + +/* helpers for defineProperty() and defineProperties() */ +DUK_INTERNAL_DECL void duk_hobject_prepare_property_descriptor(duk_hthread *thr, + duk_idx_t idx_in, + duk_uint_t *out_defprop_flags, + duk_idx_t *out_idx_value, + duk_hobject **out_getter, + duk_hobject **out_setter); +DUK_INTERNAL_DECL duk_bool_t duk_hobject_define_property_helper(duk_hthread *thr, + duk_uint_t defprop_flags, + duk_hobject *obj, + duk_hstring *key, + duk_idx_t idx_value, + duk_hobject *get, + duk_hobject *set, + duk_bool_t throw_flag); + +/* Object built-in methods */ +DUK_INTERNAL_DECL void duk_hobject_object_get_own_property_descriptor(duk_hthread *thr, duk_idx_t obj_idx); +DUK_INTERNAL_DECL void duk_hobject_object_seal_freeze_helper(duk_hthread *thr, duk_hobject *obj, duk_bool_t is_freeze); +DUK_INTERNAL_DECL duk_bool_t duk_hobject_object_is_sealed_frozen_helper(duk_hthread *thr, duk_hobject *obj, duk_bool_t is_frozen); +DUK_INTERNAL_DECL duk_bool_t duk_hobject_object_ownprop_helper(duk_hthread *thr, duk_small_uint_t required_desc_flags); + +/* internal properties */ +DUK_INTERNAL_DECL duk_tval *duk_hobject_get_internal_value_tval_ptr(duk_heap *heap, duk_hobject *obj); +DUK_INTERNAL_DECL duk_hstring *duk_hobject_get_internal_value_string(duk_heap *heap, duk_hobject *obj); +DUK_INTERNAL_DECL duk_harray *duk_hobject_get_formals(duk_hthread *thr, duk_hobject *obj); +DUK_INTERNAL_DECL duk_hobject *duk_hobject_get_varmap(duk_hthread *thr, duk_hobject *obj); + +/* hobject management functions */ +DUK_INTERNAL_DECL void duk_hobject_compact_props(duk_hthread *thr, duk_hobject *obj); + +/* ES2015 proxy */ +#if defined(DUK_USE_ES6_PROXY) +DUK_INTERNAL_DECL duk_bool_t duk_hobject_proxy_check(duk_hobject *obj, duk_hobject **out_target, duk_hobject **out_handler); +DUK_INTERNAL_DECL duk_hobject *duk_hobject_resolve_proxy_target(duk_hobject *obj); +#endif + +/* enumeration */ +DUK_INTERNAL_DECL void duk_hobject_enumerator_create(duk_hthread *thr, duk_small_uint_t enum_flags); +DUK_INTERNAL_DECL duk_ret_t duk_hobject_get_enumerated_keys(duk_hthread *thr, duk_small_uint_t enum_flags); +DUK_INTERNAL_DECL duk_bool_t duk_hobject_enumerator_next(duk_hthread *thr, duk_bool_t get_value); + +/* macros */ +DUK_INTERNAL_DECL void duk_hobject_set_prototype_updref(duk_hthread *thr, duk_hobject *h, duk_hobject *p); + +/* pc2line */ +#if defined(DUK_USE_PC2LINE) +DUK_INTERNAL_DECL void duk_hobject_pc2line_pack(duk_hthread *thr, duk_compiler_instr *instrs, duk_uint_fast32_t length); +DUK_INTERNAL_DECL duk_uint_fast32_t duk_hobject_pc2line_query(duk_hthread *thr, duk_idx_t idx_func, duk_uint_fast32_t pc); +#endif + +/* misc */ +DUK_INTERNAL_DECL duk_bool_t duk_hobject_prototype_chain_contains(duk_hthread *thr, + duk_hobject *h, + duk_hobject *p, + duk_bool_t ignore_loop); + +#if !defined(DUK_USE_OBJECT_BUILTIN) +/* These declarations are needed when related built-in is disabled and + * genbuiltins.py won't automatically emit the declerations. + */ +DUK_INTERNAL_DECL duk_ret_t duk_bi_object_prototype_to_string(duk_hthread *thr); +DUK_INTERNAL_DECL duk_ret_t duk_bi_function_prototype(duk_hthread *thr); +#endif + +#endif /* DUK_HOBJECT_H_INCLUDED */ +/* #include duk_hcompfunc.h */ +#line 1 "duk_hcompfunc.h" +/* + * Heap compiled function (ECMAScript function) representation. + * + * There is a single data buffer containing the ECMAScript function's + * bytecode, constants, and inner functions. + */ + +#if !defined(DUK_HCOMPFUNC_H_INCLUDED) +#define DUK_HCOMPFUNC_H_INCLUDED + +/* + * Field accessor macros + */ + +/* XXX: casts could be improved, especially for GET/SET DATA */ + +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HCOMPFUNC_GET_DATA(heap, h) ((duk_hbuffer_fixed *) (void *) DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (h)->data16)) +#define DUK_HCOMPFUNC_SET_DATA(heap, h, v) \ + do { \ + (h)->data16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) (v)); \ + } while (0) +#define DUK_HCOMPFUNC_GET_FUNCS(heap, h) ((duk_hobject **) (void *) (DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (h)->funcs16))) +#define DUK_HCOMPFUNC_SET_FUNCS(heap, h, v) \ + do { \ + (h)->funcs16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) (v)); \ + } while (0) +#define DUK_HCOMPFUNC_GET_BYTECODE(heap, h) ((duk_instr_t *) (void *) (DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (h)->bytecode16))) +#define DUK_HCOMPFUNC_SET_BYTECODE(heap, h, v) \ + do { \ + (h)->bytecode16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) (v)); \ + } while (0) +#define DUK_HCOMPFUNC_GET_LEXENV(heap, h) ((duk_hobject *) (void *) (DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (h)->lex_env16))) +#define DUK_HCOMPFUNC_SET_LEXENV(heap, h, v) \ + do { \ + (h)->lex_env16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) (v)); \ + } while (0) +#define DUK_HCOMPFUNC_GET_VARENV(heap, h) ((duk_hobject *) (void *) (DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (h)->var_env16))) +#define DUK_HCOMPFUNC_SET_VARENV(heap, h, v) \ + do { \ + (h)->var_env16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) (v)); \ + } while (0) +#else +#define DUK_HCOMPFUNC_GET_DATA(heap, h) ((duk_hbuffer_fixed *) (void *) (h)->data) +#define DUK_HCOMPFUNC_SET_DATA(heap, h, v) \ + do { \ + (h)->data = (duk_hbuffer *) (v); \ + } while (0) +#define DUK_HCOMPFUNC_GET_FUNCS(heap, h) ((h)->funcs) +#define DUK_HCOMPFUNC_SET_FUNCS(heap, h, v) \ + do { \ + (h)->funcs = (v); \ + } while (0) +#define DUK_HCOMPFUNC_GET_BYTECODE(heap, h) ((h)->bytecode) +#define DUK_HCOMPFUNC_SET_BYTECODE(heap, h, v) \ + do { \ + (h)->bytecode = (v); \ + } while (0) +#define DUK_HCOMPFUNC_GET_LEXENV(heap, h) ((h)->lex_env) +#define DUK_HCOMPFUNC_SET_LEXENV(heap, h, v) \ + do { \ + (h)->lex_env = (v); \ + } while (0) +#define DUK_HCOMPFUNC_GET_VARENV(heap, h) ((h)->var_env) +#define DUK_HCOMPFUNC_SET_VARENV(heap, h, v) \ + do { \ + (h)->var_env = (v); \ + } while (0) +#endif + +/* + * Accessor macros for function specific data areas + */ + +/* Note: assumes 'data' is always a fixed buffer */ +#define DUK_HCOMPFUNC_GET_BUFFER_BASE(heap, h) DUK_HBUFFER_FIXED_GET_DATA_PTR((heap), DUK_HCOMPFUNC_GET_DATA((heap), (h))) + +#define DUK_HCOMPFUNC_GET_CONSTS_BASE(heap, h) ((duk_tval *) (void *) DUK_HCOMPFUNC_GET_BUFFER_BASE((heap), (h))) + +#define DUK_HCOMPFUNC_GET_FUNCS_BASE(heap, h) DUK_HCOMPFUNC_GET_FUNCS((heap), (h)) + +#define DUK_HCOMPFUNC_GET_CODE_BASE(heap, h) DUK_HCOMPFUNC_GET_BYTECODE((heap), (h)) + +#define DUK_HCOMPFUNC_GET_CONSTS_END(heap, h) ((duk_tval *) (void *) DUK_HCOMPFUNC_GET_FUNCS((heap), (h))) + +#define DUK_HCOMPFUNC_GET_FUNCS_END(heap, h) ((duk_hobject **) (void *) DUK_HCOMPFUNC_GET_BYTECODE((heap), (h))) + +/* XXX: double evaluation of DUK_HCOMPFUNC_GET_DATA() */ +#define DUK_HCOMPFUNC_GET_CODE_END(heap, h) \ + ((duk_instr_t *) (void *) (DUK_HBUFFER_FIXED_GET_DATA_PTR((heap), DUK_HCOMPFUNC_GET_DATA((heap), (h))) + \ + DUK_HBUFFER_GET_SIZE((duk_hbuffer *) DUK_HCOMPFUNC_GET_DATA((heap), h)))) + +#define DUK_HCOMPFUNC_GET_CONSTS_SIZE(heap, h) \ + ((duk_size_t) (((const duk_uint8_t *) DUK_HCOMPFUNC_GET_CONSTS_END((heap), (h))) - \ + ((const duk_uint8_t *) DUK_HCOMPFUNC_GET_CONSTS_BASE((heap), (h))))) + +#define DUK_HCOMPFUNC_GET_FUNCS_SIZE(heap, h) \ + ((duk_size_t) (((const duk_uint8_t *) DUK_HCOMPFUNC_GET_FUNCS_END((heap), (h))) - \ + ((const duk_uint8_t *) DUK_HCOMPFUNC_GET_FUNCS_BASE((heap), (h))))) + +#define DUK_HCOMPFUNC_GET_CODE_SIZE(heap, h) \ + ((duk_size_t) (((const duk_uint8_t *) DUK_HCOMPFUNC_GET_CODE_END((heap), (h))) - \ + ((const duk_uint8_t *) DUK_HCOMPFUNC_GET_CODE_BASE((heap), (h))))) + +#define DUK_HCOMPFUNC_GET_CONSTS_COUNT(heap, h) ((duk_size_t) (DUK_HCOMPFUNC_GET_CONSTS_SIZE((heap), (h)) / sizeof(duk_tval))) + +#define DUK_HCOMPFUNC_GET_FUNCS_COUNT(heap, h) ((duk_size_t) (DUK_HCOMPFUNC_GET_FUNCS_SIZE((heap), (h)) / sizeof(duk_hobject *))) + +#define DUK_HCOMPFUNC_GET_CODE_COUNT(heap, h) ((duk_size_t) (DUK_HCOMPFUNC_GET_CODE_SIZE((heap), (h)) / sizeof(duk_instr_t))) + +/* + * Validity assert + */ + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_hcompfunc_assert_valid(duk_hcompfunc *h); +#define DUK_HCOMPFUNC_ASSERT_VALID(h) \ + do { \ + duk_hcompfunc_assert_valid((h)); \ + } while (0) +#else +#define DUK_HCOMPFUNC_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +/* + * Main struct + */ + +struct duk_hcompfunc { + /* shared object part */ + duk_hobject obj; + + /* + * Pointers to function data area for faster access. Function + * data is a buffer shared between all closures of the same + * "template" function. The data buffer is always fixed (non- + * dynamic, hence stable), with a layout as follows: + * + * constants (duk_tval) + * inner functions (duk_hobject *) + * bytecode (duk_instr_t) + * + * Note: bytecode end address can be computed from 'data' buffer + * size. It is not strictly necessary functionally, assuming + * bytecode never jumps outside its allocated area. However, + * it's a safety/robustness feature for avoiding the chance of + * executing random data as bytecode due to a compiler error. + * + * Note: values in the data buffer must be incref'd (they will + * be decref'd on release) for every compiledfunction referring + * to the 'data' element. + */ + + /* Data area, fixed allocation, stable data ptrs. */ +#if defined(DUK_USE_HEAPPTR16) + duk_uint16_t data16; +#else + duk_hbuffer *data; +#endif + + /* No need for constants pointer (= same as data). + * + * When using 16-bit packing alignment to 4 is nice. 'funcs' will be + * 4-byte aligned because 'constants' are duk_tvals. For now the + * inner function pointers are not compressed, so that 'bytecode' will + * also be 4-byte aligned. + */ +#if defined(DUK_USE_HEAPPTR16) + duk_uint16_t funcs16; + duk_uint16_t bytecode16; +#else + duk_hobject **funcs; + duk_instr_t *bytecode; +#endif + + /* Lexenv: lexical environment of closure, NULL for templates. + * Varenv: variable environment of closure, NULL for templates. + */ +#if defined(DUK_USE_HEAPPTR16) + duk_uint16_t lex_env16; + duk_uint16_t var_env16; +#else + duk_hobject *lex_env; + duk_hobject *var_env; +#endif + + /* + * 'nregs' registers are allocated on function entry, at most 'nargs' + * are initialized to arguments, and the rest to undefined. Arguments + * above 'nregs' are not mapped to registers. All registers in the + * active stack range must be initialized because they are GC reachable. + * 'nargs' is needed so that if the function is given more than 'nargs' + * arguments, the additional arguments do not 'clobber' registers + * beyond 'nregs' which must be consistently initialized to undefined. + * + * Usually there is no need to know which registers are mapped to + * local variables. Registers may be allocated to variable in any + * way (even including gaps). However, a register-variable mapping + * must be the same for the duration of the function execution and + * the register cannot be used for anything else. + * + * When looking up variables by name, the '_Varmap' map is used. + * When an activation closes, registers mapped to arguments are + * copied into the environment record based on the same map. The + * reverse map (from register to variable) is not currently needed + * at run time, except for debugging, so it is not maintained. + */ + + duk_uint16_t nregs; /* regs to allocate */ + duk_uint16_t nargs; /* number of arguments allocated to regs */ + + /* + * Additional control information is placed into the object itself + * as internal properties to avoid unnecessary fields for the + * majority of functions. The compiler tries to omit internal + * control fields when possible. + * + * Function templates: + * + * { + * name: "func", // declaration, named function expressions + * fileName: + * _Varmap: { "arg1": 0, "arg2": 1, "varname": 2 }, + * _Formals: [ "arg1", "arg2" ], + * _Source: "function func(arg1, arg2) { ... }", + * _Pc2line: , + * } + * + * Function instances: + * + * { + * length: 2, + * prototype: { constructor: }, + * caller: , + * arguments: , + * name: "func", // declaration, named function expressions + * fileName: + * _Varmap: { "arg1": 0, "arg2": 1, "varname": 2 }, + * _Formals: [ "arg1", "arg2" ], + * _Source: "function func(arg1, arg2) { ... }", + * _Pc2line: , + * } + * + * More detailed description of these properties can be found + * in the documentation. + */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + /* Line number range for function. Needed during debugging to + * determine active breakpoints. + */ + duk_uint32_t start_line; + duk_uint32_t end_line; +#endif +}; + +#endif /* DUK_HCOMPFUNC_H_INCLUDED */ +/* #include duk_hnatfunc.h */ +#line 1 "duk_hnatfunc.h" +/* + * Heap native function representation. + */ + +#if !defined(DUK_HNATFUNC_H_INCLUDED) +#define DUK_HNATFUNC_H_INCLUDED + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_hnatfunc_assert_valid(duk_hnatfunc *h); +#define DUK_HNATFUNC_ASSERT_VALID(h) \ + do { \ + duk_hnatfunc_assert_valid((h)); \ + } while (0) +#else +#define DUK_HNATFUNC_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +#define DUK_HNATFUNC_NARGS_VARARGS ((duk_int16_t) -1) +#define DUK_HNATFUNC_NARGS_MAX ((duk_int16_t) 0x7fff) + +struct duk_hnatfunc { + /* shared object part */ + duk_hobject obj; + + duk_c_function func; + duk_int16_t nargs; + duk_int16_t magic; + + /* The 'magic' field allows an opaque 16-bit field to be accessed by the + * Duktape/C function. This allows, for instance, the same native function + * to be used for a set of very similar functions, with the 'magic' field + * providing the necessary non-argument flags / values to guide the behavior + * of the native function. The value is signed on purpose: it is easier to + * convert a signed value to unsigned (simply AND with 0xffff) than vice + * versa. + * + * Note: cannot place nargs/magic into the heaphdr flags, because + * duk_hobject takes almost all flags already. + */ +}; + +#endif /* DUK_HNATFUNC_H_INCLUDED */ +/* #include duk_hboundfunc.h */ +#line 1 "duk_hboundfunc.h" +/* + * Bound function representation. + */ + +#if !defined(DUK_HBOUNDFUNC_H_INCLUDED) +#define DUK_HBOUNDFUNC_H_INCLUDED + +/* Artificial limit for args length. Ensures arithmetic won't overflow + * 32 bits when combining bound functions. + */ +#define DUK_HBOUNDFUNC_MAX_ARGS 0x20000000UL + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_hboundfunc_assert_valid(duk_hboundfunc *h); +#define DUK_HBOUNDFUNC_ASSERT_VALID(h) \ + do { \ + duk_hboundfunc_assert_valid((h)); \ + } while (0) +#else +#define DUK_HBOUNDFUNC_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +struct duk_hboundfunc { + /* Shared object part. */ + duk_hobject obj; + + /* Final target function, stored as duk_tval so that lightfunc can be + * represented too. + */ + duk_tval target; + + /* This binding. */ + duk_tval this_binding; + + /* Arguments to prepend. */ + duk_tval *args; /* Separate allocation. */ + duk_idx_t nargs; +}; + +#endif /* DUK_HBOUNDFUNC_H_INCLUDED */ +/* #include duk_hbufobj.h */ +#line 1 "duk_hbufobj.h" +/* + * Heap Buffer object representation. Used for all Buffer variants. + */ + +#if !defined(DUK_HBUFOBJ_H_INCLUDED) +#define DUK_HBUFOBJ_H_INCLUDED + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + +/* All element accessors are host endian now (driven by TypedArray spec). */ +#define DUK_HBUFOBJ_ELEM_UINT8 0 +#define DUK_HBUFOBJ_ELEM_UINT8CLAMPED 1 +#define DUK_HBUFOBJ_ELEM_INT8 2 +#define DUK_HBUFOBJ_ELEM_UINT16 3 +#define DUK_HBUFOBJ_ELEM_INT16 4 +#define DUK_HBUFOBJ_ELEM_UINT32 5 +#define DUK_HBUFOBJ_ELEM_INT32 6 +#define DUK_HBUFOBJ_ELEM_FLOAT32 7 +#define DUK_HBUFOBJ_ELEM_FLOAT64 8 +#define DUK_HBUFOBJ_ELEM_MAX 8 + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_hbufobj_assert_valid(duk_hbufobj *h); +#define DUK_HBUFOBJ_ASSERT_VALID(h) \ + do { \ + duk_hbufobj_assert_valid((h)); \ + } while (0) +#else +#define DUK_HBUFOBJ_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +/* Get the current data pointer (caller must ensure buf != NULL) as a + * duk_uint8_t ptr. Note that the result may be NULL if the underlying + * buffer has zero size and is not a fixed buffer. + */ +#define DUK_HBUFOBJ_GET_SLICE_BASE(heap, h) \ + (DUK_ASSERT_EXPR((h) != NULL), \ + DUK_ASSERT_EXPR((h)->buf != NULL), \ + (((duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR((heap), (h)->buf)) + (h)->offset)) + +/* True if slice is full, i.e. offset is zero and length covers the entire + * buffer. This status may change independently of the duk_hbufobj if + * the underlying buffer is dynamic and changes without the hbufobj + * being changed. + */ +#define DUK_HBUFOBJ_FULL_SLICE(h) \ + (DUK_ASSERT_EXPR((h) != NULL), \ + DUK_ASSERT_EXPR((h)->buf != NULL), \ + ((h)->offset == 0 && (h)->length == DUK_HBUFFER_GET_SIZE((h)->buf))) + +/* Validate that the whole slice [0,length[ is contained in the underlying + * buffer. Caller must ensure 'buf' != NULL. + */ +#define DUK_HBUFOBJ_VALID_SLICE(h) \ + (DUK_ASSERT_EXPR((h) != NULL), \ + DUK_ASSERT_EXPR((h)->buf != NULL), \ + ((h)->offset + (h)->length <= DUK_HBUFFER_GET_SIZE((h)->buf))) + +/* Validate byte read/write for virtual 'offset', i.e. check that the + * offset, taking into account h->offset, is within the underlying + * buffer size. This is a safety check which is needed to ensure + * that even a misconfigured duk_hbufobj never causes memory unsafe + * behavior (e.g. if an underlying dynamic buffer changes after being + * setup). Caller must ensure 'buf' != NULL. + */ +#define DUK_HBUFOBJ_VALID_BYTEOFFSET_INCL(h, off) \ + (DUK_ASSERT_EXPR((h) != NULL), DUK_ASSERT_EXPR((h)->buf != NULL), ((h)->offset + (off) < DUK_HBUFFER_GET_SIZE((h)->buf))) + +#define DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h, off) \ + (DUK_ASSERT_EXPR((h) != NULL), DUK_ASSERT_EXPR((h)->buf != NULL), ((h)->offset + (off) <= DUK_HBUFFER_GET_SIZE((h)->buf))) + +/* Clamp an input byte length (already assumed to be within the nominal + * duk_hbufobj 'length') to the current dynamic buffer limits to yield + * a byte length limit that's safe for memory accesses. This value can + * be invalidated by any side effect because it may trigger a user + * callback that resizes the underlying buffer. + */ +#define DUK_HBUFOBJ_CLAMP_BYTELENGTH(h, len) (DUK_ASSERT_EXPR((h) != NULL), duk_hbufobj_clamp_bytelength((h), (len))) + +/* Typed arrays have virtual indices, ArrayBuffer and DataView do not. */ +#define DUK_HBUFOBJ_HAS_VIRTUAL_INDICES(h) ((h)->is_typedarray) + +struct duk_hbufobj { + /* Shared object part. */ + duk_hobject obj; + + /* Underlying buffer (refcounted), may be NULL. */ + duk_hbuffer *buf; + + /* .buffer reference to an ArrayBuffer, may be NULL. */ + duk_hobject *buf_prop; + + /* Slice and accessor information. + * + * Because the underlying buffer may be dynamic, these may be + * invalidated by the buffer being modified so that both offset + * and length should be validated before every access. Behavior + * when the underlying buffer has changed doesn't need to be clean: + * virtual 'length' doesn't need to be affected, reads can return + * zero/NaN, and writes can be ignored. + * + * Note that a data pointer cannot be precomputed because 'buf' may + * be dynamic and its pointer unstable. + */ + + duk_uint_t offset; /* byte offset to buf */ + duk_uint_t length; /* byte index limit for element access, exclusive */ + duk_uint8_t shift; /* element size shift: + * 0 = u8/i8 + * 1 = u16/i16 + * 2 = u32/i32/float + * 3 = double + */ + duk_uint8_t elem_type; /* element type */ + duk_uint8_t is_typedarray; +}; + +DUK_INTERNAL_DECL duk_uint_t duk_hbufobj_clamp_bytelength(duk_hbufobj *h_bufobj, duk_uint_t len); +DUK_INTERNAL_DECL void duk_hbufobj_push_uint8array_from_plain(duk_hthread *thr, duk_hbuffer *h_buf); +DUK_INTERNAL_DECL void duk_hbufobj_push_validated_read(duk_hthread *thr, + duk_hbufobj *h_bufobj, + duk_uint8_t *p, + duk_small_uint_t elem_size); +DUK_INTERNAL_DECL void duk_hbufobj_validated_write(duk_hthread *thr, + duk_hbufobj *h_bufobj, + duk_uint8_t *p, + duk_small_uint_t elem_size); +DUK_INTERNAL_DECL void duk_hbufobj_promote_plain(duk_hthread *thr, duk_idx_t idx); + +#else /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* nothing */ + +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ +#endif /* DUK_HBUFOBJ_H_INCLUDED */ +/* #include duk_hthread.h */ +#line 1 "duk_hthread.h" +/* + * Heap thread object representation. + * + * duk_hthread is also the 'context' for public API functions via a + * different typedef. Most API calls operate on the topmost frame + * of the value stack only. + */ + +#if !defined(DUK_HTHREAD_H_INCLUDED) +#define DUK_HTHREAD_H_INCLUDED + +/* + * Stack constants + */ + +/* Initial valstack size, roughly 0.7kiB. */ +#define DUK_VALSTACK_INITIAL_SIZE 96U + +/* Internal extra elements assumed on function entry, always added to + * user-defined 'extra' for e.g. the duk_check_stack() call. + */ +#define DUK_VALSTACK_INTERNAL_EXTRA 32U + +/* Number of elements guaranteed to be user accessible (in addition to call + * arguments) on Duktape/C function entry. This is the major public API + * commitment. + */ +#define DUK_VALSTACK_API_ENTRY_MINIMUM DUK_API_ENTRY_STACK + +/* + * Activation defines + */ + +#define DUK_ACT_FLAG_STRICT (1U << 0) /* function executes in strict mode */ +#define DUK_ACT_FLAG_TAILCALLED (1U << 1) /* activation has tail called one or more times */ +#define DUK_ACT_FLAG_CONSTRUCT (1U << 2) /* function executes as a constructor (called via "new") */ +#define DUK_ACT_FLAG_PREVENT_YIELD (1U << 3) /* activation prevents yield (native call or "new") */ +#define DUK_ACT_FLAG_DIRECT_EVAL (1U << 4) /* activation is a direct eval call */ +#define DUK_ACT_FLAG_CONSTRUCT_PROXY (1U << 5) /* activation is for Proxy 'construct' call, special return value handling */ +#define DUK_ACT_FLAG_BREAKPOINT_ACTIVE (1U << 6) /* activation has active breakpoint(s) */ + +#define DUK_ACT_GET_FUNC(act) ((act)->func) + +/* + * Flags for __FILE__ / __LINE__ registered into tracedata + */ + +#define DUK_TB_FLAG_NOBLAME_FILELINE (1U << 0) /* don't report __FILE__ / __LINE__ as fileName/lineNumber */ + +/* + * Catcher defines + */ + +/* XXX: remove catcher type entirely */ + +/* flags field: LLLLLLFT, L = label (24 bits), F = flags (4 bits), T = type (4 bits) */ +#define DUK_CAT_TYPE_MASK 0x0000000fUL +#define DUK_CAT_TYPE_BITS 4 +#define DUK_CAT_LABEL_MASK 0xffffff00UL +#define DUK_CAT_LABEL_BITS 24 +#define DUK_CAT_LABEL_SHIFT 8 + +#define DUK_CAT_FLAG_CATCH_ENABLED (1U << 4) /* catch part will catch */ +#define DUK_CAT_FLAG_FINALLY_ENABLED (1U << 5) /* finally part will catch */ +#define DUK_CAT_FLAG_CATCH_BINDING_ENABLED (1U << 6) /* request to create catch binding */ +#define DUK_CAT_FLAG_LEXENV_ACTIVE (1U << 7) /* catch or with binding is currently active */ + +#define DUK_CAT_TYPE_UNKNOWN 0 +#define DUK_CAT_TYPE_TCF 1 +#define DUK_CAT_TYPE_LABEL 2 + +#define DUK_CAT_GET_TYPE(c) ((c)->flags & DUK_CAT_TYPE_MASK) +#define DUK_CAT_GET_LABEL(c) (((c)->flags & DUK_CAT_LABEL_MASK) >> DUK_CAT_LABEL_SHIFT) + +#define DUK_CAT_HAS_CATCH_ENABLED(c) ((c)->flags & DUK_CAT_FLAG_CATCH_ENABLED) +#define DUK_CAT_HAS_FINALLY_ENABLED(c) ((c)->flags & DUK_CAT_FLAG_FINALLY_ENABLED) +#define DUK_CAT_HAS_CATCH_BINDING_ENABLED(c) ((c)->flags & DUK_CAT_FLAG_CATCH_BINDING_ENABLED) +#define DUK_CAT_HAS_LEXENV_ACTIVE(c) ((c)->flags & DUK_CAT_FLAG_LEXENV_ACTIVE) + +#define DUK_CAT_SET_CATCH_ENABLED(c) \ + do { \ + (c)->flags |= DUK_CAT_FLAG_CATCH_ENABLED; \ + } while (0) +#define DUK_CAT_SET_FINALLY_ENABLED(c) \ + do { \ + (c)->flags |= DUK_CAT_FLAG_FINALLY_ENABLED; \ + } while (0) +#define DUK_CAT_SET_CATCH_BINDING_ENABLED(c) \ + do { \ + (c)->flags |= DUK_CAT_FLAG_CATCH_BINDING_ENABLED; \ + } while (0) +#define DUK_CAT_SET_LEXENV_ACTIVE(c) \ + do { \ + (c)->flags |= DUK_CAT_FLAG_LEXENV_ACTIVE; \ + } while (0) + +#define DUK_CAT_CLEAR_CATCH_ENABLED(c) \ + do { \ + (c)->flags &= ~DUK_CAT_FLAG_CATCH_ENABLED; \ + } while (0) +#define DUK_CAT_CLEAR_FINALLY_ENABLED(c) \ + do { \ + (c)->flags &= ~DUK_CAT_FLAG_FINALLY_ENABLED; \ + } while (0) +#define DUK_CAT_CLEAR_CATCH_BINDING_ENABLED(c) \ + do { \ + (c)->flags &= ~DUK_CAT_FLAG_CATCH_BINDING_ENABLED; \ + } while (0) +#define DUK_CAT_CLEAR_LEXENV_ACTIVE(c) \ + do { \ + (c)->flags &= ~DUK_CAT_FLAG_LEXENV_ACTIVE; \ + } while (0) + +/* + * Thread defines + */ + +#if defined(DUK_USE_ROM_STRINGS) +#define DUK_HTHREAD_GET_STRING(thr, idx) ((duk_hstring *) DUK_LOSE_CONST(duk_rom_strings_stridx[(idx)])) +#else /* DUK_USE_ROM_STRINGS */ +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HTHREAD_GET_STRING(thr, idx) ((duk_hstring *) DUK_USE_HEAPPTR_DEC16((thr)->heap->heap_udata, (thr)->strs16[(idx)])) +#else +#define DUK_HTHREAD_GET_STRING(thr, idx) ((thr)->strs[(idx)]) +#endif +#endif /* DUK_USE_ROM_STRINGS */ + +/* values for the state field */ +#define DUK_HTHREAD_STATE_INACTIVE 1 /* thread not currently running */ +#define DUK_HTHREAD_STATE_RUNNING 2 /* thread currently running (only one at a time) */ +#define DUK_HTHREAD_STATE_RESUMED 3 /* thread resumed another thread (active but not running) */ +#define DUK_HTHREAD_STATE_YIELDED 4 /* thread has yielded */ +#define DUK_HTHREAD_STATE_TERMINATED 5 /* thread has terminated */ + +/* Executor interrupt default interval when nothing else requires a + * smaller value. The default interval must be small enough to allow + * for reasonable execution timeout checking but large enough to keep + * impact on execution performance low. + */ +#if defined(DUK_USE_INTERRUPT_COUNTER) +#define DUK_HTHREAD_INTCTR_DEFAULT (256L * 1024L) +#endif + +/* + * Assert context is valid: non-NULL pointer, fields look sane. + * + * This is used by public API call entrypoints to catch invalid 'ctx' pointers + * as early as possible; invalid 'ctx' pointers cause very odd and difficult to + * diagnose behavior so it's worth checking even when the check is not 100%. + */ + +#if defined(DUK_USE_ASSERTIONS) +/* Assertions for internals. */ +DUK_INTERNAL_DECL void duk_hthread_assert_valid(duk_hthread *thr); +#define DUK_HTHREAD_ASSERT_VALID(thr) \ + do { \ + duk_hthread_assert_valid((thr)); \ + } while (0) + +/* Assertions for public API calls; a bit stronger. */ +DUK_INTERNAL_DECL void duk_ctx_assert_valid(duk_hthread *thr); +#define DUK_CTX_ASSERT_VALID(thr) \ + do { \ + duk_ctx_assert_valid((thr)); \ + } while (0) +#else +#define DUK_HTHREAD_ASSERT_VALID(thr) \ + do { \ + } while (0) +#define DUK_CTX_ASSERT_VALID(thr) \ + do { \ + } while (0) +#endif + +/* Assertions for API call entry specifically. Checks 'ctx' but also may + * check internal state (e.g. not in a debugger transport callback). + */ +#define DUK_ASSERT_API_ENTRY(thr) \ + do { \ + DUK_CTX_ASSERT_VALID((thr)); \ + DUK_ASSERT((thr)->heap != NULL); \ + DUK_ASSERT((thr)->heap->dbg_calling_transport == 0); \ + } while (0) + +/* + * Assertion helpers. + */ + +#define DUK_ASSERT_STRIDX_VALID(val) DUK_ASSERT((duk_uint_t) (val) < DUK_HEAP_NUM_STRINGS) + +#define DUK_ASSERT_BIDX_VALID(val) DUK_ASSERT((duk_uint_t) (val) < DUK_NUM_BUILTINS) + +/* + * Misc + */ + +/* Fast access to 'this' binding. Assumes there's a call in progress. */ +#define DUK_HTHREAD_THIS_PTR(thr) \ + (DUK_ASSERT_EXPR((thr) != NULL), DUK_ASSERT_EXPR((thr)->valstack_bottom > (thr)->valstack), (thr)->valstack_bottom - 1) + +/* + * Struct defines + */ + +/* Fields are ordered for alignment/packing. */ +struct duk_activation { + duk_tval tv_func; /* borrowed: full duk_tval for function being executed; for lightfuncs */ + duk_hobject *func; /* borrowed: function being executed; for bound function calls, this is the final, real function, NULL + for lightfuncs */ + duk_activation *parent; /* previous (parent) activation (or NULL if none) */ + duk_hobject *var_env; /* current variable environment (may be NULL if delayed) */ + duk_hobject *lex_env; /* current lexical environment (may be NULL if delayed) */ + duk_catcher *cat; /* current catcher (or NULL) */ + +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) + /* Previous value of 'func' caller, restored when unwound. Only in use + * when 'func' is non-strict. + */ + duk_hobject *prev_caller; +#endif + + duk_instr_t *curr_pc; /* next instruction to execute (points to 'func' bytecode, stable pointer), NULL for native calls */ + + /* bottom_byteoff and retval_byteoff are only used for book-keeping + * of ECMAScript-initiated calls, to allow returning to an ECMAScript + * function properly. + */ + + /* Bottom of valstack for this activation, used to reset + * valstack_bottom on return; offset is absolute. There's + * no need to track 'top' because native call handling deals + * with that using locals, and for ECMAScript returns 'nregs' + * indicates the necessary top. + */ + duk_size_t bottom_byteoff; + + /* Return value when returning to this activation (points to caller + * reg, not callee reg); offset is absolute (only set if activation is + * not topmost). + * + * Note: bottom_byteoff is always set, while retval_byteoff is only + * applicable for activations below the topmost one. Currently + * retval_byteoff for the topmost activation is considered garbage + * (and it not initialized on entry or cleared on return; may contain + * previous or garbage values). + */ + duk_size_t retval_byteoff; + + /* Current 'this' binding is the value just below bottom. + * Previously, 'this' binding was handled with an index to the + * (calling) valstack. This works for everything except tail + * calls, which must not "accumulate" valstack temps. + */ + + /* Value stack reserve (valstack_end) byte offset to be restored + * when returning to this activation. Only used by the bytecode + * executor. + */ + duk_size_t reserve_byteoff; + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + duk_uint32_t prev_line; /* needed for stepping */ +#endif + + duk_small_uint_t flags; +}; + +struct duk_catcher { + duk_catcher *parent; /* previous (parent) catcher (or NULL if none) */ + duk_hstring *h_varname; /* borrowed reference to catch variable name (or NULL if none) */ + /* (reference is valid as long activation exists) */ + duk_instr_t *pc_base; /* resume execution from pc_base or pc_base+1 (points to 'func' bytecode, stable pointer) */ + duk_size_t idx_base; /* idx_base and idx_base+1 get completion value and type */ + duk_uint32_t flags; /* type and control flags, label number */ + /* XXX: could pack 'flags' and 'idx_base' to same value in practice, + * on 32-bit targets this would make duk_catcher 16 bytes. + */ +}; + +struct duk_hthread { + /* Shared object part */ + duk_hobject obj; + + /* Pointer to bytecode executor's 'curr_pc' variable. Used to copy + * the current PC back into the topmost activation when activation + * state is about to change (or "syncing" is otherwise needed). This + * is rather awkward but important for performance, see execution.rst. + */ + duk_instr_t **ptr_curr_pc; + + /* Backpointers. */ + duk_heap *heap; + + /* Current strictness flag: affects API calls. */ + duk_uint8_t strict; + + /* Thread state. */ + duk_uint8_t state; + duk_uint8_t unused1; + duk_uint8_t unused2; + + /* XXX: Valstack and callstack are currently assumed to have non-NULL + * pointers. Relaxing this would not lead to big benefits (except + * perhaps for terminated threads). + */ + + /* Value stack: these are expressed as pointers for faster stack + * manipulation. [valstack,valstack_top[ is GC-reachable, + * [valstack_top,valstack_alloc_end[ is not GC-reachable but kept + * initialized as 'undefined'. [valstack,valstack_end[ is the + * guaranteed/reserved space and the valstack cannot be resized to + * a smaller size. [valstack_end,valstack_alloc_end[ is currently + * allocated slack that can be used to grow the current guaranteed + * space but may be shrunk away without notice. + * + * + * <----------------------- guaranteed ---> + * <---- slack ---> + * <--- frame ---> + * .-------------+=============+----------+--------------. + * |xxxxxxxxxxxxx|yyyyyyyyyyyyy|uuuuuuuuuu|uuuuuuuuuuuuuu| + * `-------------+=============+----------+--------------' + * + * ^ ^ ^ ^ ^ + * | | | | | + * valstack bottom top end alloc_end + * + * xxx = arbitrary values, below current frame + * yyy = arbitrary values, inside current frame + * uuu = outside active value stack, initialized to 'undefined' + */ + duk_tval *valstack; /* start of valstack allocation */ + duk_tval *valstack_end; /* end of valstack reservation/guarantee (exclusive) */ + duk_tval *valstack_alloc_end; /* end of valstack allocation */ + duk_tval *valstack_bottom; /* bottom of current frame */ + duk_tval *valstack_top; /* top of current frame (exclusive) */ + + /* Call stack, represented as a linked list starting from the current + * activation (or NULL if nothing is active). + */ + duk_activation *callstack_curr; /* current activation (or NULL if none) */ + duk_size_t callstack_top; /* number of activation records in callstack (0 if none) */ + duk_size_t callstack_preventcount; /* number of activation records in callstack preventing a yield */ + + /* Yield/resume book-keeping. */ + duk_hthread *resumer; /* who resumed us (if any) */ + + /* Current compiler state (if any), used for augmenting SyntaxErrors. */ + duk_compiler_ctx *compile_ctx; + +#if defined(DUK_USE_INTERRUPT_COUNTER) + /* Interrupt counter for triggering a slow path check for execution + * timeout, debugger interaction such as breakpoints, etc. The value + * is valid for the current running thread, and both the init and + * counter values are copied whenever a thread switch occurs. It's + * important for the counter to be conveniently accessible for the + * bytecode executor inner loop for performance reasons. + */ + duk_int_t interrupt_counter; /* countdown state */ + duk_int_t interrupt_init; /* start value for current countdown */ +#endif + + /* Builtin-objects; may or may not be shared with other threads, + * threads existing in different "compartments" will have different + * built-ins. Must be stored on a per-thread basis because there + * is no intermediate structure for a thread group / compartment. + * This takes quite a lot of space, currently 43x4 = 172 bytes on + * 32-bit platforms. + * + * In some cases the builtins array could be ROM based, but it's + * sometimes edited (e.g. for sandboxing) so it's better to keep + * this array in RAM. + */ + duk_hobject *builtins[DUK_NUM_BUILTINS]; + + /* Convenience copies from heap/vm for faster access. */ +#if defined(DUK_USE_ROM_STRINGS) + /* No field needed when strings are in ROM. */ +#else +#if defined(DUK_USE_HEAPPTR16) + duk_uint16_t *strs16; +#else + duk_hstring **strs; +#endif +#endif +}; + +/* + * Prototypes + */ + +DUK_INTERNAL_DECL void duk_hthread_copy_builtin_objects(duk_hthread *thr_from, duk_hthread *thr_to); +DUK_INTERNAL_DECL void duk_hthread_create_builtin_objects(duk_hthread *thr); +DUK_INTERNAL_DECL duk_bool_t duk_hthread_init_stacks(duk_heap *heap, duk_hthread *thr); +DUK_INTERNAL_DECL void duk_hthread_terminate(duk_hthread *thr); + +DUK_INTERNAL_DECL duk_activation *duk_hthread_activation_alloc(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_hthread_activation_free(duk_hthread *thr, duk_activation *act); +DUK_INTERNAL_DECL void duk_hthread_activation_unwind_norz(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_hthread_activation_unwind_reuse_norz(duk_hthread *thr); +DUK_INTERNAL_DECL duk_activation *duk_hthread_get_activation_for_level(duk_hthread *thr, duk_int_t level); + +DUK_INTERNAL_DECL duk_catcher *duk_hthread_catcher_alloc(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_hthread_catcher_free(duk_hthread *thr, duk_catcher *cat); +DUK_INTERNAL_DECL void duk_hthread_catcher_unwind_norz(duk_hthread *thr, duk_activation *act); +DUK_INTERNAL_DECL void duk_hthread_catcher_unwind_nolexenv_norz(duk_hthread *thr, duk_activation *act); + +#if defined(DUK_USE_FINALIZER_TORTURE) +DUK_INTERNAL_DECL void duk_hthread_valstack_torture_realloc(duk_hthread *thr); +#endif + +DUK_INTERNAL_DECL void *duk_hthread_get_valstack_ptr(duk_heap *heap, void *ud); /* indirect allocs */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) +DUK_INTERNAL_DECL duk_uint_fast32_t duk_hthread_get_act_curr_pc(duk_hthread *thr, duk_activation *act); +#endif +DUK_INTERNAL_DECL duk_uint_fast32_t duk_hthread_get_act_prev_pc(duk_hthread *thr, duk_activation *act); +DUK_INTERNAL_DECL void duk_hthread_sync_currpc(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_hthread_sync_and_null_currpc(duk_hthread *thr); + +#endif /* DUK_HTHREAD_H_INCLUDED */ +/* #include duk_harray.h */ +#line 1 "duk_harray.h" +/* + * Array object representation, used for actual Array instances. + * + * All objects with the exotic array behavior (which must coincide with having + * internal class array) MUST be duk_harrays. No other object can be a + * duk_harray. However, duk_harrays may not always have an array part. + */ + +#if !defined(DUK_HARRAY_H_INCLUDED) +#define DUK_HARRAY_H_INCLUDED + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_harray_assert_valid(duk_harray *h); +#define DUK_HARRAY_ASSERT_VALID(h) \ + do { \ + duk_harray_assert_valid((h)); \ + } while (0) +#else +#define DUK_HARRAY_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +#define DUK_HARRAY_LENGTH_WRITABLE(h) (!(h)->length_nonwritable) +#define DUK_HARRAY_LENGTH_NONWRITABLE(h) ((h)->length_nonwritable) +#define DUK_HARRAY_SET_LENGTH_WRITABLE(h) \ + do { \ + (h)->length_nonwritable = 0; \ + } while (0) +#define DUK_HARRAY_SET_LENGTH_NONWRITABLE(h) \ + do { \ + (h)->length_nonwritable = 1; \ + } while (0) + +struct duk_harray { + /* Shared object part. */ + duk_hobject obj; + + /* Array .length. + * + * At present Array .length may be smaller, equal, or even larger + * than the allocated underlying array part. Fast path code must + * always take this into account carefully. + */ + duk_uint32_t length; + + /* Array .length property attributes. The property is always + * non-enumerable and non-configurable. It's initially writable + * but per Object.defineProperty() rules it can be made non-writable + * even if it is non-configurable. Thus we need to track the + * writability explicitly. + * + * XXX: this field to be eliminated and moved into duk_hobject + * flags field to save space. + */ + duk_bool_t length_nonwritable; +}; + +#endif /* DUK_HARRAY_H_INCLUDED */ +/* #include duk_henv.h */ +#line 1 "duk_henv.h" +/* + * Environment object representation. + */ + +#if !defined(DUK_HENV_H_INCLUDED) +#define DUK_HENV_H_INCLUDED + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_hdecenv_assert_valid(duk_hdecenv *h); +DUK_INTERNAL_DECL void duk_hobjenv_assert_valid(duk_hobjenv *h); +#define DUK_HDECENV_ASSERT_VALID(h) \ + do { \ + duk_hdecenv_assert_valid((h)); \ + } while (0) +#define DUK_HOBJENV_ASSERT_VALID(h) \ + do { \ + duk_hobjenv_assert_valid((h)); \ + } while (0) +#else +#define DUK_HDECENV_ASSERT_VALID(h) \ + do { \ + } while (0) +#define DUK_HOBJENV_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +struct duk_hdecenv { + /* Shared object part. */ + duk_hobject obj; + + /* These control variables provide enough information to access live + * variables for a closure that is still open. If thread == NULL, + * the record is closed and the identifiers are in the property table. + */ + duk_hthread *thread; + duk_hobject *varmap; + duk_size_t regbase_byteoff; +}; + +struct duk_hobjenv { + /* Shared object part. */ + duk_hobject obj; + + /* Target object and 'this' binding for object binding. */ + duk_hobject *target; + + /* The 'target' object is used as a this binding in only some object + * environments. For example, the global environment does not provide + * a this binding, but a with statement does. + */ + duk_bool_t has_this; +}; + +#endif /* DUK_HENV_H_INCLUDED */ +/* #include duk_hbuffer.h */ +#line 1 "duk_hbuffer.h" +/* + * Heap buffer representation. + * + * Heap allocated user data buffer which is either: + * + * 1. A fixed size buffer (data follows header statically) + * 2. A dynamic size buffer (data pointer follows header) + * + * The data pointer for a variable size buffer of zero size may be NULL. + */ + +#if !defined(DUK_HBUFFER_H_INCLUDED) +#define DUK_HBUFFER_H_INCLUDED + +/* + * Flags + * + * Fixed buffer: 0 + * Dynamic buffer: DUK_HBUFFER_FLAG_DYNAMIC + * External buffer: DUK_HBUFFER_FLAG_DYNAMIC | DUK_HBUFFER_FLAG_EXTERNAL + */ + +#define DUK_HBUFFER_FLAG_DYNAMIC DUK_HEAPHDR_USER_FLAG(0) /* buffer is behind a pointer, dynamic or external */ +#define DUK_HBUFFER_FLAG_EXTERNAL DUK_HEAPHDR_USER_FLAG(1) /* buffer pointer is to an externally allocated buffer */ + +#define DUK_HBUFFER_HAS_DYNAMIC(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HBUFFER_FLAG_DYNAMIC) +#define DUK_HBUFFER_HAS_EXTERNAL(x) DUK_HEAPHDR_CHECK_FLAG_BITS(&(x)->hdr, DUK_HBUFFER_FLAG_EXTERNAL) + +#define DUK_HBUFFER_SET_DYNAMIC(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HBUFFER_FLAG_DYNAMIC) +#define DUK_HBUFFER_SET_EXTERNAL(x) DUK_HEAPHDR_SET_FLAG_BITS(&(x)->hdr, DUK_HBUFFER_FLAG_EXTERNAL) + +#define DUK_HBUFFER_CLEAR_DYNAMIC(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HBUFFER_FLAG_DYNAMIC) +#define DUK_HBUFFER_CLEAR_EXTERNAL(x) DUK_HEAPHDR_CLEAR_FLAG_BITS(&(x)->hdr, DUK_HBUFFER_FLAG_EXTERNAL) + +/* + * Misc defines + */ + +/* Impose a maximum buffer length for now. Restricted artificially to + * ensure resize computations or adding a heap header length won't + * overflow size_t and that a signed duk_int_t can hold a buffer + * length. The limit should be synchronized with DUK_HSTRING_MAX_BYTELEN. + */ + +#if defined(DUK_USE_BUFLEN16) +#define DUK_HBUFFER_MAX_BYTELEN (0x0000ffffUL) +#else +/* Intentionally not 0x7fffffffUL; at least JSON code expects that + * 2*len + 2 fits in 32 bits. + */ +#define DUK_HBUFFER_MAX_BYTELEN (0x7ffffffeUL) +#endif + +/* + * Field access + */ + +#if defined(DUK_USE_BUFLEN16) +/* size stored in duk_heaphdr unused flag bits */ +#define DUK_HBUFFER_GET_SIZE(x) ((x)->hdr.h_flags >> 16) +#define DUK_HBUFFER_SET_SIZE(x, v) \ + do { \ + duk_size_t duk__v; \ + duk__v = (v); \ + DUK_ASSERT(duk__v <= 0xffffUL); \ + (x)->hdr.h_flags = ((x)->hdr.h_flags & 0x0000ffffUL) | (((duk_uint32_t) duk__v) << 16); \ + } while (0) +#define DUK_HBUFFER_ADD_SIZE(x, dv) \ + do { \ + (x)->hdr.h_flags += ((dv) << 16); \ + } while (0) +#define DUK_HBUFFER_SUB_SIZE(x, dv) \ + do { \ + (x)->hdr.h_flags -= ((dv) << 16); \ + } while (0) +#else +#define DUK_HBUFFER_GET_SIZE(x) (((duk_hbuffer *) (x))->size) +#define DUK_HBUFFER_SET_SIZE(x, v) \ + do { \ + ((duk_hbuffer *) (x))->size = (v); \ + } while (0) +#define DUK_HBUFFER_ADD_SIZE(x, dv) \ + do { \ + (x)->size += (dv); \ + } while (0) +#define DUK_HBUFFER_SUB_SIZE(x, dv) \ + do { \ + (x)->size -= (dv); \ + } while (0) +#endif + +#define DUK_HBUFFER_FIXED_GET_SIZE(x) DUK_HBUFFER_GET_SIZE((duk_hbuffer *) (x)) +#define DUK_HBUFFER_FIXED_SET_SIZE(x, v) DUK_HBUFFER_SET_SIZE((duk_hbuffer *) (x)) + +#define DUK_HBUFFER_DYNAMIC_GET_SIZE(x) DUK_HBUFFER_GET_SIZE((duk_hbuffer *) (x)) +#define DUK_HBUFFER_DYNAMIC_SET_SIZE(x, v) DUK_HBUFFER_SET_SIZE((duk_hbuffer *) (x), (v)) +#define DUK_HBUFFER_DYNAMIC_ADD_SIZE(x, dv) DUK_HBUFFER_ADD_SIZE((duk_hbuffer *) (x), (dv)) +#define DUK_HBUFFER_DYNAMIC_SUB_SIZE(x, dv) DUK_HBUFFER_SUB_SIZE((duk_hbuffer *) (x), (dv)) + +#define DUK_HBUFFER_EXTERNAL_GET_SIZE(x) DUK_HBUFFER_GET_SIZE((duk_hbuffer *) (x)) +#define DUK_HBUFFER_EXTERNAL_SET_SIZE(x, v) DUK_HBUFFER_SET_SIZE((duk_hbuffer *) (x), (v)) + +#define DUK_HBUFFER_FIXED_GET_DATA_PTR(heap, x) ((duk_uint8_t *) (((duk_hbuffer_fixed *) (void *) (x)) + 1)) + +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(heap, x) \ + ((void *) DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, ((duk_heaphdr *) (x))->h_extra16)) +#define DUK_HBUFFER_DYNAMIC_SET_DATA_PTR(heap, x, v) \ + do { \ + ((duk_heaphdr *) (x))->h_extra16 = DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (void *) (v)); \ + } while (0) +#define DUK_HBUFFER_DYNAMIC_SET_DATA_PTR_NULL(heap, x) \ + do { \ + ((duk_heaphdr *) (x))->h_extra16 = 0; /* assume 0 <=> NULL */ \ + } while (0) +#else +#define DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(heap, x) ((x)->curr_alloc) +#define DUK_HBUFFER_DYNAMIC_SET_DATA_PTR(heap, x, v) \ + do { \ + (x)->curr_alloc = (void *) (v); \ + } while (0) +#define DUK_HBUFFER_DYNAMIC_SET_DATA_PTR_NULL(heap, x) \ + do { \ + (x)->curr_alloc = (void *) NULL; \ + } while (0) +#endif + +/* No pointer compression because pointer is potentially outside of + * Duktape heap. + */ +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HBUFFER_EXTERNAL_GET_DATA_PTR(heap, x) ((void *) (x)->curr_alloc) +#define DUK_HBUFFER_EXTERNAL_SET_DATA_PTR(heap, x, v) \ + do { \ + (x)->curr_alloc = (void *) (v); \ + } while (0) +#define DUK_HBUFFER_EXTERNAL_SET_DATA_PTR_NULL(heap, x) \ + do { \ + (x)->curr_alloc = (void *) NULL; \ + } while (0) +#else +#define DUK_HBUFFER_EXTERNAL_GET_DATA_PTR(heap, x) ((void *) (x)->curr_alloc) +#define DUK_HBUFFER_EXTERNAL_SET_DATA_PTR(heap, x, v) \ + do { \ + (x)->curr_alloc = (void *) (v); \ + } while (0) +#define DUK_HBUFFER_EXTERNAL_SET_DATA_PTR_NULL(heap, x) \ + do { \ + (x)->curr_alloc = (void *) NULL; \ + } while (0) +#endif + +/* Get a pointer to the current buffer contents (matching current allocation + * size). May be NULL for zero size dynamic/external buffer. + */ +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HBUFFER_GET_DATA_PTR(heap, x) \ + (DUK_HBUFFER_HAS_DYNAMIC((x)) ? \ + (DUK_HBUFFER_HAS_EXTERNAL((x)) ? DUK_HBUFFER_EXTERNAL_GET_DATA_PTR((heap), (duk_hbuffer_external *) (x)) : \ + DUK_HBUFFER_DYNAMIC_GET_DATA_PTR((heap), (duk_hbuffer_dynamic *) (x))) : \ + DUK_HBUFFER_FIXED_GET_DATA_PTR((heap), (duk_hbuffer_fixed *) (void *) (x))) +#else +/* Without heap pointer compression duk_hbuffer_dynamic and duk_hbuffer_external + * have the same layout so checking for fixed vs. dynamic (or external) is enough. + */ +#define DUK_HBUFFER_GET_DATA_PTR(heap, x) \ + (DUK_HBUFFER_HAS_DYNAMIC((x)) ? DUK_HBUFFER_DYNAMIC_GET_DATA_PTR((heap), (duk_hbuffer_dynamic *) (x)) : \ + DUK_HBUFFER_FIXED_GET_DATA_PTR((heap), (duk_hbuffer_fixed *) (void *) (x))) +#endif + +/* Validity assert. */ +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_hbuffer_assert_valid(duk_hbuffer *h); +#define DUK_HBUFFER_ASSERT_VALID(h) \ + do { \ + duk_hbuffer_assert_valid((h)); \ + } while (0) +#else +#define DUK_HBUFFER_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +/* + * Structs + */ + +/* Shared prefix for all buffer types. */ +struct duk_hbuffer { + duk_heaphdr hdr; + + /* It's not strictly necessary to track the current size, but + * it is useful for writing robust native code. + */ + + /* Current size. */ +#if defined(DUK_USE_BUFLEN16) + /* Stored in duk_heaphdr unused flags. */ +#else + duk_size_t size; +#endif + + /* + * Data following the header depends on the DUK_HBUFFER_FLAG_DYNAMIC + * flag. + * + * If the flag is clear (the buffer is a fixed size one), the buffer + * data follows the header directly, consisting of 'size' bytes. + * + * If the flag is set, the actual buffer is allocated separately, and + * a few control fields follow the header. Specifically: + * + * - a "void *" pointing to the current allocation + * - a duk_size_t indicating the full allocated size (always >= 'size') + * + * If DUK_HBUFFER_FLAG_EXTERNAL is set, the buffer has been allocated + * by user code, so that Duktape won't be able to resize it and won't + * free it. This allows buffers to point to e.g. an externally + * allocated structure such as a frame buffer. + * + * Unlike strings, no terminator byte (NUL) is guaranteed after the + * data. This would be convenient, but would pad aligned user buffers + * unnecessarily upwards in size. For instance, if user code requested + * a 64-byte dynamic buffer, 65 bytes would actually be allocated which + * would then potentially round upwards to perhaps 68 or 72 bytes. + */ +}; + +/* Fixed buffer; data follows struct, with proper alignment guaranteed by + * struct size. + */ +#if (DUK_USE_ALIGN_BY == 8) && defined(DUK_USE_PACK_MSVC_PRAGMA) +#pragma pack(push, 8) +#endif +struct duk_hbuffer_fixed { + /* A union is used here as a portable struct size / alignment trick: + * by adding a 32-bit or a 64-bit (unused) union member, the size of + * the struct is effectively forced to be a multiple of 4 or 8 bytes + * (respectively) without increasing the size of the struct unless + * necessary. + */ + union { + struct { + duk_heaphdr hdr; +#if defined(DUK_USE_BUFLEN16) + /* Stored in duk_heaphdr unused flags. */ +#else + duk_size_t size; +#endif + } s; +#if (DUK_USE_ALIGN_BY == 4) + duk_uint32_t dummy_for_align4; +#elif (DUK_USE_ALIGN_BY == 8) + duk_double_t dummy_for_align8_1; +#if defined(DUK_USE_64BIT_OPS) + duk_uint64_t dummy_for_align8_2; +#endif +#elif (DUK_USE_ALIGN_BY == 1) + /* no extra padding */ +#else +#error invalid DUK_USE_ALIGN_BY +#endif + } u; + + /* + * Data follows the struct header. The struct size is padded by the + * compiler based on the struct members. This guarantees that the + * buffer data will be aligned-by-4 but not necessarily aligned-by-8. + * + * On platforms where alignment does not matter, the struct padding + * could be removed (if there is any). On platforms where alignment + * by 8 is required, the struct size must be forced to be a multiple + * of 8 by some means. Without it, some user code may break, and also + * Duktape itself breaks (e.g. the compiler stores duk_tvals in a + * dynamic buffer). + */ +} +#if (DUK_USE_ALIGN_BY == 8) && defined(DUK_USE_PACK_GCC_ATTR) +__attribute__((aligned(8))) +#elif (DUK_USE_ALIGN_BY == 8) && defined(DUK_USE_PACK_CLANG_ATTR) +__attribute__((aligned(8))) +#endif +; +#if (DUK_USE_ALIGN_BY == 8) && defined(DUK_USE_PACK_MSVC_PRAGMA) +#pragma pack(pop) +#endif + +/* Dynamic buffer with 'curr_alloc' pointing to a dynamic area allocated using + * heap allocation primitives. Also used for external buffers when low memory + * options are not used. + */ +struct duk_hbuffer_dynamic { + duk_heaphdr hdr; + +#if defined(DUK_USE_BUFLEN16) + /* Stored in duk_heaphdr unused flags. */ +#else + duk_size_t size; +#endif + +#if defined(DUK_USE_HEAPPTR16) + /* Stored in duk_heaphdr h_extra16. */ +#else + void *curr_alloc; /* may be NULL if alloc_size == 0 */ +#endif + + /* + * Allocation size for 'curr_alloc' is alloc_size. There is no + * automatic NUL terminator for buffers (see above for rationale). + * + * 'curr_alloc' is explicitly allocated with heap allocation + * primitives and will thus always have alignment suitable for + * e.g. duk_tval and an IEEE double. + */ +}; + +/* External buffer with 'curr_alloc' managed by user code and pointing to an + * arbitrary address. When heap pointer compression is not used, this struct + * has the same layout as duk_hbuffer_dynamic. + */ +struct duk_hbuffer_external { + duk_heaphdr hdr; + +#if defined(DUK_USE_BUFLEN16) + /* Stored in duk_heaphdr unused flags. */ +#else + duk_size_t size; +#endif + + /* Cannot be compressed as a heap pointer because may point to + * an arbitrary address. + */ + void *curr_alloc; /* may be NULL if alloc_size == 0 */ +}; + +/* + * Prototypes + */ + +DUK_INTERNAL_DECL duk_hbuffer *duk_hbuffer_alloc(duk_heap *heap, duk_size_t size, duk_small_uint_t flags, void **out_bufdata); +DUK_INTERNAL_DECL void *duk_hbuffer_get_dynalloc_ptr(duk_heap *heap, void *ud); /* indirect allocs */ + +/* dynamic buffer ops */ +DUK_INTERNAL_DECL void duk_hbuffer_resize(duk_hthread *thr, duk_hbuffer_dynamic *buf, duk_size_t new_size); +DUK_INTERNAL_DECL void duk_hbuffer_reset(duk_hthread *thr, duk_hbuffer_dynamic *buf); + +#endif /* DUK_HBUFFER_H_INCLUDED */ +/* #include duk_hproxy.h */ +#line 1 "duk_hproxy.h" +/* + * Proxy object representation. + */ + +#if !defined(DUK_HPROXY_H_INCLUDED) +#define DUK_HPROXY_H_INCLUDED + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_hproxy_assert_valid(duk_hproxy *h); +#define DUK_HPROXY_ASSERT_VALID(h) \ + do { \ + duk_hproxy_assert_valid((h)); \ + } while (0) +#else +#define DUK_HPROXY_ASSERT_VALID(h) \ + do { \ + } while (0) +#endif + +struct duk_hproxy { + /* Shared object part. */ + duk_hobject obj; + + /* Proxy target object. */ + duk_hobject *target; + + /* Proxy handlers (traps). */ + duk_hobject *handler; +}; + +#endif /* DUK_HPROXY_H_INCLUDED */ +/* #include duk_heap.h */ +#line 1 "duk_heap.h" +/* + * Heap structure. + * + * Heap contains allocated heap objects, interned strings, and built-in + * strings for one or more threads. + */ + +#if !defined(DUK_HEAP_H_INCLUDED) +#define DUK_HEAP_H_INCLUDED + +/* alloc function typedefs in duktape.h */ + +/* + * Heap flags + */ + +#define DUK_HEAP_FLAG_MARKANDSWEEP_RECLIMIT_REACHED \ + (1U << 0) /* mark-and-sweep marking reached a recursion limit and must use multi-pass marking */ +#define DUK_HEAP_FLAG_INTERRUPT_RUNNING (1U << 1) /* executor interrupt running (used to avoid nested interrupts) */ +#define DUK_HEAP_FLAG_FINALIZER_NORESCUE (1U << 2) /* heap destruction ongoing, finalizer rescue no longer possible */ +#define DUK_HEAP_FLAG_DEBUGGER_PAUSED (1U << 3) /* debugger is paused: talk with debug client until step/resume */ + +#define DUK__HEAP_HAS_FLAGS(heap, bits) ((heap)->flags & (bits)) +#define DUK__HEAP_SET_FLAGS(heap, bits) \ + do { \ + (heap)->flags |= (bits); \ + } while (0) +#define DUK__HEAP_CLEAR_FLAGS(heap, bits) \ + do { \ + (heap)->flags &= ~(bits); \ + } while (0) + +#define DUK_HEAP_HAS_MARKANDSWEEP_RECLIMIT_REACHED(heap) DUK__HEAP_HAS_FLAGS((heap), DUK_HEAP_FLAG_MARKANDSWEEP_RECLIMIT_REACHED) +#define DUK_HEAP_HAS_INTERRUPT_RUNNING(heap) DUK__HEAP_HAS_FLAGS((heap), DUK_HEAP_FLAG_INTERRUPT_RUNNING) +#define DUK_HEAP_HAS_FINALIZER_NORESCUE(heap) DUK__HEAP_HAS_FLAGS((heap), DUK_HEAP_FLAG_FINALIZER_NORESCUE) +#define DUK_HEAP_HAS_DEBUGGER_PAUSED(heap) DUK__HEAP_HAS_FLAGS((heap), DUK_HEAP_FLAG_DEBUGGER_PAUSED) + +#define DUK_HEAP_SET_MARKANDSWEEP_RECLIMIT_REACHED(heap) DUK__HEAP_SET_FLAGS((heap), DUK_HEAP_FLAG_MARKANDSWEEP_RECLIMIT_REACHED) +#define DUK_HEAP_SET_INTERRUPT_RUNNING(heap) DUK__HEAP_SET_FLAGS((heap), DUK_HEAP_FLAG_INTERRUPT_RUNNING) +#define DUK_HEAP_SET_FINALIZER_NORESCUE(heap) DUK__HEAP_SET_FLAGS((heap), DUK_HEAP_FLAG_FINALIZER_NORESCUE) +#define DUK_HEAP_SET_DEBUGGER_PAUSED(heap) DUK__HEAP_SET_FLAGS((heap), DUK_HEAP_FLAG_DEBUGGER_PAUSED) + +#define DUK_HEAP_CLEAR_MARKANDSWEEP_RECLIMIT_REACHED(heap) \ + DUK__HEAP_CLEAR_FLAGS((heap), DUK_HEAP_FLAG_MARKANDSWEEP_RECLIMIT_REACHED) +#define DUK_HEAP_CLEAR_INTERRUPT_RUNNING(heap) DUK__HEAP_CLEAR_FLAGS((heap), DUK_HEAP_FLAG_INTERRUPT_RUNNING) +#define DUK_HEAP_CLEAR_FINALIZER_NORESCUE(heap) DUK__HEAP_CLEAR_FLAGS((heap), DUK_HEAP_FLAG_FINALIZER_NORESCUE) +#define DUK_HEAP_CLEAR_DEBUGGER_PAUSED(heap) DUK__HEAP_CLEAR_FLAGS((heap), DUK_HEAP_FLAG_DEBUGGER_PAUSED) + +/* + * Longjmp types, also double as identifying continuation type for a rethrow (in 'finally') + */ + +#define DUK_LJ_TYPE_UNKNOWN 0 /* unused */ +#define DUK_LJ_TYPE_THROW 1 /* value1 -> error object */ +#define DUK_LJ_TYPE_YIELD 2 /* value1 -> yield value, iserror -> error / normal */ +#define DUK_LJ_TYPE_RESUME 3 /* value1 -> resume value, value2 -> resumee thread, iserror -> error/normal */ +#define DUK_LJ_TYPE_BREAK 4 /* value1 -> label number, pseudo-type to indicate a break continuation (for ENDFIN) */ +#define DUK_LJ_TYPE_CONTINUE 5 /* value1 -> label number, pseudo-type to indicate a continue continuation (for ENDFIN) */ +#define DUK_LJ_TYPE_RETURN 6 /* value1 -> return value, pseudo-type to indicate a return continuation (for ENDFIN) */ +#define DUK_LJ_TYPE_NORMAL 7 /* no value, pseudo-type to indicate a normal continuation (for ENDFIN) */ + +/* + * Mark-and-sweep flags + * + * These are separate from heap level flags now but could be merged. + * The heap structure only contains a 'base mark-and-sweep flags' + * field and the GC caller can impose further flags. + */ + +/* Emergency mark-and-sweep: try extra hard, even at the cost of + * performance. + */ +#define DUK_MS_FLAG_EMERGENCY (1U << 0) + +/* Postpone rescue decisions for reachable objects with FINALIZED set. + * Used during finalize_list processing to avoid incorrect rescue + * decisions due to finalize_list being a reachability root. + */ +#define DUK_MS_FLAG_POSTPONE_RESCUE (1U << 1) + +/* Don't compact objects; needed during object property table resize + * to prevent a recursive resize. It would suffice to protect only the + * current object being resized, but this is not yet implemented. + */ +#define DUK_MS_FLAG_NO_OBJECT_COMPACTION (1U << 2) + +/* + * Thread switching + * + * To switch heap->curr_thread, use the macro below so that interrupt counters + * get updated correctly. The macro allows a NULL target thread because that + * happens e.g. in call handling. + */ + +#if defined(DUK_USE_INTERRUPT_COUNTER) +#define DUK_HEAP_SWITCH_THREAD(heap, newthr) duk_heap_switch_thread((heap), (newthr)) +#else +#define DUK_HEAP_SWITCH_THREAD(heap, newthr) \ + do { \ + (heap)->curr_thread = (newthr); \ + } while (0) +#endif + +/* + * Stats + */ + +#if defined(DUK_USE_DEBUG) +#define DUK_STATS_INC(heap, fieldname) \ + do { \ + (heap)->fieldname += 1; \ + } while (0) +#else +#define DUK_STATS_INC(heap, fieldname) \ + do { \ + } while (0) +#endif + +/* + * Other heap related defines + */ + +/* Mark-and-sweep interval is relative to combined count of objects and + * strings kept in the heap during the latest mark-and-sweep pass. + * Fixed point .8 multiplier and .0 adder. Trigger count (interval) is + * decreased by each (re)allocation attempt (regardless of size), and each + * refzero processed object. + * + * 'SKIP' indicates how many (re)allocations to wait until a retry if + * GC is skipped because there is no thread do it with yet (happens + * only during init phases). + */ +#if defined(DUK_USE_REFERENCE_COUNTING) +#define DUK_HEAP_MARK_AND_SWEEP_TRIGGER_MULT 12800L /* 50x heap size */ +#define DUK_HEAP_MARK_AND_SWEEP_TRIGGER_ADD 1024L +#define DUK_HEAP_MARK_AND_SWEEP_TRIGGER_SKIP 256L +#else +#define DUK_HEAP_MARK_AND_SWEEP_TRIGGER_MULT 256L /* 1x heap size */ +#define DUK_HEAP_MARK_AND_SWEEP_TRIGGER_ADD 1024L +#define DUK_HEAP_MARK_AND_SWEEP_TRIGGER_SKIP 256L +#endif + +/* GC torture. */ +#if defined(DUK_USE_GC_TORTURE) +#define DUK_GC_TORTURE(heap) \ + do { \ + duk_heap_mark_and_sweep((heap), 0); \ + } while (0) +#else +#define DUK_GC_TORTURE(heap) \ + do { \ + } while (0) +#endif + +/* Stringcache is used for speeding up char-offset-to-byte-offset + * translations for non-ASCII strings. + */ +#define DUK_HEAP_STRCACHE_SIZE 4 +#define DUK_HEAP_STRINGCACHE_NOCACHE_LIMIT 16 /* strings up to the this length are not cached */ + +/* Some list management macros. */ +#define DUK_HEAP_INSERT_INTO_HEAP_ALLOCATED(heap, hdr) duk_heap_insert_into_heap_allocated((heap), (hdr)) +#if defined(DUK_USE_REFERENCE_COUNTING) +#define DUK_HEAP_REMOVE_FROM_HEAP_ALLOCATED(heap, hdr) duk_heap_remove_from_heap_allocated((heap), (hdr)) +#endif +#if defined(DUK_USE_FINALIZER_SUPPORT) +#define DUK_HEAP_INSERT_INTO_FINALIZE_LIST(heap, hdr) duk_heap_insert_into_finalize_list((heap), (hdr)) +#define DUK_HEAP_REMOVE_FROM_FINALIZE_LIST(heap, hdr) duk_heap_remove_from_finalize_list((heap), (hdr)) +#endif + +/* + * Built-in strings + */ + +/* heap string indices are autogenerated in duk_strings.h */ +#if defined(DUK_USE_ROM_STRINGS) +#define DUK_HEAP_GET_STRING(heap, idx) ((duk_hstring *) DUK_LOSE_CONST(duk_rom_strings_stridx[(idx)])) +#else /* DUK_USE_ROM_STRINGS */ +#if defined(DUK_USE_HEAPPTR16) +#define DUK_HEAP_GET_STRING(heap, idx) ((duk_hstring *) DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (heap)->strs16[(idx)])) +#else +#define DUK_HEAP_GET_STRING(heap, idx) ((heap)->strs[(idx)]) +#endif +#endif /* DUK_USE_ROM_STRINGS */ + +/* + * Raw memory calls: relative to heap, but no GC interaction + */ + +#define DUK_ALLOC_RAW(heap, size) ((heap)->alloc_func((heap)->heap_udata, (size))) + +#define DUK_REALLOC_RAW(heap, ptr, newsize) ((heap)->realloc_func((heap)->heap_udata, (void *) (ptr), (newsize))) + +#define DUK_FREE_RAW(heap, ptr) ((heap)->free_func((heap)->heap_udata, (void *) (ptr))) + +/* + * Memory calls: relative to heap, GC interaction, but no error throwing. + * + * XXX: Currently a mark-and-sweep triggered by memory allocation will run + * using the heap->heap_thread. This thread is also used for running + * mark-and-sweep finalization; this is not ideal because it breaks the + * isolation between multiple global environments. + * + * Notes: + * + * - DUK_FREE() is required to ignore NULL and any other possible return + * value of a zero-sized alloc/realloc (same as ANSI C free()). + * + * - There is no DUK_REALLOC_ZEROED because we don't assume to know the + * old size. Caller must zero the reallocated memory. + * + * - DUK_REALLOC_INDIRECT() must be used when a mark-and-sweep triggered + * by an allocation failure might invalidate the original 'ptr', thus + * causing a realloc retry to use an invalid pointer. Example: we're + * reallocating the value stack and a finalizer resizes the same value + * stack during mark-and-sweep. The indirect variant requests for the + * current location of the pointer being reallocated using a callback + * right before every realloc attempt; this circuitous approach is used + * to avoid strict aliasing issues in a more straightforward indirect + * pointer (void **) approach. Note: the pointer in the storage + * location is read but is NOT updated; the caller must do that. + */ + +/* callback for indirect reallocs, request for current pointer */ +typedef void *(*duk_mem_getptr)(duk_heap *heap, void *ud); + +#define DUK_ALLOC(heap, size) duk_heap_mem_alloc((heap), (size)) +#define DUK_ALLOC_ZEROED(heap, size) duk_heap_mem_alloc_zeroed((heap), (size)) +#define DUK_REALLOC(heap, ptr, newsize) duk_heap_mem_realloc((heap), (ptr), (newsize)) +#define DUK_REALLOC_INDIRECT(heap, cb, ud, newsize) duk_heap_mem_realloc_indirect((heap), (cb), (ud), (newsize)) +#define DUK_FREE(heap, ptr) duk_heap_mem_free((heap), (ptr)) + +/* + * Checked allocation, relative to a thread + * + * DUK_FREE_CHECKED() doesn't actually throw, but accepts a 'thr' argument + * for convenience. + */ + +#define DUK_ALLOC_CHECKED(thr, size) duk_heap_mem_alloc_checked((thr), (size)) +#define DUK_ALLOC_CHECKED_ZEROED(thr, size) duk_heap_mem_alloc_checked_zeroed((thr), (size)) +#define DUK_FREE_CHECKED(thr, ptr) duk_heap_mem_free((thr)->heap, (ptr)) + +/* + * Memory constants + */ + +#define DUK_HEAP_ALLOC_FAIL_MARKANDSWEEP_LIMIT \ + 10 /* Retry allocation after mark-and-sweep for this \ + * many times. A single mark-and-sweep round is \ + * not guaranteed to free all unreferenced memory \ + * because of finalization (in fact, ANY number of \ + * rounds is strictly not enough). \ + */ + +#define DUK_HEAP_ALLOC_FAIL_MARKANDSWEEP_EMERGENCY_LIMIT \ + 3 /* Starting from this round, use emergency mode \ + * for mark-and-sweep. \ + */ + +/* + * Debugger support + */ + +/* Maximum number of breakpoints. Only breakpoints that are set are + * consulted so increasing this has no performance impact. + */ +#define DUK_HEAP_MAX_BREAKPOINTS 16 + +/* Opcode interval for a Date-based status/peek rate limit check. Only + * relevant when debugger is attached. Requesting a timestamp may be a + * slow operation on some platforms so this shouldn't be too low. On the + * other hand a high value makes Duktape react to a pause request slowly. + */ +#define DUK_HEAP_DBG_RATELIMIT_OPCODES 4000 + +/* Milliseconds between status notify and transport peeks. */ +#define DUK_HEAP_DBG_RATELIMIT_MILLISECS 200 + +/* Debugger pause flags. */ +#define DUK_PAUSE_FLAG_ONE_OPCODE (1U << 0) /* pause when a single opcode has been executed */ +#define DUK_PAUSE_FLAG_ONE_OPCODE_ACTIVE (1U << 1) /* one opcode pause actually active; artifact of current implementation */ +#define DUK_PAUSE_FLAG_LINE_CHANGE (1U << 2) /* pause when current line number changes */ +#define DUK_PAUSE_FLAG_FUNC_ENTRY (1U << 3) /* pause when entering a function */ +#define DUK_PAUSE_FLAG_FUNC_EXIT (1U << 4) /* pause when exiting current function */ +#define DUK_PAUSE_FLAG_CAUGHT_ERROR (1U << 5) /* pause when about to throw an error that is caught */ +#define DUK_PAUSE_FLAG_UNCAUGHT_ERROR (1U << 6) /* pause when about to throw an error that won't be caught */ + +struct duk_breakpoint { + duk_hstring *filename; + duk_uint32_t line; +}; + +/* + * String cache should ideally be at duk_hthread level, but that would + * cause string finalization to slow down relative to the number of + * threads; string finalization must check the string cache for "weak" + * references to the string being finalized to avoid dead pointers. + * + * Thus, string caches are now at the heap level now. + */ + +struct duk_strcache_entry { + duk_hstring *h; + duk_uint32_t bidx; + duk_uint32_t cidx; +}; + +/* + * Longjmp state, contains the information needed to perform a longjmp. + * Longjmp related values are written to value1, value2, and iserror. + */ + +struct duk_ljstate { + duk_jmpbuf *jmpbuf_ptr; /* current setjmp() catchpoint */ + duk_small_uint_t type; /* longjmp type */ + duk_bool_t iserror; /* isError flag for yield */ + duk_tval value1; /* 1st related value (type specific) */ + duk_tval value2; /* 2nd related value (type specific) */ +}; + +#define DUK_ASSERT_LJSTATE_UNSET(heap) \ + do { \ + DUK_ASSERT(heap != NULL); \ + DUK_ASSERT(heap->lj.type == DUK_LJ_TYPE_UNKNOWN); \ + DUK_ASSERT(heap->lj.iserror == 0); \ + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(&heap->lj.value1)); \ + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(&heap->lj.value2)); \ + } while (0) +#define DUK_ASSERT_LJSTATE_SET(heap) \ + do { \ + DUK_ASSERT(heap != NULL); \ + DUK_ASSERT(heap->lj.type != DUK_LJ_TYPE_UNKNOWN); \ + } while (0) + +/* + * Literal intern cache + */ + +struct duk_litcache_entry { + const duk_uint8_t *addr; + duk_hstring *h; +}; + +/* + * Main heap structure + */ + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL void duk_heap_assert_valid(duk_heap *heap); +#define DUK_HEAP_ASSERT_VALID(heap) \ + do { \ + duk_heap_assert_valid((heap)); \ + } while (0) +#else +#define DUK_HEAP_ASSERT_VALID(heap) \ + do { \ + } while (0) +#endif + +struct duk_heap { + duk_small_uint_t flags; + + /* Allocator functions. */ + duk_alloc_function alloc_func; + duk_realloc_function realloc_func; + duk_free_function free_func; + + /* Heap udata, used for allocator functions but also for other heap + * level callbacks like fatal function, pointer compression, etc. + */ + void *heap_udata; + + /* Fatal error handling, called e.g. when a longjmp() is needed but + * lj.jmpbuf_ptr is NULL. fatal_func must never return; it's not + * declared as "noreturn" because doing that for typedefs is a bit + * challenging portability-wise. + */ + duk_fatal_function fatal_func; + + /* Main list of allocated heap objects. Objects are either here, + * in finalize_list waiting for processing, or in refzero_list + * temporarily while a DECREF refzero cascade finishes. + */ + duk_heaphdr *heap_allocated; + + /* Temporary work list for freeing a cascade of objects when a DECREF + * (or DECREF_NORZ) encounters a zero refcount. Using a work list + * allows fixed C stack size when refcounts go to zero for a chain of + * objects. Outside of DECREF this is always a NULL because DECREF is + * processed without side effects (only memory free calls). + */ +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_heaphdr *refzero_list; +#endif + +#if defined(DUK_USE_FINALIZER_SUPPORT) + /* Work list for objects to be finalized. */ + duk_heaphdr *finalize_list; +#if defined(DUK_USE_ASSERTIONS) + /* Object whose finalizer is executing right now (no nesting). */ + duk_heaphdr *currently_finalizing; +#endif +#endif + + /* Freelist for duk_activations and duk_catchers. */ +#if defined(DUK_USE_CACHE_ACTIVATION) + duk_activation *activation_free; +#endif +#if defined(DUK_USE_CACHE_CATCHER) + duk_catcher *catcher_free; +#endif + + /* Voluntary mark-and-sweep trigger counter. Intentionally signed + * because we continue decreasing the value when voluntary GC cannot + * run. + */ +#if defined(DUK_USE_VOLUNTARY_GC) + duk_int_t ms_trigger_counter; +#endif + + /* Mark-and-sweep recursion control: too deep recursion causes + * multi-pass processing to avoid growing C stack without bound. + */ + duk_uint_t ms_recursion_depth; + + /* Mark-and-sweep flags automatically active (used for critical sections). */ + duk_small_uint_t ms_base_flags; + + /* Mark-and-sweep running flag. Prevents re-entry, and also causes + * refzero events to be ignored (= objects won't be queued to refzero_list). + * + * 0: mark-and-sweep not running + * 1: mark-and-sweep is running + * 2: heap destruction active or debugger active, prevent mark-and-sweep + * and refzero processing (but mark-and-sweep not itself running) + */ + duk_uint_t ms_running; + + /* Mark-and-sweep prevent count, stacking. Used to avoid M&S side + * effects (besides finalizers which are controlled separately) such + * as compacting the string table or object property tables. This + * is also bumped when ms_running is set to prevent recursive re-entry. + * Can also be bumped when mark-and-sweep is not running. + */ + duk_uint_t ms_prevent_count; + + /* Finalizer processing prevent count, stacking. Bumped when finalizers + * are processed to prevent recursive finalizer processing (first call site + * processing finalizers handles all finalizers until the list is empty). + * Can also be bumped explicitly to prevent finalizer execution. + */ + duk_uint_t pf_prevent_count; + + /* When processing finalize_list, don't actually run finalizers but + * queue finalizable objects back to heap_allocated as is. This is + * used during heap destruction to deal with finalizers that keep + * on creating more finalizable garbage. + */ + duk_uint_t pf_skip_finalizers; + +#if defined(DUK_USE_ASSERTIONS) + /* Set when we're in a critical path where an error throw would cause + * e.g. sandboxing/protected call violations or state corruption. This + * is just used for asserts. + */ + duk_bool_t error_not_allowed; +#endif + +#if defined(DUK_USE_ASSERTIONS) + /* Set when heap is still being initialized, helps with writing + * some assertions. + */ + duk_bool_t heap_initializing; +#endif + + /* Marker for detecting internal "double faults", errors thrown when + * we're trying to create an error object, see duk_error_throw.c. + */ + duk_bool_t creating_error; + + /* Marker for indicating we're calling a user error augmentation + * (errCreate/errThrow) function. Errors created/thrown during + * such a call are not augmented. + */ +#if defined(DUK_USE_AUGMENT_ERROR_THROW) || defined(DUK_USE_AUGMENT_ERROR_CREATE) + duk_bool_t augmenting_error; +#endif + + /* Longjmp state. */ + duk_ljstate lj; + + /* Heap thread, used internally and for finalization. */ + duk_hthread *heap_thread; + + /* Current running thread. */ + duk_hthread *curr_thread; + + /* Heap level "stash" object (e.g., various reachability roots). */ + duk_hobject *heap_object; + + /* duk_handle_call / duk_handle_safe_call recursion depth limiting */ + duk_int_t call_recursion_depth; + duk_int_t call_recursion_limit; + + /* Mix-in value for computing string hashes; should be reasonably unpredictable. */ + duk_uint32_t hash_seed; + + /* Random number state for duk_util_tinyrandom.c. */ +#if !defined(DUK_USE_GET_RANDOM_DOUBLE) +#if defined(DUK_USE_PREFER_SIZE) || !defined(DUK_USE_64BIT_OPS) + duk_uint32_t rnd_state; /* State for Shamir's three-op algorithm */ +#else + duk_uint64_t rnd_state[2]; /* State for xoroshiro128+ */ +#endif +#endif + + /* Counter for unique local symbol creation. */ + /* XXX: When 64-bit types are available, it would be more efficient to + * use a duk_uint64_t at least for incrementing but maybe also for + * string formatting in the Symbol constructor. + */ + duk_uint32_t sym_counter[2]; + + /* For manual debugging: instruction count based on executor and + * interrupt counter book-keeping. Inspect debug logs to see how + * they match up. + */ +#if defined(DUK_USE_INTERRUPT_COUNTER) && defined(DUK_USE_DEBUG) + duk_int_t inst_count_exec; + duk_int_t inst_count_interrupt; +#endif + + /* Debugger state. */ +#if defined(DUK_USE_DEBUGGER_SUPPORT) + /* Callbacks and udata; dbg_read_cb != NULL is used to indicate attached state. */ + duk_debug_read_function dbg_read_cb; /* required, NULL implies detached */ + duk_debug_write_function dbg_write_cb; /* required */ + duk_debug_peek_function dbg_peek_cb; + duk_debug_read_flush_function dbg_read_flush_cb; + duk_debug_write_flush_function dbg_write_flush_cb; + duk_debug_request_function dbg_request_cb; + duk_debug_detached_function dbg_detached_cb; + void *dbg_udata; + + /* The following are only relevant when debugger is attached. */ + duk_bool_t dbg_processing; /* currently processing messages or breakpoints: don't enter message processing recursively (e.g. + no breakpoints when processing debugger eval) */ + duk_bool_t dbg_state_dirty; /* resend state next time executor is about to run */ + duk_bool_t + dbg_force_restart; /* force executor restart to recheck breakpoints; used to handle function returns (see GH-303) */ + duk_bool_t dbg_detaching; /* debugger detaching; used to avoid calling detach handler recursively */ + duk_small_uint_t dbg_pause_flags; /* flags for automatic pause behavior */ + duk_activation *dbg_pause_act; /* activation related to pause behavior (pause on line change, function entry/exit) */ + duk_uint32_t dbg_pause_startline; /* starting line number for line change related pause behavior */ + duk_breakpoint dbg_breakpoints[DUK_HEAP_MAX_BREAKPOINTS]; /* breakpoints: [0,breakpoint_count[ gc reachable */ + duk_small_uint_t dbg_breakpoint_count; + duk_breakpoint + *dbg_breakpoints_active[DUK_HEAP_MAX_BREAKPOINTS + 1]; /* currently active breakpoints: NULL term, borrowed pointers */ + /* XXX: make active breakpoints actual copies instead of pointers? */ + + /* These are for rate limiting Status notifications and transport peeking. */ + duk_uint_t dbg_exec_counter; /* cumulative opcode execution count (overflows are OK) */ + duk_uint_t dbg_last_counter; /* value of dbg_exec_counter when we last did a Date-based check */ + duk_double_t dbg_last_time; /* time when status/peek was last done (Date-based rate limit) */ + + /* Used to support single-byte stream lookahead. */ + duk_bool_t dbg_have_next_byte; + duk_uint8_t dbg_next_byte; +#endif /* DUK_USE_DEBUGGER_SUPPORT */ +#if defined(DUK_USE_ASSERTIONS) + duk_bool_t dbg_calling_transport; /* transport call in progress, calling into Duktape forbidden */ +#endif + + /* String intern table (weak refs). */ +#if defined(DUK_USE_STRTAB_PTRCOMP) + duk_uint16_t *strtable16; +#else + duk_hstring **strtable; +#endif + duk_uint32_t st_mask; /* mask for lookup, st_size - 1 */ + duk_uint32_t st_size; /* stringtable size */ +#if (DUK_USE_STRTAB_MINSIZE != DUK_USE_STRTAB_MAXSIZE) + duk_uint32_t st_count; /* string count for resize load factor checks */ +#endif + duk_bool_t st_resizing; /* string table is being resized; avoid recursive resize */ + + /* String access cache (codepoint offset -> byte offset) for fast string + * character looping; 'weak' reference which needs special handling in GC. + */ + duk_strcache_entry strcache[DUK_HEAP_STRCACHE_SIZE]; + +#if defined(DUK_USE_LITCACHE_SIZE) + /* Literal intern cache. When enabled, strings interned as literals + * (e.g. duk_push_literal()) will be pinned and cached for the lifetime + * of the heap. + */ + duk_litcache_entry litcache[DUK_USE_LITCACHE_SIZE]; +#endif + + /* Built-in strings. */ +#if defined(DUK_USE_ROM_STRINGS) + /* No field needed when strings are in ROM. */ +#else +#if defined(DUK_USE_HEAPPTR16) + duk_uint16_t strs16[DUK_HEAP_NUM_STRINGS]; +#else + duk_hstring *strs[DUK_HEAP_NUM_STRINGS]; +#endif +#endif + + /* Stats. */ +#if defined(DUK_USE_DEBUG) + duk_int_t stats_exec_opcodes; + duk_int_t stats_exec_interrupt; + duk_int_t stats_exec_throw; + duk_int_t stats_call_all; + duk_int_t stats_call_tailcall; + duk_int_t stats_call_ecmatoecma; + duk_int_t stats_safecall_all; + duk_int_t stats_safecall_nothrow; + duk_int_t stats_safecall_throw; + duk_int_t stats_ms_try_count; + duk_int_t stats_ms_skip_count; + duk_int_t stats_ms_emergency_count; + duk_int_t stats_strtab_intern_hit; + duk_int_t stats_strtab_intern_miss; + duk_int_t stats_strtab_resize_check; + duk_int_t stats_strtab_resize_grow; + duk_int_t stats_strtab_resize_shrink; + duk_int_t stats_strtab_litcache_hit; + duk_int_t stats_strtab_litcache_miss; + duk_int_t stats_strtab_litcache_pin; + duk_int_t stats_object_realloc_props; + duk_int_t stats_object_abandon_array; + duk_int_t stats_getownpropdesc_count; + duk_int_t stats_getownpropdesc_hit; + duk_int_t stats_getownpropdesc_miss; + duk_int_t stats_getpropdesc_count; + duk_int_t stats_getpropdesc_hit; + duk_int_t stats_getpropdesc_miss; + duk_int_t stats_getprop_all; + duk_int_t stats_getprop_arrayidx; + duk_int_t stats_getprop_bufobjidx; + duk_int_t stats_getprop_bufferidx; + duk_int_t stats_getprop_bufferlen; + duk_int_t stats_getprop_stringidx; + duk_int_t stats_getprop_stringlen; + duk_int_t stats_getprop_proxy; + duk_int_t stats_getprop_arguments; + duk_int_t stats_putprop_all; + duk_int_t stats_putprop_arrayidx; + duk_int_t stats_putprop_bufobjidx; + duk_int_t stats_putprop_bufferidx; + duk_int_t stats_putprop_proxy; + duk_int_t stats_getvar_all; + duk_int_t stats_putvar_all; + duk_int_t stats_envrec_delayedcreate; + duk_int_t stats_envrec_create; + duk_int_t stats_envrec_newenv; + duk_int_t stats_envrec_oldenv; + duk_int_t stats_envrec_pushclosure; +#endif +}; + +/* + * Prototypes + */ + +DUK_INTERNAL_DECL +duk_heap *duk_heap_alloc(duk_alloc_function alloc_func, + duk_realloc_function realloc_func, + duk_free_function free_func, + void *heap_udata, + duk_fatal_function fatal_func); +DUK_INTERNAL_DECL void duk_heap_free(duk_heap *heap); +DUK_INTERNAL_DECL void duk_free_hobject(duk_heap *heap, duk_hobject *h); +DUK_INTERNAL_DECL void duk_free_hbuffer(duk_heap *heap, duk_hbuffer *h); +DUK_INTERNAL_DECL void duk_free_hstring(duk_heap *heap, duk_hstring *h); +DUK_INTERNAL_DECL void duk_heap_free_heaphdr_raw(duk_heap *heap, duk_heaphdr *hdr); + +DUK_INTERNAL_DECL void duk_heap_insert_into_heap_allocated(duk_heap *heap, duk_heaphdr *hdr); +#if defined(DUK_USE_REFERENCE_COUNTING) +DUK_INTERNAL_DECL void duk_heap_remove_from_heap_allocated(duk_heap *heap, duk_heaphdr *hdr); +#endif +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_INTERNAL_DECL void duk_heap_insert_into_finalize_list(duk_heap *heap, duk_heaphdr *hdr); +DUK_INTERNAL_DECL void duk_heap_remove_from_finalize_list(duk_heap *heap, duk_heaphdr *hdr); +#endif +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL duk_bool_t duk_heap_in_heap_allocated(duk_heap *heap, duk_heaphdr *ptr); +#endif +#if defined(DUK_USE_INTERRUPT_COUNTER) +DUK_INTERNAL_DECL void duk_heap_switch_thread(duk_heap *heap, duk_hthread *new_thr); +#endif + +DUK_INTERNAL_DECL duk_hstring *duk_heap_strtable_intern(duk_heap *heap, const duk_uint8_t *str, duk_uint32_t blen); +DUK_INTERNAL_DECL duk_hstring *duk_heap_strtable_intern_checked(duk_hthread *thr, const duk_uint8_t *str, duk_uint32_t len); +#if defined(DUK_USE_LITCACHE_SIZE) +DUK_INTERNAL_DECL duk_hstring *duk_heap_strtable_intern_literal_checked(duk_hthread *thr, + const duk_uint8_t *str, + duk_uint32_t blen); +#endif +DUK_INTERNAL_DECL duk_hstring *duk_heap_strtable_intern_u32(duk_heap *heap, duk_uint32_t val); +DUK_INTERNAL_DECL duk_hstring *duk_heap_strtable_intern_u32_checked(duk_hthread *thr, duk_uint32_t val); +#if defined(DUK_USE_REFERENCE_COUNTING) +DUK_INTERNAL_DECL void duk_heap_strtable_unlink(duk_heap *heap, duk_hstring *h); +#endif +DUK_INTERNAL_DECL void duk_heap_strtable_unlink_prev(duk_heap *heap, duk_hstring *h, duk_hstring *prev); +DUK_INTERNAL_DECL void duk_heap_strtable_force_resize(duk_heap *heap); +DUK_INTERNAL void duk_heap_strtable_free(duk_heap *heap); +#if defined(DUK_USE_DEBUG) +DUK_INTERNAL void duk_heap_strtable_dump(duk_heap *heap); +#endif + +DUK_INTERNAL_DECL void duk_heap_strcache_string_remove(duk_heap *heap, duk_hstring *h); +DUK_INTERNAL_DECL duk_uint_fast32_t duk_heap_strcache_offset_char2byte(duk_hthread *thr, + duk_hstring *h, + duk_uint_fast32_t char_offset); + +#if defined(DUK_USE_PROVIDE_DEFAULT_ALLOC_FUNCTIONS) +DUK_INTERNAL_DECL void *duk_default_alloc_function(void *udata, duk_size_t size); +DUK_INTERNAL_DECL void *duk_default_realloc_function(void *udata, void *ptr, duk_size_t newsize); +DUK_INTERNAL_DECL void duk_default_free_function(void *udata, void *ptr); +#endif + +DUK_INTERNAL_DECL void *duk_heap_mem_alloc(duk_heap *heap, duk_size_t size); +DUK_INTERNAL_DECL void *duk_heap_mem_alloc_zeroed(duk_heap *heap, duk_size_t size); +DUK_INTERNAL_DECL void *duk_heap_mem_alloc_checked(duk_hthread *thr, duk_size_t size); +DUK_INTERNAL_DECL void *duk_heap_mem_alloc_checked_zeroed(duk_hthread *thr, duk_size_t size); +DUK_INTERNAL_DECL void *duk_heap_mem_realloc(duk_heap *heap, void *ptr, duk_size_t newsize); +DUK_INTERNAL_DECL void *duk_heap_mem_realloc_indirect(duk_heap *heap, duk_mem_getptr cb, void *ud, duk_size_t newsize); +DUK_INTERNAL_DECL void duk_heap_mem_free(duk_heap *heap, void *ptr); + +DUK_INTERNAL_DECL void duk_heap_free_freelists(duk_heap *heap); + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_INTERNAL_DECL void duk_heap_run_finalizer(duk_heap *heap, duk_hobject *obj); +DUK_INTERNAL_DECL void duk_heap_process_finalize_list(duk_heap *heap); +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +DUK_INTERNAL_DECL void duk_heap_mark_and_sweep(duk_heap *heap, duk_small_uint_t flags); + +DUK_INTERNAL_DECL duk_uint32_t duk_heap_hashstring(duk_heap *heap, const duk_uint8_t *str, duk_size_t len); + +#endif /* DUK_HEAP_H_INCLUDED */ +/* #include duk_debugger.h */ +#line 1 "duk_debugger.h" +#if !defined(DUK_DEBUGGER_H_INCLUDED) +#define DUK_DEBUGGER_H_INCLUDED + +/* Debugger protocol version is defined in the public API header. */ + +/* Initial bytes for markers. */ +#define DUK_DBG_IB_EOM 0x00 +#define DUK_DBG_IB_REQUEST 0x01 +#define DUK_DBG_IB_REPLY 0x02 +#define DUK_DBG_IB_ERROR 0x03 +#define DUK_DBG_IB_NOTIFY 0x04 + +/* Other initial bytes. */ +#define DUK_DBG_IB_INT4 0x10 +#define DUK_DBG_IB_STR4 0x11 +#define DUK_DBG_IB_STR2 0x12 +#define DUK_DBG_IB_BUF4 0x13 +#define DUK_DBG_IB_BUF2 0x14 +#define DUK_DBG_IB_UNUSED 0x15 +#define DUK_DBG_IB_UNDEFINED 0x16 +#define DUK_DBG_IB_NULL 0x17 +#define DUK_DBG_IB_TRUE 0x18 +#define DUK_DBG_IB_FALSE 0x19 +#define DUK_DBG_IB_NUMBER 0x1a +#define DUK_DBG_IB_OBJECT 0x1b +#define DUK_DBG_IB_POINTER 0x1c +#define DUK_DBG_IB_LIGHTFUNC 0x1d +#define DUK_DBG_IB_HEAPPTR 0x1e +/* The short string/integer initial bytes starting from 0x60 don't have + * defines now. + */ + +/* Error codes. */ +#define DUK_DBG_ERR_UNKNOWN 0x00 +#define DUK_DBG_ERR_UNSUPPORTED 0x01 +#define DUK_DBG_ERR_TOOMANY 0x02 +#define DUK_DBG_ERR_NOTFOUND 0x03 +#define DUK_DBG_ERR_APPLICATION 0x04 + +/* Commands and notifys initiated by Duktape. */ +#define DUK_DBG_CMD_STATUS 0x01 +#define DUK_DBG_CMD_UNUSED_2 0x02 /* Duktape 1.x: print notify */ +#define DUK_DBG_CMD_UNUSED_3 0x03 /* Duktape 1.x: alert notify */ +#define DUK_DBG_CMD_UNUSED_4 0x04 /* Duktape 1.x: log notify */ +#define DUK_DBG_CMD_THROW 0x05 +#define DUK_DBG_CMD_DETACHING 0x06 +#define DUK_DBG_CMD_APPNOTIFY 0x07 + +/* Commands initiated by debug client. */ +#define DUK_DBG_CMD_BASICINFO 0x10 +#define DUK_DBG_CMD_TRIGGERSTATUS 0x11 +#define DUK_DBG_CMD_PAUSE 0x12 +#define DUK_DBG_CMD_RESUME 0x13 +#define DUK_DBG_CMD_STEPINTO 0x14 +#define DUK_DBG_CMD_STEPOVER 0x15 +#define DUK_DBG_CMD_STEPOUT 0x16 +#define DUK_DBG_CMD_LISTBREAK 0x17 +#define DUK_DBG_CMD_ADDBREAK 0x18 +#define DUK_DBG_CMD_DELBREAK 0x19 +#define DUK_DBG_CMD_GETVAR 0x1a +#define DUK_DBG_CMD_PUTVAR 0x1b +#define DUK_DBG_CMD_GETCALLSTACK 0x1c +#define DUK_DBG_CMD_GETLOCALS 0x1d +#define DUK_DBG_CMD_EVAL 0x1e +#define DUK_DBG_CMD_DETACH 0x1f +#define DUK_DBG_CMD_DUMPHEAP 0x20 +#define DUK_DBG_CMD_GETBYTECODE 0x21 +#define DUK_DBG_CMD_APPREQUEST 0x22 +#define DUK_DBG_CMD_GETHEAPOBJINFO 0x23 +#define DUK_DBG_CMD_GETOBJPROPDESC 0x24 +#define DUK_DBG_CMD_GETOBJPROPDESCRANGE 0x25 + +/* The low 8 bits map directly to duk_hobject.h DUK_PROPDESC_FLAG_xxx. + * The remaining flags are specific to the debugger. + */ +#define DUK_DBG_PROPFLAG_SYMBOL (1U << 8) +#define DUK_DBG_PROPFLAG_HIDDEN (1U << 9) + +#if defined(DUK_USE_DEBUGGER_SUPPORT) +DUK_INTERNAL_DECL void duk_debug_do_detach(duk_heap *heap); + +DUK_INTERNAL_DECL duk_bool_t duk_debug_read_peek(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_debug_write_flush(duk_hthread *thr); + +DUK_INTERNAL_DECL void duk_debug_skip_bytes(duk_hthread *thr, duk_size_t length); +DUK_INTERNAL_DECL void duk_debug_skip_byte(duk_hthread *thr); + +DUK_INTERNAL_DECL void duk_debug_read_bytes(duk_hthread *thr, duk_uint8_t *data, duk_size_t length); +DUK_INTERNAL_DECL duk_uint8_t duk_debug_read_byte(duk_hthread *thr); +DUK_INTERNAL_DECL duk_int32_t duk_debug_read_int(duk_hthread *thr); +DUK_INTERNAL_DECL duk_hstring *duk_debug_read_hstring(duk_hthread *thr); +/* XXX: exposed duk_debug_read_pointer */ +/* XXX: exposed duk_debug_read_buffer */ +/* XXX: exposed duk_debug_read_hbuffer */ +#if 0 +DUK_INTERNAL_DECL duk_heaphdr *duk_debug_read_heapptr(duk_hthread *thr); +#endif +#if defined(DUK_USE_DEBUGGER_INSPECT) +DUK_INTERNAL_DECL duk_heaphdr *duk_debug_read_any_ptr(duk_hthread *thr); +#endif +DUK_INTERNAL_DECL duk_tval *duk_debug_read_tval(duk_hthread *thr); + +DUK_INTERNAL_DECL void duk_debug_write_bytes(duk_hthread *thr, const duk_uint8_t *data, duk_size_t length); +DUK_INTERNAL_DECL void duk_debug_write_byte(duk_hthread *thr, duk_uint8_t x); +DUK_INTERNAL_DECL void duk_debug_write_unused(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_debug_write_undefined(duk_hthread *thr); +#if defined(DUK_USE_DEBUGGER_INSPECT) +DUK_INTERNAL_DECL void duk_debug_write_null(duk_hthread *thr); +#endif +DUK_INTERNAL_DECL void duk_debug_write_boolean(duk_hthread *thr, duk_uint_t val); +DUK_INTERNAL_DECL void duk_debug_write_int(duk_hthread *thr, duk_int32_t x); +DUK_INTERNAL_DECL void duk_debug_write_uint(duk_hthread *thr, duk_uint32_t x); +DUK_INTERNAL_DECL void duk_debug_write_string(duk_hthread *thr, const char *data, duk_size_t length); +DUK_INTERNAL_DECL void duk_debug_write_cstring(duk_hthread *thr, const char *data); +DUK_INTERNAL_DECL void duk_debug_write_hstring(duk_hthread *thr, duk_hstring *h); +DUK_INTERNAL_DECL void duk_debug_write_buffer(duk_hthread *thr, const char *data, duk_size_t length); +DUK_INTERNAL_DECL void duk_debug_write_hbuffer(duk_hthread *thr, duk_hbuffer *h); +DUK_INTERNAL_DECL void duk_debug_write_pointer(duk_hthread *thr, void *ptr); +#if defined(DUK_USE_DEBUGGER_DUMPHEAP) || defined(DUK_USE_DEBUGGER_INSPECT) +DUK_INTERNAL_DECL void duk_debug_write_heapptr(duk_hthread *thr, duk_heaphdr *h); +#endif +DUK_INTERNAL_DECL void duk_debug_write_hobject(duk_hthread *thr, duk_hobject *obj); +DUK_INTERNAL_DECL void duk_debug_write_tval(duk_hthread *thr, duk_tval *tv); +#if 0 /* unused */ +DUK_INTERNAL_DECL void duk_debug_write_request(duk_hthread *thr, duk_small_uint_t command); +#endif +DUK_INTERNAL_DECL void duk_debug_write_reply(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_debug_write_error_eom(duk_hthread *thr, duk_small_uint_t err_code, const char *msg); +DUK_INTERNAL_DECL void duk_debug_write_notify(duk_hthread *thr, duk_small_uint_t command); +DUK_INTERNAL_DECL void duk_debug_write_eom(duk_hthread *thr); + +DUK_INTERNAL_DECL duk_uint_fast32_t duk_debug_curr_line(duk_hthread *thr); +DUK_INTERNAL_DECL void duk_debug_send_status(duk_hthread *thr); +#if defined(DUK_USE_DEBUGGER_THROW_NOTIFY) +DUK_INTERNAL_DECL void duk_debug_send_throw(duk_hthread *thr, duk_bool_t fatal); +#endif + +DUK_INTERNAL_DECL void duk_debug_halt_execution(duk_hthread *thr, duk_bool_t use_prev_pc); +DUK_INTERNAL_DECL duk_bool_t duk_debug_process_messages(duk_hthread *thr, duk_bool_t no_block); + +DUK_INTERNAL_DECL duk_small_int_t duk_debug_add_breakpoint(duk_hthread *thr, duk_hstring *filename, duk_uint32_t line); +DUK_INTERNAL_DECL duk_bool_t duk_debug_remove_breakpoint(duk_hthread *thr, duk_small_uint_t breakpoint_index); + +DUK_INTERNAL_DECL duk_bool_t duk_debug_is_attached(duk_heap *heap); +DUK_INTERNAL_DECL duk_bool_t duk_debug_is_paused(duk_heap *heap); +DUK_INTERNAL_DECL void duk_debug_set_paused(duk_heap *heap); +DUK_INTERNAL_DECL void duk_debug_clear_paused(duk_heap *heap); +DUK_INTERNAL_DECL void duk_debug_clear_pause_state(duk_heap *heap); +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + +#endif /* DUK_DEBUGGER_H_INCLUDED */ +/* #include duk_debug.h */ +#line 1 "duk_debug.h" +/* + * Debugging macros, DUK_DPRINT() and its variants in particular. + * + * DUK_DPRINT() allows formatted debug prints, and supports standard + * and Duktape specific formatters. See duk_debug_vsnprintf.c for details. + * + * DUK_D(x), DUK_DD(x), and DUK_DDD(x) are used together with log macros + * for technical reasons. They are concretely used to hide 'x' from the + * compiler when the corresponding log level is disabled. This allows + * clean builds on non-C99 compilers, at the cost of more verbose code. + * Examples: + * + * DUK_D(DUK_DPRINT("foo")); + * DUK_DD(DUK_DDPRINT("foo")); + * DUK_DDD(DUK_DDDPRINT("foo")); + * + * This approach is preferable to the old "double parentheses" hack because + * double parentheses make the C99 solution worse: __FILE__ and __LINE__ can + * no longer be added transparently without going through globals, which + * works poorly with threading. + */ + +#if !defined(DUK_DEBUG_H_INCLUDED) +#define DUK_DEBUG_H_INCLUDED + +#if defined(DUK_USE_DEBUG) + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 0) +#define DUK_D(x) x +#else +#define DUK_D(x) \ + do { \ + } while (0) /* omit */ +#endif + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 1) +#define DUK_DD(x) x +#else +#define DUK_DD(x) \ + do { \ + } while (0) /* omit */ +#endif + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) +#define DUK_DDD(x) x +#else +#define DUK_DDD(x) \ + do { \ + } while (0) /* omit */ +#endif + +/* + * Exposed debug macros: debugging enabled + */ + +#if defined(DUK_USE_VARIADIC_MACROS) + +/* Note: combining __FILE__, __LINE__, and __func__ into fmt would be + * possible compile time, but waste some space with shared function names. + */ +#define DUK__DEBUG_LOG(lev, ...) \ + duk_debug_log((duk_int_t) (lev), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO, DUK_FUNC_MACRO, __VA_ARGS__); + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 0) +#define DUK_DPRINT(...) DUK__DEBUG_LOG(DUK_LEVEL_DEBUG, __VA_ARGS__) +#else +#define DUK_DPRINT(...) +#endif + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 1) +#define DUK_DDPRINT(...) DUK__DEBUG_LOG(DUK_LEVEL_DDEBUG, __VA_ARGS__) +#else +#define DUK_DDPRINT(...) +#endif + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) +#define DUK_DDDPRINT(...) DUK__DEBUG_LOG(DUK_LEVEL_DDDEBUG, __VA_ARGS__) +#else +#define DUK_DDDPRINT(...) +#endif + +#else /* DUK_USE_VARIADIC_MACROS */ + +#define DUK__DEBUG_STASH(lev) \ + (void) DUK_SNPRINTF(duk_debug_file_stash, DUK_DEBUG_STASH_SIZE, "%s", (const char *) DUK_FILE_MACRO), \ + (void) (duk_debug_file_stash[DUK_DEBUG_STASH_SIZE - 1] = (char) 0), \ + (void) (duk_debug_line_stash = (duk_int_t) DUK_LINE_MACRO), \ + (void) DUK_SNPRINTF(duk_debug_func_stash, DUK_DEBUG_STASH_SIZE, "%s", (const char *) DUK_FUNC_MACRO), \ + (void) (duk_debug_func_stash[DUK_DEBUG_STASH_SIZE - 1] = (char) 0), (void) (duk_debug_level_stash = (lev)) + +/* Without variadic macros resort to comma expression trickery to handle debug + * prints. This generates a lot of harmless warnings. These hacks are not + * needed normally because DUK_D() and friends will hide the entire debug log + * statement from the compiler. + */ + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 0) +#define DUK_DPRINT DUK__DEBUG_STASH(DUK_LEVEL_DEBUG), (void) duk_debug_log /* args go here in parens */ +#else +#define DUK_DPRINT 0 && /* args go here as a comma expression in parens */ +#endif + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 1) +#define DUK_DDPRINT DUK__DEBUG_STASH(DUK_LEVEL_DDEBUG), (void) duk_debug_log /* args go here in parens */ +#else +#define DUK_DDPRINT 0 && /* args */ +#endif + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) +#define DUK_DDDPRINT DUK__DEBUG_STASH(DUK_LEVEL_DDDEBUG), (void) duk_debug_log /* args go here in parens */ +#else +#define DUK_DDDPRINT 0 && /* args */ +#endif + +#endif /* DUK_USE_VARIADIC_MACROS */ + +#else /* DUK_USE_DEBUG */ + +/* + * Exposed debug macros: debugging disabled + */ + +#define DUK_D(x) \ + do { \ + } while (0) /* omit */ +#define DUK_DD(x) \ + do { \ + } while (0) /* omit */ +#define DUK_DDD(x) \ + do { \ + } while (0) /* omit */ + +#if defined(DUK_USE_VARIADIC_MACROS) + +#define DUK_DPRINT(...) +#define DUK_DDPRINT(...) +#define DUK_DDDPRINT(...) + +#else /* DUK_USE_VARIADIC_MACROS */ + +#define DUK_DPRINT 0 && /* args go here as a comma expression in parens */ +#define DUK_DDPRINT 0 && /* args */ +#define DUK_DDDPRINT 0 && /* args */ + +#endif /* DUK_USE_VARIADIC_MACROS */ + +#endif /* DUK_USE_DEBUG */ + +/* + * Structs + */ + +#if defined(DUK_USE_DEBUG) +struct duk_fixedbuffer { + duk_uint8_t *buffer; + duk_size_t length; + duk_size_t offset; + duk_bool_t truncated; +}; +#endif + +/* + * Prototypes + */ + +#if defined(DUK_USE_DEBUG) +DUK_INTERNAL_DECL duk_int_t duk_debug_vsnprintf(char *str, duk_size_t size, const char *format, va_list ap); +#if 0 /*unused*/ +DUK_INTERNAL_DECL duk_int_t duk_debug_snprintf(char *str, duk_size_t size, const char *format, ...); +#endif +DUK_INTERNAL_DECL void duk_debug_format_funcptr(char *buf, duk_size_t buf_size, duk_uint8_t *fptr, duk_size_t fptr_size); + +#if defined(DUK_USE_VARIADIC_MACROS) +DUK_INTERNAL_DECL void duk_debug_log(duk_int_t level, const char *file, duk_int_t line, const char *func, const char *fmt, ...); +#else /* DUK_USE_VARIADIC_MACROS */ +/* parameter passing, not thread safe */ +#define DUK_DEBUG_STASH_SIZE 128 +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL char duk_debug_file_stash[DUK_DEBUG_STASH_SIZE]; +DUK_INTERNAL_DECL duk_int_t duk_debug_line_stash; +DUK_INTERNAL_DECL char duk_debug_func_stash[DUK_DEBUG_STASH_SIZE]; +DUK_INTERNAL_DECL duk_int_t duk_debug_level_stash; +#endif +DUK_INTERNAL_DECL void duk_debug_log(const char *fmt, ...); +#endif /* DUK_USE_VARIADIC_MACROS */ + +DUK_INTERNAL_DECL void duk_fb_put_bytes(duk_fixedbuffer *fb, const duk_uint8_t *buffer, duk_size_t length); +DUK_INTERNAL_DECL void duk_fb_put_byte(duk_fixedbuffer *fb, duk_uint8_t x); +DUK_INTERNAL_DECL void duk_fb_put_cstring(duk_fixedbuffer *fb, const char *x); +DUK_INTERNAL_DECL void duk_fb_sprintf(duk_fixedbuffer *fb, const char *fmt, ...); +DUK_INTERNAL_DECL void duk_fb_put_funcptr(duk_fixedbuffer *fb, duk_uint8_t *fptr, duk_size_t fptr_size); +DUK_INTERNAL_DECL duk_bool_t duk_fb_is_full(duk_fixedbuffer *fb); + +#endif /* DUK_USE_DEBUG */ + +#endif /* DUK_DEBUG_H_INCLUDED */ +/* #include duk_error.h */ +#line 1 "duk_error.h" +/* + * Error handling macros, assertion macro, error codes. + * + * There are three types of 'errors': + * + * 1. Ordinary errors relative to a thread, cause a longjmp, catchable. + * 2. Fatal errors relative to a heap, cause fatal handler to be called. + * 3. Fatal errors without context, cause the default (not heap specific) + * fatal handler to be called. + * + * Fatal errors without context are used by debug code such as assertions. + * By providing a fatal error handler for a Duktape heap, user code can + * avoid fatal errors without context in non-debug builds. + */ + +#if !defined(DUK_ERROR_H_INCLUDED) +#define DUK_ERROR_H_INCLUDED + +/* + * Error codes: defined in duktape.h + * + * Error codes are used as a shorthand to throw exceptions from inside + * the implementation. The appropriate ECMAScript object is constructed + * based on the code. ECMAScript code throws objects directly. The error + * codes are defined in the public API header because they are also used + * by calling code. + */ + +/* + * Normal error + * + * Normal error is thrown with a longjmp() through the current setjmp() + * catchpoint record in the duk_heap. The 'curr_thread' of the duk_heap + * identifies the throwing thread. + * + * Error formatting is usually unnecessary. The error macros provide a + * zero argument version (no formatting) and separate macros for small + * argument counts. Variadic macros are not used to avoid portability + * issues and avoid the need for stash-based workarounds when they're not + * available. Vararg calls are avoided for non-formatted error calls + * because vararg call sites are larger than normal, and there are a lot + * of call sites with no formatting. + * + * Note that special formatting provided by debug macros is NOT available. + * + * The _RAW variants allow the caller to specify file and line. This makes + * it easier to write checked calls which want to use the call site of the + * checked function, not the error macro call inside the checked function. + */ + +#if defined(DUK_USE_VERBOSE_ERRORS) + +/* Because there are quite many call sites, pack error code (require at most + * 8-bit) into a single argument. + */ +#define DUK_ERROR(thr, err, msg) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) DUK_LINE_MACRO; \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error((thr), DUK_FILE_MACRO, (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), (msg)); \ + } while (0) +#define DUK_ERROR_RAW(thr, file, line, err, msg) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) (line); \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error((thr), (file), (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), (msg)); \ + } while (0) + +#define DUK_ERROR_FMT1(thr, err, fmt, arg1) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) DUK_LINE_MACRO; \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error_fmt((thr), \ + DUK_FILE_MACRO, \ + (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), \ + (fmt), \ + (arg1)); \ + } while (0) +#define DUK_ERROR_RAW_FMT1(thr, file, line, err, fmt, arg1) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) (line); \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error_fmt((thr), \ + (file), \ + (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), \ + (fmt), \ + (arg1)); \ + } while (0) + +#define DUK_ERROR_FMT2(thr, err, fmt, arg1, arg2) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) DUK_LINE_MACRO; \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error_fmt((thr), \ + DUK_FILE_MACRO, \ + (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), \ + (fmt), \ + (arg1), \ + (arg2)); \ + } while (0) +#define DUK_ERROR_RAW_FMT2(thr, file, line, err, fmt, arg1, arg2) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) (line); \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error_fmt((thr), \ + (file), \ + (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), \ + (fmt), \ + (arg1), \ + (arg2)); \ + } while (0) + +#define DUK_ERROR_FMT3(thr, err, fmt, arg1, arg2, arg3) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) DUK_LINE_MACRO; \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error_fmt((thr), \ + DUK_FILE_MACRO, \ + (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), \ + (fmt), \ + (arg1), \ + (arg2), \ + (arg3)); \ + } while (0) +#define DUK_ERROR_RAW_FMT3(thr, file, line, err, fmt, arg1, arg2, arg3) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) (line); \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error_fmt((thr), \ + (file), \ + (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), \ + (fmt), \ + (arg1), \ + (arg2), \ + (arg3)); \ + } while (0) + +#define DUK_ERROR_FMT4(thr, err, fmt, arg1, arg2, arg3, arg4) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) DUK_LINE_MACRO; \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error_fmt((thr), \ + DUK_FILE_MACRO, \ + (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), \ + (fmt), \ + (arg1), \ + (arg2), \ + (arg3), \ + (arg4)); \ + } while (0) +#define DUK_ERROR_RAW_FMT4(thr, file, line, err, fmt, arg1, arg2, arg3, arg4) \ + do { \ + duk_errcode_t duk__err = (err); \ + duk_int_t duk__line = (duk_int_t) (line); \ + DUK_ASSERT(duk__err >= 0 && duk__err <= 0xff); \ + DUK_ASSERT(duk__line >= 0 && duk__line <= 0x00ffffffL); \ + duk_err_handle_error_fmt((thr), \ + (file), \ + (((duk_uint_t) duk__err) << 24) | ((duk_uint_t) duk__line), \ + (fmt), \ + (arg1), \ + (arg2), \ + (arg3), \ + (arg4)); \ + } while (0) + +#else /* DUK_USE_VERBOSE_ERRORS */ + +#define DUK_ERROR(thr, err, msg) duk_err_handle_error((thr), (err)) +#define DUK_ERROR_RAW(thr, file, line, err, msg) duk_err_handle_error((thr), (err)) + +#define DUK_ERROR_FMT1(thr, err, fmt, arg1) DUK_ERROR((thr), (err), (fmt)) +#define DUK_ERROR_RAW_FMT1(thr, file, line, err, fmt, arg1) DUK_ERROR_RAW((thr), (file), (line), (err), (fmt)) + +#define DUK_ERROR_FMT2(thr, err, fmt, arg1, arg2) DUK_ERROR((thr), (err), (fmt)) +#define DUK_ERROR_RAW_FMT2(thr, file, line, err, fmt, arg1, arg2) DUK_ERROR_RAW((thr), (file), (line), (err), (fmt)) + +#define DUK_ERROR_FMT3(thr, err, fmt, arg1, arg2, arg3) DUK_ERROR((thr), (err), (fmt)) +#define DUK_ERROR_RAW_FMT3(thr, file, line, err, fmt, arg1, arg2, arg3) DUK_ERROR_RAW((thr), (file), (line), (err), (fmt)) + +#define DUK_ERROR_FMT4(thr, err, fmt, arg1, arg2, arg3, arg4) DUK_ERROR((thr), (err), (fmt)) +#define DUK_ERROR_RAW_FMT4(thr, file, line, err, fmt, arg1, arg2, arg3, arg4) DUK_ERROR_RAW((thr), (file), (line), (err), (fmt)) + +#endif /* DUK_USE_VERBOSE_ERRORS */ + +/* + * Fatal error without context + * + * The macro is an expression to make it compatible with DUK_ASSERT_EXPR(). + */ + +#define DUK_FATAL_WITHOUT_CONTEXT(msg) duk_default_fatal_handler(NULL, (msg)) + +/* + * Error throwing helpers + * + * The goal is to provide verbose and configurable error messages. Call + * sites should be clean in source code and compile to a small footprint. + * Small footprint is also useful for performance because small cold paths + * reduce code cache pressure. Adding macros here only makes sense if there + * are enough call sites to get concrete benefits. + * + * DUK_ERROR_xxx() macros are generic and can be used anywhere. + * + * DUK_DCERROR_xxx() macros can only be used in Duktape/C functions where + * the "return DUK_RET_xxx;" shorthand is available for low memory targets. + * The DUK_DCERROR_xxx() macros always either throw or perform a + * 'return DUK_RET_xxx' from the calling function. + */ + +#if defined(DUK_USE_VERBOSE_ERRORS) +/* Verbose errors with key/value summaries (non-paranoid) or without key/value + * summaries (paranoid, for some security sensitive environments), the paranoid + * vs. non-paranoid distinction affects only a few specific errors. + */ +#if defined(DUK_USE_PARANOID_ERRORS) +#define DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, expectname, lowmemstr) \ + do { \ + duk_err_require_type_index((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO, (idx), (expectname)); \ + } while (0) +#else /* DUK_USE_PARANOID_ERRORS */ +#define DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, expectname, lowmemstr) \ + do { \ + duk_err_require_type_index((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO, (idx), (expectname)); \ + } while (0) +#endif /* DUK_USE_PARANOID_ERRORS */ + +#define DUK_ERROR_INTERNAL(thr) \ + do { \ + duk_err_error_internal((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO); \ + } while (0) +#define DUK_DCERROR_INTERNAL(thr) \ + do { \ + DUK_ERROR_INTERNAL((thr)); \ + return 0; \ + } while (0) +#define DUK_ERROR_ALLOC_FAILED(thr) \ + do { \ + duk_err_error_alloc_failed((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO); \ + } while (0) +#define DUK_ERROR_UNSUPPORTED(thr) \ + do { \ + DUK_ERROR((thr), DUK_ERR_ERROR, DUK_STR_UNSUPPORTED); \ + } while (0) +#define DUK_DCERROR_UNSUPPORTED(thr) \ + do { \ + DUK_ERROR_UNSUPPORTED((thr)); \ + return 0; \ + } while (0) +#define DUK_ERROR_ERROR(thr, msg) \ + do { \ + duk_err_error((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO, (msg)); \ + } while (0) +#define DUK_ERROR_RANGE_INDEX(thr, idx) \ + do { \ + duk_err_range_index((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO, (idx)); \ + } while (0) +#define DUK_ERROR_RANGE_PUSH_BEYOND(thr) \ + do { \ + duk_err_range_push_beyond((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO); \ + } while (0) +#define DUK_ERROR_RANGE_INVALID_ARGS(thr) \ + do { \ + DUK_ERROR_RANGE((thr), DUK_STR_INVALID_ARGS); \ + } while (0) +#define DUK_DCERROR_RANGE_INVALID_ARGS(thr) \ + do { \ + DUK_ERROR_RANGE_INVALID_ARGS((thr)); \ + return 0; \ + } while (0) +#define DUK_ERROR_RANGE_INVALID_COUNT(thr) \ + do { \ + DUK_ERROR_RANGE((thr), DUK_STR_INVALID_COUNT); \ + } while (0) +#define DUK_DCERROR_RANGE_INVALID_COUNT(thr) \ + do { \ + DUK_ERROR_RANGE_INVALID_COUNT((thr)); \ + return 0; \ + } while (0) +#define DUK_ERROR_RANGE_INVALID_LENGTH(thr) \ + do { \ + DUK_ERROR_RANGE((thr), DUK_STR_INVALID_LENGTH); \ + } while (0) +#define DUK_DCERROR_RANGE_INVALID_LENGTH(thr) \ + do { \ + DUK_ERROR_RANGE_INVALID_LENGTH((thr)); \ + return 0; \ + } while (0) +#define DUK_ERROR_RANGE(thr, msg) \ + do { \ + duk_err_range((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO, (msg)); \ + } while (0) +#define DUK_ERROR_EVAL(thr, msg) \ + do { \ + DUK_ERROR((thr), DUK_ERR_EVAL_ERROR, (msg)); \ + } while (0) +#define DUK_ERROR_REFERENCE(thr, msg) \ + do { \ + DUK_ERROR((thr), DUK_ERR_REFERENCE_ERROR, (msg)); \ + } while (0) +#define DUK_ERROR_SYNTAX(thr, msg) \ + do { \ + DUK_ERROR((thr), DUK_ERR_SYNTAX_ERROR, (msg)); \ + } while (0) +#define DUK_ERROR_TYPE_INVALID_ARGS(thr) \ + do { \ + duk_err_type_invalid_args((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO); \ + } while (0) +#define DUK_DCERROR_TYPE_INVALID_ARGS(thr) \ + do { \ + DUK_ERROR_TYPE_INVALID_ARGS((thr)); \ + return 0; \ + } while (0) +#define DUK_ERROR_TYPE_INVALID_STATE(thr) \ + do { \ + duk_err_type_invalid_state((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO); \ + } while (0) +#define DUK_DCERROR_TYPE_INVALID_STATE(thr) \ + do { \ + DUK_ERROR_TYPE_INVALID_STATE((thr)); \ + return 0; \ + } while (0) +#define DUK_ERROR_TYPE_INVALID_TRAP_RESULT(thr) \ + do { \ + duk_err_type_invalid_trap_result((thr), DUK_FILE_MACRO, (duk_int_t) DUK_LINE_MACRO); \ + } while (0) +#define DUK_DCERROR_TYPE_INVALID_TRAP_RESULT(thr) \ + do { \ + DUK_ERROR_TYPE((thr), DUK_STR_INVALID_TRAP_RESULT); \ + } while (0) +#define DUK_ERROR_TYPE(thr, msg) \ + do { \ + DUK_ERROR((thr), DUK_ERR_TYPE_ERROR, (msg)); \ + } while (0) +#define DUK_ERROR_URI(thr, msg) \ + do { \ + DUK_ERROR((thr), DUK_ERR_URI_ERROR, (msg)); \ + } while (0) +#else /* DUK_USE_VERBOSE_ERRORS */ +/* Non-verbose errors for low memory targets: no file, line, or message. */ + +#define DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, expectname, lowmemstr) \ + do { \ + duk_err_type((thr)); \ + } while (0) + +#define DUK_ERROR_INTERNAL(thr) \ + do { \ + duk_err_error((thr)); \ + } while (0) +#define DUK_DCERROR_INTERNAL(thr) \ + do { \ + DUK_UNREF((thr)); \ + return DUK_RET_ERROR; \ + } while (0) +#define DUK_ERROR_ALLOC_FAILED(thr) \ + do { \ + duk_err_error((thr)); \ + } while (0) +#define DUK_ERROR_UNSUPPORTED(thr) \ + do { \ + duk_err_error((thr)); \ + } while (0) +#define DUK_DCERROR_UNSUPPORTED(thr) \ + do { \ + DUK_UNREF((thr)); \ + return DUK_RET_ERROR; \ + } while (0) +#define DUK_ERROR_ERROR(thr, msg) \ + do { \ + duk_err_error((thr)); \ + } while (0) +#define DUK_ERROR_RANGE_INDEX(thr, idx) \ + do { \ + duk_err_range((thr)); \ + } while (0) +#define DUK_ERROR_RANGE_PUSH_BEYOND(thr) \ + do { \ + duk_err_range((thr)); \ + } while (0) +#define DUK_ERROR_RANGE_INVALID_ARGS(thr) \ + do { \ + duk_err_range((thr)); \ + } while (0) +#define DUK_DCERROR_RANGE_INVALID_ARGS(thr) \ + do { \ + DUK_UNREF((thr)); \ + return DUK_RET_RANGE_ERROR; \ + } while (0) +#define DUK_ERROR_RANGE_INVALID_COUNT(thr) \ + do { \ + duk_err_range((thr)); \ + } while (0) +#define DUK_DCERROR_RANGE_INVALID_COUNT(thr) \ + do { \ + DUK_UNREF((thr)); \ + return DUK_RET_RANGE_ERROR; \ + } while (0) +#define DUK_ERROR_RANGE_INVALID_LENGTH(thr) \ + do { \ + duk_err_range((thr)); \ + } while (0) +#define DUK_DCERROR_RANGE_INVALID_LENGTH(thr) \ + do { \ + DUK_UNREF((thr)); \ + return DUK_RET_RANGE_ERROR; \ + } while (0) +#define DUK_ERROR_RANGE(thr, msg) \ + do { \ + duk_err_range((thr)); \ + } while (0) +#define DUK_ERROR_EVAL(thr, msg) \ + do { \ + duk_err_eval((thr)); \ + } while (0) +#define DUK_ERROR_REFERENCE(thr, msg) \ + do { \ + duk_err_reference((thr)); \ + } while (0) +#define DUK_ERROR_SYNTAX(thr, msg) \ + do { \ + duk_err_syntax((thr)); \ + } while (0) +#define DUK_ERROR_TYPE_INVALID_ARGS(thr) \ + do { \ + duk_err_type((thr)); \ + } while (0) +#define DUK_DCERROR_TYPE_INVALID_ARGS(thr) \ + do { \ + DUK_UNREF((thr)); \ + return DUK_RET_TYPE_ERROR; \ + } while (0) +#define DUK_ERROR_TYPE_INVALID_STATE(thr) \ + do { \ + duk_err_type((thr)); \ + } while (0) +#define DUK_DCERROR_TYPE_INVALID_STATE(thr) \ + do { \ + duk_err_type((thr)); \ + } while (0) +#define DUK_ERROR_TYPE_INVALID_TRAP_RESULT(thr) \ + do { \ + duk_err_type((thr)); \ + } while (0) +#define DUK_DCERROR_TYPE_INVALID_TRAP_RESULT(thr) \ + do { \ + DUK_UNREF((thr)); \ + return DUK_RET_TYPE_ERROR; \ + } while (0) +#define DUK_ERROR_TYPE_INVALID_TRAP_RESULT(thr) \ + do { \ + duk_err_type((thr)); \ + } while (0) +#define DUK_ERROR_TYPE(thr, msg) \ + do { \ + duk_err_type((thr)); \ + } while (0) +#define DUK_ERROR_URI(thr, msg) \ + do { \ + duk_err_uri((thr)); \ + } while (0) +#endif /* DUK_USE_VERBOSE_ERRORS */ + +/* + * Assert macro: failure causes a fatal error. + * + * NOTE: since the assert macro doesn't take a heap/context argument, there's + * no way to look up a heap/context specific fatal error handler which may have + * been given by the application. Instead, assertion failures always use the + * internal default fatal error handler; it can be replaced via duk_config.h + * and then applies to all Duktape heaps. + */ + +#if defined(DUK_USE_ASSERTIONS) + +/* The message should be a compile time constant without formatting (less risk); + * we don't care about assertion text size because they're not used in production + * builds. + */ +#define DUK_ASSERT(x) \ + do { \ + if (!(x)) { \ + DUK_FATAL_WITHOUT_CONTEXT("assertion failed: " #x " (" DUK_FILE_MACRO \ + ":" DUK_MACRO_STRINGIFY(DUK_LINE_MACRO) ")"); \ + } \ + } while (0) + +/* Assertion compatible inside a comma expression, evaluates to void. */ +#define DUK_ASSERT_EXPR(x) \ + ((void) ((x) ? 0 : \ + (DUK_FATAL_WITHOUT_CONTEXT("assertion failed: " #x " (" DUK_FILE_MACRO \ + ":" DUK_MACRO_STRINGIFY(DUK_LINE_MACRO) ")"), \ + 0))) + +#else /* DUK_USE_ASSERTIONS */ + +#define DUK_ASSERT(x) \ + do { /* assertion omitted */ \ + } while (0) + +#define DUK_ASSERT_EXPR(x) ((void) 0) + +#endif /* DUK_USE_ASSERTIONS */ + +/* this variant is used when an assert would generate a compile warning by + * being always true (e.g. >= 0 comparison for an unsigned value + */ +#define DUK_ASSERT_DISABLE(x) \ + do { /* assertion disabled */ \ + } while (0) + +/* + * Assertion helpers + */ + +#if defined(DUK_USE_ASSERTIONS) && defined(DUK_USE_REFERENCE_COUNTING) +#define DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR(h) \ + do { \ + DUK_ASSERT((h) == NULL || DUK_HEAPHDR_GET_REFCOUNT((duk_heaphdr *) (h)) > 0); \ + } while (0) +#define DUK_ASSERT_REFCOUNT_NONZERO_TVAL(tv) \ + do { \ + if ((tv) != NULL && DUK_TVAL_IS_HEAP_ALLOCATED((tv))) { \ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(DUK_TVAL_GET_HEAPHDR((tv))) > 0); \ + } \ + } while (0) +#else +#define DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR(h) /* no refcount check */ +#define DUK_ASSERT_REFCOUNT_NONZERO_TVAL(tv) /* no refcount check */ +#endif + +#define DUK_ASSERT_TOP(ctx, n) DUK_ASSERT((duk_idx_t) duk_get_top((ctx)) == (duk_idx_t) (n)) + +#if defined(DUK_USE_ASSERTIONS) && defined(DUK_USE_PACKED_TVAL) +#define DUK_ASSERT_DOUBLE_IS_NORMALIZED(dval) \ + do { \ + duk_double_union duk__assert_tmp_du; \ + duk__assert_tmp_du.d = (dval); \ + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&duk__assert_tmp_du)); \ + } while (0) +#else +#define DUK_ASSERT_DOUBLE_IS_NORMALIZED(dval) /* nop */ +#endif + +#define DUK_ASSERT_VS_SPACE(thr) DUK_ASSERT(thr->valstack_top < thr->valstack_end) + +/* + * Helper to initialize a memory area (e.g. struct) with garbage when + * assertions enabled. + */ + +#if defined(DUK_USE_ASSERTIONS) +#define DUK_ASSERT_SET_GARBAGE(ptr, size) \ + do { \ + duk_memset_unsafe((void *) (ptr), 0x5a, size); \ + } while (0) +#else +#define DUK_ASSERT_SET_GARBAGE(ptr, size) \ + do { \ + } while (0) +#endif + +/* + * Helper for valstack space + * + * Caller of DUK_ASSERT_VALSTACK_SPACE() estimates the number of free stack entries + * required for its own use, and any child calls which are not (a) Duktape API calls + * or (b) Duktape calls which involve extending the valstack (e.g. getter call). + */ + +#define DUK_VALSTACK_ASSERT_EXTRA \ + 5 /* this is added to checks to allow for Duktape \ + * API calls in addition to function's own use \ + */ +#if defined(DUK_USE_ASSERTIONS) +#define DUK_ASSERT_VALSTACK_SPACE(thr, n) \ + do { \ + DUK_ASSERT((thr) != NULL); \ + DUK_ASSERT((thr)->valstack_end - (thr)->valstack_top >= (n) + DUK_VALSTACK_ASSERT_EXTRA); \ + } while (0) +#else +#define DUK_ASSERT_VALSTACK_SPACE(thr, n) /* no valstack space check */ +#endif + +/* + * Prototypes + */ + +#if defined(DUK_USE_VERBOSE_ERRORS) +DUK_NORETURN( + DUK_INTERNAL_DECL void duk_err_handle_error(duk_hthread *thr, const char *filename, duk_uint_t line_and_code, const char *msg)); +DUK_NORETURN(DUK_INTERNAL_DECL void + duk_err_handle_error_fmt(duk_hthread *thr, const char *filename, duk_uint_t line_and_code, const char *fmt, ...)); +#else /* DUK_USE_VERBOSE_ERRORS */ +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_handle_error(duk_hthread *thr, duk_errcode_t code)); +#endif /* DUK_USE_VERBOSE_ERRORS */ + +#if defined(DUK_USE_VERBOSE_ERRORS) +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_create_and_throw(duk_hthread *thr, + duk_errcode_t code, + const char *msg, + const char *filename, + duk_int_t line)); +#else +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_create_and_throw(duk_hthread *thr, duk_errcode_t code)); +#endif + +DUK_NORETURN(DUK_INTERNAL_DECL void duk_error_throw_from_negative_rc(duk_hthread *thr, duk_ret_t rc)); + +#define DUK_AUGMENT_FLAG_NOBLAME_FILELINE (1U << 0) /* if set, don't blame C file/line for .fileName and .lineNumber */ +#define DUK_AUGMENT_FLAG_SKIP_ONE (1U << 1) /* if set, skip topmost activation in traceback construction */ + +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) +DUK_INTERNAL_DECL void duk_err_augment_error_create(duk_hthread *thr, + duk_hthread *thr_callstack, + const char *filename, + duk_int_t line, + duk_small_uint_t flags); +#endif +#if defined(DUK_USE_AUGMENT_ERROR_THROW) +DUK_INTERNAL_DECL void duk_err_augment_error_throw(duk_hthread *thr); +#endif + +#if defined(DUK_USE_VERBOSE_ERRORS) +#if defined(DUK_USE_PARANOID_ERRORS) +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_require_type_index(duk_hthread *thr, + const char *filename, + duk_int_t linenumber, + duk_idx_t idx, + const char *expect_name)); +#else +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_require_type_index(duk_hthread *thr, + const char *filename, + duk_int_t linenumber, + duk_idx_t idx, + const char *expect_name)); +#endif +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_error_internal(duk_hthread *thr, const char *filename, duk_int_t linenumber)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_error_alloc_failed(duk_hthread *thr, const char *filename, duk_int_t linenumber)); +DUK_NORETURN( + DUK_INTERNAL_DECL void duk_err_error(duk_hthread *thr, const char *filename, duk_int_t linenumber, const char *message)); +DUK_NORETURN( + DUK_INTERNAL_DECL void duk_err_range_index(duk_hthread *thr, const char *filename, duk_int_t linenumber, duk_idx_t idx)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_range_push_beyond(duk_hthread *thr, const char *filename, duk_int_t linenumber)); +DUK_NORETURN( + DUK_INTERNAL_DECL void duk_err_range(duk_hthread *thr, const char *filename, duk_int_t linenumber, const char *message)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_type_invalid_args(duk_hthread *thr, const char *filename, duk_int_t linenumber)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_type_invalid_state(duk_hthread *thr, const char *filename, duk_int_t linenumber)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_type_invalid_trap_result(duk_hthread *thr, const char *filename, duk_int_t linenumber)); +#else /* DUK_VERBOSE_ERRORS */ +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_error(duk_hthread *thr)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_range(duk_hthread *thr)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_eval(duk_hthread *thr)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_reference(duk_hthread *thr)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_syntax(duk_hthread *thr)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_type(duk_hthread *thr)); +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_uri(duk_hthread *thr)); +#endif /* DUK_VERBOSE_ERRORS */ + +DUK_NORETURN(DUK_INTERNAL_DECL void duk_err_longjmp(duk_hthread *thr)); + +DUK_NORETURN(DUK_INTERNAL_DECL void duk_default_fatal_handler(void *udata, const char *msg)); + +DUK_INTERNAL_DECL void duk_err_setup_ljstate1(duk_hthread *thr, duk_small_uint_t lj_type, duk_tval *tv_val); +#if defined(DUK_USE_DEBUGGER_SUPPORT) +DUK_INTERNAL_DECL void duk_err_check_debugger_integration(duk_hthread *thr); +#endif + +DUK_INTERNAL_DECL duk_hobject *duk_error_prototype_from_code(duk_hthread *thr, duk_errcode_t err_code); + +#endif /* DUK_ERROR_H_INCLUDED */ +/* #include duk_unicode.h */ +#line 1 "duk_unicode.h" +/* + * Unicode helpers + */ + +#if !defined(DUK_UNICODE_H_INCLUDED) +#define DUK_UNICODE_H_INCLUDED + +/* + * UTF-8 / XUTF-8 / CESU-8 constants + */ + +#define DUK_UNICODE_MAX_XUTF8_LENGTH 7 /* up to 36 bit codepoints */ +#define DUK_UNICODE_MAX_XUTF8_BMP_LENGTH 3 /* all codepoints up to U+FFFF */ +#define DUK_UNICODE_MAX_CESU8_LENGTH 6 /* all codepoints up to U+10FFFF */ +#define DUK_UNICODE_MAX_CESU8_BMP_LENGTH 3 /* all codepoints up to U+FFFF */ + +/* + * Useful Unicode codepoints + * + * Integer constants must be signed to avoid unexpected coercions + * in comparisons. + */ + +#define DUK_UNICODE_CP_ZWNJ 0x200cL /* zero-width non-joiner */ +#define DUK_UNICODE_CP_ZWJ 0x200dL /* zero-width joiner */ +#define DUK_UNICODE_CP_REPLACEMENT_CHARACTER \ + 0xfffdL /* http://en.wikipedia.org/wiki/Replacement_character#Replacement_character \ + */ + +/* + * ASCII character constants + * + * C character literals like 'x' have a platform specific value and do + * not match ASCII (UTF-8) values on e.g. EBCDIC platforms. So, use + * these (admittedly awkward) constants instead. These constants must + * also have signed values to avoid unexpected coercions in comparisons. + * + * http://en.wikipedia.org/wiki/ASCII + */ + +#define DUK_ASC_NUL 0x00 +#define DUK_ASC_SOH 0x01 +#define DUK_ASC_STX 0x02 +#define DUK_ASC_ETX 0x03 +#define DUK_ASC_EOT 0x04 +#define DUK_ASC_ENQ 0x05 +#define DUK_ASC_ACK 0x06 +#define DUK_ASC_BEL 0x07 +#define DUK_ASC_BS 0x08 +#define DUK_ASC_HT 0x09 +#define DUK_ASC_LF 0x0a +#define DUK_ASC_VT 0x0b +#define DUK_ASC_FF 0x0c +#define DUK_ASC_CR 0x0d +#define DUK_ASC_SO 0x0e +#define DUK_ASC_SI 0x0f +#define DUK_ASC_DLE 0x10 +#define DUK_ASC_DC1 0x11 +#define DUK_ASC_DC2 0x12 +#define DUK_ASC_DC3 0x13 +#define DUK_ASC_DC4 0x14 +#define DUK_ASC_NAK 0x15 +#define DUK_ASC_SYN 0x16 +#define DUK_ASC_ETB 0x17 +#define DUK_ASC_CAN 0x18 +#define DUK_ASC_EM 0x19 +#define DUK_ASC_SUB 0x1a +#define DUK_ASC_ESC 0x1b +#define DUK_ASC_FS 0x1c +#define DUK_ASC_GS 0x1d +#define DUK_ASC_RS 0x1e +#define DUK_ASC_US 0x1f +#define DUK_ASC_SPACE 0x20 +#define DUK_ASC_EXCLAMATION 0x21 +#define DUK_ASC_DOUBLEQUOTE 0x22 +#define DUK_ASC_HASH 0x23 +#define DUK_ASC_DOLLAR 0x24 +#define DUK_ASC_PERCENT 0x25 +#define DUK_ASC_AMP 0x26 +#define DUK_ASC_SINGLEQUOTE 0x27 +#define DUK_ASC_LPAREN 0x28 +#define DUK_ASC_RPAREN 0x29 +#define DUK_ASC_STAR 0x2a +#define DUK_ASC_PLUS 0x2b +#define DUK_ASC_COMMA 0x2c +#define DUK_ASC_MINUS 0x2d +#define DUK_ASC_PERIOD 0x2e +#define DUK_ASC_SLASH 0x2f +#define DUK_ASC_0 0x30 +#define DUK_ASC_1 0x31 +#define DUK_ASC_2 0x32 +#define DUK_ASC_3 0x33 +#define DUK_ASC_4 0x34 +#define DUK_ASC_5 0x35 +#define DUK_ASC_6 0x36 +#define DUK_ASC_7 0x37 +#define DUK_ASC_8 0x38 +#define DUK_ASC_9 0x39 +#define DUK_ASC_COLON 0x3a +#define DUK_ASC_SEMICOLON 0x3b +#define DUK_ASC_LANGLE 0x3c +#define DUK_ASC_EQUALS 0x3d +#define DUK_ASC_RANGLE 0x3e +#define DUK_ASC_QUESTION 0x3f +#define DUK_ASC_ATSIGN 0x40 +#define DUK_ASC_UC_A 0x41 +#define DUK_ASC_UC_B 0x42 +#define DUK_ASC_UC_C 0x43 +#define DUK_ASC_UC_D 0x44 +#define DUK_ASC_UC_E 0x45 +#define DUK_ASC_UC_F 0x46 +#define DUK_ASC_UC_G 0x47 +#define DUK_ASC_UC_H 0x48 +#define DUK_ASC_UC_I 0x49 +#define DUK_ASC_UC_J 0x4a +#define DUK_ASC_UC_K 0x4b +#define DUK_ASC_UC_L 0x4c +#define DUK_ASC_UC_M 0x4d +#define DUK_ASC_UC_N 0x4e +#define DUK_ASC_UC_O 0x4f +#define DUK_ASC_UC_P 0x50 +#define DUK_ASC_UC_Q 0x51 +#define DUK_ASC_UC_R 0x52 +#define DUK_ASC_UC_S 0x53 +#define DUK_ASC_UC_T 0x54 +#define DUK_ASC_UC_U 0x55 +#define DUK_ASC_UC_V 0x56 +#define DUK_ASC_UC_W 0x57 +#define DUK_ASC_UC_X 0x58 +#define DUK_ASC_UC_Y 0x59 +#define DUK_ASC_UC_Z 0x5a +#define DUK_ASC_LBRACKET 0x5b +#define DUK_ASC_BACKSLASH 0x5c +#define DUK_ASC_RBRACKET 0x5d +#define DUK_ASC_CARET 0x5e +#define DUK_ASC_UNDERSCORE 0x5f +#define DUK_ASC_GRAVE 0x60 +#define DUK_ASC_LC_A 0x61 +#define DUK_ASC_LC_B 0x62 +#define DUK_ASC_LC_C 0x63 +#define DUK_ASC_LC_D 0x64 +#define DUK_ASC_LC_E 0x65 +#define DUK_ASC_LC_F 0x66 +#define DUK_ASC_LC_G 0x67 +#define DUK_ASC_LC_H 0x68 +#define DUK_ASC_LC_I 0x69 +#define DUK_ASC_LC_J 0x6a +#define DUK_ASC_LC_K 0x6b +#define DUK_ASC_LC_L 0x6c +#define DUK_ASC_LC_M 0x6d +#define DUK_ASC_LC_N 0x6e +#define DUK_ASC_LC_O 0x6f +#define DUK_ASC_LC_P 0x70 +#define DUK_ASC_LC_Q 0x71 +#define DUK_ASC_LC_R 0x72 +#define DUK_ASC_LC_S 0x73 +#define DUK_ASC_LC_T 0x74 +#define DUK_ASC_LC_U 0x75 +#define DUK_ASC_LC_V 0x76 +#define DUK_ASC_LC_W 0x77 +#define DUK_ASC_LC_X 0x78 +#define DUK_ASC_LC_Y 0x79 +#define DUK_ASC_LC_Z 0x7a +#define DUK_ASC_LCURLY 0x7b +#define DUK_ASC_PIPE 0x7c +#define DUK_ASC_RCURLY 0x7d +#define DUK_ASC_TILDE 0x7e +#define DUK_ASC_DEL 0x7f + +/* + * Miscellaneous + */ + +/* Uppercase A is 0x41, lowercase a is 0x61; OR 0x20 to convert uppercase + * to lowercase. + */ +#define DUK_LOWERCASE_CHAR_ASCII(x) ((x) | 0x20) + +/* + * Unicode tables + */ + +#if defined(DUK_USE_SOURCE_NONBMP) +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +extern const duk_uint8_t duk_unicode_ids_noa[1116]; +#else +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +extern const duk_uint8_t duk_unicode_ids_noabmp[625]; +#endif + +#if defined(DUK_USE_SOURCE_NONBMP) +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +extern const duk_uint8_t duk_unicode_ids_m_let_noa[42]; +#else +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +extern const duk_uint8_t duk_unicode_ids_m_let_noabmp[24]; +#endif + +#if defined(DUK_USE_SOURCE_NONBMP) +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +extern const duk_uint8_t duk_unicode_idp_m_ids_noa[576]; +#else +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +extern const duk_uint8_t duk_unicode_idp_m_ids_noabmp[358]; +#endif + +/* + * Automatically generated by extract_caseconv.py, do not edit! + */ + +extern const duk_uint8_t duk_unicode_caseconv_uc[1411]; +extern const duk_uint8_t duk_unicode_caseconv_lc[706]; + +#if defined(DUK_USE_REGEXP_CANON_WORKAROUND) +/* + * Automatically generated by extract_caseconv.py, do not edit! + */ + +extern const duk_uint16_t duk_unicode_re_canon_lookup[65536]; +#endif + +#if defined(DUK_USE_REGEXP_CANON_BITMAP) +/* + * Automatically generated by extract_caseconv.py, do not edit! + */ + +#define DUK_CANON_BITMAP_BLKSIZE 32 +#define DUK_CANON_BITMAP_BLKSHIFT 5 +#define DUK_CANON_BITMAP_BLKMASK 31 +extern const duk_uint8_t duk_unicode_re_canon_bitmap[256]; +#endif + +/* + * Extern + */ + +/* duk_unicode_support.c */ +#if !defined(DUK_SINGLE_FILE) +DUK_INTERNAL_DECL const duk_uint8_t duk_unicode_xutf8_markers[7]; +DUK_INTERNAL_DECL const duk_uint16_t duk_unicode_re_ranges_digit[2]; +DUK_INTERNAL_DECL const duk_uint16_t duk_unicode_re_ranges_white[22]; +DUK_INTERNAL_DECL const duk_uint16_t duk_unicode_re_ranges_wordchar[8]; +DUK_INTERNAL_DECL const duk_uint16_t duk_unicode_re_ranges_not_digit[4]; +DUK_INTERNAL_DECL const duk_uint16_t duk_unicode_re_ranges_not_white[24]; +DUK_INTERNAL_DECL const duk_uint16_t duk_unicode_re_ranges_not_wordchar[10]; +DUK_INTERNAL_DECL const duk_int8_t duk_is_idchar_tab[128]; +#endif /* !DUK_SINGLE_FILE */ + +/* + * Prototypes + */ + +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_get_xutf8_length(duk_ucodepoint_t cp); +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_get_cesu8_length(duk_ucodepoint_t cp); +#endif +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_encode_xutf8(duk_ucodepoint_t cp, duk_uint8_t *out); +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_encode_cesu8(duk_ucodepoint_t cp, duk_uint8_t *out); +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_decode_xutf8(duk_hthread *thr, + const duk_uint8_t **ptr, + const duk_uint8_t *ptr_start, + const duk_uint8_t *ptr_end, + duk_ucodepoint_t *out_cp); +DUK_INTERNAL_DECL duk_ucodepoint_t duk_unicode_decode_xutf8_checked(duk_hthread *thr, + const duk_uint8_t **ptr, + const duk_uint8_t *ptr_start, + const duk_uint8_t *ptr_end); +DUK_INTERNAL_DECL duk_size_t duk_unicode_unvalidated_utf8_length(const duk_uint8_t *data, duk_size_t blen); +DUK_INTERNAL_DECL duk_bool_t duk_unicode_is_utf8_compatible(const duk_uint8_t *buf, duk_size_t len); +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_is_whitespace(duk_codepoint_t cp); +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_is_line_terminator(duk_codepoint_t cp); +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_is_identifier_start(duk_codepoint_t cp); +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_is_identifier_part(duk_codepoint_t cp); +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_is_letter(duk_codepoint_t cp); +DUK_INTERNAL_DECL void duk_unicode_case_convert_string(duk_hthread *thr, duk_bool_t uppercase); +#if defined(DUK_USE_REGEXP_SUPPORT) +DUK_INTERNAL_DECL duk_codepoint_t duk_unicode_re_canonicalize_char(duk_hthread *thr, duk_codepoint_t cp); +DUK_INTERNAL_DECL duk_small_int_t duk_unicode_re_is_wordchar(duk_codepoint_t cp); +#endif + +#endif /* DUK_UNICODE_H_INCLUDED */ +/* #include duk_json.h */ +#line 1 "duk_json.h" +/* + * Defines for JSON, especially duk_bi_json.c. + */ + +#if !defined(DUK_JSON_H_INCLUDED) +#define DUK_JSON_H_INCLUDED + +/* Encoding/decoding flags */ +#define DUK_JSON_FLAG_ASCII_ONLY (1U << 0) /* escape any non-ASCII characters */ +#define DUK_JSON_FLAG_AVOID_KEY_QUOTES (1U << 1) /* avoid key quotes when key is an ASCII Identifier */ +#define DUK_JSON_FLAG_EXT_CUSTOM (1U << 2) /* extended types: custom encoding */ +#define DUK_JSON_FLAG_EXT_COMPATIBLE (1U << 3) /* extended types: compatible encoding */ + +/* How much stack to require on entry to object/array encode */ +#define DUK_JSON_ENC_REQSTACK 32 + +/* How much stack to require on entry to object/array decode */ +#define DUK_JSON_DEC_REQSTACK 32 + +/* How large a loop detection stack to use */ +#define DUK_JSON_ENC_LOOPARRAY 64 + +/* Encoding state. Heap object references are all borrowed. */ +typedef struct { + duk_hthread *thr; + duk_bufwriter_ctx bw; /* output bufwriter */ + duk_hobject *h_replacer; /* replacer function */ + duk_hstring *h_gap; /* gap (if empty string, NULL) */ + duk_idx_t idx_proplist; /* explicit PropertyList */ + duk_idx_t idx_loop; /* valstack index of loop detection object */ + duk_small_uint_t flags; + duk_small_uint_t flag_ascii_only; + duk_small_uint_t flag_avoid_key_quotes; +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + duk_small_uint_t flag_ext_custom; + duk_small_uint_t flag_ext_compatible; + duk_small_uint_t flag_ext_custom_or_compatible; +#endif + duk_uint_t recursion_depth; + duk_uint_t recursion_limit; + duk_uint_t mask_for_undefined; /* type bit mask: types which certainly produce 'undefined' */ +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + duk_small_uint_t stridx_custom_undefined; + duk_small_uint_t stridx_custom_nan; + duk_small_uint_t stridx_custom_neginf; + duk_small_uint_t stridx_custom_posinf; + duk_small_uint_t stridx_custom_function; +#endif + duk_hobject *visiting[DUK_JSON_ENC_LOOPARRAY]; /* indexed by recursion_depth */ +} duk_json_enc_ctx; + +typedef struct { + duk_hthread *thr; + const duk_uint8_t *p; + const duk_uint8_t *p_start; + const duk_uint8_t *p_end; + duk_idx_t idx_reviver; + duk_small_uint_t flags; +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + duk_small_uint_t flag_ext_custom; + duk_small_uint_t flag_ext_compatible; + duk_small_uint_t flag_ext_custom_or_compatible; +#endif + duk_int_t recursion_depth; + duk_int_t recursion_limit; +} duk_json_dec_ctx; + +#endif /* DUK_JSON_H_INCLUDED */ +/* #include duk_js.h */ +#line 1 "duk_js.h" +/* + * ECMAScript execution, support primitives. + */ + +#if !defined(DUK_JS_H_INCLUDED) +#define DUK_JS_H_INCLUDED + +/* Flags for call handling. Lowest flags must match bytecode DUK_BC_CALL_FLAG_xxx 1:1. */ +#define DUK_CALL_FLAG_TAILCALL (1U << 0) /* setup for a tail call */ +#define DUK_CALL_FLAG_CONSTRUCT (1U << 1) /* constructor call (i.e. called as 'new Foo()') */ +#define DUK_CALL_FLAG_CALLED_AS_EVAL (1U << 2) /* call was made using the identifier 'eval' */ +#define DUK_CALL_FLAG_ALLOW_ECMATOECMA (1U << 3) /* ecma-to-ecma call with executor reuse is possible */ +#define DUK_CALL_FLAG_DIRECT_EVAL (1U << 4) /* call is a direct eval call */ +#define DUK_CALL_FLAG_CONSTRUCT_PROXY (1U << 5) /* handled via 'construct' proxy trap, check return value invariant(s) */ +#define DUK_CALL_FLAG_DEFAULT_INSTANCE_UPDATED \ + (1U << 6) /* prototype of 'default instance' updated, temporary flag in call handling */ + +/* Flags for duk_js_equals_helper(). */ +#define DUK_EQUALS_FLAG_SAMEVALUE (1U << 0) /* use SameValue instead of non-strict equality */ +#define DUK_EQUALS_FLAG_STRICT (1U << 1) /* use strict equality instead of non-strict equality */ + +/* Flags for duk_js_compare_helper(). */ +#define DUK_COMPARE_FLAG_NEGATE (1U << 0) /* negate result */ +#define DUK_COMPARE_FLAG_EVAL_LEFT_FIRST (1U << 1) /* eval left argument first */ + +/* conversions, coercions, comparison, etc */ +DUK_INTERNAL_DECL duk_bool_t duk_js_toboolean(duk_tval *tv); +DUK_INTERNAL_DECL duk_double_t duk_js_tonumber(duk_hthread *thr, duk_tval *tv); +DUK_INTERNAL_DECL duk_double_t duk_js_tointeger_number(duk_double_t x); +DUK_INTERNAL_DECL duk_double_t duk_js_tointeger(duk_hthread *thr, duk_tval *tv); +DUK_INTERNAL_DECL duk_uint32_t duk_js_touint32(duk_hthread *thr, duk_tval *tv); +DUK_INTERNAL_DECL duk_int32_t duk_js_toint32(duk_hthread *thr, duk_tval *tv); +DUK_INTERNAL_DECL duk_uint16_t duk_js_touint16(duk_hthread *thr, duk_tval *tv); +DUK_INTERNAL_DECL duk_uarridx_t duk_js_to_arrayindex_string(const duk_uint8_t *str, duk_uint32_t blen); +#if !defined(DUK_USE_HSTRING_ARRIDX) +DUK_INTERNAL_DECL duk_uarridx_t duk_js_to_arrayindex_hstring_fast_known(duk_hstring *h); +DUK_INTERNAL_DECL duk_uarridx_t duk_js_to_arrayindex_hstring_fast(duk_hstring *h); +#endif +DUK_INTERNAL_DECL duk_bool_t duk_js_equals_helper(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y, duk_small_uint_t flags); +DUK_INTERNAL_DECL duk_small_int_t duk_js_data_compare(const duk_uint8_t *buf1, + const duk_uint8_t *buf2, + duk_size_t len1, + duk_size_t len2); +DUK_INTERNAL_DECL duk_small_int_t duk_js_string_compare(duk_hstring *h1, duk_hstring *h2); +#if 0 /* unused */ +DUK_INTERNAL_DECL duk_small_int_t duk_js_buffer_compare(duk_heap *heap, duk_hbuffer *h1, duk_hbuffer *h2); +#endif +DUK_INTERNAL_DECL duk_bool_t duk_js_compare_helper(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y, duk_small_uint_t flags); +DUK_INTERNAL_DECL duk_bool_t duk_js_instanceof(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y); +#if defined(DUK_USE_SYMBOL_BUILTIN) +DUK_INTERNAL_DECL duk_bool_t duk_js_instanceof_ordinary(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y); +#endif +DUK_INTERNAL_DECL duk_bool_t duk_js_in(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y); +DUK_INTERNAL_DECL duk_small_uint_t duk_js_typeof_stridx(duk_tval *tv_x); +DUK_INTERNAL_DECL duk_bool_t duk_js_isarray_hobject(duk_hobject *h); +DUK_INTERNAL_DECL duk_bool_t duk_js_isarray(duk_tval *tv); + +/* arithmetic */ +DUK_INTERNAL_DECL double duk_js_arith_pow(double x, double y); +DUK_INTERNAL_DECL double duk_js_arith_mod(double x, double y); + +#define duk_js_equals(thr, tv_x, tv_y) duk_js_equals_helper((thr), (tv_x), (tv_y), 0) +#define duk_js_strict_equals(tv_x, tv_y) duk_js_equals_helper(NULL, (tv_x), (tv_y), DUK_EQUALS_FLAG_STRICT) +#define duk_js_samevalue(tv_x, tv_y) duk_js_equals_helper(NULL, (tv_x), (tv_y), DUK_EQUALS_FLAG_SAMEVALUE) + +/* E5 Sections 11.8.1, 11.8.5; x < y */ +#define duk_js_lessthan(thr, tv_x, tv_y) duk_js_compare_helper((thr), (tv_x), (tv_Y), DUK_COMPARE_FLAG_EVAL_LEFT_FIRST) + +/* E5 Sections 11.8.2, 11.8.5; x > y --> y < x */ +#define duk_js_greaterthan(thr, tv_x, tv_y) duk_js_compare_helper((thr), (tv_y), (tv_x), 0) + +/* E5 Sections 11.8.3, 11.8.5; x <= y --> not (x > y) --> not (y < x) */ +#define duk_js_lessthanorequal(thr, tv_x, tv_y) duk_js_compare_helper((thr), (tv_y), (tv_x), DUK_COMPARE_FLAG_NEGATE) + +/* E5 Sections 11.8.4, 11.8.5; x >= y --> not (x < y) */ +#define duk_js_greaterthanorequal(thr, tv_x, tv_y) \ + duk_js_compare_helper((thr), (tv_x), (tv_y), DUK_COMPARE_FLAG_EVAL_LEFT_FIRST | DUK_COMPARE_FLAG_NEGATE) + +/* identifiers and environment handling */ +#if 0 /*unused*/ +DUK_INTERNAL duk_bool_t duk_js_hasvar_envrec(duk_hthread *thr, duk_hobject *env, duk_hstring *name); +#endif +DUK_INTERNAL_DECL duk_bool_t duk_js_getvar_envrec(duk_hthread *thr, duk_hobject *env, duk_hstring *name, duk_bool_t throw_flag); +DUK_INTERNAL_DECL duk_bool_t duk_js_getvar_activation(duk_hthread *thr, + duk_activation *act, + duk_hstring *name, + duk_bool_t throw_flag); +DUK_INTERNAL_DECL void duk_js_putvar_envrec(duk_hthread *thr, + duk_hobject *env, + duk_hstring *name, + duk_tval *val, + duk_bool_t strict); +DUK_INTERNAL_DECL void duk_js_putvar_activation(duk_hthread *thr, + duk_activation *act, + duk_hstring *name, + duk_tval *val, + duk_bool_t strict); +#if 0 /*unused*/ +DUK_INTERNAL_DECL duk_bool_t duk_js_delvar_envrec(duk_hthread *thr, duk_hobject *env, duk_hstring *name); +#endif +DUK_INTERNAL_DECL duk_bool_t duk_js_delvar_activation(duk_hthread *thr, duk_activation *act, duk_hstring *name); +DUK_INTERNAL_DECL duk_bool_t duk_js_declvar_activation(duk_hthread *thr, + duk_activation *act, + duk_hstring *name, + duk_tval *val, + duk_small_uint_t prop_flags, + duk_bool_t is_func_decl); +DUK_INTERNAL_DECL void duk_js_init_activation_environment_records_delayed(duk_hthread *thr, duk_activation *act); +DUK_INTERNAL_DECL void duk_js_close_environment_record(duk_hthread *thr, duk_hobject *env); +DUK_INTERNAL_DECL duk_hobject *duk_create_activation_environment_record(duk_hthread *thr, + duk_hobject *func, + duk_size_t bottom_byteoff); +DUK_INTERNAL_DECL void duk_js_push_closure(duk_hthread *thr, + duk_hcompfunc *fun_temp, + duk_hobject *outer_var_env, + duk_hobject *outer_lex_env, + duk_bool_t add_auto_proto); + +/* call handling */ +DUK_INTERNAL_DECL void duk_native_stack_check(duk_hthread *thr); +DUK_INTERNAL_DECL duk_int_t duk_handle_call_unprotected(duk_hthread *thr, duk_idx_t idx_func, duk_small_uint_t call_flags); +DUK_INTERNAL_DECL duk_int_t duk_handle_call_unprotected_nargs(duk_hthread *thr, duk_idx_t nargs, duk_small_uint_t call_flags); +DUK_INTERNAL_DECL duk_int_t +duk_handle_safe_call(duk_hthread *thr, duk_safe_call_function func, void *udata, duk_idx_t num_stack_args, duk_idx_t num_stack_res); +DUK_INTERNAL_DECL void duk_call_construct_postprocess(duk_hthread *thr, duk_small_uint_t proxy_invariant); +#if defined(DUK_USE_VERBOSE_ERRORS) +DUK_INTERNAL_DECL void duk_call_setup_propcall_error(duk_hthread *thr, duk_tval *tv_base, duk_tval *tv_key); +#endif + +/* bytecode execution */ +DUK_INTERNAL_DECL void duk_js_execute_bytecode(duk_hthread *exec_thr); + +#endif /* DUK_JS_H_INCLUDED */ +/* #include duk_numconv.h */ +#line 1 "duk_numconv.h" +/* + * Number-to-string conversion. The semantics of these is very tightly + * bound with the ECMAScript semantics required for call sites. + */ + +#if !defined(DUK_NUMCONV_H_INCLUDED) +#define DUK_NUMCONV_H_INCLUDED + +/* Output a specified number of digits instead of using the shortest + * form. Used for toPrecision() and toFixed(). + */ +#define DUK_N2S_FLAG_FIXED_FORMAT (1U << 0) + +/* Force exponential format. Used for toExponential(). */ +#define DUK_N2S_FLAG_FORCE_EXP (1U << 1) + +/* If number would need zero padding (for whole number part), use + * exponential format instead. E.g. if input number is 12300, 3 + * digits are generated ("123"), output "1.23e+4" instead of "12300". + * Used for toPrecision(). + */ +#define DUK_N2S_FLAG_NO_ZERO_PAD (1U << 2) + +/* Digit count indicates number of fractions (i.e. an absolute + * digit index instead of a relative one). Used together with + * DUK_N2S_FLAG_FIXED_FORMAT for toFixed(). + */ +#define DUK_N2S_FLAG_FRACTION_DIGITS (1U << 3) + +/* + * String-to-number conversion + */ + +/* Maximum exponent value when parsing numbers. This is not strictly + * compliant as there should be no upper limit, but as we parse the + * exponent without a bigint, impose some limit. The limit should be + * small enough that multiplying it (or limit-1 to be precise) won't + * overflow signed 32-bit integer range. Exponent is only parsed with + * radix 10, but with maximum radix (36) a safe limit is: + * (10000000*36).toString(16) -> '15752a00' + */ +#define DUK_S2N_MAX_EXPONENT 10000000L + +/* Trim white space (= allow leading and trailing whitespace) */ +#define DUK_S2N_FLAG_TRIM_WHITE (1U << 0) + +/* Allow exponent */ +#define DUK_S2N_FLAG_ALLOW_EXP (1U << 1) + +/* Allow trailing garbage (e.g. treat "123foo" as "123) */ +#define DUK_S2N_FLAG_ALLOW_GARBAGE (1U << 2) + +/* Allow leading plus sign */ +#define DUK_S2N_FLAG_ALLOW_PLUS (1U << 3) + +/* Allow leading minus sign */ +#define DUK_S2N_FLAG_ALLOW_MINUS (1U << 4) + +/* Allow 'Infinity' */ +#define DUK_S2N_FLAG_ALLOW_INF (1U << 5) + +/* Allow fraction part */ +#define DUK_S2N_FLAG_ALLOW_FRAC (1U << 6) + +/* Allow naked fraction (e.g. ".123") */ +#define DUK_S2N_FLAG_ALLOW_NAKED_FRAC (1U << 7) + +/* Allow empty fraction (e.g. "123.") */ +#define DUK_S2N_FLAG_ALLOW_EMPTY_FRAC (1U << 8) + +/* Allow empty string to be interpreted as 0 */ +#define DUK_S2N_FLAG_ALLOW_EMPTY_AS_ZERO (1U << 9) + +/* Allow leading zeroes (e.g. "0123" -> "123") */ +#define DUK_S2N_FLAG_ALLOW_LEADING_ZERO (1U << 10) + +/* Allow automatic detection of hex base ("0x" or "0X" prefix), + * overrides radix argument and forces integer mode. + */ +#define DUK_S2N_FLAG_ALLOW_AUTO_HEX_INT (1U << 11) + +/* Allow automatic detection of legacy octal base ("0n"), + * overrides radix argument and forces integer mode. + */ +#define DUK_S2N_FLAG_ALLOW_AUTO_LEGACY_OCT_INT (1U << 12) + +/* Allow automatic detection of ES2015 octal base ("0o123"), + * overrides radix argument and forces integer mode. + */ +#define DUK_S2N_FLAG_ALLOW_AUTO_OCT_INT (1U << 13) + +/* Allow automatic detection of ES2015 binary base ("0b10001"), + * overrides radix argument and forces integer mode. + */ +#define DUK_S2N_FLAG_ALLOW_AUTO_BIN_INT (1U << 14) + +/* + * Prototypes + */ + +DUK_INTERNAL_DECL void duk_numconv_stringify(duk_hthread *thr, + duk_small_int_t radix, + duk_small_int_t digits, + duk_small_uint_t flags); +DUK_INTERNAL_DECL void duk_numconv_parse(duk_hthread *thr, duk_small_int_t radix, duk_small_uint_t flags); + +#endif /* DUK_NUMCONV_H_INCLUDED */ +/* #include duk_bi_protos.h */ +#line 1 "duk_bi_protos.h" +/* + * Prototypes for built-in functions not automatically covered by the + * header declarations emitted by genbuiltins.py. + */ + +#if !defined(DUK_BUILTIN_PROTOS_H_INCLUDED) +#define DUK_BUILTIN_PROTOS_H_INCLUDED + +/* Buffer size needed for ISO 8601 formatting. + * Accurate value is 32 + 1 for NUL termination: + * >>> len('+123456-01-23T12:34:56.123+12:34') + * 32 + * Include additional space to be safe. + */ +#define DUK_BI_DATE_ISO8601_BUFSIZE 40 + +/* Helpers exposed for internal use */ +DUK_INTERNAL_DECL void duk_bi_date_timeval_to_parts(duk_double_t d, duk_int_t *parts, duk_double_t *dparts, duk_small_uint_t flags); +DUK_INTERNAL_DECL duk_double_t duk_bi_date_get_timeval_from_dparts(duk_double_t *dparts, duk_small_uint_t flags); +DUK_INTERNAL_DECL duk_bool_t duk_bi_date_is_leap_year(duk_int_t year); +DUK_INTERNAL_DECL duk_bool_t duk_bi_date_timeval_in_valid_range(duk_double_t x); +DUK_INTERNAL_DECL duk_bool_t duk_bi_date_year_in_valid_range(duk_double_t year); +DUK_INTERNAL_DECL duk_bool_t duk_bi_date_timeval_in_leeway_range(duk_double_t x); +/* Built-in providers */ +#if defined(DUK_USE_DATE_NOW_GETTIMEOFDAY) +DUK_INTERNAL_DECL duk_double_t duk_bi_date_get_now_gettimeofday(void); +#endif +#if defined(DUK_USE_DATE_NOW_TIME) +DUK_INTERNAL_DECL duk_double_t duk_bi_date_get_now_time(void); +#endif +#if defined(DUK_USE_DATE_NOW_WINDOWS) +DUK_INTERNAL_DECL duk_double_t duk_bi_date_get_now_windows(void); +#endif +#if defined(DUK_USE_DATE_NOW_WINDOWS_SUBMS) +DUK_INTERNAL_DECL duk_double_t duk_bi_date_get_now_windows_subms(void); +#endif +#if defined(DUK_USE_DATE_TZO_GMTIME_R) || defined(DUK_USE_DATE_TZO_GMTIME_S) || defined(DUK_USE_DATE_TZO_GMTIME) +DUK_INTERNAL_DECL duk_int_t duk_bi_date_get_local_tzoffset_gmtime(duk_double_t d); +#endif +#if defined(DUK_USE_DATE_TZO_WINDOWS) +DUK_INTERNAL_DECL duk_int_t duk_bi_date_get_local_tzoffset_windows(duk_double_t d); +#endif +#if defined(DUK_USE_DATE_TZO_WINDOWS_NO_DST) +DUK_INTERNAL_DECL duk_int_t duk_bi_date_get_local_tzoffset_windows_no_dst(duk_double_t d); +#endif +#if defined(DUK_USE_DATE_PRS_STRPTIME) +DUK_INTERNAL_DECL duk_bool_t duk_bi_date_parse_string_strptime(duk_hthread *thr, const char *str); +#endif +#if defined(DUK_USE_DATE_PRS_GETDATE) +DUK_INTERNAL_DECL duk_bool_t duk_bi_date_parse_string_getdate(duk_hthread *thr, const char *str); +#endif +#if defined(DUK_USE_DATE_FMT_STRFTIME) +DUK_INTERNAL_DECL duk_bool_t duk_bi_date_format_parts_strftime(duk_hthread *thr, + duk_int_t *parts, + duk_int_t tzoffset, + duk_small_uint_t flags); +#endif + +#if defined(DUK_USE_GET_MONOTONIC_TIME_CLOCK_GETTIME) +DUK_INTERNAL_DECL duk_double_t duk_bi_date_get_monotonic_time_clock_gettime(void); +#endif +#if defined(DUK_USE_GET_MONOTONIC_TIME_WINDOWS_QPC) +DUK_INTERNAL_DECL duk_double_t duk_bi_date_get_monotonic_time_windows_qpc(void); +#endif + +DUK_INTERNAL_DECL +void duk_bi_json_parse_helper(duk_hthread *thr, duk_idx_t idx_value, duk_idx_t idx_reviver, duk_small_uint_t flags); +DUK_INTERNAL_DECL +void duk_bi_json_stringify_helper(duk_hthread *thr, + duk_idx_t idx_value, + duk_idx_t idx_replacer, + duk_idx_t idx_space, + duk_small_uint_t flags); + +DUK_INTERNAL_DECL duk_ret_t duk_textdecoder_decode_utf8_nodejs(duk_hthread *thr); + +#if defined(DUK_USE_ES6_PROXY) +DUK_INTERNAL_DECL void duk_proxy_ownkeys_postprocess(duk_hthread *thr, duk_hobject *h_proxy_target, duk_uint_t flags); +#endif + +#endif /* DUK_BUILTIN_PROTOS_H_INCLUDED */ +/* #include duk_selftest.h */ +#line 1 "duk_selftest.h" +/* + * Selftest code + */ + +#if !defined(DUK_SELFTEST_H_INCLUDED) +#define DUK_SELFTEST_H_INCLUDED + +#if defined(DUK_USE_SELF_TESTS) +DUK_INTERNAL_DECL duk_uint_t duk_selftest_run_tests(duk_alloc_function alloc_func, + duk_realloc_function realloc_func, + duk_free_function free_func, + void *udata); +#endif + +#endif /* DUK_SELFTEST_H_INCLUDED */ +#line 76 "duk_internal.h" + +#endif /* DUK_INTERNAL_H_INCLUDED */ +#line 10 "duk_replacements.c" + +#if defined(DUK_USE_COMPUTED_NAN) +DUK_INTERNAL double duk_computed_nan; +#endif + +#if defined(DUK_USE_COMPUTED_INFINITY) +DUK_INTERNAL double duk_computed_infinity; +#endif + +#if defined(DUK_USE_REPL_FPCLASSIFY) +DUK_INTERNAL int duk_repl_fpclassify(double x) { + duk_double_union u; + duk_uint_fast16_t expt; + duk_small_int_t mzero; + + u.d = x; + expt = (duk_uint_fast16_t) (u.us[DUK_DBL_IDX_US0] & 0x7ff0UL); + if (expt > 0x0000UL && expt < 0x7ff0UL) { + /* expt values [0x001,0x7fe] = normal */ + return DUK_FP_NORMAL; + } + + mzero = (u.ui[DUK_DBL_IDX_UI1] == 0 && (u.ui[DUK_DBL_IDX_UI0] & 0x000fffffUL) == 0); + if (expt == 0x0000UL) { + /* expt 0x000 is zero/subnormal */ + if (mzero) { + return DUK_FP_ZERO; + } else { + return DUK_FP_SUBNORMAL; + } + } else { + /* expt 0xfff is infinite/nan */ + if (mzero) { + return DUK_FP_INFINITE; + } else { + return DUK_FP_NAN; + } + } +} +#endif + +#if defined(DUK_USE_REPL_SIGNBIT) +DUK_INTERNAL int duk_repl_signbit(double x) { + duk_double_union u; + u.d = x; + return (int) (u.uc[DUK_DBL_IDX_UC0] & 0x80UL); +} +#endif + +#if defined(DUK_USE_REPL_ISFINITE) +DUK_INTERNAL int duk_repl_isfinite(double x) { + int c = DUK_FPCLASSIFY(x); + if (c == DUK_FP_NAN || c == DUK_FP_INFINITE) { + return 0; + } else { + return 1; + } +} +#endif + +#if defined(DUK_USE_REPL_ISNAN) +DUK_INTERNAL int duk_repl_isnan(double x) { + int c = DUK_FPCLASSIFY(x); + return (c == DUK_FP_NAN); +} +#endif + +#if defined(DUK_USE_REPL_ISINF) +DUK_INTERNAL int duk_repl_isinf(double x) { + int c = DUK_FPCLASSIFY(x); + return (c == DUK_FP_INFINITE); +} +#endif +#line 1 "duk_debug_macros.c" +/* + * Debugging macro calls. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_DEBUG) + +/* + * Debugging enabled + */ + +#include +#include +#include + +#if !defined(DUK_USE_DEBUG_WRITE) +#error debugging enabled (DUK_USE_DEBUG) but DUK_USE_DEBUG_WRITE not defined +#endif + +#define DUK__DEBUG_BUFSIZE DUK_USE_DEBUG_BUFSIZE + +#if defined(DUK_USE_VARIADIC_MACROS) + +DUK_INTERNAL void duk_debug_log(duk_int_t level, const char *file, duk_int_t line, const char *func, const char *fmt, ...) { + va_list ap; + long arg_level; + const char *arg_file; + long arg_line; + const char *arg_func; + const char *arg_msg; + char buf[DUK__DEBUG_BUFSIZE]; + + va_start(ap, fmt); + + duk_memzero((void *) buf, (size_t) DUK__DEBUG_BUFSIZE); + duk_debug_vsnprintf(buf, DUK__DEBUG_BUFSIZE - 1, fmt, ap); + + arg_level = (long) level; + arg_file = (const char *) file; + arg_line = (long) line; + arg_func = (const char *) func; + arg_msg = (const char *) buf; + DUK_USE_DEBUG_WRITE(arg_level, arg_file, arg_line, arg_func, arg_msg); + + va_end(ap); +} + +#else /* DUK_USE_VARIADIC_MACROS */ + +DUK_INTERNAL char duk_debug_file_stash[DUK_DEBUG_STASH_SIZE]; +DUK_INTERNAL duk_int_t duk_debug_line_stash; +DUK_INTERNAL char duk_debug_func_stash[DUK_DEBUG_STASH_SIZE]; +DUK_INTERNAL duk_int_t duk_debug_level_stash; + +DUK_INTERNAL void duk_debug_log(const char *fmt, ...) { + va_list ap; + long arg_level; + const char *arg_file; + long arg_line; + const char *arg_func; + const char *arg_msg; + char buf[DUK__DEBUG_BUFSIZE]; + + va_start(ap, fmt); + + duk_memzero((void *) buf, (size_t) DUK__DEBUG_BUFSIZE); + duk_debug_vsnprintf(buf, DUK__DEBUG_BUFSIZE - 1, fmt, ap); + + arg_level = (long) duk_debug_level_stash; + arg_file = (const char *) duk_debug_file_stash; + arg_line = (long) duk_debug_line_stash; + arg_func = (const char *) duk_debug_func_stash; + arg_msg = (const char *) buf; + DUK_USE_DEBUG_WRITE(arg_level, arg_file, arg_line, arg_func, arg_msg); + + va_end(ap); +} + +#endif /* DUK_USE_VARIADIC_MACROS */ + +#else /* DUK_USE_DEBUG */ + +/* + * Debugging disabled + */ + +#endif /* DUK_USE_DEBUG */ + +/* automatic undefs */ +#undef DUK__DEBUG_BUFSIZE +#line 1 "duk_builtins.c" +/* + * Automatically generated by genbuiltins.py, do not edit! + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_ASSERTIONS) +#define DUK__REFCINIT(refc) 0 /*h_assert_refcount*/, (refc) /*actual*/ +#else +#define DUK__REFCINIT(refc) (refc) /*actual*/ +#endif + +#if defined(DUK_USE_ROM_STRINGS) +#error ROM support not enabled, rerun configure.py with --rom-support +#else /* DUK_USE_ROM_STRINGS */ +DUK_INTERNAL const duk_uint8_t duk_strings_data[972] = { +79,40,209,144,168,105,6,78,54,139,89,185,44,48,46,90,120,8,154,140,35,103, +35,113,193,73,5,52,112,180,104,166,135,52,188,4,98,12,27,146,156,80,211,31, +129,115,150,64,52,220,109,24,18,68,156,24,38,67,114,36,55,9,119,151,132, +140,93,18,113,128,153,201,212,201,205,2,248,8,196,24,224,104,82,146,40,224, +193,48,114,168,37,147,196,54,123,28,4,98,12,43,148,67,103,177,192,70,32, +196,121,68,54,123,28,18,192,199,144,124,4,98,12,43,136,108,244,117,184,8, +196,24,95,40,134,207,71,91,128,140,65,133,113,13,158,158,151,1,24,131,11, +229,16,217,233,233,112,17,136,48,206,21,110,4,244,244,184,8,196,24,103,10, +183,2,122,218,156,4,98,12,24,203,112,64,179,113,193,79,8,218,155,131,32, +184,70,212,220,13,10,82,68,252,123,144,217,146,38,228,207,18,0,100,37,64, +178,212,11,161,17,104,162,96,10,200,193,57,165,65,169,16,5,100,81,27,70,18, +32,10,200,68,185,13,116,221,197,184,64,89,57,41,197,13,49,234,5,208,156, +113,87,55,118,147,20,187,56,161,166,92,221,212,73,210,236,226,134,153,115, +119,76,201,203,179,138,26,99,73,212,136,136,164,25,174,137,56,32,72,137, +101,23,52,45,13,34,86,9,79,136,104,201,114,149,96,52,138,134,140,151,75, +226,233,186,120,121,22,39,54,83,141,5,55,68,236,36,164,3,16,225,115,150,64, +52,205,163,2,72,154,83,138,26,99,75,12,11,150,103,5,36,20,211,70,140,133, +67,72,49,241,160,227,81,196,52,168,106,39,132,252,183,136,105,80,212,79,2, +249,110,128,126,88,95,133,109,237,237,237,151,235,127,46,249,119,203,190, +186,206,33,181,2,208,61,190,12,19,34,65,19,81,132,108,228,97,1,107,33,12, +32,45,100,137,64,247,175,9,19,155,41,198,130,155,134,69,146,100,227,226, +231,146,51,192,204,73,140,224,145,221,102,241,68,196,169,248,30,75,12,11, +151,242,233,187,143,138,24,137,162,164,255,253,63,3,201,97,129,114,254,92, +112,75,136,108,166,6,136,159,255,167,224,121,44,48,46,95,203,166,238,74, +113,67,77,201,128,223,255,223,224,121,44,48,46,95,203,145,46,9,205,16,39, +201,62,36,0,192,21,147,255,238,145,39,199,197,211,116,240,242,113,197,78, +214,211,226,233,187,107,105,19,119,37,56,161,166,52,221,212,201,205,36,240, +242,16,96,152,12,26,20,164,137,150,70,154,103,28,137,50,202,96,18,132,241, +41,104,105,56,218,48,36,138,183,57,56,128,68,24,38,2,52,12,34,10,133,147, +141,3,8,119,185,13,153,34,125,206,76,17,49,38,93,206,52,151,154,119,56,28, +76,130,112,200,141,206,21,209,96,23,35,238,114,160,139,0,243,238,114,78, +164,68,68,110,113,226,210,90,26,66,110,113,128,121,247,57,80,68,141,170, +183,56,84,52,11,70,73,19,110,114,160,93,8,113,57,143,66,200,84,53,244,154, +73,24,240,81,32,38,68,18,49,228,207,23,88,100,109,70,114,92,193,4,137,173, +168,36,220,73,19,247,247,182,168,209,144,187,223,58,156,104,79,190,183,127, +123,105,160,110,247,206,167,26,19,239,173,223,222,218,67,75,189,243,169, +198,132,251,235,183,247,182,154,134,151,123,231,83,141,9,247,215,111,239, +109,22,141,22,247,206,167,26,19,239,172,223,218,45,26,47,157,78,52,39,223, +74,24,144,10,32,129,34,20,64,152,142,129,57,179,67,104,68,12,129,161,140, +72,156,100,40,40,185,152,100,89,38,65,13,196,34,228,67,149,13,2,215,129, +149,209,65,104,209,77,14,104,144,81,33,170,67,101,48,52,68,113,70,210,88, +209,36,233,22,154,86,68,196,114,76,232,145,102,120,186,195,156,112,105,225, +228,113,71,80,68,162,115,101,50,85,200,25,108,116,44,132,178,38,114,137,96, +148,136,70,209,134,37,222,232,204,228,188,200,209,200,200,99,221,25,150,84, +121,34,70,209,107,36,227,66,20,160,92,136,164,49,235,35,8,217,201,40,108, +201,18,128,68,26,201,51,188,2,80,12,67,190,40,168,38,68,190,46,153,5,50,12, +207,160,86,129,26,83,4,208,34,225,4,88,192, +}; +#endif /* DUK_USE_ROM_STRINGS */ + +#if defined(DUK_USE_ROM_OBJECTS) +#error ROM support not enabled, rerun configure.py with --rom-support +#else /* DUK_USE_ROM_OBJECTS */ +/* native functions: 185 */ +DUK_INTERNAL const duk_c_function duk_bi_native_functions[185] = { + NULL, + duk_bi_array_constructor, + duk_bi_array_constructor_is_array, + duk_bi_array_prototype_concat, + duk_bi_array_prototype_indexof_shared, + duk_bi_array_prototype_iter_shared, + duk_bi_array_prototype_join_shared, + duk_bi_array_prototype_pop, + duk_bi_array_prototype_push, + duk_bi_array_prototype_reduce_shared, + duk_bi_array_prototype_reverse, + duk_bi_array_prototype_shift, + duk_bi_array_prototype_slice, + duk_bi_array_prototype_sort, + duk_bi_array_prototype_splice, + duk_bi_array_prototype_to_string, + duk_bi_array_prototype_unshift, + duk_bi_arraybuffer_constructor, + duk_bi_arraybuffer_isview, + duk_bi_boolean_constructor, + duk_bi_boolean_prototype_tostring_shared, + duk_bi_buffer_compare_shared, + duk_bi_buffer_readfield, + duk_bi_buffer_slice_shared, + duk_bi_buffer_writefield, + duk_bi_cbor_decode, + duk_bi_cbor_encode, + duk_bi_dataview_constructor, + duk_bi_date_constructor, + duk_bi_date_constructor_now, + duk_bi_date_constructor_parse, + duk_bi_date_constructor_utc, + duk_bi_date_prototype_get_shared, + duk_bi_date_prototype_get_timezone_offset, + duk_bi_date_prototype_set_shared, + duk_bi_date_prototype_set_time, + duk_bi_date_prototype_to_json, + duk_bi_date_prototype_toprimitive, + duk_bi_date_prototype_tostring_shared, + duk_bi_date_prototype_value_of, + duk_bi_duktape_object_act, + duk_bi_duktape_object_compact, + duk_bi_duktape_object_dec, + duk_bi_duktape_object_enc, + duk_bi_duktape_object_fin, + duk_bi_duktape_object_gc, + duk_bi_duktape_object_info, + duk_bi_error_constructor_shared, + duk_bi_error_prototype_filename_getter, + duk_bi_error_prototype_filename_setter, + duk_bi_error_prototype_linenumber_getter, + duk_bi_error_prototype_linenumber_setter, + duk_bi_error_prototype_stack_getter, + duk_bi_error_prototype_stack_setter, + duk_bi_error_prototype_to_string, + duk_bi_function_constructor, + duk_bi_function_prototype, + duk_bi_function_prototype_apply, + duk_bi_function_prototype_bind, + duk_bi_function_prototype_call, + duk_bi_function_prototype_hasinstance, + duk_bi_function_prototype_to_string, + duk_bi_global_object_decode_uri, + duk_bi_global_object_decode_uri_component, + duk_bi_global_object_encode_uri, + duk_bi_global_object_encode_uri_component, + duk_bi_global_object_escape, + duk_bi_global_object_eval, + duk_bi_global_object_is_finite, + duk_bi_global_object_is_nan, + duk_bi_global_object_parse_float, + duk_bi_global_object_parse_int, + duk_bi_global_object_unescape, + duk_bi_json_object_parse, + duk_bi_json_object_stringify, + duk_bi_math_object_clz32, + duk_bi_math_object_hypot, + duk_bi_math_object_imul, + duk_bi_math_object_max, + duk_bi_math_object_min, + duk_bi_math_object_onearg_shared, + duk_bi_math_object_random, + duk_bi_math_object_sign, + duk_bi_math_object_twoarg_shared, + duk_bi_native_function_length, + duk_bi_native_function_name, + duk_bi_nodejs_buffer_byte_length, + duk_bi_nodejs_buffer_concat, + duk_bi_nodejs_buffer_constructor, + duk_bi_nodejs_buffer_copy, + duk_bi_nodejs_buffer_fill, + duk_bi_nodejs_buffer_is_buffer, + duk_bi_nodejs_buffer_is_encoding, + duk_bi_nodejs_buffer_tojson, + duk_bi_nodejs_buffer_tostring, + duk_bi_nodejs_buffer_write, + duk_bi_number_check_shared, + duk_bi_number_constructor, + duk_bi_number_prototype_to_exponential, + duk_bi_number_prototype_to_fixed, + duk_bi_number_prototype_to_locale_string, + duk_bi_number_prototype_to_precision, + duk_bi_number_prototype_to_string, + duk_bi_number_prototype_value_of, + duk_bi_object_constructor, + duk_bi_object_constructor_assign, + duk_bi_object_constructor_create, + duk_bi_object_constructor_define_properties, + duk_bi_object_constructor_define_property, + duk_bi_object_constructor_get_own_property_descriptor, + duk_bi_object_constructor_is, + duk_bi_object_constructor_is_extensible, + duk_bi_object_constructor_is_sealed_frozen_shared, + duk_bi_object_constructor_keys_shared, + duk_bi_object_constructor_prevent_extensions, + duk_bi_object_constructor_seal_freeze_shared, + duk_bi_object_getprototype_shared, + duk_bi_object_prototype_defineaccessor, + duk_bi_object_prototype_has_own_property, + duk_bi_object_prototype_is_prototype_of, + duk_bi_object_prototype_lookupaccessor, + duk_bi_object_prototype_property_is_enumerable, + duk_bi_object_prototype_to_locale_string, + duk_bi_object_prototype_to_string, + duk_bi_object_prototype_value_of, + duk_bi_object_setprototype_shared, + duk_bi_performance_now, + duk_bi_pointer_constructor, + duk_bi_pointer_prototype_tostring_shared, + duk_bi_proxy_constructor, + duk_bi_reflect_apply, + duk_bi_reflect_construct, + duk_bi_reflect_object_delete_property, + duk_bi_reflect_object_get, + duk_bi_reflect_object_has, + duk_bi_reflect_object_set, + duk_bi_regexp_constructor, + duk_bi_regexp_prototype_exec, + duk_bi_regexp_prototype_flags, + duk_bi_regexp_prototype_shared_getter, + duk_bi_regexp_prototype_test, + duk_bi_regexp_prototype_tostring, + duk_bi_string_constructor, + duk_bi_string_constructor_from_char_code, + duk_bi_string_constructor_from_code_point, + duk_bi_string_prototype_caseconv_shared, + duk_bi_string_prototype_char_at, + duk_bi_string_prototype_char_code_at, + duk_bi_string_prototype_concat, + duk_bi_string_prototype_includes, + duk_bi_string_prototype_indexof_shared, + duk_bi_string_prototype_locale_compare, + duk_bi_string_prototype_match, + duk_bi_string_prototype_repeat, + duk_bi_string_prototype_replace, + duk_bi_string_prototype_search, + duk_bi_string_prototype_slice, + duk_bi_string_prototype_split, + duk_bi_string_prototype_startswith_endswith, + duk_bi_string_prototype_substr, + duk_bi_string_prototype_substring, + duk_bi_string_prototype_to_string, + duk_bi_string_prototype_trim, + duk_bi_symbol_constructor_shared, + duk_bi_symbol_key_for, + duk_bi_symbol_toprimitive, + duk_bi_symbol_tostring_shared, + duk_bi_textdecoder_constructor, + duk_bi_textdecoder_prototype_decode, + duk_bi_textdecoder_prototype_shared_getter, + duk_bi_textencoder_constructor, + duk_bi_textencoder_prototype_encode, + duk_bi_textencoder_prototype_encoding_getter, + duk_bi_thread_constructor, + duk_bi_thread_current, + duk_bi_thread_resume, + duk_bi_thread_yield, + duk_bi_type_error_thrower, + duk_bi_typedarray_buffer_getter, + duk_bi_typedarray_bytelength_getter, + duk_bi_typedarray_byteoffset_getter, + duk_bi_typedarray_constructor, + duk_bi_typedarray_set, + duk_bi_uint8array_allocplain, + duk_bi_uint8array_plainof, +}; +#if defined(DUK_USE_DOUBLE_LE) +DUK_INTERNAL const duk_uint8_t duk_builtins_data[4281] = { +144,148,105,226,32,68,52,228,254,12,104,202,37,132,52,167,194,138,105,245, +124,57,28,211,57,18,64,52,239,126,44,138,111,175,241,164,19,87,145,30,33, +167,22,145,159,8,211,139,9,225,42,5,240,145,139,163,163,8,211,139,10,228, +64,211,19,132,140,93,29,56,70,156,88,119,34,66,146,36,104,137,194,70,46, +142,172,35,78,44,47,146,195,102,11,240,145,139,163,175,8,211,139,9,228,240, +242,112,145,139,163,179,8,211,139,8,237,34,130,118,49,116,118,225,26,48,0, +1,98,29,201,158,46,183,39,135,147,132,140,93,16,132,76,66,33,8,66,16,132, +33,8,66,26,180,105,97,167,68,150,34,33,154,112,0,1,91,247,35,79,111,237, +198,174,232,47,31,23,95,17,13,31,249,96,211,49,50,53,214,77,141,24,0,0,181, +10,228,240,242,15,128,140,65,128,134,188,0,0,90,167,97,181,224,0,2,213,62, +53,224,0,2,213,66,237,120,0,0,181,81,204,107,192,0,5,170,150,67,94,0,0,45, +84,245,90,240,0,1,106,169,162,215,128,0,11,85,93,150,188,0,0,90,171,111,53, +109,22,162,26,48,0,1,84,23,201,146,243,225,26,39,12,145,136,104,192,0,5,61, +11,228,201,121,240,100,19,134,72,196,33,195,14,40,203,112,64,190,76,232, +145,153,136,0,0,0,0,0,0,31,15,249,152,0,0,0,0,0,0,30,15,249,120,144,13,96, +155,194,56,80,206,36,67,141,20,228,70,57,81,206,100,131,156,39,132,168,23, +194,70,46,137,208,21,200,129,166,39,9,24,186,39,72,119,34,66,146,36,104, +137,194,70,46,137,212,23,201,97,179,5,248,72,197,209,58,194,121,60,60,156, +36,98,232,157,129,29,164,80,78,198,46,137,218,146,121,25,71,146,9,209,5, +209,61,48,126,14,138,152,30,67,186,23,143,139,175,131,202,135,228,72,85, +144,83,60,179,30,94,209,233,102,30,98,105,230,103,30,114,121,231,104,30, +122,137,231,233,30,130,153,232,106,30,138,169,232,235,30,144,67,193,25,19, +136,108,207,30,41,224,140,137,194,173,192,153,228,5,242,100,188,248,70,137, +195,36,79,78,47,147,37,231,193,144,78,25,34,122,145,111,36,74,232,176,13, +17,61,234,226,93,207,148,160,84,75,141,7,27,161,32,33,18,225,80,212,76,154, +2,2,70,65,56,100,237,34,140,209,2,67,32,156,50,118,145,64,186,230,61,205, +35,103,155,32,36,141,19,134,78,210,40,206,16,36,70,137,195,39,105,20,11, +174,99,220,210,54,121,210,1,137,33,1,228,207,16,17,70,146,66,3,201,164,32, +0,65,112,152,56,196,159,31,23,77,211,195,201,199,23,160,72,214,246,81,6,12, +73,241,214,111,31,23,60,145,158,56,50,72,81,67,230,232,242,80,19,49,39,199, +89,188,124,92,242,70,120,227,64,194,75,154,72,12,9,73,6,111,21,120,12,40, +144,19,39,25,0,225,144,168,105,56,248,185,228,140,241,200,96,64,100,42,26, +78,62,46,121,35,52,18,92,116,1,36,64,47,158,64,49,98,66,100,156,242,65,23, +196,149,35,103,194,94,100,108,144,230,203,156,64,66,37,201,16,11,32,249, +132,4,34,92,44,93,146,55,152,72,24,137,112,151,153,27,36,5,100,229,144,8, +162,98,92,210,5,76,73,241,214,111,31,23,60,145,158,57,44,48,46,92,185,164, +160,72,151,41,0,50,107,179,244,59,36,93,127,92,6,19,172,3,11,216,0,56,224, +151,29,102,241,241,115,201,25,227,164,64,106,37,199,197,211,116,240,242, +113,197,233,144,40,248,185,228,140,241,196,75,132,109,24,72,128,43,39,84, +129,13,173,161,144,168,105,56,98,78,100,142,214,215,69,1,13,173,161,144, +168,105,57,34,78,100,142,214,215,69,16,67,107,105,110,114,168,254,24,147, +153,35,181,181,212,32,67,107,105,110,114,168,254,72,147,153,35,181,181,212, +36,65,130,3,144,8,26,252,200,13,30,85,16,16,64,90,242,231,192,64,161,163, +203,31,26,172,193,17,4,23,105,159,96,27,172,251,16,32,196,4,14,137,112,17, +136,48,164,28,134,80,215,202,1,132,130,8,12,39,52,64,155,31,24,56,36,1,189, +207,132,0,35,233,35,195,62,3,196,149,36,100,72,160,2,200,232,44,227,0,11, +37,160,68,142,128,36,157,25,200,32,26,79,90,4,73,43,192,122,54,71,65,103, +44,248,14,134,140,151,227,138,231,208,45,96,148,248,134,140,151,227,138, +231,240,1,255,254,10,74,146,56,128,104,4,147,152,72,6,144,28,174,143,8,1, +30,1,165,3,96,31,0,211,3,21,11,153,35,0,211,131,68,131,160,137,16,250,5, +196,131,160,137,200,160,199,156,67,248,0,255,255,65,140,10,48,177,115,56, +35,130,60,19,134,79,89,240,52,177,115,56,39,12,156,123,144,217,251,15,135, +34,167,30,20,170,154,255,232,12,47,244,0,97,28,17,224,39,238,32,40,71,4, +120,39,12,156,4,253,228,5,137,195,39,30,228,54,124,4,253,228,128,194,115, +68,9,252,15,128,232,104,201,126,56,191,35,64,90,193,41,241,13,25,47,199,23, +228,105,3,86,225,1,100,224,156,199,130,36,249,144,10,192,76,71,250,16,15, +18,61,96,17,62,200,3,72,128,136,143,247,32,22,75,64,137,248,64,22,79,90,39, +249,64,38,84,12,167,20,52,223,196,2,230,238,45,214,36,120,32,72,158,208,4, +102,238,45,194,2,201,197,186,196,143,4,9,19,218,0,92,221,202,61,228,143,4, +9,19,218,8,35,55,113,110,16,22,78,81,239,36,120,32,72,158,208,64,73,197,12, +255,0,13,18,60,128,159,212,128,169,76,17,156,185,100,76,255,163,64,65,26, +57,114,200,153,255,70,144,33,13,18,232,50,75,226,104,6,149,3,41,199,246, +130,12,128,28,142,156,120,203,175,158,8,194,207,1,6,81,20,79,88,11,237,84, +11,161,32,127,255,255,255,255,255,247,191,137,235,16,221,170,129,116,36,0, +16,0,0,0,0,0,0,12,196,0,0,0,0,0,0,15,135,242,61,123,164,137,162,164,218,67, +74,134,162,120,128,0,0,0,0,0,1,224,254,71,173,33,129,52,84,155,72,105,80, +212,79,16,0,0,0,0,0,0,60,63,195,244,143,146,22,230,192,0,0,0,0,0,0,176,60, +33,214,2,251,82,1,73,180,134,204,134,36,96,127,255,255,255,255,255,159,161, +144,235,16,221,169,0,164,218,67,102,67,18,48,63,255,255,255,255,255,207, +240,196,60,17,145,56,134,204,241,226,158,8,200,156,42,220,9,158,65,196,34, +92,42,26,137,147,120,64,74,37,196,54,100,49,35,188,36,5,68,184,208,113,187, +194,80,212,75,146,1,73,196,54,100,49,35,188,38,57,37,56,240,0,0,0,0,0,0,0, +0,32,235,248,68,48,156,2,24,94,24,0,243,119,10,139,144,123,242,3,102,238, +18,239,115,72,217,160,11,223,16,23,55,113,241,32,145,36,57,188,18,16,102,3, +5,120,35,34,89,32,15,180,152,173,127,0,218,235,88,0,228,180,227,200,0,0,0, +0,0,0,248,127,197,107,240,64,6,77,220,24,38,78,74,113,67,77,130,4,12,155, +185,52,48,156,148,226,134,155,4,10,194,96,129,132,166,238,45,194,2,201,193, +130,100,228,167,20,52,216,32,113,41,187,139,112,128,178,114,104,97,57,41, +197,13,54,8,32,48,216,32,130,195,224,130,19,97,124,134,23,6,0,57,137,62,77, +12,38,12,0,179,18,124,45,22,190,96,128,141,176,134,28,98,79,180,152,139, +218,45,124,193,1,27,97,16,32,196,159,24,230,204,246,194,40,89,137,62,210, +98,103,92,217,158,216,70,7,49,39,193,130,100,182,17,194,140,73,246,147,16, +250,9,146,216,72,6,49,39,193,131,22,194,72,73,137,62,210,98,31,65,139,97, +40,32,196,159,14,234,70,86,194,88,89,137,62,210,98,63,93,72,202,216,76,10, +49,39,198,33,180,153,37,108,38,134,152,147,237,38,38,117,13,164,201,43,97, +56,40,196,159,36,65,57,163,149,176,158,26,98,79,180,152,165,210,9,205,28, +173,133,0,243,18,124,98,22,180,72,130,115,71,43,97,68,72,196,159,105,49,51, +168,90,209,34,9,205,28,173,133,33,19,18,124,154,24,76,185,164,227,138,89, +18,119,0,7,145,39,201,161,132,188,64,124,137,62,49,11,90,36,65,57,163,149, +210,166,37,34,79,180,152,153,212,45,104,145,4,230,142,87,74,160,84,137,62, +72,130,115,71,43,171,234,134,200,147,237,38,41,116,130,115,71,43,171,235,5, +72,147,227,16,218,76,146,186,254,184,108,137,62,210,98,103,80,218,76,146, +186,254,192,68,137,62,29,212,140,174,207,178,23,34,79,180,152,143,215,82, +50,187,62,208,60,137,62,12,19,37,210,182,21,34,79,180,152,135,208,76,151, +74,224,68,137,62,49,205,153,238,175,186,23,34,79,180,152,153,215,54,103, +186,190,240,92,137,62,22,139,95,48,64,70,235,251,225,210,36,251,73,136,189, +162,215,204,16,17,186,255,2,14,98,79,152,32,35,108,48,64,242,36,249,130,2, +55,75,6,212,224,72,200,51,128,114,108,28,100,128,0,0,0,0,0,0,0,12,110,127, +48,98,115,249,201,117,243,249,195,21,159,206,38,47,63,156,86,8,75,144,94, +82,1,38,73,79,208,67,95,233,1,6,128,14,79,129,186,40,249,18,149,182,207, +144,200,155,188,248,204,105,184,207,142,199,137,175,201,0,159,72,10,5,21, +221,10,120,74,129,124,36,98,232,228,74,81,62,160,20,10,107,186,21,114,32, +105,137,194,70,46,142,68,165,19,235,1,64,170,187,161,119,34,66,146,36,104, +137,194,70,46,142,68,165,19,236,1,64,174,187,161,95,37,134,204,23,225,35, +23,71,34,82,137,246,128,160,89,93,208,167,147,195,201,194,70,46,142,68,165, +19,238,1,64,182,187,161,71,105,20,19,177,139,163,145,41,68,16,7,6,15,82,70, +72,115,96,0,0,0,0,0,27,234,32,91,60,165,195,201,194,8,134,149,216,162,0, +192,41,225,8,2,48,177,36,1,149,13,196,15,0,200,209,97,199,128,99,32,176, +195,192,113,57,143,0,167,133,32,230,80,28,202,139,175,238,2,48,189,192,20, +1,119,80,87,193,186,129,89,56,72,197,209,200,193,185,35,23,71,109,13,219, +36,98,232,237,156,13,26,208,211,14,102,19,87,137,91,95,128,0,10,96,24,92,0, +0,83,2,53,56,0,0,165,3,28,204,160,160,226,100,226,200,211,76,241,240,0,1, +102,8,22,75,64,137,73,20,230,105,133,7,19,39,22,70,154,103,143,128,0,11,48, +20,28,76,156,113,75,34,78,62,0,0,45,3,103,31,0,0,22,65,44,57,137,62,33,179, +216,162,152,192,131,18,124,162,27,61,138,41,108,32,196,159,16,217,232,235, +81,76,104,73,137,62,81,13,158,142,181,20,184,16,98,79,136,108,244,244,168, +166,56,36,196,159,40,134,207,79,74,138,93,10,49,39,194,173,192,158,158,149, +20,188,20,98,79,133,91,129,61,109,74,41,124,30,68,159,16,217,236,83,108,96, +68,137,62,81,13,158,197,54,182,17,34,79,136,108,244,117,169,182,52,38,68, +159,40,134,207,71,90,155,92,8,145,39,196,54,122,122,84,219,28,19,34,79,148, +67,103,167,165,77,174,133,72,147,225,86,224,79,79,74,155,94,10,145,39,194, +173,192,158,182,165,54,190,206,25,212,35,208,226,100,150,211,201,29,162,44, +140,35,103,0,0,0,0,0,0,3,192,252,206,25,228,35,208,226,100,150,211,201,29, +162,44,140,35,103,0,0,0,0,0,0,3,192,252,206,25,244,35,208,226,100,150,211, +201,29,162,44,140,35,103,0,0,0,0,0,0,3,192,252,206,26,4,35,208,226,100,150, +211,201,29,162,44,140,35,103,0,0,0,0,0,0,0,1,0,206,26,20,35,208,226,100, +150,211,201,29,162,44,140,35,103,0,0,0,0,0,0,0,1,0,206,26,36,35,208,226, +100,150,211,201,29,162,44,140,35,103,0,0,0,0,0,0,0,65,0,206,26,52,35,208, +226,100,150,211,201,29,162,44,140,35,103,0,0,0,0,0,0,0,65,0,206,26,68,35, +208,226,100,150,211,201,29,162,44,140,35,103,0,0,0,0,0,0,0,65,0,206,26,84, +35,208,226,100,150,211,201,29,162,44,140,35,103,0,0,0,0,0,0,0,129,0,195, +154,99,16,38,36,0,251,68,117,179,216,162,128,68,72,1,241,13,158,197,20,150, +25,18,0,125,162,58,217,232,235,117,100,162,136,25,18,0,125,162,58,217,232, +235,116,36,162,145,2,226,64,15,136,108,244,117,186,178,81,73,129,113,32,7, +196,54,122,58,221,9,40,165,64,200,144,3,237,17,214,207,79,75,171,37,20,80, +200,144,3,237,17,214,207,79,75,161,37,20,138,23,18,0,124,67,103,167,165, +213,146,138,77,11,137,0,62,33,179,211,210,232,73,69,42,133,196,128,31,10, +183,2,125,89,40,163,5,196,128,31,10,183,2,125,9,40,164,96,200,144,3,224, +221,64,172,157,89,40,163,134,68,128,31,6,234,5,100,232,73,69,35,133,68,128, +31,104,142,182,125,89,40,180,0,168,144,3,237,17,214,207,161,37,22,144,19, +18,0,124,67,103,213,146,139,80,9,137,0,62,33,179,232,73,69,172,5,90,40,153, +59,68,117,179,216,166,192,77,162,137,147,136,108,246,41,180,176,219,69,19, +39,104,142,182,122,58,221,89,41,178,6,218,40,153,59,68,117,179,209,214,232, +73,77,162,6,90,40,153,56,134,207,71,91,171,37,54,152,25,104,162,100,226,27, +61,29,110,132,148,218,160,109,162,137,147,180,71,91,61,61,46,172,148,217, +67,109,20,76,157,162,58,217,233,233,116,36,166,209,67,45,20,76,156,67,103, +167,165,213,146,155,77,12,180,81,50,113,13,158,158,151,66,74,109,84,50,209, +68,201,194,173,192,159,86,74,108,193,150,138,38,78,21,110,4,250,18,83,104, +193,182,138,38,78,13,212,10,201,213,146,155,56,109,162,137,147,131,117,2, +178,116,36,166,209,194,237,20,76,157,162,58,217,245,100,167,16,2,237,20,76, +157,162,58,217,244,36,167,18,2,173,20,76,156,67,103,213,146,156,80,10,180, +81,50,113,13,159,66,74,113,97,175,221,48,216,110,64,4,42,22,189,179,0,196, +133,0,185,80,32,28,78,99,193,18,80,36,4,19,159,141,172,0,178,90,4,74,73,0, +22,209,68,201,187,129,4,2,8,3,132,64,60,36,6,149,113,72,176,171,240,84,0, +157,91,116,116,32,11,42,218,221,216,181,129,32,3,234,219,165,3,188,231,235, +249,8,187,152,252,47,86,227,105,18,7,244,17,91,42,56,175,185,248,110,173, +198,209,208,36,0,238,82,97,87,188,189,179,240,93,122,32,12,22,162,42,125, +144,132,160,7,236,161,25,232,237,105,64,205,59,127,102,158,160,230,63,11, +217,66,51,210,129,154,118,254,205,61,65,236,127,171,197,34,168,48,6,90,194, +1,0,39,75,88,72,8,9,33,186,194,80,64,76,13,214,19,2,130,96,110,150,189,0, +65,6,51,214,20,128,65,17,11,214,19,130,137,121,211,210,211,144,6,39,75,88, +80,0,201,119,235,10,8,41,86,231,71,88,80,129,79,135,186,122,133,224,34,25, +69,234,80,3,91,141,172,40,96,139,113,180,181,133,36,21,110,54,142,134,176, +165,1,176,23,213,47,0,216,134,234,215,128,111,117,181,232,128,209,3,70,230, +107,64,5,139,168,209,235,10,32,36,144,102,235,136,3,146,27,172,40,160,146, +132,103,172,40,192,115,3,117,133,28,22,113,163,69,172,41,103,1,66,188,17, +145,52,168,4,202,113,67,76,130,227,76,194,13,240,108,0,0,83,224,0,2,193,0, +104,146,84,97,48,0,1,94,192,56,169,24,145,179,192,0,5,112,8,56,16,32,128, +56,18,52,125,230,86,147,190,140,28,50,21,13,39,31,23,60,145,158,57,12,141, +47,129,6,155,194,188,24,49,39,199,89,188,124,92,242,70,120,224,201,33,69, +15,155,163,201,68,14,49,39,199,197,211,116,240,242,113,197,232,18,180,254, +36,3,17,46,18,243,35,100,128,172,156,178,70,163,154,76,34,248,146,164,108, +248,75,204,141,146,28,217,115,137,27,95,27,241,173,236,162,160,224,200,2, +206,9,113,13,148,192,209,18,22,164,146,37,193,57,162,4,249,39,196,128,24,2, +178,66,213,136,68,201,16,77,209,131,31,192,242,88,96,92,191,151,34,100,136, +38,232,255,252,92,221,199,197,12,68,209,82,66,212,11,155,185,41,197,13,55, +38,3,66,213,47,135,254,72,12,162,99,133,116,112,0,1,72,66,14,16,16,50,37, +202,160,150,154,66,14,20,8,57,192,28,24,80,113,50,113,100,105,166,120,248, +0,0,179,1,65,196,201,199,20,178,36,227,224,0,2,208,54,113,240,0,1,100,11, +181,192,0,5,178,1,18,160,65,24,131,20,145,25,188,48,132,122,28,76,146,218, +121,35,180,69,145,132,108,224,0,0,0,0,0,0,120,31,153,188,56,132,122,28,76, +146,218,121,35,180,69,145,132,108,224,0,0,0,0,0,0,120,31,168,160,45,110,23, +30,176,33,184,0,0,183,32,29,235,2,27,199,23,0,0,23,4,51,120,129,8,244,56, +153,37,180,242,71,104,139,35,8,217,192,0,0,0,0,0,0,240,63,51,120,145,8,244, +56,153,37,180,242,71,104,139,35,8,217,192,0,0,0,0,0,0,0,64,51,120,161,8, +244,56,153,37,180,242,71,104,139,35,8,217,192,0,0,0,0,0,0,0,64,51,120,177, +8,244,56,153,37,180,242,71,104,139,35,8,217,192,0,0,0,0,0,0,16,64,51,120, +193,8,244,56,153,37,180,242,71,104,139,35,8,217,192,0,0,0,0,0,0,16,64,51, +120,209,8,244,56,153,37,180,242,71,104,139,35,8,217,192,0,0,0,0,0,0,16,64, +51,120,225,8,244,56,153,37,180,242,71,104,139,35,8,217,192,0,0,0,0,0,0,32, +64,32,227,194,0,97,57,162,4,246,104,5,34,92,35,68,225,161,166,220,16,16, +137,112,52,41,73,29,185,1,65,196,201,197,145,166,153,246,72,3,137,204,120, +34,74,8,199,1,67,17,162,112,201,84,128,97,144,78,25,42,16,131,169,1,205,66, +8,35,68,225,161,166,239,128,0,10,192,64,196,104,156,50,96,0,2,172,73,240, +117,96,57,170,97,4,104,156,52,52,221,240,0,1,82,1,74,9,129,125,240,0,1,82, +32,148,25,174,137,58,23,51,190,0,0,42,69,64,195,32,156,50,96,0,2,160,81, +238,2,3,107,173,218,3,192, +}; +#elif defined(DUK_USE_DOUBLE_BE) +DUK_INTERNAL const duk_uint8_t duk_builtins_data[4281] = { +144,148,105,226,32,68,52,228,254,12,104,202,37,132,52,167,194,138,105,245, +124,57,28,211,57,18,64,52,239,126,44,138,111,175,241,164,19,87,145,30,33, +167,22,145,159,8,211,139,9,225,42,5,240,145,139,163,163,8,211,139,10,228, +64,211,19,132,140,93,29,56,70,156,88,119,34,66,146,36,104,137,194,70,46, +142,172,35,78,44,47,146,195,102,11,240,145,139,163,175,8,211,139,9,228,240, +242,112,145,139,163,179,8,211,139,8,237,34,130,118,49,116,118,225,26,48,0, +1,98,29,201,158,46,183,39,135,147,132,140,93,16,132,76,66,33,8,66,16,132, +33,8,66,26,180,105,97,167,68,150,34,33,154,112,0,1,91,247,35,79,111,237, +198,174,232,47,31,23,95,17,13,31,249,96,211,49,50,53,214,77,141,24,0,0,181, +10,228,240,242,15,128,140,65,128,134,188,0,0,90,167,97,181,224,0,2,213,62, +53,224,0,2,213,66,237,120,0,0,181,81,204,107,192,0,5,170,150,67,94,0,0,45, +84,245,90,240,0,1,106,169,162,215,128,0,11,85,93,150,188,0,0,90,171,111,53, +109,22,162,26,48,0,1,84,23,201,146,243,225,26,39,12,145,136,104,192,0,5,61, +11,228,201,121,240,100,19,134,72,196,33,195,14,40,203,112,64,190,76,232, +145,153,136,15,255,0,0,0,0,0,0,25,152,15,254,0,0,0,0,0,0,25,120,144,13,96, +155,194,56,80,206,36,67,141,20,228,70,57,81,206,100,131,156,39,132,168,23, +194,70,46,137,208,21,200,129,166,39,9,24,186,39,72,119,34,66,146,36,104, +137,194,70,46,137,212,23,201,97,179,5,248,72,197,209,58,194,121,60,60,156, +36,98,232,157,129,29,164,80,78,198,46,137,218,146,121,25,71,146,9,209,5, +209,61,48,126,14,138,152,30,67,186,23,143,139,175,131,202,135,228,72,85, +144,83,60,179,30,94,209,233,102,30,98,105,230,103,30,114,121,231,104,30, +122,137,231,233,30,130,153,232,106,30,138,169,232,235,30,144,67,193,25,19, +136,108,207,30,41,224,140,137,194,173,192,153,228,5,242,100,188,248,70,137, +195,36,79,78,47,147,37,231,193,144,78,25,34,122,145,111,36,74,232,176,13, +17,61,234,226,93,207,148,160,84,75,141,7,27,161,32,33,18,225,80,212,76,154, +2,2,70,65,56,100,237,34,140,209,2,67,32,156,50,118,145,64,186,230,61,205, +35,103,155,32,36,141,19,134,78,210,40,206,16,36,70,137,195,39,105,20,11, +174,99,220,210,54,121,210,1,137,33,1,228,207,16,17,70,146,66,3,201,164,32, +0,65,112,152,56,196,159,31,23,77,211,195,201,199,23,160,72,214,246,81,6,12, +73,241,214,111,31,23,60,145,158,56,50,72,81,67,230,232,242,80,19,49,39,199, +89,188,124,92,242,70,120,227,64,194,75,154,72,12,9,73,6,111,21,120,12,40, +144,19,39,25,0,225,144,168,105,56,248,185,228,140,241,200,96,64,100,42,26, +78,62,46,121,35,52,18,92,116,1,36,64,47,158,64,49,98,66,100,156,242,65,23, +196,149,35,103,194,94,100,108,144,230,203,156,64,66,37,201,16,11,32,249, +132,4,34,92,44,93,146,55,152,72,24,137,112,151,153,27,36,5,100,229,144,8, +162,98,92,210,5,76,73,241,214,111,31,23,60,145,158,57,44,48,46,92,185,164, +160,72,151,41,0,50,107,179,244,59,36,93,127,92,6,19,172,3,11,216,0,56,224, +151,29,102,241,241,115,201,25,227,164,64,106,37,199,197,211,116,240,242, +113,197,233,144,40,248,185,228,140,241,196,75,132,109,24,72,128,43,39,84, +129,13,173,161,144,168,105,56,98,78,100,142,214,215,69,1,13,173,161,144, +168,105,57,34,78,100,142,214,215,69,16,67,107,105,110,114,168,254,24,147, +153,35,181,181,212,32,67,107,105,110,114,168,254,72,147,153,35,181,181,212, +36,65,130,3,144,8,26,252,200,13,30,85,16,16,64,90,242,231,192,64,161,163, +203,31,26,172,193,17,4,23,105,159,96,27,172,251,16,32,196,4,14,137,112,17, +136,48,164,28,134,80,215,202,1,132,130,8,12,39,52,64,155,31,24,56,36,1,189, +207,132,0,35,233,35,195,62,3,196,149,36,100,72,160,2,200,232,44,227,0,11, +37,160,68,142,128,36,157,25,200,32,26,79,90,4,73,43,192,122,54,71,65,103, +44,248,14,134,140,151,227,138,231,208,45,96,148,248,134,140,151,227,138, +231,240,1,255,254,10,74,146,56,128,104,4,147,152,72,6,144,28,174,143,8,1, +30,1,165,3,96,31,0,211,3,21,11,153,35,0,211,131,68,131,160,137,16,250,5, +196,131,160,137,200,160,199,156,67,248,0,255,255,65,140,10,48,177,115,56, +35,130,60,19,134,79,89,240,52,177,115,56,39,12,156,123,144,217,251,15,135, +34,167,30,20,170,154,255,232,12,47,244,0,97,28,17,224,39,238,32,40,71,4, +120,39,12,156,4,253,228,5,137,195,39,30,228,54,124,4,253,228,128,194,115, +68,9,252,15,128,232,104,201,126,56,191,35,64,90,193,41,241,13,25,47,199,23, +228,105,3,86,225,1,100,224,156,199,130,36,249,144,10,192,76,71,250,16,15, +18,61,96,17,62,200,3,72,128,136,143,247,32,22,75,64,137,248,64,22,79,90,39, +249,64,38,84,12,167,20,52,223,196,2,230,238,45,214,36,120,32,72,158,208,4, +102,238,45,194,2,201,197,186,196,143,4,9,19,218,0,92,221,202,61,228,143,4, +9,19,218,8,35,55,113,110,16,22,78,81,239,36,120,32,72,158,208,64,73,197,12, +255,0,13,18,60,128,159,212,128,169,76,17,156,185,100,76,255,163,64,65,26, +57,114,200,153,255,70,144,33,13,18,232,50,75,226,104,6,149,3,41,199,246, +130,12,128,28,142,156,120,203,175,158,8,194,207,1,6,81,20,79,88,11,237,84, +11,161,32,63,247,255,255,255,255,255,255,137,235,16,221,170,129,116,36,0,0, +0,0,0,0,0,0,28,196,7,255,128,0,0,0,0,0,2,61,123,164,137,162,164,218,67,74, +134,162,120,128,255,224,0,0,0,0,0,0,71,173,33,129,52,84,155,72,105,80,212, +79,16,63,252,0,0,0,0,0,0,3,244,143,146,22,230,192,60,176,0,0,0,0,0,0,33, +214,2,251,82,1,73,180,134,204,134,36,96,33,159,255,255,255,255,255,255,144, +235,16,221,169,0,164,218,67,102,67,18,48,48,207,255,255,255,255,255,255, +196,60,17,145,56,134,204,241,226,158,8,200,156,42,220,9,158,65,196,34,92, +42,26,137,147,120,64,74,37,196,54,100,49,35,188,36,5,68,184,208,113,187, +194,80,212,75,146,1,73,196,54,100,49,35,188,38,57,37,56,240,0,0,0,0,0,0,0, +0,32,235,248,68,48,156,2,24,94,24,0,243,119,10,139,144,123,242,3,102,238, +18,239,115,72,217,160,11,223,16,23,55,113,241,32,145,36,57,188,18,16,102,3, +5,120,35,34,89,32,15,180,152,173,127,0,218,235,88,0,228,180,227,200,127, +248,0,0,0,0,0,0,197,107,240,64,6,77,220,24,38,78,74,113,67,77,130,4,12,155, +185,52,48,156,148,226,134,155,4,10,194,96,129,132,166,238,45,194,2,201,193, +130,100,228,167,20,52,216,32,113,41,187,139,112,128,178,114,104,97,57,41, +197,13,54,8,32,48,216,32,130,195,224,130,19,97,124,134,23,6,0,57,137,62,77, +12,38,12,0,179,18,124,45,22,190,96,128,141,176,134,28,98,79,180,152,139, +218,45,124,193,1,27,97,16,32,196,159,24,230,204,246,194,40,89,137,62,210, +98,103,92,217,158,216,70,7,49,39,193,130,100,182,17,194,140,73,246,147,16, +250,9,146,216,72,6,49,39,193,131,22,194,72,73,137,62,210,98,31,65,139,97, +40,32,196,159,14,234,70,86,194,88,89,137,62,210,98,63,93,72,202,216,76,10, +49,39,198,33,180,153,37,108,38,134,152,147,237,38,38,117,13,164,201,43,97, +56,40,196,159,36,65,57,163,149,176,158,26,98,79,180,152,165,210,9,205,28, +173,133,0,243,18,124,98,22,180,72,130,115,71,43,97,68,72,196,159,105,49,51, +168,90,209,34,9,205,28,173,133,33,19,18,124,154,24,76,185,164,227,138,89, +18,119,0,7,145,39,201,161,132,188,64,124,137,62,49,11,90,36,65,57,163,149, +210,166,37,34,79,180,152,153,212,45,104,145,4,230,142,87,74,160,84,137,62, +72,130,115,71,43,171,234,134,200,147,237,38,41,116,130,115,71,43,171,235,5, +72,147,227,16,218,76,146,186,254,184,108,137,62,210,98,103,80,218,76,146, +186,254,192,68,137,62,29,212,140,174,207,178,23,34,79,180,152,143,215,82, +50,187,62,208,60,137,62,12,19,37,210,182,21,34,79,180,152,135,208,76,151, +74,224,68,137,62,49,205,153,238,175,186,23,34,79,180,152,153,215,54,103, +186,190,240,92,137,62,22,139,95,48,64,70,235,251,225,210,36,251,73,136,189, +162,215,204,16,17,186,255,2,14,98,79,152,32,35,108,48,64,242,36,249,130,2, +55,75,6,212,224,72,200,51,128,114,108,28,100,128,0,0,0,0,0,0,0,12,110,127, +48,98,115,249,201,117,243,249,195,21,159,206,38,47,63,156,86,8,75,144,94, +82,1,38,73,79,208,67,95,233,1,6,128,14,79,129,186,40,249,18,149,182,207, +144,200,155,188,248,204,105,184,207,142,199,137,175,201,0,159,72,10,5,21, +221,10,120,74,129,124,36,98,232,228,74,81,62,160,20,10,107,186,21,114,32, +105,137,194,70,46,142,68,165,19,235,1,64,170,187,161,119,34,66,146,36,104, +137,194,70,46,142,68,165,19,236,1,64,174,187,161,95,37,134,204,23,225,35, +23,71,34,82,137,246,128,160,89,93,208,167,147,195,201,194,70,46,142,68,165, +19,238,1,64,182,187,161,71,105,20,19,177,139,163,145,41,68,16,7,6,15,82,70, +72,115,96,32,106,27,128,0,0,0,0,91,60,165,195,201,194,8,134,149,216,162,0, +192,41,225,8,2,48,177,36,1,149,13,196,15,0,200,209,97,199,128,99,32,176, +195,192,113,57,143,0,167,133,32,230,80,28,202,139,175,238,2,48,189,192,20, +1,119,80,87,193,186,129,89,56,72,197,209,200,193,185,35,23,71,109,13,219, +36,98,232,237,156,13,26,208,211,14,102,19,87,137,91,95,128,0,10,96,24,92,0, +0,83,2,53,56,0,0,165,3,28,204,160,160,226,100,226,200,211,76,241,240,0,1, +102,8,22,75,64,137,73,20,230,105,133,7,19,39,22,70,154,103,143,128,0,11,48, +20,28,76,156,113,75,34,78,62,0,0,45,3,103,31,0,0,22,65,44,57,137,62,33,179, +216,162,152,192,131,18,124,162,27,61,138,41,108,32,196,159,16,217,232,235, +81,76,104,73,137,62,81,13,158,142,181,20,184,16,98,79,136,108,244,244,168, +166,56,36,196,159,40,134,207,79,74,138,93,10,49,39,194,173,192,158,158,149, +20,188,20,98,79,133,91,129,61,109,74,41,124,30,68,159,16,217,236,83,108,96, +68,137,62,81,13,158,197,54,182,17,34,79,136,108,244,117,169,182,52,38,68, +159,40,134,207,71,90,155,92,8,145,39,196,54,122,122,84,219,28,19,34,79,148, +67,103,167,165,77,174,133,72,147,225,86,224,79,79,74,155,94,10,145,39,194, +173,192,158,182,165,54,190,206,25,212,35,208,226,100,150,211,201,29,162,44, +140,35,103,0,255,192,0,0,0,0,0,0,206,25,228,35,208,226,100,150,211,201,29, +162,44,140,35,103,0,255,192,0,0,0,0,0,0,206,25,244,35,208,226,100,150,211, +201,29,162,44,140,35,103,0,255,192,0,0,0,0,0,0,206,26,4,35,208,226,100,150, +211,201,29,162,44,140,35,103,1,0,0,0,0,0,0,0,0,206,26,20,35,208,226,100, +150,211,201,29,162,44,140,35,103,1,0,0,0,0,0,0,0,0,206,26,36,35,208,226, +100,150,211,201,29,162,44,140,35,103,1,0,64,0,0,0,0,0,0,206,26,52,35,208, +226,100,150,211,201,29,162,44,140,35,103,1,0,64,0,0,0,0,0,0,206,26,68,35, +208,226,100,150,211,201,29,162,44,140,35,103,1,0,64,0,0,0,0,0,0,206,26,84, +35,208,226,100,150,211,201,29,162,44,140,35,103,1,0,128,0,0,0,0,0,0,195, +154,99,16,38,36,0,251,68,117,179,216,162,128,68,72,1,241,13,158,197,20,150, +25,18,0,125,162,58,217,232,235,117,100,162,136,25,18,0,125,162,58,217,232, +235,116,36,162,145,2,226,64,15,136,108,244,117,186,178,81,73,129,113,32,7, +196,54,122,58,221,9,40,165,64,200,144,3,237,17,214,207,79,75,171,37,20,80, +200,144,3,237,17,214,207,79,75,161,37,20,138,23,18,0,124,67,103,167,165, +213,146,138,77,11,137,0,62,33,179,211,210,232,73,69,42,133,196,128,31,10, +183,2,125,89,40,163,5,196,128,31,10,183,2,125,9,40,164,96,200,144,3,224, +221,64,172,157,89,40,163,134,68,128,31,6,234,5,100,232,73,69,35,133,68,128, +31,104,142,182,125,89,40,180,0,168,144,3,237,17,214,207,161,37,22,144,19, +18,0,124,67,103,213,146,139,80,9,137,0,62,33,179,232,73,69,172,5,90,40,153, +59,68,117,179,216,166,192,77,162,137,147,136,108,246,41,180,176,219,69,19, +39,104,142,182,122,58,221,89,41,178,6,218,40,153,59,68,117,179,209,214,232, +73,77,162,6,90,40,153,56,134,207,71,91,171,37,54,152,25,104,162,100,226,27, +61,29,110,132,148,218,160,109,162,137,147,180,71,91,61,61,46,172,148,217, +67,109,20,76,157,162,58,217,233,233,116,36,166,209,67,45,20,76,156,67,103, +167,165,213,146,155,77,12,180,81,50,113,13,158,158,151,66,74,109,84,50,209, +68,201,194,173,192,159,86,74,108,193,150,138,38,78,21,110,4,250,18,83,104, +193,182,138,38,78,13,212,10,201,213,146,155,56,109,162,137,147,131,117,2, +178,116,36,166,209,194,237,20,76,157,162,58,217,245,100,167,16,2,237,20,76, +157,162,58,217,244,36,167,18,2,173,20,76,156,67,103,213,146,156,80,10,180, +81,50,113,13,159,66,74,113,97,175,221,48,216,110,64,4,42,22,189,179,0,196, +133,0,185,80,32,28,78,99,193,18,80,36,4,19,159,141,172,0,178,90,4,74,73,0, +22,209,68,201,187,129,4,2,8,3,132,64,60,36,4,0,91,240,168,177,69,118,144, +157,91,116,116,32,32,1,53,216,221,218,170,139,3,234,219,165,0,255,152,185, +11,251,232,231,188,47,86,227,105,18,1,255,184,170,59,41,92,23,240,110,173, +198,209,208,36,3,253,188,183,177,82,110,80,224,93,122,32,32,4,144,253,170, +34,22,140,7,236,161,25,232,237,105,64,63,230,160,158,102,127,59,205,11,217, +66,51,210,128,127,237,65,60,204,254,119,155,171,197,34,168,48,6,90,194,1,0, +39,75,88,72,8,9,33,186,194,80,64,76,13,214,19,2,130,96,110,150,189,0,65,6, +51,214,20,128,65,17,11,214,19,130,137,121,211,210,211,144,6,39,75,88,80,0, +201,119,235,10,8,41,86,231,71,88,80,129,79,135,186,122,133,224,34,25,69, +234,80,3,91,141,172,40,96,139,113,180,181,133,36,21,110,54,142,134,176,165, +1,176,23,213,47,0,216,134,234,215,128,111,117,181,232,128,209,3,70,230,107, +64,5,139,168,209,235,10,32,36,144,102,235,136,3,146,27,172,40,160,146,132, +103,172,40,192,115,3,117,133,28,22,113,163,69,172,41,103,1,66,188,17,145, +52,168,4,202,113,67,76,130,227,76,194,13,240,108,0,0,83,224,0,2,193,0,104, +146,84,97,48,0,1,94,192,56,169,24,145,179,192,0,5,112,8,56,16,32,128,56,18, +52,125,230,86,147,190,140,28,50,21,13,39,31,23,60,145,158,57,12,141,47,129, +6,155,194,188,24,49,39,199,89,188,124,92,242,70,120,224,201,33,69,15,155, +163,201,68,14,49,39,199,197,211,116,240,242,113,197,232,18,180,254,36,3,17, +46,18,243,35,100,128,172,156,178,70,163,154,76,34,248,146,164,108,248,75, +204,141,146,28,217,115,137,27,95,27,241,173,236,162,160,224,200,2,206,9, +113,13,148,192,209,18,22,164,146,37,193,57,162,4,249,39,196,128,24,2,178, +66,213,136,68,201,16,77,209,131,31,192,242,88,96,92,191,151,34,100,136,38, +232,255,252,92,221,199,197,12,68,209,82,66,212,11,155,185,41,197,13,55,38, +3,66,213,47,135,254,72,12,162,99,133,116,112,0,1,72,66,14,16,16,50,37,202, +160,150,154,66,14,20,8,57,192,28,24,80,113,50,113,100,105,166,120,248,0,0, +179,1,65,196,201,199,20,178,36,227,224,0,2,208,54,113,240,0,1,100,11,181, +192,0,5,178,1,18,160,65,24,131,20,145,25,188,48,132,122,28,76,146,218,121, +35,180,69,145,132,108,224,31,248,0,0,0,0,0,0,25,188,56,132,122,28,76,146, +218,121,35,180,69,145,132,108,224,31,248,0,0,0,0,0,0,40,160,45,110,23,30, +176,33,184,0,0,183,32,29,235,2,27,199,23,0,0,23,4,51,120,129,8,244,56,153, +37,180,242,71,104,139,35,8,217,192,63,240,0,0,0,0,0,0,51,120,145,8,244,56, +153,37,180,242,71,104,139,35,8,217,192,64,0,0,0,0,0,0,0,51,120,161,8,244, +56,153,37,180,242,71,104,139,35,8,217,192,64,0,0,0,0,0,0,0,51,120,177,8, +244,56,153,37,180,242,71,104,139,35,8,217,192,64,16,0,0,0,0,0,0,51,120,193, +8,244,56,153,37,180,242,71,104,139,35,8,217,192,64,16,0,0,0,0,0,0,51,120, +209,8,244,56,153,37,180,242,71,104,139,35,8,217,192,64,16,0,0,0,0,0,0,51, +120,225,8,244,56,153,37,180,242,71,104,139,35,8,217,192,64,32,0,0,0,0,0,0, +32,227,194,0,97,57,162,4,246,104,5,34,92,35,68,225,161,166,220,16,16,137, +112,52,41,73,29,185,1,65,196,201,197,145,166,153,246,72,3,137,204,120,34, +74,8,199,1,67,17,162,112,201,84,128,97,144,78,25,42,16,131,169,1,205,66,8, +35,68,225,161,166,239,128,0,10,192,64,196,104,156,50,96,0,2,172,73,240,117, +96,57,170,97,4,104,156,52,52,221,240,0,1,82,1,74,9,129,125,240,0,1,82,32, +148,25,174,137,58,23,51,190,0,0,42,69,64,195,32,156,50,96,0,2,160,81,238,2, +3,107,173,218,3,192, +}; +#elif defined(DUK_USE_DOUBLE_ME) +DUK_INTERNAL const duk_uint8_t duk_builtins_data[4281] = { +144,148,105,226,32,68,52,228,254,12,104,202,37,132,52,167,194,138,105,245, +124,57,28,211,57,18,64,52,239,126,44,138,111,175,241,164,19,87,145,30,33, +167,22,145,159,8,211,139,9,225,42,5,240,145,139,163,163,8,211,139,10,228, +64,211,19,132,140,93,29,56,70,156,88,119,34,66,146,36,104,137,194,70,46, +142,172,35,78,44,47,146,195,102,11,240,145,139,163,175,8,211,139,9,228,240, +242,112,145,139,163,179,8,211,139,8,237,34,130,118,49,116,118,225,26,48,0, +1,98,29,201,158,46,183,39,135,147,132,140,93,16,132,76,66,33,8,66,16,132, +33,8,66,26,180,105,97,167,68,150,34,33,154,112,0,1,91,247,35,79,111,237, +198,174,232,47,31,23,95,17,13,31,249,96,211,49,50,53,214,77,141,24,0,0,181, +10,228,240,242,15,128,140,65,128,134,188,0,0,90,167,97,181,224,0,2,213,62, +53,224,0,2,213,66,237,120,0,0,181,81,204,107,192,0,5,170,150,67,94,0,0,45, +84,245,90,240,0,1,106,169,162,215,128,0,11,85,93,150,188,0,0,90,171,111,53, +109,22,162,26,48,0,1,84,23,201,146,243,225,26,39,12,145,136,104,192,0,5,61, +11,228,201,121,240,100,19,134,72,196,33,195,14,40,203,112,64,190,76,232, +145,153,136,0,0,31,15,224,0,0,0,25,152,0,0,30,15,224,0,0,0,25,120,144,13, +96,155,194,56,80,206,36,67,141,20,228,70,57,81,206,100,131,156,39,132,168, +23,194,70,46,137,208,21,200,129,166,39,9,24,186,39,72,119,34,66,146,36,104, +137,194,70,46,137,212,23,201,97,179,5,248,72,197,209,58,194,121,60,60,156, +36,98,232,157,129,29,164,80,78,198,46,137,218,146,121,25,71,146,9,209,5, +209,61,48,126,14,138,152,30,67,186,23,143,139,175,131,202,135,228,72,85, +144,83,60,179,30,94,209,233,102,30,98,105,230,103,30,114,121,231,104,30, +122,137,231,233,30,130,153,232,106,30,138,169,232,235,30,144,67,193,25,19, +136,108,207,30,41,224,140,137,194,173,192,153,228,5,242,100,188,248,70,137, +195,36,79,78,47,147,37,231,193,144,78,25,34,122,145,111,36,74,232,176,13, +17,61,234,226,93,207,148,160,84,75,141,7,27,161,32,33,18,225,80,212,76,154, +2,2,70,65,56,100,237,34,140,209,2,67,32,156,50,118,145,64,186,230,61,205, +35,103,155,32,36,141,19,134,78,210,40,206,16,36,70,137,195,39,105,20,11, +174,99,220,210,54,121,210,1,137,33,1,228,207,16,17,70,146,66,3,201,164,32, +0,65,112,152,56,196,159,31,23,77,211,195,201,199,23,160,72,214,246,81,6,12, +73,241,214,111,31,23,60,145,158,56,50,72,81,67,230,232,242,80,19,49,39,199, +89,188,124,92,242,70,120,227,64,194,75,154,72,12,9,73,6,111,21,120,12,40, +144,19,39,25,0,225,144,168,105,56,248,185,228,140,241,200,96,64,100,42,26, +78,62,46,121,35,52,18,92,116,1,36,64,47,158,64,49,98,66,100,156,242,65,23, +196,149,35,103,194,94,100,108,144,230,203,156,64,66,37,201,16,11,32,249, +132,4,34,92,44,93,146,55,152,72,24,137,112,151,153,27,36,5,100,229,144,8, +162,98,92,210,5,76,73,241,214,111,31,23,60,145,158,57,44,48,46,92,185,164, +160,72,151,41,0,50,107,179,244,59,36,93,127,92,6,19,172,3,11,216,0,56,224, +151,29,102,241,241,115,201,25,227,164,64,106,37,199,197,211,116,240,242, +113,197,233,144,40,248,185,228,140,241,196,75,132,109,24,72,128,43,39,84, +129,13,173,161,144,168,105,56,98,78,100,142,214,215,69,1,13,173,161,144, +168,105,57,34,78,100,142,214,215,69,16,67,107,105,110,114,168,254,24,147, +153,35,181,181,212,32,67,107,105,110,114,168,254,72,147,153,35,181,181,212, +36,65,130,3,144,8,26,252,200,13,30,85,16,16,64,90,242,231,192,64,161,163, +203,31,26,172,193,17,4,23,105,159,96,27,172,251,16,32,196,4,14,137,112,17, +136,48,164,28,134,80,215,202,1,132,130,8,12,39,52,64,155,31,24,56,36,1,189, +207,132,0,35,233,35,195,62,3,196,149,36,100,72,160,2,200,232,44,227,0,11, +37,160,68,142,128,36,157,25,200,32,26,79,90,4,73,43,192,122,54,71,65,103, +44,248,14,134,140,151,227,138,231,208,45,96,148,248,134,140,151,227,138, +231,240,1,255,254,10,74,146,56,128,104,4,147,152,72,6,144,28,174,143,8,1, +30,1,165,3,96,31,0,211,3,21,11,153,35,0,211,131,68,131,160,137,16,250,5, +196,131,160,137,200,160,199,156,67,248,0,255,255,65,140,10,48,177,115,56, +35,130,60,19,134,79,89,240,52,177,115,56,39,12,156,123,144,217,251,15,135, +34,167,30,20,170,154,255,232,12,47,244,0,97,28,17,224,39,238,32,40,71,4, +120,39,12,156,4,253,228,5,137,195,39,30,228,54,124,4,253,228,128,194,115, +68,9,252,15,128,232,104,201,126,56,191,35,64,90,193,41,241,13,25,47,199,23, +228,105,3,86,225,1,100,224,156,199,130,36,249,144,10,192,76,71,250,16,15, +18,61,96,17,62,200,3,72,128,136,143,247,32,22,75,64,137,248,64,22,79,90,39, +249,64,38,84,12,167,20,52,223,196,2,230,238,45,214,36,120,32,72,158,208,4, +102,238,45,194,2,201,197,186,196,143,4,9,19,218,0,92,221,202,61,228,143,4, +9,19,218,8,35,55,113,110,16,22,78,81,239,36,120,32,72,158,208,64,73,197,12, +255,0,13,18,60,128,159,212,128,169,76,17,156,185,100,76,255,163,64,65,26, +57,114,200,153,255,70,144,33,13,18,232,50,75,226,104,6,149,3,41,199,246, +130,12,128,28,142,156,120,203,175,158,8,194,207,1,6,81,20,79,88,11,237,84, +11,161,32,127,255,247,191,255,255,255,255,137,235,16,221,170,129,116,36,0, +0,0,0,0,16,0,0,12,196,0,0,15,135,240,0,0,0,2,61,123,164,137,162,164,218,67, +74,134,162,120,128,0,1,224,254,0,0,0,0,71,173,33,129,52,84,155,72,105,80, +212,79,16,0,0,60,63,192,0,0,0,3,244,143,146,22,230,192,0,0,176,60,0,0,0,0, +33,214,2,251,82,1,73,180,134,204,134,36,96,127,255,159,161,255,255,255,255, +144,235,16,221,169,0,164,218,67,102,67,18,48,63,255,207,240,255,255,255, +255,196,60,17,145,56,134,204,241,226,158,8,200,156,42,220,9,158,65,196,34, +92,42,26,137,147,120,64,74,37,196,54,100,49,35,188,36,5,68,184,208,113,187, +194,80,212,75,146,1,73,196,54,100,49,35,188,38,57,37,56,240,0,0,0,0,0,0,0, +0,32,235,248,68,48,156,2,24,94,24,0,243,119,10,139,144,123,242,3,102,238, +18,239,115,72,217,160,11,223,16,23,55,113,241,32,145,36,57,188,18,16,102,3, +5,120,35,34,89,32,15,180,152,173,127,0,218,235,88,0,228,180,227,200,0,0, +248,127,0,0,0,0,197,107,240,64,6,77,220,24,38,78,74,113,67,77,130,4,12,155, +185,52,48,156,148,226,134,155,4,10,194,96,129,132,166,238,45,194,2,201,193, +130,100,228,167,20,52,216,32,113,41,187,139,112,128,178,114,104,97,57,41, +197,13,54,8,32,48,216,32,130,195,224,130,19,97,124,134,23,6,0,57,137,62,77, +12,38,12,0,179,18,124,45,22,190,96,128,141,176,134,28,98,79,180,152,139, +218,45,124,193,1,27,97,16,32,196,159,24,230,204,246,194,40,89,137,62,210, +98,103,92,217,158,216,70,7,49,39,193,130,100,182,17,194,140,73,246,147,16, +250,9,146,216,72,6,49,39,193,131,22,194,72,73,137,62,210,98,31,65,139,97, +40,32,196,159,14,234,70,86,194,88,89,137,62,210,98,63,93,72,202,216,76,10, +49,39,198,33,180,153,37,108,38,134,152,147,237,38,38,117,13,164,201,43,97, +56,40,196,159,36,65,57,163,149,176,158,26,98,79,180,152,165,210,9,205,28, +173,133,0,243,18,124,98,22,180,72,130,115,71,43,97,68,72,196,159,105,49,51, +168,90,209,34,9,205,28,173,133,33,19,18,124,154,24,76,185,164,227,138,89, +18,119,0,7,145,39,201,161,132,188,64,124,137,62,49,11,90,36,65,57,163,149, +210,166,37,34,79,180,152,153,212,45,104,145,4,230,142,87,74,160,84,137,62, +72,130,115,71,43,171,234,134,200,147,237,38,41,116,130,115,71,43,171,235,5, +72,147,227,16,218,76,146,186,254,184,108,137,62,210,98,103,80,218,76,146, +186,254,192,68,137,62,29,212,140,174,207,178,23,34,79,180,152,143,215,82, +50,187,62,208,60,137,62,12,19,37,210,182,21,34,79,180,152,135,208,76,151, +74,224,68,137,62,49,205,153,238,175,186,23,34,79,180,152,153,215,54,103, +186,190,240,92,137,62,22,139,95,48,64,70,235,251,225,210,36,251,73,136,189, +162,215,204,16,17,186,255,2,14,98,79,152,32,35,108,48,64,242,36,249,130,2, +55,75,6,212,224,72,200,51,128,114,108,28,100,128,0,0,0,0,0,0,0,12,110,127, +48,98,115,249,201,117,243,249,195,21,159,206,38,47,63,156,86,8,75,144,94, +82,1,38,73,79,208,67,95,233,1,6,128,14,79,129,186,40,249,18,149,182,207, +144,200,155,188,248,204,105,184,207,142,199,137,175,201,0,159,72,10,5,21, +221,10,120,74,129,124,36,98,232,228,74,81,62,160,20,10,107,186,21,114,32, +105,137,194,70,46,142,68,165,19,235,1,64,170,187,161,119,34,66,146,36,104, +137,194,70,46,142,68,165,19,236,1,64,174,187,161,95,37,134,204,23,225,35, +23,71,34,82,137,246,128,160,89,93,208,167,147,195,201,194,70,46,142,68,165, +19,238,1,64,182,187,161,71,105,20,19,177,139,163,145,41,68,16,7,6,15,82,70, +72,115,96,0,27,234,32,0,0,0,0,91,60,165,195,201,194,8,134,149,216,162,0, +192,41,225,8,2,48,177,36,1,149,13,196,15,0,200,209,97,199,128,99,32,176, +195,192,113,57,143,0,167,133,32,230,80,28,202,139,175,238,2,48,189,192,20, +1,119,80,87,193,186,129,89,56,72,197,209,200,193,185,35,23,71,109,13,219, +36,98,232,237,156,13,26,208,211,14,102,19,87,137,91,95,128,0,10,96,24,92,0, +0,83,2,53,56,0,0,165,3,28,204,160,160,226,100,226,200,211,76,241,240,0,1, +102,8,22,75,64,137,73,20,230,105,133,7,19,39,22,70,154,103,143,128,0,11,48, +20,28,76,156,113,75,34,78,62,0,0,45,3,103,31,0,0,22,65,44,57,137,62,33,179, +216,162,152,192,131,18,124,162,27,61,138,41,108,32,196,159,16,217,232,235, +81,76,104,73,137,62,81,13,158,142,181,20,184,16,98,79,136,108,244,244,168, +166,56,36,196,159,40,134,207,79,74,138,93,10,49,39,194,173,192,158,158,149, +20,188,20,98,79,133,91,129,61,109,74,41,124,30,68,159,16,217,236,83,108,96, +68,137,62,81,13,158,197,54,182,17,34,79,136,108,244,117,169,182,52,38,68, +159,40,134,207,71,90,155,92,8,145,39,196,54,122,122,84,219,28,19,34,79,148, +67,103,167,165,77,174,133,72,147,225,86,224,79,79,74,155,94,10,145,39,194, +173,192,158,182,165,54,190,206,25,212,35,208,226,100,150,211,201,29,162,44, +140,35,103,0,0,3,192,252,0,0,0,0,206,25,228,35,208,226,100,150,211,201,29, +162,44,140,35,103,0,0,3,192,252,0,0,0,0,206,25,244,35,208,226,100,150,211, +201,29,162,44,140,35,103,0,0,3,192,252,0,0,0,0,206,26,4,35,208,226,100,150, +211,201,29,162,44,140,35,103,0,0,0,1,0,0,0,0,0,206,26,20,35,208,226,100, +150,211,201,29,162,44,140,35,103,0,0,0,1,0,0,0,0,0,206,26,36,35,208,226, +100,150,211,201,29,162,44,140,35,103,0,0,0,65,0,0,0,0,0,206,26,52,35,208, +226,100,150,211,201,29,162,44,140,35,103,0,0,0,65,0,0,0,0,0,206,26,68,35, +208,226,100,150,211,201,29,162,44,140,35,103,0,0,0,65,0,0,0,0,0,206,26,84, +35,208,226,100,150,211,201,29,162,44,140,35,103,0,0,0,129,0,0,0,0,0,195, +154,99,16,38,36,0,251,68,117,179,216,162,128,68,72,1,241,13,158,197,20,150, +25,18,0,125,162,58,217,232,235,117,100,162,136,25,18,0,125,162,58,217,232, +235,116,36,162,145,2,226,64,15,136,108,244,117,186,178,81,73,129,113,32,7, +196,54,122,58,221,9,40,165,64,200,144,3,237,17,214,207,79,75,171,37,20,80, +200,144,3,237,17,214,207,79,75,161,37,20,138,23,18,0,124,67,103,167,165, +213,146,138,77,11,137,0,62,33,179,211,210,232,73,69,42,133,196,128,31,10, +183,2,125,89,40,163,5,196,128,31,10,183,2,125,9,40,164,96,200,144,3,224, +221,64,172,157,89,40,163,134,68,128,31,6,234,5,100,232,73,69,35,133,68,128, +31,104,142,182,125,89,40,180,0,168,144,3,237,17,214,207,161,37,22,144,19, +18,0,124,67,103,213,146,139,80,9,137,0,62,33,179,232,73,69,172,5,90,40,153, +59,68,117,179,216,166,192,77,162,137,147,136,108,246,41,180,176,219,69,19, +39,104,142,182,122,58,221,89,41,178,6,218,40,153,59,68,117,179,209,214,232, +73,77,162,6,90,40,153,56,134,207,71,91,171,37,54,152,25,104,162,100,226,27, +61,29,110,132,148,218,160,109,162,137,147,180,71,91,61,61,46,172,148,217, +67,109,20,76,157,162,58,217,233,233,116,36,166,209,67,45,20,76,156,67,103, +167,165,213,146,155,77,12,180,81,50,113,13,158,158,151,66,74,109,84,50,209, +68,201,194,173,192,159,86,74,108,193,150,138,38,78,21,110,4,250,18,83,104, +193,182,138,38,78,13,212,10,201,213,146,155,56,109,162,137,147,131,117,2, +178,116,36,166,209,194,237,20,76,157,162,58,217,245,100,167,16,2,237,20,76, +157,162,58,217,244,36,167,18,2,173,20,76,156,67,103,213,146,156,80,10,180, +81,50,113,13,159,66,74,113,97,175,221,48,216,110,64,4,42,22,189,179,0,196, +133,0,185,80,32,28,78,99,193,18,80,36,4,19,159,141,172,0,178,90,4,74,73,0, +22,209,68,201,187,129,4,2,8,3,132,64,60,36,0,171,240,84,6,149,113,72,176, +157,91,116,116,32,88,181,129,32,11,42,218,221,131,234,219,165,1,8,187,152, +255,188,231,235,248,47,86,227,105,18,2,56,175,185,255,244,17,91,40,110,173, +198,209,208,36,7,188,189,179,240,238,82,97,80,93,122,32,125,144,132,160,12, +22,162,42,7,236,161,25,232,237,105,64,158,160,230,63,205,59,127,102,11,217, +66,51,210,129,61,65,236,127,154,118,254,205,171,197,34,168,48,6,90,194,1,0, +39,75,88,72,8,9,33,186,194,80,64,76,13,214,19,2,130,96,110,150,189,0,65,6, +51,214,20,128,65,17,11,214,19,130,137,121,211,210,211,144,6,39,75,88,80,0, +201,119,235,10,8,41,86,231,71,88,80,129,79,135,186,122,133,224,34,25,69, +234,80,3,91,141,172,40,96,139,113,180,181,133,36,21,110,54,142,134,176,165, +1,176,23,213,47,0,216,134,234,215,128,111,117,181,232,128,209,3,70,230,107, +64,5,139,168,209,235,10,32,36,144,102,235,136,3,146,27,172,40,160,146,132, +103,172,40,192,115,3,117,133,28,22,113,163,69,172,41,103,1,66,188,17,145, +52,168,4,202,113,67,76,130,227,76,194,13,240,108,0,0,83,224,0,2,193,0,104, +146,84,97,48,0,1,94,192,56,169,24,145,179,192,0,5,112,8,56,16,32,128,56,18, +52,125,230,86,147,190,140,28,50,21,13,39,31,23,60,145,158,57,12,141,47,129, +6,155,194,188,24,49,39,199,89,188,124,92,242,70,120,224,201,33,69,15,155, +163,201,68,14,49,39,199,197,211,116,240,242,113,197,232,18,180,254,36,3,17, +46,18,243,35,100,128,172,156,178,70,163,154,76,34,248,146,164,108,248,75, +204,141,146,28,217,115,137,27,95,27,241,173,236,162,160,224,200,2,206,9, +113,13,148,192,209,18,22,164,146,37,193,57,162,4,249,39,196,128,24,2,178, +66,213,136,68,201,16,77,209,131,31,192,242,88,96,92,191,151,34,100,136,38, +232,255,252,92,221,199,197,12,68,209,82,66,212,11,155,185,41,197,13,55,38, +3,66,213,47,135,254,72,12,162,99,133,116,112,0,1,72,66,14,16,16,50,37,202, +160,150,154,66,14,20,8,57,192,28,24,80,113,50,113,100,105,166,120,248,0,0, +179,1,65,196,201,199,20,178,36,227,224,0,2,208,54,113,240,0,1,100,11,181, +192,0,5,178,1,18,160,65,24,131,20,145,25,188,48,132,122,28,76,146,218,121, +35,180,69,145,132,108,224,0,0,120,31,128,0,0,0,25,188,56,132,122,28,76,146, +218,121,35,180,69,145,132,108,224,0,0,120,31,128,0,0,0,40,160,45,110,23,30, +176,33,184,0,0,183,32,29,235,2,27,199,23,0,0,23,4,51,120,129,8,244,56,153, +37,180,242,71,104,139,35,8,217,192,0,0,240,63,0,0,0,0,51,120,145,8,244,56, +153,37,180,242,71,104,139,35,8,217,192,0,0,0,64,0,0,0,0,51,120,161,8,244, +56,153,37,180,242,71,104,139,35,8,217,192,0,0,0,64,0,0,0,0,51,120,177,8, +244,56,153,37,180,242,71,104,139,35,8,217,192,0,0,16,64,0,0,0,0,51,120,193, +8,244,56,153,37,180,242,71,104,139,35,8,217,192,0,0,16,64,0,0,0,0,51,120, +209,8,244,56,153,37,180,242,71,104,139,35,8,217,192,0,0,16,64,0,0,0,0,51, +120,225,8,244,56,153,37,180,242,71,104,139,35,8,217,192,0,0,32,64,0,0,0,0, +32,227,194,0,97,57,162,4,246,104,5,34,92,35,68,225,161,166,220,16,16,137, +112,52,41,73,29,185,1,65,196,201,197,145,166,153,246,72,3,137,204,120,34, +74,8,199,1,67,17,162,112,201,84,128,97,144,78,25,42,16,131,169,1,205,66,8, +35,68,225,161,166,239,128,0,10,192,64,196,104,156,50,96,0,2,172,73,240,117, +96,57,170,97,4,104,156,52,52,221,240,0,1,82,1,74,9,129,125,240,0,1,82,32, +148,25,174,137,58,23,51,190,0,0,42,69,64,195,32,156,50,96,0,2,160,81,238,2, +3,107,173,218,3,192, +}; +#else +#error invalid endianness defines +#endif +#endif /* DUK_USE_ROM_OBJECTS */ + +/* automatic undefs */ +#undef DUK__REFCINIT +#line 1 "duk_error_macros.c" +/* + * Error and fatal handling. + */ + +/* #include duk_internal.h -> already included */ + +#define DUK__ERRFMT_BUFSIZE 256 /* size for formatting buffers */ + +#if defined(DUK_USE_VERBOSE_ERRORS) + +DUK_INTERNAL DUK_COLD void duk_err_handle_error_fmt(duk_hthread *thr, + const char *filename, + duk_uint_t line_and_code, + const char *fmt, + ...) { + va_list ap; + char msg[DUK__ERRFMT_BUFSIZE]; + va_start(ap, fmt); + (void) DUK_VSNPRINTF(msg, sizeof(msg), fmt, ap); + msg[sizeof(msg) - 1] = (char) 0; + duk_err_create_and_throw(thr, + (duk_errcode_t) (line_and_code >> 24), + msg, + filename, + (duk_int_t) (line_and_code & 0x00ffffffL)); + va_end(ap); /* dead code, but ensures portability (see Linux man page notes) */ +} + +DUK_INTERNAL DUK_COLD void duk_err_handle_error(duk_hthread *thr, const char *filename, duk_uint_t line_and_code, const char *msg) { + duk_err_create_and_throw(thr, + (duk_errcode_t) (line_and_code >> 24), + msg, + filename, + (duk_int_t) (line_and_code & 0x00ffffffL)); +} + +#else /* DUK_USE_VERBOSE_ERRORS */ + +DUK_INTERNAL DUK_COLD void duk_err_handle_error(duk_hthread *thr, duk_errcode_t code) { + duk_err_create_and_throw(thr, code); +} + +#endif /* DUK_USE_VERBOSE_ERRORS */ + +/* + * Error throwing helpers + */ + +#if defined(DUK_USE_VERBOSE_ERRORS) +#if defined(DUK_USE_PARANOID_ERRORS) +DUK_INTERNAL DUK_COLD void duk_err_require_type_index(duk_hthread *thr, + const char *filename, + duk_int_t linenumber, + duk_idx_t idx, + const char *expect_name) { + DUK_ERROR_RAW_FMT3(thr, + filename, + linenumber, + DUK_ERR_TYPE_ERROR, + "%s required, found %s (stack index %ld)", + expect_name, + duk_get_type_name(thr, idx), + (long) idx); +} +#else +DUK_INTERNAL DUK_COLD void duk_err_require_type_index(duk_hthread *thr, + const char *filename, + duk_int_t linenumber, + duk_idx_t idx, + const char *expect_name) { + DUK_ERROR_RAW_FMT3(thr, + filename, + linenumber, + DUK_ERR_TYPE_ERROR, + "%s required, found %s (stack index %ld)", + expect_name, + duk_push_string_readable(thr, idx), + (long) idx); +} +#endif +DUK_INTERNAL DUK_COLD void duk_err_error_internal(duk_hthread *thr, const char *filename, duk_int_t linenumber) { + DUK_ERROR_RAW(thr, filename, linenumber, DUK_ERR_ERROR, DUK_STR_INTERNAL_ERROR); +} +DUK_INTERNAL DUK_COLD void duk_err_error_alloc_failed(duk_hthread *thr, const char *filename, duk_int_t linenumber) { + DUK_ERROR_RAW(thr, filename, linenumber, DUK_ERR_ERROR, DUK_STR_ALLOC_FAILED); +} +DUK_INTERNAL DUK_COLD void duk_err_error(duk_hthread *thr, const char *filename, duk_int_t linenumber, const char *message) { + DUK_ERROR_RAW(thr, filename, linenumber, DUK_ERR_ERROR, message); +} +DUK_INTERNAL DUK_COLD void duk_err_range(duk_hthread *thr, const char *filename, duk_int_t linenumber, const char *message) { + DUK_ERROR_RAW(thr, filename, linenumber, DUK_ERR_RANGE_ERROR, message); +} +DUK_INTERNAL DUK_COLD void duk_err_range_index(duk_hthread *thr, const char *filename, duk_int_t linenumber, duk_idx_t idx) { + DUK_ERROR_RAW_FMT1(thr, filename, linenumber, DUK_ERR_RANGE_ERROR, "invalid stack index %ld", (long) (idx)); +} +DUK_INTERNAL DUK_COLD void duk_err_range_push_beyond(duk_hthread *thr, const char *filename, duk_int_t linenumber) { + DUK_ERROR_RAW(thr, filename, linenumber, DUK_ERR_RANGE_ERROR, DUK_STR_PUSH_BEYOND_ALLOC_STACK); +} +DUK_INTERNAL DUK_COLD void duk_err_type_invalid_args(duk_hthread *thr, const char *filename, duk_int_t linenumber) { + DUK_ERROR_RAW(thr, filename, linenumber, DUK_ERR_TYPE_ERROR, DUK_STR_INVALID_ARGS); +} +DUK_INTERNAL DUK_COLD void duk_err_type_invalid_state(duk_hthread *thr, const char *filename, duk_int_t linenumber) { + DUK_ERROR_RAW(thr, filename, linenumber, DUK_ERR_TYPE_ERROR, DUK_STR_INVALID_STATE); +} +DUK_INTERNAL DUK_COLD void duk_err_type_invalid_trap_result(duk_hthread *thr, const char *filename, duk_int_t linenumber) { + DUK_ERROR_RAW(thr, filename, linenumber, DUK_ERR_TYPE_ERROR, DUK_STR_INVALID_TRAP_RESULT); +} +#else +/* The file/line arguments are NULL and 0, they're ignored by DUK_ERROR_RAW() + * when non-verbose errors are used. + */ + +DUK_NORETURN(DUK_LOCAL_DECL void duk__err_shared(duk_hthread *thr, duk_errcode_t code)); +DUK_LOCAL void duk__err_shared(duk_hthread *thr, duk_errcode_t code) { + DUK_ERROR_RAW(thr, NULL, 0, code, NULL); +} +DUK_INTERNAL DUK_COLD void duk_err_error(duk_hthread *thr) { + duk__err_shared(thr, DUK_ERR_ERROR); +} +DUK_INTERNAL DUK_COLD void duk_err_range(duk_hthread *thr) { + duk__err_shared(thr, DUK_ERR_RANGE_ERROR); +} +DUK_INTERNAL DUK_COLD void duk_err_eval(duk_hthread *thr) { + duk__err_shared(thr, DUK_ERR_EVAL_ERROR); +} +DUK_INTERNAL DUK_COLD void duk_err_reference(duk_hthread *thr) { + duk__err_shared(thr, DUK_ERR_REFERENCE_ERROR); +} +DUK_INTERNAL DUK_COLD void duk_err_syntax(duk_hthread *thr) { + duk__err_shared(thr, DUK_ERR_SYNTAX_ERROR); +} +DUK_INTERNAL DUK_COLD void duk_err_type(duk_hthread *thr) { + duk__err_shared(thr, DUK_ERR_TYPE_ERROR); +} +DUK_INTERNAL DUK_COLD void duk_err_uri(duk_hthread *thr) { + duk__err_shared(thr, DUK_ERR_URI_ERROR); +} +#endif + +/* + * Default fatal error handler + */ + +DUK_INTERNAL DUK_COLD void duk_default_fatal_handler(void *udata, const char *msg) { + DUK_UNREF(udata); + DUK_UNREF(msg); + + msg = msg ? msg : "NULL"; + +#if defined(DUK_USE_FATAL_HANDLER) + /* duk_config.h provided a custom default fatal handler. */ + DUK_D(DUK_DPRINT("custom default fatal error handler called: %s", msg)); + DUK_USE_FATAL_HANDLER(udata, msg); +#elif defined(DUK_USE_CPP_EXCEPTIONS) + /* With C++ use a duk_fatal_exception which user code can catch in + * a natural way. + */ + DUK_D(DUK_DPRINT("built-in default C++ fatal error handler called: %s", msg)); + throw duk_fatal_exception(msg); +#else + /* Default behavior is to abort() on error. There's no printout + * which makes this awkward, so it's always recommended to use an + * explicit fatal error handler. + * + * ==================================================================== + * NOTE: If you are seeing this, you are most likely dealing with an + * uncaught error. You should provide a fatal error handler in Duktape + * heap creation, and should consider using a protected call as your + * first call into an empty Duktape context to properly handle errors. + * See: + * - http://duktape.org/guide.html#error-handling + * - http://wiki.duktape.org/HowtoFatalErrors.html + * - http://duktape.org/api.html#taglist-protected + * ==================================================================== + */ + DUK_D(DUK_DPRINT("built-in default fatal error handler called: %s", msg)); + DUK_ABORT(); +#endif + + DUK_D(DUK_DPRINT("fatal error handler returned, enter forever loop")); + for (;;) { + /* Loop forever to ensure we don't return. */ + } +} + +/* automatic undefs */ +#undef DUK__ERRFMT_BUFSIZE +#line 1 "duk_unicode_support.c" +/* + * Various Unicode help functions for character classification predicates, + * case conversion, decoding, etc. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Fast path tables + */ + +#if defined(DUK_USE_IDCHAR_FASTPATH) +DUK_INTERNAL const duk_int8_t duk_is_idchar_tab[128] = { + /* 0: not IdentifierStart or IdentifierPart + * 1: IdentifierStart and IdentifierPart + * -1: IdentifierPart only + */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x00...0x0f */ + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x10...0x1f */ + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0x20...0x2f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 0, 0, 0, 0, 0, 0, /* 0x30...0x3f */ + 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0x40...0x4f */ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 1, /* 0x50...0x5f */ + 0, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, /* 0x60...0x6f */ + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0 /* 0x70...0x7f */ +}; +#endif + +/* + * XUTF-8 and CESU-8 encoding/decoding + */ + +DUK_INTERNAL duk_small_int_t duk_unicode_get_xutf8_length(duk_ucodepoint_t cp) { + duk_uint_fast32_t x = (duk_uint_fast32_t) cp; + if (x < 0x80UL) { + /* 7 bits */ + return 1; + } else if (x < 0x800UL) { + /* 11 bits */ + return 2; + } else if (x < 0x10000UL) { + /* 16 bits */ + return 3; + } else if (x < 0x200000UL) { + /* 21 bits */ + return 4; + } else if (x < 0x4000000UL) { + /* 26 bits */ + return 5; + } else if (x < (duk_ucodepoint_t) 0x80000000UL) { + /* 31 bits */ + return 6; + } else { + /* 36 bits */ + return 7; + } +} + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL duk_small_int_t duk_unicode_get_cesu8_length(duk_ucodepoint_t cp) { + duk_uint_fast32_t x = (duk_uint_fast32_t) cp; + if (x < 0x80UL) { + /* 7 bits */ + return 1; + } else if (x < 0x800UL) { + /* 11 bits */ + return 2; + } else if (x < 0x10000UL) { + /* 16 bits */ + return 3; + } else { + /* Encoded as surrogate pair, each encoding to 3 bytes for + * 6 bytes total. Codepoints above U+10FFFF encode as 6 bytes + * too, see duk_unicode_encode_cesu8(). + */ + return 3 + 3; + } +} +#endif /* DUK_USE_ASSERTIONS */ + +DUK_INTERNAL const duk_uint8_t duk_unicode_xutf8_markers[7] = { 0x00, 0xc0, 0xe0, 0xf0, 0xf8, 0xfc, 0xfe }; + +/* Encode to extended UTF-8; 'out' must have space for at least + * DUK_UNICODE_MAX_XUTF8_LENGTH bytes. Allows encoding of any + * 32-bit (unsigned) codepoint. + */ +DUK_INTERNAL duk_small_int_t duk_unicode_encode_xutf8(duk_ucodepoint_t cp, duk_uint8_t *out) { + duk_uint_fast32_t x = (duk_uint_fast32_t) cp; + duk_small_int_t len; + duk_uint8_t marker; + duk_small_int_t i; + + len = duk_unicode_get_xutf8_length(cp); + DUK_ASSERT(len > 0); + + marker = duk_unicode_xutf8_markers[len - 1]; /* 64-bit OK because always >= 0 */ + + i = len; + DUK_ASSERT(i > 0); + do { + i--; + if (i > 0) { + out[i] = (duk_uint8_t) (0x80 + (x & 0x3f)); + x >>= 6; + } else { + /* Note: masking of 'x' is not necessary because of + * range check and shifting -> no bits overlapping + * the marker should be set. + */ + out[0] = (duk_uint8_t) (marker + x); + } + } while (i > 0); + + return len; +} + +/* Encode to CESU-8; 'out' must have space for at least + * DUK_UNICODE_MAX_CESU8_LENGTH bytes; codepoints above U+10FFFF + * will encode to garbage but won't overwrite the output buffer. + */ +DUK_INTERNAL duk_small_int_t duk_unicode_encode_cesu8(duk_ucodepoint_t cp, duk_uint8_t *out) { + duk_uint_fast32_t x = (duk_uint_fast32_t) cp; + duk_small_int_t len; + + if (x < 0x80UL) { + out[0] = (duk_uint8_t) x; + len = 1; + } else if (x < 0x800UL) { + out[0] = (duk_uint8_t) (0xc0 + ((x >> 6) & 0x1f)); + out[1] = (duk_uint8_t) (0x80 + (x & 0x3f)); + len = 2; + } else if (x < 0x10000UL) { + /* surrogate pairs get encoded here */ + out[0] = (duk_uint8_t) (0xe0 + ((x >> 12) & 0x0f)); + out[1] = (duk_uint8_t) (0x80 + ((x >> 6) & 0x3f)); + out[2] = (duk_uint8_t) (0x80 + (x & 0x3f)); + len = 3; + } else { + /* + * Unicode codepoints above U+FFFF are encoded as surrogate + * pairs here. This ensures that all CESU-8 codepoints are + * 16-bit values as expected in ECMAScript. The surrogate + * pairs always get a 3-byte encoding (each) in CESU-8. + * See: http://en.wikipedia.org/wiki/Surrogate_pair + * + * 20-bit codepoint, 10 bits (A and B) per surrogate pair: + * + * x = 0b00000000 0000AAAA AAAAAABB BBBBBBBB + * sp1 = 0b110110AA AAAAAAAA (0xd800 + ((x >> 10) & 0x3ff)) + * sp2 = 0b110111BB BBBBBBBB (0xdc00 + (x & 0x3ff)) + * + * Encoded into CESU-8: + * + * sp1 -> 0b11101101 (0xe0 + ((sp1 >> 12) & 0x0f)) + * -> 0b1010AAAA (0x80 + ((sp1 >> 6) & 0x3f)) + * -> 0b10AAAAAA (0x80 + (sp1 & 0x3f)) + * sp2 -> 0b11101101 (0xe0 + ((sp2 >> 12) & 0x0f)) + * -> 0b1011BBBB (0x80 + ((sp2 >> 6) & 0x3f)) + * -> 0b10BBBBBB (0x80 + (sp2 & 0x3f)) + * + * Note that 0x10000 must be subtracted first. The code below + * avoids the sp1, sp2 temporaries which saves around 20 bytes + * of code. + */ + + x -= 0x10000UL; + + out[0] = (duk_uint8_t) (0xed); + out[1] = (duk_uint8_t) (0xa0 + ((x >> 16) & 0x0f)); + out[2] = (duk_uint8_t) (0x80 + ((x >> 10) & 0x3f)); + out[3] = (duk_uint8_t) (0xed); + out[4] = (duk_uint8_t) (0xb0 + ((x >> 6) & 0x0f)); + out[5] = (duk_uint8_t) (0x80 + (x & 0x3f)); + len = 6; + } + + return len; +} + +/* Decode helper. Return zero on error. */ +DUK_INTERNAL duk_small_int_t duk_unicode_decode_xutf8(duk_hthread *thr, + const duk_uint8_t **ptr, + const duk_uint8_t *ptr_start, + const duk_uint8_t *ptr_end, + duk_ucodepoint_t *out_cp) { + const duk_uint8_t *p; + duk_uint32_t res; + duk_uint_fast8_t ch; + duk_small_int_t n; + + DUK_UNREF(thr); + + p = *ptr; + if (p < ptr_start || p >= ptr_end) { + goto fail; + } + + /* + * UTF-8 decoder which accepts longer than standard byte sequences. + * This allows full 32-bit code points to be used. + */ + + ch = (duk_uint_fast8_t) (*p++); + if (ch < 0x80) { + /* 0xxx xxxx [7 bits] */ + res = (duk_uint32_t) (ch & 0x7f); + n = 0; + } else if (ch < 0xc0) { + /* 10xx xxxx -> invalid */ + goto fail; + } else if (ch < 0xe0) { + /* 110x xxxx 10xx xxxx [11 bits] */ + res = (duk_uint32_t) (ch & 0x1f); + n = 1; + } else if (ch < 0xf0) { + /* 1110 xxxx 10xx xxxx 10xx xxxx [16 bits] */ + res = (duk_uint32_t) (ch & 0x0f); + n = 2; + } else if (ch < 0xf8) { + /* 1111 0xxx 10xx xxxx 10xx xxxx 10xx xxxx [21 bits] */ + res = (duk_uint32_t) (ch & 0x07); + n = 3; + } else if (ch < 0xfc) { + /* 1111 10xx 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx [26 bits] */ + res = (duk_uint32_t) (ch & 0x03); + n = 4; + } else if (ch < 0xfe) { + /* 1111 110x 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx [31 bits] */ + res = (duk_uint32_t) (ch & 0x01); + n = 5; + } else if (ch < 0xff) { + /* 1111 1110 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx [36 bits] */ + res = (duk_uint32_t) (0); + n = 6; + } else { + /* 8-byte format could be: + * 1111 1111 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx 10xx xxxx [41 bits] + * + * However, this format would not have a zero bit following the + * leading one bits and would not allow 0xFF to be used as an + * "invalid xutf-8" marker for internal keys. Further, 8-byte + * encodings (up to 41 bit code points) are not currently needed. + */ + goto fail; + } + + DUK_ASSERT(p >= ptr_start); /* verified at beginning */ + if (p + n > ptr_end) { + /* check pointer at end */ + goto fail; + } + + while (n > 0) { + DUK_ASSERT(p >= ptr_start && p < ptr_end); + ch = (duk_uint_fast8_t) (*p++); +#if 0 + if (ch & 0xc0 != 0x80) { + /* not a continuation byte */ + p--; + *ptr = p; + *out_cp = DUK_UNICODE_CP_REPLACEMENT_CHARACTER; + return 1; + } +#endif + res = (res << 6) + (duk_uint32_t) (ch & 0x3f); + n--; + } + + *ptr = p; + *out_cp = res; + return 1; + +fail: + return 0; +} + +/* used by e.g. duk_regexp_executor.c, string built-ins */ +DUK_INTERNAL duk_ucodepoint_t duk_unicode_decode_xutf8_checked(duk_hthread *thr, + const duk_uint8_t **ptr, + const duk_uint8_t *ptr_start, + const duk_uint8_t *ptr_end) { + duk_ucodepoint_t cp; + + if (duk_unicode_decode_xutf8(thr, ptr, ptr_start, ptr_end, &cp)) { + return cp; + } + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return 0;); +} + +/* Compute (extended) utf-8 length without codepoint encoding validation, + * used for string interning. + * + * NOTE: This algorithm is performance critical, more so than string hashing + * in some cases. It is needed when interning a string and needs to scan + * every byte of the string with no skipping. Having an ASCII fast path + * is useful if possible in the algorithm. The current algorithms were + * chosen from several variants, based on x64 gcc -O2 testing. See: + * https://github.com/svaarala/duktape/pull/422 + * + * NOTE: must match tools/dukutil.py:duk_unicode_unvalidated_utf8_length(). + */ + +#if defined(DUK_USE_PREFER_SIZE) +/* Small variant; roughly 150 bytes smaller than the fast variant. */ +DUK_INTERNAL duk_size_t duk_unicode_unvalidated_utf8_length(const duk_uint8_t *data, duk_size_t blen) { + const duk_uint8_t *p; + const duk_uint8_t *p_end; + duk_size_t ncont; + duk_size_t clen; + + p = data; + p_end = data + blen; + ncont = 0; + while (p != p_end) { + duk_uint8_t x; + x = *p++; + if (DUK_UNLIKELY(x >= 0x80 && x <= 0xbf)) { + ncont++; + } + } + + DUK_ASSERT(ncont <= blen); + clen = blen - ncont; + DUK_ASSERT(clen <= blen); + return clen; +} +#else /* DUK_USE_PREFER_SIZE */ +/* This seems like a good overall approach. Fast path for ASCII in 4 byte + * blocks. + */ +DUK_INTERNAL duk_size_t duk_unicode_unvalidated_utf8_length(const duk_uint8_t *data, duk_size_t blen) { + const duk_uint8_t *p; + const duk_uint8_t *p_end; + const duk_uint32_t *p32_end; + const duk_uint32_t *p32; + duk_size_t ncont; + duk_size_t clen; + + ncont = 0; /* number of continuation (non-initial) bytes in [0x80,0xbf] */ + p = data; + p_end = data + blen; + if (blen < 16) { + goto skip_fastpath; + } + + /* Align 'p' to 4; the input data may have arbitrary alignment. + * End of string check not needed because blen >= 16. + */ + while (((duk_size_t) (const void *) p) & 0x03U) { + duk_uint8_t x; + x = *p++; + if (DUK_UNLIKELY(x >= 0x80 && x <= 0xbf)) { + ncont++; + } + } + + /* Full, aligned 4-byte reads. */ + p32_end = (const duk_uint32_t *) (const void *) (p + ((duk_size_t) (p_end - p) & (duk_size_t) (~0x03))); + p32 = (const duk_uint32_t *) (const void *) p; + while (p32 != (const duk_uint32_t *) p32_end) { + duk_uint32_t x; + x = *p32++; + if (DUK_LIKELY((x & 0x80808080UL) == 0)) { + ; /* ASCII fast path */ + } else { + /* Flip highest bit of each byte which changes + * the bit pattern 10xxxxxx into 00xxxxxx which + * allows an easy bit mask test. + */ + x ^= 0x80808080UL; + if (DUK_UNLIKELY(!(x & 0xc0000000UL))) { + ncont++; + } + if (DUK_UNLIKELY(!(x & 0x00c00000UL))) { + ncont++; + } + if (DUK_UNLIKELY(!(x & 0x0000c000UL))) { + ncont++; + } + if (DUK_UNLIKELY(!(x & 0x000000c0UL))) { + ncont++; + } + } + } + p = (const duk_uint8_t *) p32; + /* Fall through to handle the rest. */ + +skip_fastpath: + while (p != p_end) { + duk_uint8_t x; + x = *p++; + if (DUK_UNLIKELY(x >= 0x80 && x <= 0xbf)) { + ncont++; + } + } + + DUK_ASSERT(ncont <= blen); + clen = blen - ncont; + DUK_ASSERT(clen <= blen); + return clen; +} +#endif /* DUK_USE_PREFER_SIZE */ + +/* Check whether a string is UTF-8 compatible or not. */ +DUK_INTERNAL duk_bool_t duk_unicode_is_utf8_compatible(const duk_uint8_t *buf, duk_size_t len) { + duk_size_t i = 0; +#if !defined(DUK_USE_PREFER_SIZE) + duk_size_t len_safe; +#endif + + /* Many practical strings are ASCII only, so use a fast path check + * to check chunks of bytes at once with minimal branch cost. + */ +#if !defined(DUK_USE_PREFER_SIZE) + len_safe = len & ~0x03UL; + for (; i < len_safe; i += 4) { + duk_uint8_t t = buf[i] | buf[i + 1] | buf[i + 2] | buf[i + 3]; + if (DUK_UNLIKELY((t & 0x80U) != 0U)) { + /* At least one byte was outside 0x00-0x7f, break + * out to slow path (and remain there). + * + * XXX: We could also deal with the problem character + * and resume fast path later. + */ + break; + } + } +#endif + + for (; i < len;) { + duk_uint8_t t; + duk_size_t left; + duk_size_t ncont; + duk_uint32_t cp; + duk_uint32_t mincp; + + t = buf[i++]; + if (DUK_LIKELY((t & 0x80U) == 0U)) { + /* Fast path, ASCII. */ + continue; + } + + /* Non-ASCII start byte, slow path. + * + * 10xx xxxx -> continuation byte + * 110x xxxx + 1*CONT -> [0x80, 0x7ff] + * 1110 xxxx + 2*CONT -> [0x800, 0xffff], must reject [0xd800,0xdfff] + * 1111 0xxx + 3*CONT -> [0x10000, 0x10ffff] + */ + left = len - i; + if (t <= 0xdfU) { /* 1101 1111 = 0xdf */ + if (t <= 0xbfU) { /* 1011 1111 = 0xbf */ + return 0; + } + ncont = 1; + mincp = 0x80UL; + cp = t & 0x1fU; + } else if (t <= 0xefU) { /* 1110 1111 = 0xef */ + ncont = 2; + mincp = 0x800UL; + cp = t & 0x0fU; + } else if (t <= 0xf7U) { /* 1111 0111 = 0xf7 */ + ncont = 3; + mincp = 0x10000UL; + cp = t & 0x07U; + } else { + return 0; + } + if (left < ncont) { + return 0; + } + while (ncont > 0U) { + t = buf[i++]; + if ((t & 0xc0U) != 0x80U) { /* 10xx xxxx */ + return 0; + } + cp = (cp << 6) + (t & 0x3fU); + ncont--; + } + if (cp < mincp || cp > 0x10ffffUL || (cp >= 0xd800UL && cp <= 0xdfffUL)) { + return 0; + } + } + + return 1; +} + +/* + * Unicode range matcher + * + * Matches a codepoint against a packed bitstream of character ranges. + * Used for slow path Unicode matching. + */ + +/* Must match tools/extract_chars.py, generate_match_table3(). */ +DUK_LOCAL duk_uint32_t duk__uni_decode_value(duk_bitdecoder_ctx *bd_ctx) { + duk_uint32_t t; + + t = (duk_uint32_t) duk_bd_decode(bd_ctx, 4); + if (t <= 0x0eU) { + return t; + } + t = (duk_uint32_t) duk_bd_decode(bd_ctx, 8); + if (t <= 0xfdU) { + return t + 0x0f; + } + if (t == 0xfeU) { + t = (duk_uint32_t) duk_bd_decode(bd_ctx, 12); + return t + 0x0fU + 0xfeU; + } else { + t = (duk_uint32_t) duk_bd_decode(bd_ctx, 24); + return t + 0x0fU + 0xfeU + 0x1000UL; + } +} + +DUK_LOCAL duk_small_int_t duk__uni_range_match(const duk_uint8_t *unitab, duk_size_t unilen, duk_codepoint_t cp) { + duk_bitdecoder_ctx bd_ctx; + duk_codepoint_t prev_re; + + duk_memzero(&bd_ctx, sizeof(bd_ctx)); + bd_ctx.data = (const duk_uint8_t *) unitab; + bd_ctx.length = (duk_size_t) unilen; + + prev_re = 0; + for (;;) { + duk_codepoint_t r1, r2; + r1 = (duk_codepoint_t) duk__uni_decode_value(&bd_ctx); + if (r1 == 0) { + break; + } + r2 = (duk_codepoint_t) duk__uni_decode_value(&bd_ctx); + + r1 = prev_re + r1; + r2 = r1 + r2; + prev_re = r2; + + /* [r1,r2] is the range */ + + DUK_DDD(DUK_DDDPRINT("duk__uni_range_match: cp=%06lx range=[0x%06lx,0x%06lx]", + (unsigned long) cp, + (unsigned long) r1, + (unsigned long) r2)); + if (cp >= r1 && cp <= r2) { + return 1; + } + } + + return 0; +} + +/* + * "WhiteSpace" production check. + */ + +DUK_INTERNAL duk_small_int_t duk_unicode_is_whitespace(duk_codepoint_t cp) { + /* + * E5 Section 7.2 specifies six characters specifically as + * white space: + * + * 0009;;Cc;0;S;;;;;N;CHARACTER TABULATION;;;; + * 000B;;Cc;0;S;;;;;N;LINE TABULATION;;;; + * 000C;;Cc;0;WS;;;;;N;FORM FEED (FF);;;; + * 0020;SPACE;Zs;0;WS;;;;;N;;;;; + * 00A0;NO-BREAK SPACE;Zs;0;CS; 0020;;;;N;NON-BREAKING SPACE;;;; + * FEFF;ZERO WIDTH NO-BREAK SPACE;Cf;0;BN;;;;;N;BYTE ORDER MARK;;;; + * + * It also specifies any Unicode category 'Zs' characters as white + * space. These can be extracted with the "tools/extract_chars.py" script. + * Current result: + * + * RAW OUTPUT: + * =========== + * 0020;SPACE;Zs;0;WS;;;;;N;;;;; + * 00A0;NO-BREAK SPACE;Zs;0;CS; 0020;;;;N;NON-BREAKING SPACE;;;; + * 1680;OGHAM SPACE MARK;Zs;0;WS;;;;;N;;;;; + * 180E;MONGOLIAN VOWEL SEPARATOR;Zs;0;WS;;;;;N;;;;; + * 2000;EN QUAD;Zs;0;WS;2002;;;;N;;;;; + * 2001;EM QUAD;Zs;0;WS;2003;;;;N;;;;; + * 2002;EN SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 2003;EM SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 2004;THREE-PER-EM SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 2005;FOUR-PER-EM SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 2006;SIX-PER-EM SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 2007;FIGURE SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 2008;PUNCTUATION SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 2009;THIN SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 200A;HAIR SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 202F;NARROW NO-BREAK SPACE;Zs;0;CS; 0020;;;;N;;;;; + * 205F;MEDIUM MATHEMATICAL SPACE;Zs;0;WS; 0020;;;;N;;;;; + * 3000;IDEOGRAPHIC SPACE;Zs;0;WS; 0020;;;;N;;;;; + * + * RANGES: + * ======= + * 0x0020 + * 0x00a0 + * 0x1680 + * 0x180e + * 0x2000 ... 0x200a + * 0x202f + * 0x205f + * 0x3000 + * + * A manual decoder (below) is probably most compact for this. + */ + + duk_uint_fast8_t lo; + duk_uint_fast32_t hi; + + /* cp == -1 (EOF) never matches and causes return value 0 */ + + lo = (duk_uint_fast8_t) (cp & 0xff); + hi = (duk_uint_fast32_t) (cp >> 8); /* does not fit into an uchar */ + + if (hi == 0x0000UL) { + if (lo == 0x09U || lo == 0x0bU || lo == 0x0cU || lo == 0x20U || lo == 0xa0U) { + return 1; + } + } else if (hi == 0x0020UL) { + if (lo <= 0x0aU || lo == 0x2fU || lo == 0x5fU) { + return 1; + } + } else if (cp == 0x1680L || cp == 0x180eL || cp == 0x3000L || cp == 0xfeffL) { + return 1; + } + + return 0; +} + +/* + * "LineTerminator" production check. + */ + +DUK_INTERNAL duk_small_int_t duk_unicode_is_line_terminator(duk_codepoint_t cp) { + /* + * E5 Section 7.3 + * + * A LineTerminatorSequence essentially merges sequences + * into a single line terminator. This must be handled by the caller. + */ + + if (cp == 0x000aL || cp == 0x000dL || cp == 0x2028L || cp == 0x2029L) { + return 1; + } + + return 0; +} + +/* + * "IdentifierStart" production check. + */ + +DUK_INTERNAL duk_small_int_t duk_unicode_is_identifier_start(duk_codepoint_t cp) { + /* + * E5 Section 7.6: + * + * IdentifierStart: + * UnicodeLetter + * $ + * _ + * \ UnicodeEscapeSequence + * + * IdentifierStart production has one multi-character production: + * + * \ UnicodeEscapeSequence + * + * The '\' character is -not- matched by this function. Rather, the caller + * should decode the escape and then call this function to check whether the + * decoded character is acceptable (see discussion in E5 Section 7.6). + * + * The "UnicodeLetter" alternative of the production allows letters + * from various Unicode categories. These can be extracted with the + * "tools/extract_chars.py" script. + * + * Because the result has hundreds of Unicode codepoint ranges, matching + * for any values >= 0x80 are done using a very slow range-by-range scan + * and a packed range format. + * + * The ASCII portion (codepoints 0x00 ... 0x7f) is fast-pathed below because + * it matters the most. The ASCII related ranges of IdentifierStart are: + * + * 0x0041 ... 0x005a ['A' ... 'Z'] + * 0x0061 ... 0x007a ['a' ... 'z'] + * 0x0024 ['$'] + * 0x005f ['_'] + */ + + /* ASCII (and EOF) fast path -- quick accept and reject */ + if (cp <= 0x7fL) { +#if defined(DUK_USE_IDCHAR_FASTPATH) + return (cp >= 0) && (duk_is_idchar_tab[cp] > 0); +#else + if ((cp >= 'a' && cp <= 'z') || (cp >= 'A' && cp <= 'Z') || cp == '_' || cp == '$') { + return 1; + } + return 0; +#endif + } + + /* Non-ASCII slow path (range-by-range linear comparison), very slow */ + +#if defined(DUK_USE_SOURCE_NONBMP) + if (duk__uni_range_match(duk_unicode_ids_noa, (duk_size_t) sizeof(duk_unicode_ids_noa), (duk_codepoint_t) cp)) { + return 1; + } + return 0; +#else + if (cp < 0x10000L) { + if (duk__uni_range_match(duk_unicode_ids_noabmp, sizeof(duk_unicode_ids_noabmp), (duk_codepoint_t) cp)) { + return 1; + } + return 0; + } else { + /* without explicit non-BMP support, assume non-BMP characters + * are always accepted as identifier characters. + */ + return 1; + } +#endif +} + +/* + * "IdentifierPart" production check. + */ + +DUK_INTERNAL duk_small_int_t duk_unicode_is_identifier_part(duk_codepoint_t cp) { + /* + * E5 Section 7.6: + * + * IdentifierPart: + * IdentifierStart + * UnicodeCombiningMark + * UnicodeDigit + * UnicodeConnectorPunctuation + * [U+200C] + * [U+200D] + * + * IdentifierPart production has one multi-character production + * as part of its IdentifierStart alternative. The '\' character + * of an escape sequence is not matched here, see discussion in + * duk_unicode_is_identifier_start(). + * + * To match non-ASCII characters (codepoints >= 0x80), a very slow + * linear range-by-range scan is used. The codepoint is first compared + * to the IdentifierStart ranges, and if it doesn't match, then to a + * set consisting of code points in IdentifierPart but not in + * IdentifierStart. This is done to keep the unicode range data small, + * at the expense of speed. + * + * The ASCII fast path consists of: + * + * 0x0030 ... 0x0039 ['0' ... '9', UnicodeDigit] + * 0x0041 ... 0x005a ['A' ... 'Z', IdentifierStart] + * 0x0061 ... 0x007a ['a' ... 'z', IdentifierStart] + * 0x0024 ['$', IdentifierStart] + * 0x005f ['_', IdentifierStart and + * UnicodeConnectorPunctuation] + * + * UnicodeCombiningMark has no code points <= 0x7f. + * + * The matching code reuses the "identifier start" tables, and then + * consults a separate range set for characters in "identifier part" + * but not in "identifier start". These can be extracted with the + * "tools/extract_chars.py" script. + * + * UnicodeCombiningMark -> categories Mn, Mc + * UnicodeDigit -> categories Nd + * UnicodeConnectorPunctuation -> categories Pc + */ + + /* ASCII (and EOF) fast path -- quick accept and reject */ + if (cp <= 0x7fL) { +#if defined(DUK_USE_IDCHAR_FASTPATH) + return (cp >= 0) && (duk_is_idchar_tab[cp] != 0); +#else + if ((cp >= 'a' && cp <= 'z') || (cp >= 'A' && cp <= 'Z') || (cp >= '0' && cp <= '9') || cp == '_' || cp == '$') { + return 1; + } + return 0; +#endif + } + + /* Non-ASCII slow path (range-by-range linear comparison), very slow */ + +#if defined(DUK_USE_SOURCE_NONBMP) + if (duk__uni_range_match(duk_unicode_ids_noa, sizeof(duk_unicode_ids_noa), (duk_codepoint_t) cp) || + duk__uni_range_match(duk_unicode_idp_m_ids_noa, sizeof(duk_unicode_idp_m_ids_noa), (duk_codepoint_t) cp)) { + return 1; + } + return 0; +#else + if (cp < 0x10000L) { + if (duk__uni_range_match(duk_unicode_ids_noabmp, sizeof(duk_unicode_ids_noabmp), (duk_codepoint_t) cp) || + duk__uni_range_match(duk_unicode_idp_m_ids_noabmp, + sizeof(duk_unicode_idp_m_ids_noabmp), + (duk_codepoint_t) cp)) { + return 1; + } + return 0; + } else { + /* without explicit non-BMP support, assume non-BMP characters + * are always accepted as identifier characters. + */ + return 1; + } +#endif +} + +/* + * Unicode letter check. + */ + +DUK_INTERNAL duk_small_int_t duk_unicode_is_letter(duk_codepoint_t cp) { + /* + * Unicode letter is now taken to be the categories: + * + * Lu, Ll, Lt, Lm, Lo + * + * (Not sure if this is exactly correct.) + * + * The ASCII fast path consists of: + * + * 0x0041 ... 0x005a ['A' ... 'Z'] + * 0x0061 ... 0x007a ['a' ... 'z'] + */ + + /* ASCII (and EOF) fast path -- quick accept and reject */ + if (cp <= 0x7fL) { + if ((cp >= 'a' && cp <= 'z') || (cp >= 'A' && cp <= 'Z')) { + return 1; + } + return 0; + } + + /* Non-ASCII slow path (range-by-range linear comparison), very slow */ + +#if defined(DUK_USE_SOURCE_NONBMP) + if (duk__uni_range_match(duk_unicode_ids_noa, sizeof(duk_unicode_ids_noa), (duk_codepoint_t) cp) && + !duk__uni_range_match(duk_unicode_ids_m_let_noa, sizeof(duk_unicode_ids_m_let_noa), (duk_codepoint_t) cp)) { + return 1; + } + return 0; +#else + if (cp < 0x10000L) { + if (duk__uni_range_match(duk_unicode_ids_noabmp, sizeof(duk_unicode_ids_noabmp), (duk_codepoint_t) cp) && + !duk__uni_range_match(duk_unicode_ids_m_let_noabmp, + sizeof(duk_unicode_ids_m_let_noabmp), + (duk_codepoint_t) cp)) { + return 1; + } + return 0; + } else { + /* without explicit non-BMP support, assume non-BMP characters + * are always accepted as letters. + */ + return 1; + } +#endif +} + +/* + * Complex case conversion helper which decodes a bit-packed conversion + * control stream generated by tools/extract_caseconv.py. The conversion + * is very slow because it runs through the conversion data in a linear + * fashion to save space (which is why ASCII characters have a special + * fast path before arriving here). + * + * The particular bit counts etc have been determined experimentally to + * be small but still sufficient, and must match the Python script + * (tools/extract_caseconv.py). + * + * The return value is the case converted codepoint or -1 if the conversion + * results in multiple characters (this is useful for regexp Canonicalization + * operation). If 'buf' is not NULL, the result codepoint(s) are also + * appended to the hbuffer. + * + * Context and locale specific rules must be checked before consulting + * this function. + */ + +DUK_LOCAL +duk_codepoint_t duk__slow_case_conversion(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_codepoint_t cp, duk_bitdecoder_ctx *bd_ctx) { + duk_small_int_t skip = 0; + duk_small_int_t n; + duk_small_int_t t; + duk_small_int_t count; + duk_codepoint_t tmp_cp; + duk_codepoint_t start_i; + duk_codepoint_t start_o; + + DUK_ASSERT(bd_ctx != NULL); + DUK_UNREF(thr); + + DUK_DDD(DUK_DDDPRINT("slow case conversion for codepoint: %ld", (long) cp)); + + /* range conversion with a "skip" */ + DUK_DDD(DUK_DDDPRINT("checking ranges")); + for (;;) { + skip++; + n = (duk_small_int_t) duk_bd_decode(bd_ctx, 6); + if (n == 0x3f) { + /* end marker */ + break; + } + DUK_DDD(DUK_DDDPRINT("skip=%ld, n=%ld", (long) skip, (long) n)); + + while (n--) { + start_i = (duk_codepoint_t) duk_bd_decode(bd_ctx, 16); + start_o = (duk_codepoint_t) duk_bd_decode(bd_ctx, 16); + count = (duk_small_int_t) duk_bd_decode(bd_ctx, 7); + DUK_DDD(DUK_DDDPRINT("range: start_i=%ld, start_o=%ld, count=%ld, skip=%ld", + (long) start_i, + (long) start_o, + (long) count, + (long) skip)); + + if (cp >= start_i) { + tmp_cp = cp - start_i; /* always >= 0 */ + if (tmp_cp < (duk_codepoint_t) count * (duk_codepoint_t) skip && + (tmp_cp % (duk_codepoint_t) skip) == 0) { + DUK_DDD(DUK_DDDPRINT("range matches input codepoint")); + cp = start_o + tmp_cp; + goto single; + } + } + } + } + + /* 1:1 conversion */ + n = (duk_small_int_t) duk_bd_decode(bd_ctx, 7); + DUK_DDD(DUK_DDDPRINT("checking 1:1 conversions (count %ld)", (long) n)); + while (n--) { + start_i = (duk_codepoint_t) duk_bd_decode(bd_ctx, 16); + start_o = (duk_codepoint_t) duk_bd_decode(bd_ctx, 16); + DUK_DDD(DUK_DDDPRINT("1:1 conversion %ld -> %ld", (long) start_i, (long) start_o)); + if (cp == start_i) { + DUK_DDD(DUK_DDDPRINT("1:1 matches input codepoint")); + cp = start_o; + goto single; + } + } + + /* complex, multicharacter conversion */ + n = (duk_small_int_t) duk_bd_decode(bd_ctx, 7); + DUK_DDD(DUK_DDDPRINT("checking 1:n conversions (count %ld)", (long) n)); + while (n--) { + start_i = (duk_codepoint_t) duk_bd_decode(bd_ctx, 16); + t = (duk_small_int_t) duk_bd_decode(bd_ctx, 2); + DUK_DDD(DUK_DDDPRINT("1:n conversion %ld -> %ld chars", (long) start_i, (long) t)); + if (cp == start_i) { + DUK_DDD(DUK_DDDPRINT("1:n matches input codepoint")); + if (bw != NULL) { + while (t--) { + tmp_cp = (duk_codepoint_t) duk_bd_decode(bd_ctx, 16); + DUK_BW_WRITE_RAW_XUTF8(thr, bw, (duk_ucodepoint_t) tmp_cp); + } + } + return -1; + } else { + while (t--) { + (void) duk_bd_decode(bd_ctx, 16); + } + } + } + + /* default: no change */ + DUK_DDD(DUK_DDDPRINT("no rule matches, output is same as input")); + /* fall through */ + +single: + if (bw != NULL) { + DUK_BW_WRITE_RAW_XUTF8(thr, bw, (duk_ucodepoint_t) cp); + } + return cp; +} + +/* + * Case conversion helper, with context/local sensitivity. + * For proper case conversion, one needs to know the character + * and the preceding and following characters, as well as + * locale/language. + */ + +/* XXX: add 'language' argument when locale/language sensitive rule + * support added. + */ +DUK_LOCAL +duk_codepoint_t duk__case_transform_helper(duk_hthread *thr, + duk_bufwriter_ctx *bw, + duk_codepoint_t cp, + duk_codepoint_t prev, + duk_codepoint_t next, + duk_bool_t uppercase) { + duk_bitdecoder_ctx bd_ctx; + + /* fast path for ASCII */ + if (cp < 0x80L) { + /* XXX: there are language sensitive rules for the ASCII range. + * If/when language/locale support is implemented, they need to + * be implemented here for the fast path. There are no context + * sensitive rules for ASCII range. + */ + + if (uppercase) { + if (cp >= 'a' && cp <= 'z') { + cp = cp - 'a' + 'A'; + } + } else { + if (cp >= 'A' && cp <= 'Z') { + cp = cp - 'A' + 'a'; + } + } + + if (bw != NULL) { + DUK_BW_WRITE_RAW_U8(thr, bw, (duk_uint8_t) cp); + } + return cp; + } + + /* context and locale specific rules which cannot currently be represented + * in the caseconv bitstream: hardcoded rules in C + */ + if (uppercase) { + /* XXX: turkish / azeri */ + } else { + /* + * Final sigma context specific rule. This is a rather tricky + * rule and this handling is probably not 100% correct now. + * The rule is not locale/language specific so it is supported. + */ + + if (cp == 0x03a3L && /* U+03A3 = GREEK CAPITAL LETTER SIGMA */ + duk_unicode_is_letter(prev) && /* prev exists and is not a letter */ + !duk_unicode_is_letter(next)) { /* next does not exist or next is not a letter */ + /* Capital sigma occurred at "end of word", lowercase to + * U+03C2 = GREEK SMALL LETTER FINAL SIGMA. Otherwise + * fall through and let the normal rules lowercase it to + * U+03C3 = GREEK SMALL LETTER SIGMA. + */ + cp = 0x03c2L; + goto singlechar; + } + + /* XXX: lithuanian not implemented */ + /* XXX: lithuanian, explicit dot rules */ + /* XXX: turkish / azeri, lowercase rules */ + } + + /* 1:1 or special conversions, but not locale/context specific: script generated rules */ + duk_memzero(&bd_ctx, sizeof(bd_ctx)); + if (uppercase) { + bd_ctx.data = (const duk_uint8_t *) duk_unicode_caseconv_uc; + bd_ctx.length = (duk_size_t) sizeof(duk_unicode_caseconv_uc); + } else { + bd_ctx.data = (const duk_uint8_t *) duk_unicode_caseconv_lc; + bd_ctx.length = (duk_size_t) sizeof(duk_unicode_caseconv_lc); + } + return duk__slow_case_conversion(thr, bw, cp, &bd_ctx); + +singlechar: + if (bw != NULL) { + DUK_BW_WRITE_RAW_XUTF8(thr, bw, (duk_ucodepoint_t) cp); + } + return cp; + + /* unused now, not needed until Turkish/Azeri */ +#if 0 + nochar: + return -1; +#endif +} + +/* + * Replace valstack top with case converted version. + */ + +DUK_INTERNAL void duk_unicode_case_convert_string(duk_hthread *thr, duk_bool_t uppercase) { + duk_hstring *h_input; + duk_bufwriter_ctx bw_alloc; + duk_bufwriter_ctx *bw; + const duk_uint8_t *p, *p_start, *p_end; + duk_codepoint_t prev, curr, next; + + h_input = duk_require_hstring(thr, -1); /* Accept symbols. */ + DUK_ASSERT(h_input != NULL); + + bw = &bw_alloc; + DUK_BW_INIT_PUSHBUF(thr, bw, DUK_HSTRING_GET_BYTELEN(h_input)); + + /* [ ... input buffer ] */ + + p_start = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_input); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h_input); + p = p_start; + + prev = -1; + DUK_UNREF(prev); + curr = -1; + next = -1; + for (;;) { + prev = curr; + curr = next; + next = -1; + if (p < p_end) { + next = (duk_codepoint_t) duk_unicode_decode_xutf8_checked(thr, &p, p_start, p_end); + } else { + /* end of input and last char has been processed */ + if (curr < 0) { + break; + } + } + + /* on first round, skip */ + if (curr >= 0) { + /* XXX: could add a fast path to process chunks of input codepoints, + * but relative benefit would be quite small. + */ + + /* Ensure space for maximum multi-character result; estimate is overkill. */ + DUK_BW_ENSURE(thr, bw, 8 * DUK_UNICODE_MAX_XUTF8_LENGTH); + + duk__case_transform_helper(thr, bw, (duk_codepoint_t) curr, prev, next, uppercase); + } + } + + DUK_BW_COMPACT(thr, bw); + (void) duk_buffer_to_string(thr, -1); /* Safe, output is encoded. */ + /* invalidates h_buf pointer */ + duk_remove_m2(thr); +} + +#if defined(DUK_USE_REGEXP_SUPPORT) + +/* + * Canonicalize() abstract operation needed for canonicalization of individual + * codepoints during regexp compilation and execution, see E5 Section 15.10.2.8. + * Note that codepoints are canonicalized one character at a time, so no context + * specific rules can apply. Locale specific rules can apply, though. + */ + +DUK_INTERNAL duk_codepoint_t duk_unicode_re_canonicalize_char(duk_hthread *thr, duk_codepoint_t cp) { +#if defined(DUK_USE_REGEXP_CANON_WORKAROUND) + /* Fast canonicalization lookup at the cost of 128kB footprint. */ + DUK_ASSERT(cp >= 0); + DUK_UNREF(thr); + if (DUK_LIKELY(cp < 0x10000L)) { + return (duk_codepoint_t) duk_unicode_re_canon_lookup[cp]; + } + return cp; +#else /* DUK_USE_REGEXP_CANON_WORKAROUND */ + duk_codepoint_t y; + + y = duk__case_transform_helper(thr, + NULL, /* NULL is allowed, no output */ + cp, /* curr char */ + -1, /* prev char */ + -1, /* next char */ + 1); /* uppercase */ + + if ((y < 0) || (cp >= 0x80 && y < 0x80)) { + /* multiple codepoint conversion or non-ASCII mapped to ASCII + * --> leave as is. + */ + return cp; + } + + return y; +#endif /* DUK_USE_REGEXP_CANON_WORKAROUND */ +} + +/* + * E5 Section 15.10.2.6 "IsWordChar" abstract operation. Assume + * x < 0 for characters read outside the string. + */ + +DUK_INTERNAL duk_small_int_t duk_unicode_re_is_wordchar(duk_codepoint_t x) { + /* + * Note: the description in E5 Section 15.10.2.6 has a typo, it + * contains 'A' twice and lacks 'a'; the intent is [0-9a-zA-Z_]. + */ + if ((x >= '0' && x <= '9') || (x >= 'a' && x <= 'z') || (x >= 'A' && x <= 'Z') || (x == '_')) { + return 1; + } + return 0; +} + +/* + * Regexp range tables + */ + +/* exposed because lexer needs these too */ +DUK_INTERNAL const duk_uint16_t duk_unicode_re_ranges_digit[2] = { + (duk_uint16_t) 0x0030UL, + (duk_uint16_t) 0x0039UL, +}; +DUK_INTERNAL const duk_uint16_t duk_unicode_re_ranges_white[22] = { + (duk_uint16_t) 0x0009UL, (duk_uint16_t) 0x000DUL, (duk_uint16_t) 0x0020UL, (duk_uint16_t) 0x0020UL, (duk_uint16_t) 0x00A0UL, + (duk_uint16_t) 0x00A0UL, (duk_uint16_t) 0x1680UL, (duk_uint16_t) 0x1680UL, (duk_uint16_t) 0x180EUL, (duk_uint16_t) 0x180EUL, + (duk_uint16_t) 0x2000UL, (duk_uint16_t) 0x200AUL, (duk_uint16_t) 0x2028UL, (duk_uint16_t) 0x2029UL, (duk_uint16_t) 0x202FUL, + (duk_uint16_t) 0x202FUL, (duk_uint16_t) 0x205FUL, (duk_uint16_t) 0x205FUL, (duk_uint16_t) 0x3000UL, (duk_uint16_t) 0x3000UL, + (duk_uint16_t) 0xFEFFUL, (duk_uint16_t) 0xFEFFUL, +}; +DUK_INTERNAL const duk_uint16_t duk_unicode_re_ranges_wordchar[8] = { + (duk_uint16_t) 0x0030UL, (duk_uint16_t) 0x0039UL, (duk_uint16_t) 0x0041UL, (duk_uint16_t) 0x005AUL, + (duk_uint16_t) 0x005FUL, (duk_uint16_t) 0x005FUL, (duk_uint16_t) 0x0061UL, (duk_uint16_t) 0x007AUL, +}; +DUK_INTERNAL const duk_uint16_t duk_unicode_re_ranges_not_digit[4] = { + (duk_uint16_t) 0x0000UL, + (duk_uint16_t) 0x002FUL, + (duk_uint16_t) 0x003AUL, + (duk_uint16_t) 0xFFFFUL, +}; +DUK_INTERNAL const duk_uint16_t duk_unicode_re_ranges_not_white[24] = { + (duk_uint16_t) 0x0000UL, (duk_uint16_t) 0x0008UL, (duk_uint16_t) 0x000EUL, (duk_uint16_t) 0x001FUL, (duk_uint16_t) 0x0021UL, + (duk_uint16_t) 0x009FUL, (duk_uint16_t) 0x00A1UL, (duk_uint16_t) 0x167FUL, (duk_uint16_t) 0x1681UL, (duk_uint16_t) 0x180DUL, + (duk_uint16_t) 0x180FUL, (duk_uint16_t) 0x1FFFUL, (duk_uint16_t) 0x200BUL, (duk_uint16_t) 0x2027UL, (duk_uint16_t) 0x202AUL, + (duk_uint16_t) 0x202EUL, (duk_uint16_t) 0x2030UL, (duk_uint16_t) 0x205EUL, (duk_uint16_t) 0x2060UL, (duk_uint16_t) 0x2FFFUL, + (duk_uint16_t) 0x3001UL, (duk_uint16_t) 0xFEFEUL, (duk_uint16_t) 0xFF00UL, (duk_uint16_t) 0xFFFFUL, +}; +DUK_INTERNAL const duk_uint16_t duk_unicode_re_ranges_not_wordchar[10] = { + (duk_uint16_t) 0x0000UL, (duk_uint16_t) 0x002FUL, (duk_uint16_t) 0x003AUL, (duk_uint16_t) 0x0040UL, (duk_uint16_t) 0x005BUL, + (duk_uint16_t) 0x005EUL, (duk_uint16_t) 0x0060UL, (duk_uint16_t) 0x0060UL, (duk_uint16_t) 0x007BUL, (duk_uint16_t) 0xFFFFUL, +}; + +#endif /* DUK_USE_REGEXP_SUPPORT */ +#line 1 "duk_util_memrw.c" +/* + * Macro support functions for reading/writing raw data. + * + * These are done using memcpy to ensure they're valid even for unaligned + * reads/writes on platforms where alignment counts. On x86 at least gcc + * is able to compile these into a bswap+mov. "Always inline" is used to + * ensure these macros compile to minimal code. + */ + +/* #include duk_internal.h -> already included */ + +union duk__u16_union { + duk_uint8_t b[2]; + duk_uint16_t x; +}; +typedef union duk__u16_union duk__u16_union; + +union duk__u32_union { + duk_uint8_t b[4]; + duk_uint32_t x; +}; +typedef union duk__u32_union duk__u32_union; + +#if defined(DUK_USE_64BIT_OPS) +union duk__u64_union { + duk_uint8_t b[8]; + duk_uint64_t x; +}; +typedef union duk__u64_union duk__u64_union; +#endif + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_uint16_t duk_raw_read_u16_be(const duk_uint8_t *p) { + duk__u16_union u; + duk_memcpy((void *) u.b, (const void *) p, (size_t) 2); + u.x = DUK_NTOH16(u.x); + return u.x; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_uint32_t duk_raw_read_u32_be(const duk_uint8_t *p) { + duk__u32_union u; + duk_memcpy((void *) u.b, (const void *) p, (size_t) 4); + u.x = DUK_NTOH32(u.x); + return u.x; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_float_t duk_raw_read_float_be(const duk_uint8_t *p) { + duk_float_union fu; + duk_memcpy((void *) fu.uc, (const void *) p, (size_t) 4); + duk_fltunion_big_to_host(&fu); + return fu.f; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_double_t duk_raw_read_double_be(const duk_uint8_t *p) { + duk_double_union du; + duk_memcpy((void *) du.uc, (const void *) p, (size_t) 8); + duk_dblunion_big_to_host(&du); + return du.d; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_uint16_t duk_raw_readinc_u16_be(const duk_uint8_t **p) { + duk_uint16_t res = duk_raw_read_u16_be(*p); + *p += 2; + return res; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_uint32_t duk_raw_readinc_u32_be(const duk_uint8_t **p) { + duk_uint32_t res = duk_raw_read_u32_be(*p); + *p += 4; + return res; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_float_t duk_raw_readinc_float_be(const duk_uint8_t **p) { + duk_float_t res = duk_raw_read_float_be(*p); + *p += 4; + return res; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_double_t duk_raw_readinc_double_be(const duk_uint8_t **p) { + duk_double_t res = duk_raw_read_double_be(*p); + *p += 8; + return res; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_raw_write_u16_be(duk_uint8_t *p, duk_uint16_t val) { + duk__u16_union u; + u.x = DUK_HTON16(val); + duk_memcpy((void *) p, (const void *) u.b, (size_t) 2); +} + +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_raw_write_u32_be(duk_uint8_t *p, duk_uint32_t val) { + duk__u32_union u; + u.x = DUK_HTON32(val); + duk_memcpy((void *) p, (const void *) u.b, (size_t) 4); +} + +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_raw_write_float_be(duk_uint8_t *p, duk_float_t val) { + duk_float_union fu; + fu.f = val; + duk_fltunion_host_to_big(&fu); + duk_memcpy((void *) p, (const void *) fu.uc, (size_t) 4); +} + +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_raw_write_double_be(duk_uint8_t *p, duk_double_t val) { + duk_double_union du; + du.d = val; + duk_dblunion_host_to_big(&du); + duk_memcpy((void *) p, (const void *) du.uc, (size_t) 8); +} + +DUK_INTERNAL duk_small_int_t duk_raw_write_xutf8(duk_uint8_t *p, duk_ucodepoint_t val) { + duk_small_int_t len = duk_unicode_encode_xutf8(val, p); + return len; +} + +DUK_INTERNAL duk_small_int_t duk_raw_write_cesu8(duk_uint8_t *p, duk_ucodepoint_t val) { + duk_small_int_t len = duk_unicode_encode_cesu8(val, p); + return len; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_raw_writeinc_u16_be(duk_uint8_t **p, duk_uint16_t val) { + duk_raw_write_u16_be(*p, val); + *p += 2; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_raw_writeinc_u32_be(duk_uint8_t **p, duk_uint32_t val) { + duk_raw_write_u32_be(*p, val); + *p += 4; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_raw_writeinc_float_be(duk_uint8_t **p, duk_float_t val) { + duk_raw_write_float_be(*p, val); + *p += 4; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_raw_writeinc_double_be(duk_uint8_t **p, duk_double_t val) { + duk_raw_write_double_be(*p, val); + *p += 8; +} + +DUK_INTERNAL void duk_raw_writeinc_xutf8(duk_uint8_t **p, duk_ucodepoint_t val) { + duk_small_int_t len = duk_unicode_encode_xutf8(val, *p); + *p += len; +} + +DUK_INTERNAL void duk_raw_writeinc_cesu8(duk_uint8_t **p, duk_ucodepoint_t val) { + duk_small_int_t len = duk_unicode_encode_cesu8(val, *p); + *p += len; +} +#line 1 "duk_util_misc.c" +/* + * Misc util stuff. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Lowercase digits for radix values 2 to 36. Also doubles as lowercase + * hex nybble table. + */ + +DUK_INTERNAL const duk_uint8_t duk_lc_digits[36] = { + DUK_ASC_0, DUK_ASC_1, DUK_ASC_2, DUK_ASC_3, DUK_ASC_4, DUK_ASC_5, DUK_ASC_6, DUK_ASC_7, + DUK_ASC_8, DUK_ASC_9, DUK_ASC_LC_A, DUK_ASC_LC_B, DUK_ASC_LC_C, DUK_ASC_LC_D, DUK_ASC_LC_E, DUK_ASC_LC_F, + DUK_ASC_LC_G, DUK_ASC_LC_H, DUK_ASC_LC_I, DUK_ASC_LC_J, DUK_ASC_LC_K, DUK_ASC_LC_L, DUK_ASC_LC_M, DUK_ASC_LC_N, + DUK_ASC_LC_O, DUK_ASC_LC_P, DUK_ASC_LC_Q, DUK_ASC_LC_R, DUK_ASC_LC_S, DUK_ASC_LC_T, DUK_ASC_LC_U, DUK_ASC_LC_V, + DUK_ASC_LC_W, DUK_ASC_LC_X, DUK_ASC_LC_Y, DUK_ASC_LC_Z +}; + +DUK_INTERNAL const duk_uint8_t duk_uc_nybbles[16] = { DUK_ASC_0, DUK_ASC_1, DUK_ASC_2, DUK_ASC_3, + DUK_ASC_4, DUK_ASC_5, DUK_ASC_6, DUK_ASC_7, + DUK_ASC_8, DUK_ASC_9, DUK_ASC_UC_A, DUK_ASC_UC_B, + DUK_ASC_UC_C, DUK_ASC_UC_D, DUK_ASC_UC_E, DUK_ASC_UC_F }; + +/* + * Table for hex decoding ASCII hex digits + */ + +DUK_INTERNAL const duk_int8_t duk_hex_dectab[256] = { + /* -1 if invalid */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x00-0x0f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x10-0x1f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x20-0x2f */ + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, -1, -1, -1, -1, -1, -1, /* 0x30-0x3f */ + -1, 10, 11, 12, 13, 14, 15, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x40-0x4f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x50-0x5f */ + -1, 10, 11, 12, 13, 14, 15, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x60-0x6f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x70-0x7f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x80-0x8f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x90-0x9f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xa0-0xaf */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xb0-0xbf */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xc0-0xcf */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xd0-0xdf */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xe0-0xef */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1 /* 0xf0-0xff */ +}; + +#if defined(DUK_USE_HEX_FASTPATH) +/* Preshifted << 4. Must use 16-bit entry to allow negative value signaling. */ +DUK_INTERNAL const duk_int16_t duk_hex_dectab_shift4[256] = { + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x00-0x0f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x10-0x1f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x20-0x2f */ + 0x00, 0x10, 0x20, 0x30, 0x40, 0x50, 0x60, 0x70, 0x80, 0x90, -1, -1, -1, -1, -1, -1, /* 0x30-0x3f */ + -1, 0xa0, 0xb0, 0xc0, 0xd0, 0xe0, 0xf0, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x40-0x4f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x50-0x5f */ + -1, 0xa0, 0xb0, 0xc0, 0xd0, 0xe0, 0xf0, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x60-0x6f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x70-0x7f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x80-0x8f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0x90-0x9f */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xa0-0xaf */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xb0-0xbf */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xc0-0xcf */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xd0-0xdf */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 0xe0-0xef */ + -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1 /* 0xf0-0xff */ +}; +#endif + +/* + * Table for hex encoding bytes + */ + +#if defined(DUK_USE_HEX_FASTPATH) +/* Lookup to encode one byte directly into 2 characters: + * + * def genhextab(bswap): + * for i in xrange(256): + * t = chr(i).encode('hex') + * if bswap: + * t = t[1] + t[0] + * print('0x' + t.encode('hex') + 'U') + * print('big endian'); genhextab(False) + * print('little endian'); genhextab(True) + */ +DUK_INTERNAL const duk_uint16_t duk_hex_enctab[256] = { +#if defined(DUK_USE_INTEGER_BE) + 0x3030U, 0x3031U, 0x3032U, 0x3033U, 0x3034U, 0x3035U, 0x3036U, 0x3037U, 0x3038U, 0x3039U, 0x3061U, 0x3062U, 0x3063U, + 0x3064U, 0x3065U, 0x3066U, 0x3130U, 0x3131U, 0x3132U, 0x3133U, 0x3134U, 0x3135U, 0x3136U, 0x3137U, 0x3138U, 0x3139U, + 0x3161U, 0x3162U, 0x3163U, 0x3164U, 0x3165U, 0x3166U, 0x3230U, 0x3231U, 0x3232U, 0x3233U, 0x3234U, 0x3235U, 0x3236U, + 0x3237U, 0x3238U, 0x3239U, 0x3261U, 0x3262U, 0x3263U, 0x3264U, 0x3265U, 0x3266U, 0x3330U, 0x3331U, 0x3332U, 0x3333U, + 0x3334U, 0x3335U, 0x3336U, 0x3337U, 0x3338U, 0x3339U, 0x3361U, 0x3362U, 0x3363U, 0x3364U, 0x3365U, 0x3366U, 0x3430U, + 0x3431U, 0x3432U, 0x3433U, 0x3434U, 0x3435U, 0x3436U, 0x3437U, 0x3438U, 0x3439U, 0x3461U, 0x3462U, 0x3463U, 0x3464U, + 0x3465U, 0x3466U, 0x3530U, 0x3531U, 0x3532U, 0x3533U, 0x3534U, 0x3535U, 0x3536U, 0x3537U, 0x3538U, 0x3539U, 0x3561U, + 0x3562U, 0x3563U, 0x3564U, 0x3565U, 0x3566U, 0x3630U, 0x3631U, 0x3632U, 0x3633U, 0x3634U, 0x3635U, 0x3636U, 0x3637U, + 0x3638U, 0x3639U, 0x3661U, 0x3662U, 0x3663U, 0x3664U, 0x3665U, 0x3666U, 0x3730U, 0x3731U, 0x3732U, 0x3733U, 0x3734U, + 0x3735U, 0x3736U, 0x3737U, 0x3738U, 0x3739U, 0x3761U, 0x3762U, 0x3763U, 0x3764U, 0x3765U, 0x3766U, 0x3830U, 0x3831U, + 0x3832U, 0x3833U, 0x3834U, 0x3835U, 0x3836U, 0x3837U, 0x3838U, 0x3839U, 0x3861U, 0x3862U, 0x3863U, 0x3864U, 0x3865U, + 0x3866U, 0x3930U, 0x3931U, 0x3932U, 0x3933U, 0x3934U, 0x3935U, 0x3936U, 0x3937U, 0x3938U, 0x3939U, 0x3961U, 0x3962U, + 0x3963U, 0x3964U, 0x3965U, 0x3966U, 0x6130U, 0x6131U, 0x6132U, 0x6133U, 0x6134U, 0x6135U, 0x6136U, 0x6137U, 0x6138U, + 0x6139U, 0x6161U, 0x6162U, 0x6163U, 0x6164U, 0x6165U, 0x6166U, 0x6230U, 0x6231U, 0x6232U, 0x6233U, 0x6234U, 0x6235U, + 0x6236U, 0x6237U, 0x6238U, 0x6239U, 0x6261U, 0x6262U, 0x6263U, 0x6264U, 0x6265U, 0x6266U, 0x6330U, 0x6331U, 0x6332U, + 0x6333U, 0x6334U, 0x6335U, 0x6336U, 0x6337U, 0x6338U, 0x6339U, 0x6361U, 0x6362U, 0x6363U, 0x6364U, 0x6365U, 0x6366U, + 0x6430U, 0x6431U, 0x6432U, 0x6433U, 0x6434U, 0x6435U, 0x6436U, 0x6437U, 0x6438U, 0x6439U, 0x6461U, 0x6462U, 0x6463U, + 0x6464U, 0x6465U, 0x6466U, 0x6530U, 0x6531U, 0x6532U, 0x6533U, 0x6534U, 0x6535U, 0x6536U, 0x6537U, 0x6538U, 0x6539U, + 0x6561U, 0x6562U, 0x6563U, 0x6564U, 0x6565U, 0x6566U, 0x6630U, 0x6631U, 0x6632U, 0x6633U, 0x6634U, 0x6635U, 0x6636U, + 0x6637U, 0x6638U, 0x6639U, 0x6661U, 0x6662U, 0x6663U, 0x6664U, 0x6665U, 0x6666U +#else /* DUK_USE_INTEGER_BE */ + 0x3030U, 0x3130U, 0x3230U, 0x3330U, 0x3430U, 0x3530U, 0x3630U, 0x3730U, 0x3830U, 0x3930U, 0x6130U, 0x6230U, 0x6330U, + 0x6430U, 0x6530U, 0x6630U, 0x3031U, 0x3131U, 0x3231U, 0x3331U, 0x3431U, 0x3531U, 0x3631U, 0x3731U, 0x3831U, 0x3931U, + 0x6131U, 0x6231U, 0x6331U, 0x6431U, 0x6531U, 0x6631U, 0x3032U, 0x3132U, 0x3232U, 0x3332U, 0x3432U, 0x3532U, 0x3632U, + 0x3732U, 0x3832U, 0x3932U, 0x6132U, 0x6232U, 0x6332U, 0x6432U, 0x6532U, 0x6632U, 0x3033U, 0x3133U, 0x3233U, 0x3333U, + 0x3433U, 0x3533U, 0x3633U, 0x3733U, 0x3833U, 0x3933U, 0x6133U, 0x6233U, 0x6333U, 0x6433U, 0x6533U, 0x6633U, 0x3034U, + 0x3134U, 0x3234U, 0x3334U, 0x3434U, 0x3534U, 0x3634U, 0x3734U, 0x3834U, 0x3934U, 0x6134U, 0x6234U, 0x6334U, 0x6434U, + 0x6534U, 0x6634U, 0x3035U, 0x3135U, 0x3235U, 0x3335U, 0x3435U, 0x3535U, 0x3635U, 0x3735U, 0x3835U, 0x3935U, 0x6135U, + 0x6235U, 0x6335U, 0x6435U, 0x6535U, 0x6635U, 0x3036U, 0x3136U, 0x3236U, 0x3336U, 0x3436U, 0x3536U, 0x3636U, 0x3736U, + 0x3836U, 0x3936U, 0x6136U, 0x6236U, 0x6336U, 0x6436U, 0x6536U, 0x6636U, 0x3037U, 0x3137U, 0x3237U, 0x3337U, 0x3437U, + 0x3537U, 0x3637U, 0x3737U, 0x3837U, 0x3937U, 0x6137U, 0x6237U, 0x6337U, 0x6437U, 0x6537U, 0x6637U, 0x3038U, 0x3138U, + 0x3238U, 0x3338U, 0x3438U, 0x3538U, 0x3638U, 0x3738U, 0x3838U, 0x3938U, 0x6138U, 0x6238U, 0x6338U, 0x6438U, 0x6538U, + 0x6638U, 0x3039U, 0x3139U, 0x3239U, 0x3339U, 0x3439U, 0x3539U, 0x3639U, 0x3739U, 0x3839U, 0x3939U, 0x6139U, 0x6239U, + 0x6339U, 0x6439U, 0x6539U, 0x6639U, 0x3061U, 0x3161U, 0x3261U, 0x3361U, 0x3461U, 0x3561U, 0x3661U, 0x3761U, 0x3861U, + 0x3961U, 0x6161U, 0x6261U, 0x6361U, 0x6461U, 0x6561U, 0x6661U, 0x3062U, 0x3162U, 0x3262U, 0x3362U, 0x3462U, 0x3562U, + 0x3662U, 0x3762U, 0x3862U, 0x3962U, 0x6162U, 0x6262U, 0x6362U, 0x6462U, 0x6562U, 0x6662U, 0x3063U, 0x3163U, 0x3263U, + 0x3363U, 0x3463U, 0x3563U, 0x3663U, 0x3763U, 0x3863U, 0x3963U, 0x6163U, 0x6263U, 0x6363U, 0x6463U, 0x6563U, 0x6663U, + 0x3064U, 0x3164U, 0x3264U, 0x3364U, 0x3464U, 0x3564U, 0x3664U, 0x3764U, 0x3864U, 0x3964U, 0x6164U, 0x6264U, 0x6364U, + 0x6464U, 0x6564U, 0x6664U, 0x3065U, 0x3165U, 0x3265U, 0x3365U, 0x3465U, 0x3565U, 0x3665U, 0x3765U, 0x3865U, 0x3965U, + 0x6165U, 0x6265U, 0x6365U, 0x6465U, 0x6565U, 0x6665U, 0x3066U, 0x3166U, 0x3266U, 0x3366U, 0x3466U, 0x3566U, 0x3666U, + 0x3766U, 0x3866U, 0x3966U, 0x6166U, 0x6266U, 0x6366U, 0x6466U, 0x6566U, 0x6666U +#endif /* DUK_USE_INTEGER_BE */ +}; +#endif /* DUK_USE_HEX_FASTPATH */ + +/* + * Arbitrary byteswap for potentially unaligned values + * + * Used to byteswap pointers e.g. in debugger code. + */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) /* For now only needed by the debugger. */ +DUK_INTERNAL void duk_byteswap_bytes(duk_uint8_t *p, duk_small_uint_t len) { + duk_uint8_t tmp; + duk_uint8_t *q = p + len - 1; + + while (p - q < 0) { + tmp = *p; + *p = *q; + *q = tmp; + p++; + q--; + } +} +#endif + +/* + * Random + */ + +DUK_INTERNAL duk_double_t duk_util_get_random_double(duk_hthread *thr) { +#if defined(DUK_USE_GET_RANDOM_DOUBLE) + return DUK_USE_GET_RANDOM_DOUBLE(thr->heap->heap_udata); +#else + return duk_util_tinyrandom_get_double(thr); +#endif +} +#line 1 "duk_hobject_class.c" +/* + * Hobject ECMAScript [[Class]]. + */ + +/* #include duk_internal.h -> already included */ + +#if (DUK_STRIDX_UC_ARGUMENTS > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_BOOLEAN > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_DATE > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_ERROR > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_FUNCTION > 255) +#error constant too large +#endif +#if (DUK_STRIDX_JSON > 255) +#error constant too large +#endif +#if (DUK_STRIDX_MATH > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_NUMBER > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_OBJECT > 255) +#error constant too large +#endif +#if (DUK_STRIDX_REG_EXP > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_STRING > 255) +#error constant too large +#endif +#if (DUK_STRIDX_GLOBAL > 255) +#error constant too large +#endif +#if (DUK_STRIDX_OBJ_ENV > 255) +#error constant too large +#endif +#if (DUK_STRIDX_DEC_ENV > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_POINTER > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UC_THREAD > 255) +#error constant too large +#endif +#if (DUK_STRIDX_ARRAY_BUFFER > 255) +#error constant too large +#endif +#if (DUK_STRIDX_DATA_VIEW > 255) +#error constant too large +#endif +#if (DUK_STRIDX_INT8_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UINT8_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UINT8_CLAMPED_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_INT16_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UINT16_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_INT32_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_UINT32_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_FLOAT32_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_FLOAT64_ARRAY > 255) +#error constant too large +#endif +#if (DUK_STRIDX_EMPTY_STRING > 255) +#error constant too large +#endif + +/* Note: assumes that these string indexes are 8-bit, genstrings.py must ensure that */ +DUK_INTERNAL duk_uint8_t duk_class_number_to_stridx[32] = { + DUK_STRIDX_EMPTY_STRING, /* NONE, intentionally empty */ + DUK_STRIDX_UC_OBJECT, + DUK_STRIDX_UC_ARRAY, + DUK_STRIDX_UC_FUNCTION, + DUK_STRIDX_UC_ARGUMENTS, + DUK_STRIDX_UC_BOOLEAN, + DUK_STRIDX_UC_DATE, + DUK_STRIDX_UC_ERROR, + DUK_STRIDX_JSON, + DUK_STRIDX_MATH, + DUK_STRIDX_UC_NUMBER, + DUK_STRIDX_REG_EXP, + DUK_STRIDX_UC_STRING, + DUK_STRIDX_GLOBAL, + DUK_STRIDX_UC_SYMBOL, + DUK_STRIDX_OBJ_ENV, + DUK_STRIDX_DEC_ENV, + DUK_STRIDX_UC_POINTER, + DUK_STRIDX_UC_THREAD, + DUK_STRIDX_ARRAY_BUFFER, + DUK_STRIDX_DATA_VIEW, + DUK_STRIDX_INT8_ARRAY, + DUK_STRIDX_UINT8_ARRAY, + DUK_STRIDX_UINT8_CLAMPED_ARRAY, + DUK_STRIDX_INT16_ARRAY, + DUK_STRIDX_UINT16_ARRAY, + DUK_STRIDX_INT32_ARRAY, + DUK_STRIDX_UINT32_ARRAY, + DUK_STRIDX_FLOAT32_ARRAY, + DUK_STRIDX_FLOAT64_ARRAY, + DUK_STRIDX_EMPTY_STRING, /* UNUSED, intentionally empty */ + DUK_STRIDX_EMPTY_STRING, /* UNUSED, intentionally empty */ +}; +#line 1 "duk_alloc_default.c" +/* + * Default allocation functions. + * + * Assumes behavior such as malloc allowing zero size, yielding + * a NULL or a unique pointer which is a no-op for free. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_PROVIDE_DEFAULT_ALLOC_FUNCTIONS) +DUK_INTERNAL void *duk_default_alloc_function(void *udata, duk_size_t size) { + void *res; + DUK_UNREF(udata); + res = DUK_ANSI_MALLOC(size); + DUK_DDD(DUK_DDDPRINT("default alloc function: %lu -> %p", (unsigned long) size, (void *) res)); + return res; +} + +DUK_INTERNAL void *duk_default_realloc_function(void *udata, void *ptr, duk_size_t newsize) { + void *res; + DUK_UNREF(udata); + res = DUK_ANSI_REALLOC(ptr, newsize); + DUK_DDD(DUK_DDDPRINT("default realloc function: %p %lu -> %p", (void *) ptr, (unsigned long) newsize, (void *) res)); + return res; +} + +DUK_INTERNAL void duk_default_free_function(void *udata, void *ptr) { + DUK_DDD(DUK_DDDPRINT("default free function: %p", (void *) ptr)); + DUK_UNREF(udata); + DUK_ANSI_FREE(ptr); +} +#endif /* DUK_USE_PROVIDE_DEFAULT_ALLOC_FUNCTIONS */ +#line 1 "duk_api_buffer.c" +/* + * Buffer + */ + +/* #include duk_internal.h -> already included */ + +DUK_EXTERNAL void *duk_resize_buffer(duk_hthread *thr, duk_idx_t idx, duk_size_t new_size) { + duk_hbuffer_dynamic *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hbuffer_dynamic *) duk_require_hbuffer(thr, idx); + DUK_ASSERT(h != NULL); + + if (!(DUK_HBUFFER_HAS_DYNAMIC(h) && !DUK_HBUFFER_HAS_EXTERNAL(h))) { + DUK_ERROR_TYPE(thr, DUK_STR_WRONG_BUFFER_TYPE); + DUK_WO_NORETURN(return NULL;); + } + + /* Maximum size check is handled by callee. */ + duk_hbuffer_resize(thr, h, new_size); + + return DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(thr->heap, h); +} + +DUK_EXTERNAL void *duk_steal_buffer(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_size) { + duk_hbuffer_dynamic *h; + void *ptr; + duk_size_t sz; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hbuffer_dynamic *) duk_require_hbuffer(thr, idx); + DUK_ASSERT(h != NULL); + + if (!(DUK_HBUFFER_HAS_DYNAMIC(h) && !DUK_HBUFFER_HAS_EXTERNAL(h))) { + DUK_ERROR_TYPE(thr, DUK_STR_WRONG_BUFFER_TYPE); + DUK_WO_NORETURN(return NULL;); + } + + /* Forget the previous allocation, setting size to 0 and alloc to + * NULL. Caller is responsible for freeing the previous allocation. + * Getting the allocation and clearing it is done in the same API + * call to avoid any chance of a realloc. + */ + ptr = DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(thr->heap, h); + sz = DUK_HBUFFER_DYNAMIC_GET_SIZE(h); + if (out_size) { + *out_size = sz; + } + DUK_HBUFFER_DYNAMIC_SET_DATA_PTR_NULL(thr->heap, h); + DUK_HBUFFER_DYNAMIC_SET_SIZE(h, 0); + + return ptr; +} + +DUK_EXTERNAL void duk_config_buffer(duk_hthread *thr, duk_idx_t idx, void *ptr, duk_size_t len) { + duk_hbuffer_external *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hbuffer_external *) duk_require_hbuffer(thr, idx); + DUK_ASSERT(h != NULL); + + if (!DUK_HBUFFER_HAS_EXTERNAL(h)) { + DUK_ERROR_TYPE(thr, DUK_STR_WRONG_BUFFER_TYPE); + DUK_WO_NORETURN(return;); + } + DUK_ASSERT(DUK_HBUFFER_HAS_DYNAMIC(h)); + + DUK_HBUFFER_EXTERNAL_SET_DATA_PTR(thr->heap, h, ptr); + DUK_HBUFFER_EXTERNAL_SET_SIZE(h, len); +} +#line 1 "duk_api_bytecode.c" +/* + * Bytecode dump/load + * + * The bytecode load primitive is more important performance-wise than the + * dump primitive. + * + * Unlike most Duktape API calls, bytecode dump/load is not guaranteed to be + * memory safe for invalid arguments - caller beware! There's little point + * in trying to achieve memory safety unless bytecode instructions are also + * validated which is not easy to do with indirect register references etc. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_BYTECODE_DUMP_SUPPORT) + +#define DUK__SER_MARKER 0xbf +#define DUK__SER_STRING 0x00 +#define DUK__SER_NUMBER 0x01 +#define DUK__BYTECODE_INITIAL_ALLOC 256 +#define DUK__NO_FORMALS 0xffffffffUL + +/* + * Dump/load helpers, xxx_raw() helpers do no buffer checks + */ + +DUK_LOCAL const duk_uint8_t *duk__load_string_raw(duk_hthread *thr, const duk_uint8_t *p) { + duk_uint32_t len; + + len = DUK_RAW_READINC_U32_BE(p); + duk_push_lstring(thr, (const char *) p, len); + p += len; + return p; +} + +DUK_LOCAL const duk_uint8_t *duk__load_buffer_raw(duk_hthread *thr, const duk_uint8_t *p) { + duk_uint32_t len; + duk_uint8_t *buf; + + len = DUK_RAW_READINC_U32_BE(p); + buf = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, (duk_size_t) len); + DUK_ASSERT(buf != NULL); + duk_memcpy((void *) buf, (const void *) p, (size_t) len); + p += len; + return p; +} + +DUK_LOCAL duk_uint8_t *duk__dump_hstring_raw(duk_uint8_t *p, duk_hstring *h) { + duk_size_t len; + duk_uint32_t tmp32; + + DUK_ASSERT(h != NULL); + + len = DUK_HSTRING_GET_BYTELEN(h); + DUK_ASSERT(len <= 0xffffffffUL); /* string limits */ + tmp32 = (duk_uint32_t) len; + DUK_RAW_WRITEINC_U32_BE(p, tmp32); + duk_memcpy((void *) p, (const void *) DUK_HSTRING_GET_DATA(h), len); + p += len; + return p; +} + +DUK_LOCAL duk_uint8_t *duk__dump_hbuffer_raw(duk_hthread *thr, duk_uint8_t *p, duk_hbuffer *h) { + duk_size_t len; + duk_uint32_t tmp32; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(h != NULL); + DUK_UNREF(thr); + + len = DUK_HBUFFER_GET_SIZE(h); + DUK_ASSERT(len <= 0xffffffffUL); /* buffer limits */ + tmp32 = (duk_uint32_t) len; + DUK_RAW_WRITEINC_U32_BE(p, tmp32); + /* When len == 0, buffer data pointer may be NULL. */ + duk_memcpy_unsafe((void *) p, (const void *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h), len); + p += len; + return p; +} + +DUK_LOCAL duk_uint8_t *duk__dump_string_prop(duk_hthread *thr, + duk_uint8_t *p, + duk_bufwriter_ctx *bw_ctx, + duk_hobject *func, + duk_small_uint_t stridx) { + duk_hstring *h_str; + duk_tval *tv; + + tv = duk_hobject_find_entry_tval_ptr_stridx(thr->heap, (duk_hobject *) func, stridx); + if (tv != NULL && DUK_TVAL_IS_STRING(tv)) { + h_str = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h_str != NULL); + } else { + h_str = DUK_HTHREAD_STRING_EMPTY_STRING(thr); + DUK_ASSERT(h_str != NULL); + } + DUK_ASSERT(DUK_HSTRING_MAX_BYTELEN <= 0x7fffffffUL); /* ensures no overflow */ + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 4U + DUK_HSTRING_GET_BYTELEN(h_str), p); + p = duk__dump_hstring_raw(p, h_str); + return p; +} + +DUK_LOCAL duk_uint8_t *duk__dump_buffer_prop(duk_hthread *thr, + duk_uint8_t *p, + duk_bufwriter_ctx *bw_ctx, + duk_hobject *func, + duk_small_uint_t stridx) { + duk_tval *tv; + + tv = duk_hobject_find_entry_tval_ptr_stridx(thr->heap, (duk_hobject *) func, stridx); + if (tv != NULL && DUK_TVAL_IS_BUFFER(tv)) { + duk_hbuffer *h_buf; + h_buf = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h_buf != NULL); + DUK_ASSERT(DUK_HBUFFER_MAX_BYTELEN <= 0x7fffffffUL); /* ensures no overflow */ + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 4U + DUK_HBUFFER_GET_SIZE(h_buf), p); + p = duk__dump_hbuffer_raw(thr, p, h_buf); + } else { + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 4U, p); + DUK_RAW_WRITEINC_U32_BE(p, 0); + } + return p; +} + +DUK_LOCAL duk_uint8_t *duk__dump_uint32_prop(duk_hthread *thr, + duk_uint8_t *p, + duk_bufwriter_ctx *bw_ctx, + duk_hobject *func, + duk_small_uint_t stridx, + duk_uint32_t def_value) { + duk_tval *tv; + duk_uint32_t val; + + tv = duk_hobject_find_entry_tval_ptr_stridx(thr->heap, (duk_hobject *) func, stridx); + if (tv != NULL && DUK_TVAL_IS_NUMBER(tv)) { + val = (duk_uint32_t) DUK_TVAL_GET_NUMBER(tv); + } else { + val = def_value; + } + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 4U, p); + DUK_RAW_WRITEINC_U32_BE(p, val); + return p; +} + +DUK_LOCAL duk_uint8_t *duk__dump_varmap(duk_hthread *thr, duk_uint8_t *p, duk_bufwriter_ctx *bw_ctx, duk_hobject *func) { + duk_hobject *h; + + h = duk_hobject_get_varmap(thr, (duk_hobject *) func); + if (h != NULL) { + duk_uint_fast32_t i; + + /* We know _Varmap only has own properties so walk property + * table directly. We also know _Varmap is dense and all + * values are numbers; assert for these. GC and finalizers + * shouldn't affect _Varmap so side effects should be fine. + */ + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ENEXT(h); i++) { + duk_hstring *key; + duk_tval *tv_val; + duk_uint32_t val; + + key = DUK_HOBJECT_E_GET_KEY(thr->heap, h, i); + DUK_ASSERT(key != NULL); /* _Varmap is dense */ + DUK_ASSERT(!DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, h, i)); + tv_val = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, h, i); + DUK_ASSERT(tv_val != NULL); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_val)); /* known to be number; in fact an integer */ +#if defined(DUK_USE_FASTINT) + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv_val)); + DUK_ASSERT(DUK_TVAL_GET_FASTINT(tv_val) == + (duk_int64_t) DUK_TVAL_GET_FASTINT_U32(tv_val)); /* known to be 32-bit */ + val = DUK_TVAL_GET_FASTINT_U32(tv_val); +#else + val = (duk_uint32_t) DUK_TVAL_GET_NUMBER(tv_val); +#endif + + DUK_ASSERT(DUK_HSTRING_MAX_BYTELEN <= 0x7fffffffUL); /* ensures no overflow */ + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 4U + DUK_HSTRING_GET_BYTELEN(key) + 4U, p); + p = duk__dump_hstring_raw(p, key); + DUK_RAW_WRITEINC_U32_BE(p, val); + } + } + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 4U, p); + DUK_RAW_WRITEINC_U32_BE(p, 0); /* end of _Varmap */ + return p; +} + +DUK_LOCAL duk_uint8_t *duk__dump_formals(duk_hthread *thr, duk_uint8_t *p, duk_bufwriter_ctx *bw_ctx, duk_hobject *func) { + duk_harray *h; + + h = duk_hobject_get_formals(thr, (duk_hobject *) func); + if (h != NULL) { + duk_uint32_t i; + + /* Here we rely on _Formals being a dense array containing + * strings. This should be the case unless _Formals has been + * tweaked by the application (which we don't support right + * now). + */ + + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 4U, p); + DUK_ASSERT(h->length != DUK__NO_FORMALS); /* limits */ + DUK_RAW_WRITEINC_U32_BE(p, h->length); + + for (i = 0; i < h->length; i++) { + duk_tval *tv_val; + duk_hstring *varname; + + tv_val = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, (duk_hobject *) h, i); + DUK_ASSERT(tv_val != NULL); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv_val)); + + varname = DUK_TVAL_GET_STRING(tv_val); + DUK_ASSERT(varname != NULL); + DUK_ASSERT(DUK_HSTRING_GET_BYTELEN(varname) >= 1); + + DUK_ASSERT(DUK_HSTRING_MAX_BYTELEN <= 0x7fffffffUL); /* ensures no overflow */ + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 4U + DUK_HSTRING_GET_BYTELEN(varname), p); + p = duk__dump_hstring_raw(p, varname); + } + } else { + DUK_DD(DUK_DDPRINT("dumping function without _Formals, emit marker to indicate missing _Formals")); + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 4U, p); + DUK_RAW_WRITEINC_U32_BE(p, DUK__NO_FORMALS); /* marker: no formals */ + } + return p; +} + +static duk_uint8_t *duk__dump_func(duk_hthread *thr, duk_hcompfunc *func, duk_bufwriter_ctx *bw_ctx, duk_uint8_t *p) { + duk_tval *tv, *tv_end; + duk_instr_t *ins, *ins_end; + duk_hobject **fn, **fn_end; + duk_hstring *h_str; + duk_uint32_t count_instr; + duk_uint32_t tmp32; + duk_uint16_t tmp16; + duk_double_t d; + + DUK_DD(DUK_DDPRINT("dumping function %p to %p: " + "consts=[%p,%p[ (%ld bytes, %ld items), " + "funcs=[%p,%p[ (%ld bytes, %ld items), " + "code=[%p,%p[ (%ld bytes, %ld items)", + (void *) func, + (void *) p, + (void *) DUK_HCOMPFUNC_GET_CONSTS_BASE(thr->heap, func), + (void *) DUK_HCOMPFUNC_GET_CONSTS_END(thr->heap, func), + (long) DUK_HCOMPFUNC_GET_CONSTS_SIZE(thr->heap, func), + (long) DUK_HCOMPFUNC_GET_CONSTS_COUNT(thr->heap, func), + (void *) DUK_HCOMPFUNC_GET_FUNCS_BASE(thr->heap, func), + (void *) DUK_HCOMPFUNC_GET_FUNCS_END(thr->heap, func), + (long) DUK_HCOMPFUNC_GET_FUNCS_SIZE(thr->heap, func), + (long) DUK_HCOMPFUNC_GET_FUNCS_COUNT(thr->heap, func), + (void *) DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, func), + (void *) DUK_HCOMPFUNC_GET_CODE_END(thr->heap, func), + (long) DUK_HCOMPFUNC_GET_CODE_SIZE(thr->heap, func), + (long) DUK_HCOMPFUNC_GET_CODE_COUNT(thr->heap, func))); + + DUK_ASSERT(DUK_USE_ESBC_MAX_BYTES <= 0x7fffffffUL); /* ensures no overflow */ + count_instr = (duk_uint32_t) DUK_HCOMPFUNC_GET_CODE_COUNT(thr->heap, func); + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 3U * 4U + 2U * 2U + 3U * 4U + count_instr * 4U, p); + + /* Fixed header info. */ + tmp32 = count_instr; + DUK_RAW_WRITEINC_U32_BE(p, tmp32); + tmp32 = (duk_uint32_t) DUK_HCOMPFUNC_GET_CONSTS_COUNT(thr->heap, func); + DUK_RAW_WRITEINC_U32_BE(p, tmp32); + tmp32 = (duk_uint32_t) DUK_HCOMPFUNC_GET_FUNCS_COUNT(thr->heap, func); + DUK_RAW_WRITEINC_U32_BE(p, tmp32); + tmp16 = func->nregs; + DUK_RAW_WRITEINC_U16_BE(p, tmp16); + tmp16 = func->nargs; + DUK_RAW_WRITEINC_U16_BE(p, tmp16); +#if defined(DUK_USE_DEBUGGER_SUPPORT) + tmp32 = func->start_line; + DUK_RAW_WRITEINC_U32_BE(p, tmp32); + tmp32 = func->end_line; + DUK_RAW_WRITEINC_U32_BE(p, tmp32); +#else + DUK_RAW_WRITEINC_U32_BE(p, 0); + DUK_RAW_WRITEINC_U32_BE(p, 0); +#endif + tmp32 = DUK_HEAPHDR_GET_FLAGS((duk_heaphdr *) func); /* masks flags, only duk_hobject flags */ + tmp32 &= ~(DUK_HOBJECT_FLAG_HAVE_FINALIZER); /* finalizer flag is lost */ + DUK_RAW_WRITEINC_U32_BE(p, tmp32); + + /* Bytecode instructions: endian conversion needed unless + * platform is big endian. + */ + ins = DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, func); + ins_end = DUK_HCOMPFUNC_GET_CODE_END(thr->heap, func); + DUK_ASSERT((duk_size_t) (ins_end - ins) == (duk_size_t) count_instr); +#if defined(DUK_USE_INTEGER_BE) + duk_memcpy_unsafe((void *) p, (const void *) ins, count_instr * sizeof(duk_instr_t)); + p += count_instr * sizeof(duk_instr_t); + DUK_UNREF(ins_end); +#else + while (ins != ins_end) { + tmp32 = (duk_uint32_t) (*ins); + DUK_RAW_WRITEINC_U32_BE(p, tmp32); + ins++; + } +#endif + + /* Constants: variable size encoding. */ + tv = DUK_HCOMPFUNC_GET_CONSTS_BASE(thr->heap, func); + tv_end = DUK_HCOMPFUNC_GET_CONSTS_END(thr->heap, func); + while (tv != tv_end) { + /* constants are strings or numbers now */ + DUK_ASSERT(DUK_TVAL_IS_STRING(tv) || DUK_TVAL_IS_NUMBER(tv)); + + if (DUK_TVAL_IS_STRING(tv)) { + h_str = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h_str != NULL); + DUK_ASSERT(DUK_HSTRING_MAX_BYTELEN <= 0x7fffffffUL); /* ensures no overflow */ + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 1U + 4U + DUK_HSTRING_GET_BYTELEN(h_str), p); + *p++ = DUK__SER_STRING; + p = duk__dump_hstring_raw(p, h_str); + } else { + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + p = DUK_BW_ENSURE_RAW(thr, bw_ctx, 1U + 8U, p); + *p++ = DUK__SER_NUMBER; + d = DUK_TVAL_GET_NUMBER(tv); + DUK_RAW_WRITEINC_DOUBLE_BE(p, d); + } + tv++; + } + + /* Inner functions recursively. */ + fn = (duk_hobject **) DUK_HCOMPFUNC_GET_FUNCS_BASE(thr->heap, func); + fn_end = (duk_hobject **) DUK_HCOMPFUNC_GET_FUNCS_END(thr->heap, func); + while (fn != fn_end) { + /* XXX: This causes recursion up to inner function depth + * which is normally not an issue, e.g. mark-and-sweep uses + * a recursion limiter to avoid C stack issues. Avoiding + * this would mean some sort of a work list or just refusing + * to serialize deep functions. + */ + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(*fn)); + p = duk__dump_func(thr, (duk_hcompfunc *) *fn, bw_ctx, p); + fn++; + } + + /* Lexenv and varenv are not dumped. */ + + /* Object extra properties. + * + * There are some difference between function templates and functions. + * For example, function templates don't have .length and nargs is + * normally used to instantiate the functions. + */ + + p = duk__dump_uint32_prop(thr, p, bw_ctx, (duk_hobject *) func, DUK_STRIDX_LENGTH, (duk_uint32_t) func->nargs); +#if defined(DUK_USE_FUNC_NAME_PROPERTY) + p = duk__dump_string_prop(thr, p, bw_ctx, (duk_hobject *) func, DUK_STRIDX_NAME); +#endif +#if defined(DUK_USE_FUNC_FILENAME_PROPERTY) + p = duk__dump_string_prop(thr, p, bw_ctx, (duk_hobject *) func, DUK_STRIDX_FILE_NAME); +#endif +#if defined(DUK_USE_PC2LINE) + p = duk__dump_buffer_prop(thr, p, bw_ctx, (duk_hobject *) func, DUK_STRIDX_INT_PC2LINE); +#endif + p = duk__dump_varmap(thr, p, bw_ctx, (duk_hobject *) func); + p = duk__dump_formals(thr, p, bw_ctx, (duk_hobject *) func); + + DUK_DD(DUK_DDPRINT("serialized function %p -> final pointer %p", (void *) func, (void *) p)); + + return p; +} + +/* Load a function from bytecode. The function object returned here must + * match what is created by duk_js_push_closure() with respect to its flags, + * properties, etc. + * + * NOTE: there are intentionally no input buffer length / bound checks. + * Adding them would be easy but wouldn't ensure memory safety as untrusted + * or broken bytecode is unsafe during execution unless the opcodes themselves + * are validated (which is quite complex, especially for indirect opcodes). + */ + +#define DUK__ASSERT_LEFT(n) \ + do { \ + DUK_ASSERT((duk_size_t) (p_end - p) >= (duk_size_t) (n)); \ + } while (0) + +static const duk_uint8_t *duk__load_func(duk_hthread *thr, const duk_uint8_t *p, const duk_uint8_t *p_end) { + duk_hcompfunc *h_fun; + duk_hbuffer *h_data; + duk_size_t data_size; + duk_uint32_t count_instr, count_const, count_funcs; + duk_uint32_t n; + duk_uint32_t tmp32; + duk_small_uint_t const_type; + duk_uint8_t *fun_data; + duk_uint8_t *q; + duk_idx_t idx_base; + duk_tval *tv1; + duk_uarridx_t arr_idx; + duk_uarridx_t arr_limit; + duk_hobject *func_env; + duk_bool_t need_pop; + + /* XXX: There's some overlap with duk_js_closure() here, but + * seems difficult to share code. Ensure that the final function + * looks the same as created by duk_js_closure(). + */ + + DUK_ASSERT(thr != NULL); + + DUK_DD(DUK_DDPRINT("loading function, p=%p, p_end=%p", (const void *) p, (const void *) p_end)); + + DUK__ASSERT_LEFT(3 * 4); + count_instr = DUK_RAW_READINC_U32_BE(p); + count_const = DUK_RAW_READINC_U32_BE(p); + count_funcs = DUK_RAW_READINC_U32_BE(p); + + data_size = sizeof(duk_tval) * count_const + sizeof(duk_hobject *) * count_funcs + sizeof(duk_instr_t) * count_instr; + + DUK_DD(DUK_DDPRINT("instr=%ld, const=%ld, funcs=%ld, data_size=%ld", + (long) count_instr, + (long) count_const, + (long) count_const, + (long) data_size)); + + /* Value stack is used to ensure reachability of constants and + * inner functions being loaded. Require enough space to handle + * large functions correctly. + */ + duk_require_stack(thr, (duk_idx_t) (2 + count_const + count_funcs)); + idx_base = duk_get_top(thr); + + /* Push function object, init flags etc. This must match + * duk_js_push_closure() quite carefully. + */ + h_fun = duk_push_hcompfunc(thr); + DUK_ASSERT(h_fun != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC((duk_hobject *) h_fun)); + DUK_ASSERT(DUK_HCOMPFUNC_GET_DATA(thr->heap, h_fun) == NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_FUNCS(thr->heap, h_fun) == NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_BYTECODE(thr->heap, h_fun) == NULL); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) h_fun) == thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); + + h_fun->nregs = DUK_RAW_READINC_U16_BE(p); + h_fun->nargs = DUK_RAW_READINC_U16_BE(p); +#if defined(DUK_USE_DEBUGGER_SUPPORT) + h_fun->start_line = DUK_RAW_READINC_U32_BE(p); + h_fun->end_line = DUK_RAW_READINC_U32_BE(p); +#else + p += 8; /* skip line info */ +#endif + + /* duk_hcompfunc flags; quite version specific */ + tmp32 = DUK_RAW_READINC_U32_BE(p); + DUK_HEAPHDR_SET_FLAGS((duk_heaphdr *) h_fun, tmp32); /* masks flags to only change duk_hobject flags */ + + /* standard prototype (no need to set here, already set) */ + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) h_fun) == thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); +#if 0 + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, &h_fun->obj, thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); +#endif + + /* assert just a few critical flags */ + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) h_fun) == DUK_HTYPE_OBJECT); + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(&h_fun->obj)); + DUK_ASSERT(DUK_HOBJECT_HAS_COMPFUNC(&h_fun->obj)); + DUK_ASSERT(!DUK_HOBJECT_HAS_NATFUNC(&h_fun->obj)); + DUK_ASSERT(!DUK_HOBJECT_IS_THREAD(&h_fun->obj)); + DUK_ASSERT(!DUK_HOBJECT_IS_PROXY(&h_fun->obj)); + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARRAY(&h_fun->obj)); + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_STRINGOBJ(&h_fun->obj)); + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(&h_fun->obj)); + + /* Create function 'data' buffer but don't attach it yet. */ + fun_data = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, data_size); + DUK_ASSERT(fun_data != NULL); + + /* Load bytecode instructions. */ + DUK_ASSERT(sizeof(duk_instr_t) == 4); + DUK__ASSERT_LEFT(count_instr * sizeof(duk_instr_t)); +#if defined(DUK_USE_INTEGER_BE) + q = fun_data + sizeof(duk_tval) * count_const + sizeof(duk_hobject *) * count_funcs; + duk_memcpy((void *) q, (const void *) p, sizeof(duk_instr_t) * count_instr); + p += sizeof(duk_instr_t) * count_instr; +#else + q = fun_data + sizeof(duk_tval) * count_const + sizeof(duk_hobject *) * count_funcs; + for (n = count_instr; n > 0; n--) { + *((duk_instr_t *) (void *) q) = DUK_RAW_READINC_U32_BE(p); + q += sizeof(duk_instr_t); + } +#endif + + /* Load constants onto value stack but don't yet copy to buffer. */ + for (n = count_const; n > 0; n--) { + DUK__ASSERT_LEFT(1); + const_type = DUK_RAW_READINC_U8(p); + switch (const_type) { + case DUK__SER_STRING: { + p = duk__load_string_raw(thr, p); + break; + } + case DUK__SER_NUMBER: { + /* Important to do a fastint check so that constants are + * properly read back as fastints. + */ + duk_tval tv_tmp; + duk_double_t val; + DUK__ASSERT_LEFT(8); + val = DUK_RAW_READINC_DOUBLE_BE(p); + DUK_TVAL_SET_NUMBER_CHKFAST_SLOW(&tv_tmp, val); + duk_push_tval(thr, &tv_tmp); + break; + } + default: { + goto format_error; + } + } + } + + /* Load inner functions to value stack, but don't yet copy to buffer. */ + for (n = count_funcs; n > 0; n--) { + p = duk__load_func(thr, p, p_end); + if (p == NULL) { + goto format_error; + } + } + + /* With constants and inner functions on value stack, we can now + * atomically finish the function 'data' buffer, bump refcounts, + * etc. + * + * Here we take advantage of the value stack being just a duk_tval + * array: we can just memcpy() the constants as long as we incref + * them afterwards. + */ + + h_data = (duk_hbuffer *) duk_known_hbuffer(thr, idx_base + 1); + DUK_ASSERT(!DUK_HBUFFER_HAS_DYNAMIC(h_data)); + DUK_HCOMPFUNC_SET_DATA(thr->heap, h_fun, h_data); + DUK_HBUFFER_INCREF(thr, h_data); + + tv1 = duk_get_tval(thr, idx_base + 2); /* may be NULL if no constants or inner funcs */ + DUK_ASSERT((count_const == 0 && count_funcs == 0) || tv1 != NULL); + + q = fun_data; + duk_memcpy_unsafe((void *) q, (const void *) tv1, sizeof(duk_tval) * count_const); + for (n = count_const; n > 0; n--) { + DUK_TVAL_INCREF_FAST(thr, (duk_tval *) (void *) q); /* no side effects */ + q += sizeof(duk_tval); + } + tv1 += count_const; + + DUK_HCOMPFUNC_SET_FUNCS(thr->heap, h_fun, (duk_hobject **) (void *) q); + for (n = count_funcs; n > 0; n--) { + duk_hobject *h_obj; + + DUK_ASSERT(DUK_TVAL_IS_OBJECT(tv1)); + h_obj = DUK_TVAL_GET_OBJECT(tv1); + DUK_ASSERT(h_obj != NULL); + tv1++; + DUK_HOBJECT_INCREF(thr, h_obj); + + *((duk_hobject **) (void *) q) = h_obj; + q += sizeof(duk_hobject *); + } + + DUK_HCOMPFUNC_SET_BYTECODE(thr->heap, h_fun, (duk_instr_t *) (void *) q); + + /* The function object is now reachable and refcounts are fine, + * so we can pop off all the temporaries. + */ + DUK_DDD(DUK_DDDPRINT("function is reachable, reset top; func: %!iT", duk_get_tval(thr, idx_base))); + duk_set_top(thr, idx_base + 1); + + /* Setup function properties. */ + tmp32 = DUK_RAW_READINC_U32_BE(p); + duk_push_u32(thr, tmp32); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_C); + +#if defined(DUK_USE_FUNC_NAME_PROPERTY) + p = duk__load_string_raw(thr, p); /* -> [ func funcname ] */ + func_env = thr->builtins[DUK_BIDX_GLOBAL_ENV]; + DUK_ASSERT(func_env != NULL); + need_pop = 0; + if (DUK_HOBJECT_HAS_NAMEBINDING((duk_hobject *) h_fun)) { + /* Original function instance/template had NAMEBINDING. + * Must create a lexical environment on loading to allow + * recursive functions like 'function foo() { foo(); }'. + */ + duk_hdecenv *new_env; + + new_env = + duk_hdecenv_alloc(thr, DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_DECENV)); + DUK_ASSERT(new_env != NULL); + DUK_ASSERT(new_env->thread == NULL); /* Closed. */ + DUK_ASSERT(new_env->varmap == NULL); + DUK_ASSERT(new_env->regbase_byteoff == 0); + DUK_HDECENV_ASSERT_VALID(new_env); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) new_env) == NULL); + DUK_HOBJECT_SET_PROTOTYPE(thr->heap, (duk_hobject *) new_env, func_env); + DUK_HOBJECT_INCREF(thr, func_env); + + func_env = (duk_hobject *) new_env; + + duk_push_hobject(thr, (duk_hobject *) new_env); + + duk_dup_m2(thr); /* -> [ func funcname env funcname ] */ + duk_dup(thr, idx_base); /* -> [ func funcname env funcname func ] */ + duk_xdef_prop(thr, -3, DUK_PROPDESC_FLAGS_NONE); /* -> [ func funcname env ] */ + + need_pop = 1; /* Need to pop env, but -after- updating h_fun and increfs. */ + } + DUK_ASSERT(func_env != NULL); + DUK_HCOMPFUNC_SET_LEXENV(thr->heap, h_fun, func_env); + DUK_HCOMPFUNC_SET_VARENV(thr->heap, h_fun, func_env); + DUK_HOBJECT_INCREF(thr, func_env); + DUK_HOBJECT_INCREF(thr, func_env); + if (need_pop) { + duk_pop(thr); + } + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_NAME, DUK_PROPDESC_FLAGS_C); +#endif /* DUK_USE_FUNC_NAME_PROPERTY */ + +#if defined(DUK_USE_FUNC_FILENAME_PROPERTY) + p = duk__load_string_raw(thr, p); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_FILE_NAME, DUK_PROPDESC_FLAGS_C); +#endif /* DUK_USE_FUNC_FILENAME_PROPERTY */ + + if (DUK_HOBJECT_HAS_CONSTRUCTABLE((duk_hobject *) h_fun)) { + /* Restore empty external .prototype only for constructable + * functions. The prototype object should inherit from + * Object.prototype. + */ + duk_push_object(thr); + DUK_ASSERT(!duk_is_bare_object(thr, -1)); + duk_dup_m2(thr); + duk_xdef_prop_stridx_short(thr, + -2, + DUK_STRIDX_CONSTRUCTOR, + DUK_PROPDESC_FLAGS_WC); /* func.prototype.constructor = func */ + duk_compact_m1(thr); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_PROTOTYPE, DUK_PROPDESC_FLAGS_W); + } + +#if defined(DUK_USE_PC2LINE) + p = duk__load_buffer_raw(thr, p); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_PC2LINE, DUK_PROPDESC_FLAGS_WC); +#endif /* DUK_USE_PC2LINE */ + + duk_push_bare_object(thr); /* _Varmap */ + for (;;) { + /* XXX: awkward */ + p = duk__load_string_raw(thr, p); + if (duk_get_length(thr, -1) == 0) { + duk_pop(thr); + break; + } + tmp32 = DUK_RAW_READINC_U32_BE(p); + duk_push_u32(thr, tmp32); + duk_put_prop(thr, -3); + } + duk_compact_m1(thr); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_VARMAP, DUK_PROPDESC_FLAGS_NONE); + + /* _Formals may have been missing in the original function, which is + * handled using a marker length. + */ + arr_limit = DUK_RAW_READINC_U32_BE(p); + if (arr_limit != DUK__NO_FORMALS) { + duk_push_bare_array(thr); /* _Formals */ + for (arr_idx = 0; arr_idx < arr_limit; arr_idx++) { + p = duk__load_string_raw(thr, p); + duk_put_prop_index(thr, -2, arr_idx); + } + duk_compact_m1(thr); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_FORMALS, DUK_PROPDESC_FLAGS_NONE); + } else { + DUK_DD(DUK_DDPRINT("no _Formals in dumped function")); + } + + /* Return with final function pushed on stack top. */ + DUK_DD(DUK_DDPRINT("final loaded function: %!iT", duk_get_tval(thr, -1))); + DUK_ASSERT_TOP(thr, idx_base + 1); + return p; + +format_error: + return NULL; +} + +DUK_EXTERNAL void duk_dump_function(duk_hthread *thr) { + duk_hcompfunc *func; + duk_bufwriter_ctx bw_ctx_alloc; + duk_bufwriter_ctx *bw_ctx = &bw_ctx_alloc; + duk_uint8_t *p; + + DUK_ASSERT_API_ENTRY(thr); + + /* Bound functions don't have all properties so we'd either need to + * lookup the non-bound target function or reject bound functions. + * For now, bound functions are rejected with TypeError. + */ + func = duk_require_hcompfunc(thr, -1); + DUK_ASSERT(func != NULL); + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(&func->obj)); + + /* Estimating the result size beforehand would be costly, so + * start with a reasonable size and extend as needed. + */ + DUK_BW_INIT_PUSHBUF(thr, bw_ctx, DUK__BYTECODE_INITIAL_ALLOC); + p = DUK_BW_GET_PTR(thr, bw_ctx); + *p++ = DUK__SER_MARKER; + p = duk__dump_func(thr, func, bw_ctx, p); + DUK_BW_SET_PTR(thr, bw_ctx, p); + DUK_BW_COMPACT(thr, bw_ctx); + + DUK_DD(DUK_DDPRINT("serialized result: %!T", duk_get_tval(thr, -1))); + + duk_remove_m2(thr); /* [ ... func buf ] -> [ ... buf ] */ +} + +DUK_EXTERNAL void duk_load_function(duk_hthread *thr) { + const duk_uint8_t *p_buf, *p, *p_end; + duk_size_t sz; + + DUK_ASSERT_API_ENTRY(thr); + + p_buf = (duk_uint8_t *) duk_require_buffer(thr, -1, &sz); + DUK_ASSERT(p_buf != NULL); + + /* The caller is responsible for being sure that bytecode being loaded + * is valid and trusted. Invalid bytecode can cause memory unsafe + * behavior directly during loading or later during bytecode execution + * (instruction validation would be quite complex to implement). + * + * This signature check is the only sanity check for detecting + * accidental invalid inputs. The initial byte ensures no ordinary + * string or Symbol will be accepted by accident. + */ + p = p_buf; + p_end = p_buf + sz; + if (sz < 1 || p[0] != DUK__SER_MARKER) { + goto format_error; + } + p++; + + p = duk__load_func(thr, p, p_end); + if (p == NULL) { + goto format_error; + } + + duk_remove_m2(thr); /* [ ... buf func ] -> [ ... func ] */ + return; + +format_error: + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_BYTECODE); + DUK_WO_NORETURN(return;); +} + +#else /* DUK_USE_BYTECODE_DUMP_SUPPORT */ + +DUK_EXTERNAL void duk_dump_function(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return;); +} + +DUK_EXTERNAL void duk_load_function(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return;); +} + +#endif /* DUK_USE_BYTECODE_DUMP_SUPPORT */ + +/* automatic undefs */ +#undef DUK__ASSERT_LEFT +#undef DUK__BYTECODE_INITIAL_ALLOC +#undef DUK__NO_FORMALS +#undef DUK__SER_MARKER +#undef DUK__SER_NUMBER +#undef DUK__SER_STRING +#line 1 "duk_api_call.c" +/* + * Calls. + * + * Protected variants should avoid ever throwing an error. Must be careful + * to catch errors related to value stack manipulation and property lookup, + * not just the call itself. + * + * The only exception is when arguments are insane, e.g. nargs/nrets are out + * of bounds; in such cases an error is thrown for two reasons. First, we + * can't always respect the value stack input/output guarantees in such cases + * so the caller would end up with the value stack in an unexpected state. + * Second, an attempt to create an error might itself fail (although this + * could be avoided by pushing a preallocated object/string or a primitive + * value). + */ + +/* #include duk_internal.h -> already included */ + +/* + * Helpers + */ + +struct duk__pcall_prop_args { + duk_idx_t obj_idx; + duk_idx_t nargs; + duk_small_uint_t call_flags; +}; +typedef struct duk__pcall_prop_args duk__pcall_prop_args; + +struct duk__pcall_method_args { + duk_idx_t nargs; + duk_small_uint_t call_flags; +}; +typedef struct duk__pcall_method_args duk__pcall_method_args; + +struct duk__pcall_args { + duk_idx_t nargs; + duk_small_uint_t call_flags; +}; +typedef struct duk__pcall_args duk__pcall_args; + +/* Compute and validate idx_func for a certain 'nargs' and 'other' + * parameter count (1 or 2, depending on whether 'this' binding is + * present). + */ +DUK_LOCAL duk_idx_t duk__call_get_idx_func(duk_hthread *thr, duk_idx_t nargs, duk_idx_t other) { + duk_idx_t idx_func; + + /* XXX: byte arithmetic? */ + + DUK_ASSERT(other >= 0); + + idx_func = duk_get_top(thr) - nargs - other; + if (DUK_UNLIKELY((idx_func | nargs) < 0)) { /* idx_func < 0 || nargs < 0; OR sign bits */ + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return 0;); + } + DUK_ASSERT(duk_is_valid_index(thr, idx_func)); + return idx_func; +} + +/* Compute idx_func, assume index will be valid. This is a valid assumption + * for protected calls: nargs < 0 is checked explicitly and duk_safe_call() + * validates the argument count. + */ +DUK_LOCAL duk_idx_t duk__call_get_idx_func_unvalidated(duk_hthread *thr, duk_idx_t nargs, duk_idx_t other) { + duk_idx_t idx_func; + + /* XXX: byte arithmetic? */ + + DUK_ASSERT(nargs >= 0); + DUK_ASSERT(other >= 0); + + idx_func = duk_get_top(thr) - nargs - other; + DUK_ASSERT(idx_func >= 0); + DUK_ASSERT(duk_is_valid_index(thr, idx_func)); + return idx_func; +} + +/* Prepare value stack for a method call through an object property. + * May currently throw an error e.g. when getting the property. + */ +DUK_LOCAL void duk__call_prop_prep_stack(duk_hthread *thr, duk_idx_t normalized_obj_idx, duk_idx_t nargs) { + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(nargs >= 0); + + DUK_DDD(DUK_DDDPRINT("duk__call_prop_prep_stack, normalized_obj_idx=%ld, nargs=%ld, stacktop=%ld", + (long) normalized_obj_idx, + (long) nargs, + (long) duk_get_top(thr))); + + /* [... key arg1 ... argN] */ + + /* duplicate key */ + duk_dup(thr, -nargs - 1); /* Note: -nargs alone would fail for nargs == 0, this is OK */ + (void) duk_get_prop(thr, normalized_obj_idx); + + DUK_DDD(DUK_DDDPRINT("func: %!T", (duk_tval *) duk_get_tval(thr, -1))); + +#if defined(DUK_USE_VERBOSE_ERRORS) + if (DUK_UNLIKELY(!duk_is_callable(thr, -1))) { + duk_tval *tv_base; + duk_tval *tv_key; + + /* tv_targ is passed on stack top (at index -1). */ + tv_base = DUK_GET_TVAL_POSIDX(thr, normalized_obj_idx); + tv_key = DUK_GET_TVAL_NEGIDX(thr, -nargs - 2); + DUK_ASSERT(tv_base >= thr->valstack_bottom && tv_base < thr->valstack_top); + DUK_ASSERT(tv_key >= thr->valstack_bottom && tv_key < thr->valstack_top); + + duk_call_setup_propcall_error(thr, tv_base, tv_key); + } +#endif + + /* [... key arg1 ... argN func] */ + + duk_replace(thr, -nargs - 2); + + /* [... func arg1 ... argN] */ + + duk_dup(thr, normalized_obj_idx); + duk_insert(thr, -nargs - 1); + + /* [... func this arg1 ... argN] */ +} + +DUK_EXTERNAL void duk_call(duk_hthread *thr, duk_idx_t nargs) { + duk_small_uint_t call_flags; + duk_idx_t idx_func; + + DUK_ASSERT_API_ENTRY(thr); + + idx_func = duk__call_get_idx_func(thr, nargs, 1); + DUK_ASSERT(duk_is_valid_index(thr, idx_func)); + + duk_insert_undefined(thr, idx_func + 1); + + call_flags = 0; /* not protected, respect reclimit, not constructor */ + duk_handle_call_unprotected(thr, idx_func, call_flags); +} + +DUK_EXTERNAL void duk_call_method(duk_hthread *thr, duk_idx_t nargs) { + duk_small_uint_t call_flags; + duk_idx_t idx_func; + + DUK_ASSERT_API_ENTRY(thr); + + idx_func = duk__call_get_idx_func(thr, nargs, 2); + DUK_ASSERT(duk_is_valid_index(thr, idx_func)); + + call_flags = 0; /* not protected, respect reclimit, not constructor */ + duk_handle_call_unprotected(thr, idx_func, call_flags); +} + +DUK_EXTERNAL void duk_call_prop(duk_hthread *thr, duk_idx_t obj_idx, duk_idx_t nargs) { + /* + * XXX: if duk_handle_call() took values through indices, this could be + * made much more sensible. However, duk_handle_call() needs to fudge + * the 'this' and 'func' values to handle bound functions, which is now + * done "in-place", so this is not a trivial change. + */ + + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); /* make absolute */ + if (DUK_UNLIKELY(nargs < 0)) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return;); + } + + duk__call_prop_prep_stack(thr, obj_idx, nargs); + + duk_call_method(thr, nargs); +} + +DUK_LOCAL duk_ret_t duk__pcall_raw(duk_hthread *thr, void *udata) { + duk__pcall_args *args; + duk_idx_t idx_func; + duk_int_t ret; + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(udata != NULL); + + args = (duk__pcall_args *) udata; + idx_func = duk__call_get_idx_func_unvalidated(thr, args->nargs, 1); + DUK_ASSERT(duk_is_valid_index(thr, idx_func)); + + duk_insert_undefined(thr, idx_func + 1); + + ret = duk_handle_call_unprotected(thr, idx_func, args->call_flags); + DUK_ASSERT(ret == 0); + DUK_UNREF(ret); + + return 1; +} + +DUK_EXTERNAL duk_int_t duk_pcall(duk_hthread *thr, duk_idx_t nargs) { + duk__pcall_args args; + + DUK_ASSERT_API_ENTRY(thr); + + args.nargs = nargs; + if (DUK_UNLIKELY(nargs < 0)) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return DUK_EXEC_ERROR;); + } + args.call_flags = 0; + + return duk_safe_call(thr, duk__pcall_raw, (void *) &args /*udata*/, nargs + 1 /*nargs*/, 1 /*nrets*/); +} + +DUK_LOCAL duk_ret_t duk__pcall_method_raw(duk_hthread *thr, void *udata) { + duk__pcall_method_args *args; + duk_idx_t idx_func; + duk_int_t ret; + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(udata != NULL); + + args = (duk__pcall_method_args *) udata; + + idx_func = duk__call_get_idx_func_unvalidated(thr, args->nargs, 2); + DUK_ASSERT(duk_is_valid_index(thr, idx_func)); + + ret = duk_handle_call_unprotected(thr, idx_func, args->call_flags); + DUK_ASSERT(ret == 0); + DUK_UNREF(ret); + + return 1; +} + +DUK_INTERNAL duk_int_t duk_pcall_method_flags(duk_hthread *thr, duk_idx_t nargs, duk_small_uint_t call_flags) { + duk__pcall_method_args args; + + DUK_ASSERT_API_ENTRY(thr); + + args.nargs = nargs; + if (DUK_UNLIKELY(nargs < 0)) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return DUK_EXEC_ERROR;); + } + args.call_flags = call_flags; + + return duk_safe_call(thr, duk__pcall_method_raw, (void *) &args /*udata*/, nargs + 2 /*nargs*/, 1 /*nrets*/); +} + +DUK_EXTERNAL duk_int_t duk_pcall_method(duk_hthread *thr, duk_idx_t nargs) { + DUK_ASSERT_API_ENTRY(thr); + + return duk_pcall_method_flags(thr, nargs, 0); +} + +DUK_LOCAL duk_ret_t duk__pcall_prop_raw(duk_hthread *thr, void *udata) { + duk__pcall_prop_args *args; + duk_idx_t obj_idx; + duk_int_t ret; + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(udata != NULL); + + args = (duk__pcall_prop_args *) udata; + + obj_idx = duk_require_normalize_index(thr, args->obj_idx); /* make absolute */ + duk__call_prop_prep_stack(thr, obj_idx, args->nargs); + + ret = duk_handle_call_unprotected_nargs(thr, args->nargs, args->call_flags); + DUK_ASSERT(ret == 0); + DUK_UNREF(ret); + return 1; +} + +DUK_EXTERNAL duk_int_t duk_pcall_prop(duk_hthread *thr, duk_idx_t obj_idx, duk_idx_t nargs) { + duk__pcall_prop_args args; + + DUK_ASSERT_API_ENTRY(thr); + + args.obj_idx = obj_idx; + args.nargs = nargs; + if (DUK_UNLIKELY(nargs < 0)) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return DUK_EXEC_ERROR;); + } + args.call_flags = 0; + + return duk_safe_call(thr, duk__pcall_prop_raw, (void *) &args /*udata*/, nargs + 1 /*nargs*/, 1 /*nrets*/); +} + +DUK_EXTERNAL duk_int_t duk_safe_call(duk_hthread *thr, duk_safe_call_function func, void *udata, duk_idx_t nargs, duk_idx_t nrets) { + duk_int_t rc; + + DUK_ASSERT_API_ENTRY(thr); + + /* nargs condition; fail if: top - bottom < nargs + * <=> top < bottom + nargs + * nrets condition; fail if: end - (top - nargs) < nrets + * <=> end - top + nargs < nrets + * <=> end + nargs < top + nrets + */ + /* XXX: check for any reserve? */ + + if (DUK_UNLIKELY((nargs | nrets) < 0 || /* nargs < 0 || nrets < 0; OR sign bits */ + thr->valstack_top < thr->valstack_bottom + nargs || /* nargs too large compared to top */ + thr->valstack_end + nargs < thr->valstack_top + nrets)) { /* nrets too large compared to reserve */ + DUK_D(DUK_DPRINT("not enough stack reserve for safe call or invalid arguments: " + "nargs=%ld < 0 (?), nrets=%ld < 0 (?), top=%ld < bottom=%ld + nargs=%ld (?), " + "end=%ld + nargs=%ld < top=%ld + nrets=%ld (?)", + (long) nargs, + (long) nrets, + (long) (thr->valstack_top - thr->valstack), + (long) (thr->valstack_bottom - thr->valstack), + (long) nargs, + (long) (thr->valstack_end - thr->valstack), + (long) nargs, + (long) (thr->valstack_top - thr->valstack), + (long) nrets)); + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return DUK_EXEC_ERROR;); + } + + rc = duk_handle_safe_call(thr, /* thread */ + func, /* func */ + udata, /* udata */ + nargs, /* num_stack_args */ + nrets); /* num_stack_res */ + + return rc; +} + +DUK_EXTERNAL void duk_new(duk_hthread *thr, duk_idx_t nargs) { + duk_idx_t idx_func; + + DUK_ASSERT_API_ENTRY(thr); + + idx_func = duk__call_get_idx_func(thr, nargs, 1); + DUK_ASSERT(duk_is_valid_index(thr, idx_func)); + + duk_push_object(thr); /* default instance; internal proto updated by call handling */ + duk_insert(thr, idx_func + 1); + + duk_handle_call_unprotected(thr, idx_func, DUK_CALL_FLAG_CONSTRUCT); +} + +DUK_LOCAL duk_ret_t duk__pnew_helper(duk_hthread *thr, void *udata) { + duk_idx_t nargs; + + DUK_ASSERT(udata != NULL); + nargs = *((duk_idx_t *) udata); + + duk_new(thr, nargs); + return 1; +} + +DUK_EXTERNAL duk_int_t duk_pnew(duk_hthread *thr, duk_idx_t nargs) { + duk_int_t rc; + + DUK_ASSERT_API_ENTRY(thr); + + /* For now, just use duk_safe_call() to wrap duk_new(). We can't + * simply use a protected duk_handle_call() because pushing the + * default instance might throw. + */ + + if (DUK_UNLIKELY(nargs < 0)) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return DUK_EXEC_ERROR;); + } + + rc = duk_safe_call(thr, duk__pnew_helper, (void *) &nargs /*udata*/, nargs + 1 /*nargs*/, 1 /*nrets*/); + return rc; +} + +DUK_EXTERNAL duk_bool_t duk_is_constructor_call(duk_hthread *thr) { + duk_activation *act; + + DUK_ASSERT_API_ENTRY(thr); + + act = thr->callstack_curr; + if (act != NULL) { + return ((act->flags & DUK_ACT_FLAG_CONSTRUCT) != 0 ? 1 : 0); + } + return 0; +} + +DUK_EXTERNAL void duk_require_constructor_call(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + if (!duk_is_constructor_call(thr)) { + DUK_ERROR_TYPE(thr, DUK_STR_CONSTRUCT_ONLY); + DUK_WO_NORETURN(return;); + } +} + +DUK_EXTERNAL duk_bool_t duk_is_strict_call(duk_hthread *thr) { + duk_activation *act; + + /* For user code this could just return 1 (strict) always + * because all Duktape/C functions are considered strict, + * and strict is also the default when nothing is running. + * However, Duktape may call this function internally when + * the current activation is an ECMAScript function, so + * this cannot be replaced by a 'return 1' without fixing + * the internal call sites. + */ + + DUK_ASSERT_API_ENTRY(thr); + + act = thr->callstack_curr; + if (act != NULL) { + return ((act->flags & DUK_ACT_FLAG_STRICT) != 0 ? 1 : 0); + } else { + /* Strict by default. */ + return 1; + } +} + +/* + * Duktape/C function magic + */ + +DUK_EXTERNAL duk_int_t duk_get_current_magic(duk_hthread *thr) { + duk_activation *act; + duk_hobject *func; + + DUK_ASSERT_API_ENTRY(thr); + + act = thr->callstack_curr; + if (act) { + func = DUK_ACT_GET_FUNC(act); + if (!func) { + duk_tval *tv = &act->tv_func; + duk_small_uint_t lf_flags; + lf_flags = DUK_TVAL_GET_LIGHTFUNC_FLAGS(tv); + return (duk_int_t) DUK_LFUNC_FLAGS_GET_MAGIC(lf_flags); + } + DUK_ASSERT(func != NULL); + + if (DUK_HOBJECT_IS_NATFUNC(func)) { + duk_hnatfunc *nf = (duk_hnatfunc *) func; + return (duk_int_t) nf->magic; + } + } + return 0; +} + +DUK_EXTERNAL duk_int_t duk_get_magic(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, idx); + if (DUK_TVAL_IS_OBJECT(tv)) { + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + if (!DUK_HOBJECT_HAS_NATFUNC(h)) { + goto type_error; + } + return (duk_int_t) ((duk_hnatfunc *) h)->magic; + } else if (DUK_TVAL_IS_LIGHTFUNC(tv)) { + duk_small_uint_t lf_flags = DUK_TVAL_GET_LIGHTFUNC_FLAGS(tv); + return (duk_int_t) DUK_LFUNC_FLAGS_GET_MAGIC(lf_flags); + } + + /* fall through */ +type_error: + DUK_ERROR_TYPE(thr, DUK_STR_UNEXPECTED_TYPE); + DUK_WO_NORETURN(return 0;); +} + +DUK_EXTERNAL void duk_set_magic(duk_hthread *thr, duk_idx_t idx, duk_int_t magic) { + duk_hnatfunc *nf; + + DUK_ASSERT_API_ENTRY(thr); + + nf = duk_require_hnatfunc(thr, idx); + DUK_ASSERT(nf != NULL); + nf->magic = (duk_int16_t) magic; +} + +/* + * Misc helpers + */ + +/* Resolve a bound function on value stack top to a non-bound target + * (leave other values as is). + */ +DUK_INTERNAL void duk_resolve_nonbound_function(duk_hthread *thr) { + duk_tval *tv; + + DUK_HTHREAD_ASSERT_VALID(thr); + + tv = DUK_GET_TVAL_NEGIDX(thr, -1); + if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h; + + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + if (DUK_HOBJECT_HAS_BOUNDFUNC(h)) { + duk_push_tval(thr, &((duk_hboundfunc *) (void *) h)->target); + duk_replace(thr, -2); +#if 0 + DUK_TVAL_SET_TVAL(tv, &((duk_hboundfunc *) h)->target); + DUK_TVAL_INCREF(thr, tv); + DUK_HOBJECT_DECREF_NORZ(thr, h); +#endif + /* Rely on Function.prototype.bind() on never creating a bound + * function whose target is not proper. This is now safe + * because the target is not even an internal property but a + * struct member. + */ + DUK_ASSERT(duk_is_lightfunc(thr, -1) || duk_is_callable(thr, -1)); + } + } + + /* Lightfuncs cannot be bound but are always callable and + * constructable. + */ +} +#line 1 "duk_api_codec.c" +/* + * Encoding and decoding basic formats: hex, base64. + * + * These are in-place operations which may allow an optimized implementation. + * + * Base-64: https://tools.ietf.org/html/rfc4648#section-4 + */ + +/* #include duk_internal.h -> already included */ + +/* + * Misc helpers + */ + +/* Shared handling for encode/decode argument. Fast path handling for + * buffer and string values because they're the most common. In particular, + * avoid creating a temporary string or buffer when possible. Return value + * is guaranteed to be non-NULL, even for zero length input. + */ +DUK_LOCAL const duk_uint8_t *duk__prep_codec_arg(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_len) { + const void *def_ptr = (const void *) out_len; /* Any non-NULL pointer will do. */ + const void *ptr; + duk_bool_t isbuffer; + + DUK_ASSERT(out_len != NULL); + DUK_ASSERT(def_ptr != NULL); + DUK_ASSERT(duk_is_valid_index(thr, idx)); /* checked by caller */ + + ptr = (const void *) + duk_get_buffer_data_raw(thr, idx, out_len, NULL /*def_ptr*/, 0 /*def_size*/, 0 /*throw_flag*/, &isbuffer); + if (isbuffer) { + DUK_ASSERT(ptr != NULL || *out_len == 0U); + if (DUK_UNLIKELY(ptr == NULL)) { + ptr = def_ptr; + } + DUK_ASSERT(ptr != NULL); + } else { + /* For strings a non-NULL pointer is always guaranteed because + * at least a NUL will be present. + */ + ptr = (const void *) duk_to_lstring(thr, idx, out_len); + DUK_ASSERT(ptr != NULL); + } + DUK_ASSERT(ptr != NULL); + return (const duk_uint8_t *) ptr; +} + +/* + * Base64 + */ + +#if defined(DUK_USE_BASE64_SUPPORT) +/* Bytes emitted for number of padding characters in range [0,4]. */ +DUK_LOCAL const duk_int8_t duk__base64_decode_nequal_step[5] = { + 3, /* #### -> 24 bits, emit 3 bytes */ + 2, /* ###= -> 18 bits, emit 2 bytes */ + 1, /* ##== -> 12 bits, emit 1 byte */ + -1, /* #=== -> 6 bits, error */ + 0, /* ==== -> 0 bits, emit 0 bytes */ +}; + +#if defined(DUK_USE_BASE64_FASTPATH) +DUK_LOCAL const duk_uint8_t duk__base64_enctab_fast[64] = { + 0x41U, 0x42U, 0x43U, 0x44U, 0x45U, 0x46U, 0x47U, 0x48U, 0x49U, 0x4aU, 0x4bU, 0x4cU, 0x4dU, 0x4eU, 0x4fU, 0x50U, /* A...P */ + 0x51U, 0x52U, 0x53U, 0x54U, 0x55U, 0x56U, 0x57U, 0x58U, 0x59U, 0x5aU, 0x61U, 0x62U, 0x63U, 0x64U, 0x65U, 0x66U, /* Q...f */ + 0x67U, 0x68U, 0x69U, 0x6aU, 0x6bU, 0x6cU, 0x6dU, 0x6eU, 0x6fU, 0x70U, 0x71U, 0x72U, 0x73U, 0x74U, 0x75U, 0x76U, /* g...v */ + 0x77U, 0x78U, 0x79U, 0x7aU, 0x30U, 0x31U, 0x32U, 0x33U, 0x34U, 0x35U, 0x36U, 0x37U, 0x38U, 0x39U, 0x2bU, 0x2fU /* w.../ */ +}; +#endif /* DUK_USE_BASE64_FASTPATH */ + +#if defined(DUK_USE_BASE64_FASTPATH) +/* Decode table for one byte of input: + * -1 = allowed whitespace + * -2 = padding + * -3 = error + * 0...63 decoded bytes + */ +DUK_LOCAL const duk_int8_t duk__base64_dectab_fast[256] = { + -3, -3, -3, -3, -3, -3, -3, -3, -3, -1, -1, -3, -3, -1, -3, -3, /* 0x00...0x0f */ + -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, /* 0x10...0x1f */ + -1, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, 62, -3, -3, -3, 63, /* 0x20...0x2f */ + 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -3, -3, -3, -2, -3, -3, /* 0x30...0x3f */ + -3, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 0x40...0x4f */ + 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, -3, -3, -3, -3, -3, /* 0x50...0x5f */ + -3, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, /* 0x60...0x6f */ + 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, -3, -3, -3, -3, -3, /* 0x70...0x7f */ + -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, /* 0x80...0x8f */ + -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, /* 0x90...0x9f */ + -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, /* 0xa0...0xaf */ + -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, /* 0xb0...0xbf */ + -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, /* 0xc0...0xcf */ + -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, /* 0xd0...0xdf */ + -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, /* 0xe0...0xef */ + -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3, -3 /* 0xf0...0xff */ +}; +#endif /* DUK_USE_BASE64_FASTPATH */ + +#if defined(DUK_USE_BASE64_FASTPATH) +DUK_LOCAL DUK_ALWAYS_INLINE void duk__base64_encode_fast_3(const duk_uint8_t *src, duk_uint8_t *dst) { + duk_uint_t t; + + t = (duk_uint_t) src[0]; + t = (t << 8) + (duk_uint_t) src[1]; + t = (t << 8) + (duk_uint_t) src[2]; + + dst[0] = duk__base64_enctab_fast[t >> 18]; + dst[1] = duk__base64_enctab_fast[(t >> 12) & 0x3fU]; + dst[2] = duk__base64_enctab_fast[(t >> 6) & 0x3fU]; + dst[3] = duk__base64_enctab_fast[t & 0x3fU]; + +#if 0 + /* Tested: not faster on x64, most likely due to aliasing between + * output and input index computation. + */ + /* aaaaaabb bbbbcccc ccdddddd */ + dst[0] = duk__base64_enctab_fast[(src[0] >> 2) & 0x3fU]; + dst[1] = duk__base64_enctab_fast[((src[0] << 4) & 0x30U) | ((src[1] >> 4) & 0x0fU)]; + dst[2] = duk__base64_enctab_fast[((src[1] << 2) & 0x3fU) | ((src[2] >> 6) & 0x03U)]; + dst[3] = duk__base64_enctab_fast[src[2] & 0x3fU]; +#endif +} + +DUK_LOCAL DUK_ALWAYS_INLINE void duk__base64_encode_fast_2(const duk_uint8_t *src, duk_uint8_t *dst) { + duk_uint_t t; + + t = (duk_uint_t) src[0]; + t = (t << 8) + (duk_uint_t) src[1]; + dst[0] = duk__base64_enctab_fast[t >> 10]; /* XXXXXX-- -------- */ + dst[1] = duk__base64_enctab_fast[(t >> 4) & 0x3fU]; /* ------XX XXXX---- */ + dst[2] = duk__base64_enctab_fast[(t << 2) & 0x3fU]; /* -------- ----XXXX */ + dst[3] = DUK_ASC_EQUALS; +} + +DUK_LOCAL DUK_ALWAYS_INLINE void duk__base64_encode_fast_1(const duk_uint8_t *src, duk_uint8_t *dst) { + duk_uint_t t; + + t = (duk_uint_t) src[0]; + dst[0] = duk__base64_enctab_fast[t >> 2]; /* XXXXXX-- */ + dst[1] = duk__base64_enctab_fast[(t << 4) & 0x3fU]; /* ------XX */ + dst[2] = DUK_ASC_EQUALS; + dst[3] = DUK_ASC_EQUALS; +} + +DUK_LOCAL void duk__base64_encode_helper(const duk_uint8_t *src, duk_size_t srclen, duk_uint8_t *dst) { + duk_size_t n; + const duk_uint8_t *p; + duk_uint8_t *q; + + n = srclen; + p = src; + q = dst; + + if (n >= 16U) { + /* Fast path, unrolled by 4, allows interleaving. Process + * 12-byte input chunks which encode to 16-char output chunks. + * Only enter when at least one block is emitted (avoids div+mul + * for short inputs too). + */ + const duk_uint8_t *p_end_fast; + + p_end_fast = p + ((n / 12U) * 12U); + DUK_ASSERT(p_end_fast >= p + 12); + do { + duk__base64_encode_fast_3(p, q); + duk__base64_encode_fast_3(p + 3, q + 4); + duk__base64_encode_fast_3(p + 6, q + 8); + duk__base64_encode_fast_3(p + 9, q + 12); + p += 12; + q += 16; + } while (DUK_LIKELY(p != p_end_fast)); + + DUK_ASSERT(src + srclen >= p); + n = (duk_size_t) (src + srclen - p); + DUK_ASSERT(n < 12U); + } + + /* Remainder. */ + while (n >= 3U) { + duk__base64_encode_fast_3(p, q); + p += 3; + q += 4; + n -= 3U; + } + DUK_ASSERT(n == 0U || n == 1U || n == 2U); + if (n == 1U) { + duk__base64_encode_fast_1(p, q); +#if 0 /* Unnecessary. */ + p += 1; + q += 4; + n -= 1U; +#endif + } else if (n == 2U) { + duk__base64_encode_fast_2(p, q); +#if 0 /* Unnecessary. */ + p += 2; + q += 4; + n -= 2U; +#endif + } else { + DUK_ASSERT(n == 0U); /* nothing to do */ + ; + } +} +#else /* DUK_USE_BASE64_FASTPATH */ +DUK_LOCAL void duk__base64_encode_helper(const duk_uint8_t *src, duk_size_t srclen, duk_uint8_t *dst) { + duk_small_uint_t i, npad; + duk_uint_t t, x, y; + const duk_uint8_t *p; + const duk_uint8_t *p_end; + duk_uint8_t *q; + + p = src; + p_end = src + srclen; + q = dst; + npad = 0U; + + while (p < p_end) { + /* Read 3 bytes into 't', padded by zero. */ + t = 0; + for (i = 0; i < 3; i++) { + t = t << 8; + if (p < p_end) { + t += (duk_uint_t) (*p++); + } else { + /* This only happens on the last loop and we're + * guaranteed to exit on the next loop. + */ + npad++; + } + } + DUK_ASSERT(npad <= 2U); + + /* Emit 4 encoded characters. If npad > 0, some of the + * chars will be incorrect (zero bits) but we fix up the + * padding after the loop. A straightforward 64-byte + * lookup would be faster and cleaner, but this is shorter. + */ + for (i = 0; i < 4; i++) { + x = ((t >> 18) & 0x3fU); + t = t << 6; + + if (x <= 51U) { + if (x <= 25) { + y = x + DUK_ASC_UC_A; + } else { + y = x - 26 + DUK_ASC_LC_A; + } + } else { + if (x <= 61U) { + y = x - 52 + DUK_ASC_0; + } else if (x == 62) { + y = DUK_ASC_PLUS; + } else { + DUK_ASSERT(x == 63); + y = DUK_ASC_SLASH; + } + } + + *q++ = (duk_uint8_t) y; + } + } + + /* Handle padding by rewriting 0-2 bogus characters at the end. + * + * Missing bytes npad base64 example + * 0 0 #### + * 1 1 ###= + * 2 2 ##== + */ + DUK_ASSERT(npad <= 2U); + while (npad > 0U) { + *(q - npad) = DUK_ASC_EQUALS; + npad--; + } +} +#endif /* DUK_USE_BASE64_FASTPATH */ + +#if defined(DUK_USE_BASE64_FASTPATH) +DUK_LOCAL duk_bool_t duk__base64_decode_helper(const duk_uint8_t *src, + duk_size_t srclen, + duk_uint8_t *dst, + duk_uint8_t **out_dst_final) { + duk_int_t x; + duk_uint_t t; + duk_small_uint_t n_equal; + duk_int8_t step; + const duk_uint8_t *p; + const duk_uint8_t *p_end; + const duk_uint8_t *p_end_safe; + duk_uint8_t *q; + + DUK_ASSERT(src != NULL); /* Required by pointer arithmetic below, which fails for NULL. */ + + p = src; + p_end = src + srclen; + p_end_safe = p_end - 8; /* If 'src <= src_end_safe', safe to read 8 bytes. */ + q = dst; + + /* Alternate between a fast path which processes clean groups with no + * padding or whitespace, and a slow path which processes one arbitrary + * group and then re-enters the fast path. This handles e.g. base64 + * with newlines reasonably well because the majority of a line is in + * the fast path. + */ + for (;;) { + /* Fast path, on each loop handle two 4-char input groups. + * If both are clean, emit 6 bytes and continue. If first + * is clean, emit 3 bytes and drop out; otherwise emit + * nothing and drop out. This approach could be extended to + * more groups per loop, but for inputs with e.g. periodic + * newlines (which are common) it might not be an improvement. + */ + while (DUK_LIKELY(p <= p_end_safe)) { + duk_int_t t1, t2; + + /* The lookup byte is intentionally sign extended to + * (at least) 32 bits and then ORed. This ensures + * that is at least 1 byte is negative, the highest + * bit of the accumulator will be set at the end and + * we don't need to check every byte. + * + * Read all input bytes first before writing output + * bytes to minimize aliasing. + */ + DUK_DDD(DUK_DDDPRINT("fast loop: p=%p, p_end_safe=%p, p_end=%p", + (const void *) p, + (const void *) p_end_safe, + (const void *) p_end)); + + t1 = (duk_int_t) duk__base64_dectab_fast[p[0]]; + t1 = (duk_int_t) ((duk_uint_t) t1 << 6) | (duk_int_t) duk__base64_dectab_fast[p[1]]; + t1 = (duk_int_t) ((duk_uint_t) t1 << 6) | (duk_int_t) duk__base64_dectab_fast[p[2]]; + t1 = (duk_int_t) ((duk_uint_t) t1 << 6) | (duk_int_t) duk__base64_dectab_fast[p[3]]; + + t2 = (duk_int_t) duk__base64_dectab_fast[p[4]]; + t2 = (duk_int_t) ((duk_uint_t) t2 << 6) | (duk_int_t) duk__base64_dectab_fast[p[5]]; + t2 = (duk_int_t) ((duk_uint_t) t2 << 6) | (duk_int_t) duk__base64_dectab_fast[p[6]]; + t2 = (duk_int_t) ((duk_uint_t) t2 << 6) | (duk_int_t) duk__base64_dectab_fast[p[7]]; + + q[0] = (duk_uint8_t) (((duk_uint_t) t1 >> 16) & 0xffU); + q[1] = (duk_uint8_t) (((duk_uint_t) t1 >> 8) & 0xffU); + q[2] = (duk_uint8_t) ((duk_uint_t) t1 & 0xffU); + + q[3] = (duk_uint8_t) (((duk_uint_t) t2 >> 16) & 0xffU); + q[4] = (duk_uint8_t) (((duk_uint_t) t2 >> 8) & 0xffU); + q[5] = (duk_uint8_t) ((duk_uint_t) t2 & 0xffU); + + /* Optimistic check using one branch. */ + if (DUK_LIKELY((t1 | t2) >= 0)) { + p += 8; + q += 6; + } else if (t1 >= 0) { + DUK_DDD( + DUK_DDDPRINT("fast loop first group was clean, second was not, process one slow path group")); + DUK_ASSERT(t2 < 0); + p += 4; + q += 3; + break; + } else { + DUK_DDD(DUK_DDDPRINT( + "fast loop first group was not clean, second does not matter, process one slow path group")); + DUK_ASSERT(t1 < 0); + break; + } + } /* fast path */ + + /* Slow path step 1: try to scan a 4-character encoded group, + * end-of-input, or start-of-padding. We exit with: + * 1. n_chars == 4: full group, no padding, no end-of-input. + * 2. n_chars < 4: partial group (may also be 0), encountered + * padding or end of input. + * + * The accumulator is initialized to 1; this allows us to detect + * a full group by comparing >= 0x1000000 without an extra + * counter variable. + */ + t = 1UL; + for (;;) { + DUK_DDD(DUK_DDDPRINT("slow loop: p=%p, p_end=%p, t=%lu", + (const void *) p, + (const void *) p_end, + (unsigned long) t)); + + if (DUK_LIKELY(p < p_end)) { + x = duk__base64_dectab_fast[*p++]; + if (DUK_LIKELY(x >= 0)) { + DUK_ASSERT(x >= 0 && x <= 63); + t = (t << 6) + (duk_uint_t) x; + if (t >= 0x1000000UL) { + break; + } + } else if (x == -1) { + continue; /* allowed ascii whitespace */ + } else if (x == -2) { + p--; + break; /* start of padding */ + } else { + DUK_ASSERT(x == -3); + goto decode_error; + } + } else { + break; /* end of input */ + } + } /* slow path step 1 */ + + /* Complete the padding by simulating pad characters, + * regardless of actual input padding chars. + */ + n_equal = 0; + while (t < 0x1000000UL) { + t = (t << 6) + 0U; + n_equal++; + } + + /* Slow path step 2: deal with full/partial group, padding, + * etc. Note that for num chars in [0,3] we intentionally emit + * 3 bytes but don't step forward that much, buffer space is + * guaranteed in setup. + * + * num chars: + * 0 #### no output (= step 0) + * 1 #=== reject, 6 bits of data + * 2 ##== 12 bits of data, output 1 byte (= step 1) + * 3 ###= 18 bits of data, output 2 bytes (= step 2) + * 4 #### 24 bits of data, output 3 bytes (= step 3) + */ + q[0] = (duk_uint8_t) ((t >> 16) & 0xffU); + q[1] = (duk_uint8_t) ((t >> 8) & 0xffU); + q[2] = (duk_uint8_t) (t & 0xffU); + + DUK_ASSERT(n_equal <= 4); + step = duk__base64_decode_nequal_step[n_equal]; + if (DUK_UNLIKELY(step < 0)) { + goto decode_error; + } + q += step; + + /* Slow path step 3: read and ignore padding and whitespace + * until (a) next non-padding and non-whitespace character + * after which we resume the fast path, or (b) end of input. + * This allows us to accept missing, partial, full, and extra + * padding cases uniformly. We also support concatenated + * base-64 documents because we resume scanning afterwards. + * + * Note that to support concatenated documents well, the '=' + * padding found inside the input must also allow for 'extra' + * padding. For example, 'Zm===' decodes to 'f' and has one + * extra padding char. So, 'Zm===Zm' should decode 'ff', even + * though the standard break-up would be 'Zm==' + '=Zm' which + * doesn't make sense. + * + * We also accept prepended padding like '==Zm9', because it + * is equivalent to an empty document with extra padding ('==') + * followed by a valid document. + */ + + for (;;) { + if (DUK_UNLIKELY(p >= p_end)) { + goto done; + } + x = duk__base64_dectab_fast[*p++]; + if (x == -1 || x == -2) { + ; /* padding or whitespace, keep eating */ + } else { + p--; + break; /* backtrack and go back to fast path, even for -1 */ + } + } /* slow path step 3 */ + } /* outer fast+slow path loop */ + +done: + DUK_DDD(DUK_DDDPRINT("done; p=%p, p_end=%p", (const void *) p, (const void *) p_end)); + + DUK_ASSERT(p == p_end); + + *out_dst_final = q; + return 1; + +decode_error: + return 0; +} +#else /* DUK_USE_BASE64_FASTPATH */ +DUK_LOCAL duk_bool_t duk__base64_decode_helper(const duk_uint8_t *src, + duk_size_t srclen, + duk_uint8_t *dst, + duk_uint8_t **out_dst_final) { + duk_uint_t t, x; + duk_int_t y; + duk_int8_t step; + const duk_uint8_t *p; + const duk_uint8_t *p_end; + duk_uint8_t *q; + /* 0x09, 0x0a, or 0x0d */ + duk_uint32_t mask_white = (1U << 9) | (1U << 10) | (1U << 13); + + /* 't' tracks progress of the decoded group: + * + * t == 1 no valid chars yet + * t >= 0x40 1x6 = 6 bits shifted in + * t >= 0x1000 2x6 = 12 bits shifted in + * t >= 0x40000 3x6 = 18 bits shifted in + * t >= 0x1000000 4x6 = 24 bits shifted in + * + * By initializing t=1 there's no need for a separate counter for + * the number of characters found so far. + */ + p = src; + p_end = src + srclen; + q = dst; + t = 1UL; + + for (;;) { + duk_small_uint_t n_equal; + + DUK_ASSERT(t >= 1U); + if (p >= p_end) { + /* End of input: if input exists, treat like + * start of padding, finish the block, then + * re-enter here to see we're done. + */ + if (t == 1U) { + break; + } else { + goto simulate_padding; + } + } + + x = *p++; + + if (x >= 0x41U) { + /* Valid: a-z and A-Z. */ + DUK_ASSERT(x >= 0x41U && x <= 0xffU); + if (x >= 0x61U && x <= 0x7aU) { + y = (duk_int_t) x - 0x61 + 26; + } else if (x <= 0x5aU) { + y = (duk_int_t) x - 0x41; + } else { + goto decode_error; + } + } else if (x >= 0x30U) { + /* Valid: 0-9 and =. */ + DUK_ASSERT(x >= 0x30U && x <= 0x40U); + if (x <= 0x39U) { + y = (duk_int_t) x - 0x30 + 52; + } else if (x == 0x3dU) { + /* Skip padding and whitespace unless we're in the + * middle of a block. Otherwise complete group by + * simulating shifting in the correct padding. + */ + if (t == 1U) { + continue; + } + goto simulate_padding; + } else { + goto decode_error; + } + } else if (x >= 0x20U) { + /* Valid: +, /, and 0x20 whitespace. */ + DUK_ASSERT(x >= 0x20U && x <= 0x2fU); + if (x == 0x2bU) { + y = 62; + } else if (x == 0x2fU) { + y = 63; + } else if (x == 0x20U) { + continue; + } else { + goto decode_error; + } + } else { + /* Valid: whitespace. */ + duk_uint32_t m; + DUK_ASSERT(x < 0x20U); /* 0x00 to 0x1f */ + m = (1U << x); + if (mask_white & m) { + /* Allow basic ASCII whitespace. */ + continue; + } else { + goto decode_error; + } + } + + DUK_ASSERT(y >= 0 && y <= 63); + t = (t << 6) + (duk_uint_t) y; + if (t < 0x1000000UL) { + continue; + } + /* fall through; no padding will be added */ + + simulate_padding: + n_equal = 0; + while (t < 0x1000000UL) { + t = (t << 6) + 0U; + n_equal++; + } + + /* Output 3 bytes from 't' and advance as needed. */ + q[0] = (duk_uint8_t) ((t >> 16) & 0xffU); + q[1] = (duk_uint8_t) ((t >> 8) & 0xffU); + q[2] = (duk_uint8_t) (t & 0xffU); + + DUK_ASSERT(n_equal <= 4U); + step = duk__base64_decode_nequal_step[n_equal]; + if (step < 0) { + goto decode_error; + } + q += step; + + /* Re-enter loop. The actual padding characters are skipped + * by the main loop. This handles cases like missing, partial, + * full, and extra padding, and allows parsing of concatenated + * documents (with extra padding) like: Zm===Zm. Also extra + * prepended padding is accepted: ===Zm9v. + */ + t = 1U; + } + DUK_ASSERT(t == 1UL); + + *out_dst_final = q; + return 1; + +decode_error: + return 0; +} +#endif /* DUK_USE_BASE64_FASTPATH */ + +DUK_EXTERNAL const char *duk_base64_encode(duk_hthread *thr, duk_idx_t idx) { + const duk_uint8_t *src; + duk_size_t srclen; + duk_size_t dstlen; + duk_uint8_t *dst; + const char *ret; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + src = duk__prep_codec_arg(thr, idx, &srclen); + DUK_ASSERT(src != NULL); + + /* Compute exact output length. Computation must not wrap; this + * limit works for 32-bit size_t: + * >>> srclen = 3221225469 + * >>> '%x' % ((srclen + 2) / 3 * 4) + * 'fffffffc' + */ + if (srclen > 3221225469UL) { + goto type_error; + } + dstlen = (srclen + 2U) / 3U * 4U; + dst = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, dstlen); + + duk__base64_encode_helper((const duk_uint8_t *) src, srclen, dst); + + ret = duk_buffer_to_string(thr, -1); /* Safe, result is ASCII. */ + duk_replace(thr, idx); + return ret; + +type_error: + DUK_ERROR_TYPE(thr, DUK_STR_BASE64_ENCODE_FAILED); + DUK_WO_NORETURN(return NULL;); +} + +DUK_EXTERNAL void duk_base64_decode(duk_hthread *thr, duk_idx_t idx) { + const duk_uint8_t *src; + duk_size_t srclen; + duk_size_t dstlen; + duk_uint8_t *dst; + duk_uint8_t *dst_final; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + src = duk__prep_codec_arg(thr, idx, &srclen); + DUK_ASSERT(src != NULL); + + /* Round up and add safety margin. Avoid addition before division to + * avoid possibility of wrapping. Margin includes +3 for rounding up, + * and +3 for one extra group: the decoder may emit and then backtrack + * a full group (3 bytes) from zero-sized input for technical reasons. + * Similarly, 'xx' may ecause 1+3 = bytes to be emitted and then + * backtracked. + */ + dstlen = (srclen / 4) * 3 + 6; /* upper limit, assuming no whitespace etc */ + dst = (duk_uint8_t *) duk_push_dynamic_buffer(thr, dstlen); + /* Note: for dstlen=0, dst may be NULL */ + + if (!duk__base64_decode_helper((const duk_uint8_t *) src, srclen, dst, &dst_final)) { + goto type_error; + } + + /* XXX: convert to fixed buffer? */ + (void) duk_resize_buffer(thr, -1, (duk_size_t) (dst_final - dst)); + duk_replace(thr, idx); + return; + +type_error: + DUK_ERROR_TYPE(thr, DUK_STR_BASE64_DECODE_FAILED); + DUK_WO_NORETURN(return;); +} +#else /* DUK_USE_BASE64_SUPPORT */ +DUK_EXTERNAL const char *duk_base64_encode(duk_hthread *thr, duk_idx_t idx) { + DUK_UNREF(idx); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return NULL;); +} + +DUK_EXTERNAL void duk_base64_decode(duk_hthread *thr, duk_idx_t idx) { + DUK_UNREF(idx); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return;); +} +#endif /* DUK_USE_BASE64_SUPPORT */ + +/* + * Hex + */ + +#if defined(DUK_USE_HEX_SUPPORT) +DUK_EXTERNAL const char *duk_hex_encode(duk_hthread *thr, duk_idx_t idx) { + const duk_uint8_t *inp; + duk_size_t len; + duk_size_t i; + duk_uint8_t *buf; + const char *ret; +#if defined(DUK_USE_HEX_FASTPATH) + duk_size_t len_safe; + duk_uint16_t *p16; +#endif + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + inp = duk__prep_codec_arg(thr, idx, &len); + DUK_ASSERT(inp != NULL); + + /* Fixed buffer, no zeroing because we'll fill all the data. */ + buf = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, len * 2); + DUK_ASSERT(buf != NULL); + +#if defined(DUK_USE_HEX_FASTPATH) + DUK_ASSERT((((duk_size_t) buf) & 0x01U) == 0); /* pointer is aligned, guaranteed for fixed buffer */ + p16 = (duk_uint16_t *) (void *) buf; + len_safe = len & ~0x03U; + for (i = 0; i < len_safe; i += 4) { + p16[0] = duk_hex_enctab[inp[i]]; + p16[1] = duk_hex_enctab[inp[i + 1]]; + p16[2] = duk_hex_enctab[inp[i + 2]]; + p16[3] = duk_hex_enctab[inp[i + 3]]; + p16 += 4; + } + for (; i < len; i++) { + *p16++ = duk_hex_enctab[inp[i]]; + } +#else /* DUK_USE_HEX_FASTPATH */ + for (i = 0; i < len; i++) { + duk_small_uint_t t; + t = (duk_small_uint_t) inp[i]; + buf[i * 2 + 0] = duk_lc_digits[t >> 4]; + buf[i * 2 + 1] = duk_lc_digits[t & 0x0f]; + } +#endif /* DUK_USE_HEX_FASTPATH */ + + /* XXX: Using a string return value forces a string intern which is + * not always necessary. As a rough performance measure, hex encode + * time for tests/perf/test-hex-encode.js dropped from ~35s to ~15s + * without string coercion. Change to returning a buffer and let the + * caller coerce to string if necessary? + */ + + ret = duk_buffer_to_string(thr, -1); /* Safe, result is ASCII. */ + duk_replace(thr, idx); + return ret; +} + +DUK_EXTERNAL void duk_hex_decode(duk_hthread *thr, duk_idx_t idx) { + const duk_uint8_t *inp; + duk_size_t len; + duk_size_t i; + duk_int_t t; + duk_uint8_t *buf; +#if defined(DUK_USE_HEX_FASTPATH) + duk_int_t chk; + duk_uint8_t *p; + duk_size_t len_safe; +#endif + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + inp = duk__prep_codec_arg(thr, idx, &len); + DUK_ASSERT(inp != NULL); + + if (len & 0x01) { + goto type_error; + } + + /* Fixed buffer, no zeroing because we'll fill all the data. */ + buf = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, len / 2); + DUK_ASSERT(buf != NULL); + +#if defined(DUK_USE_HEX_FASTPATH) + p = buf; + len_safe = len & ~0x07U; + for (i = 0; i < len_safe; i += 8) { + t = ((duk_int_t) duk_hex_dectab_shift4[inp[i]]) | ((duk_int_t) duk_hex_dectab[inp[i + 1]]); + chk = t; + p[0] = (duk_uint8_t) t; + t = ((duk_int_t) duk_hex_dectab_shift4[inp[i + 2]]) | ((duk_int_t) duk_hex_dectab[inp[i + 3]]); + chk |= t; + p[1] = (duk_uint8_t) t; + t = ((duk_int_t) duk_hex_dectab_shift4[inp[i + 4]]) | ((duk_int_t) duk_hex_dectab[inp[i + 5]]); + chk |= t; + p[2] = (duk_uint8_t) t; + t = ((duk_int_t) duk_hex_dectab_shift4[inp[i + 6]]) | ((duk_int_t) duk_hex_dectab[inp[i + 7]]); + chk |= t; + p[3] = (duk_uint8_t) t; + p += 4; + + /* Check if any lookup above had a negative result. */ + if (DUK_UNLIKELY(chk < 0)) { + goto type_error; + } + } + for (; i < len; i += 2) { + /* First cast to duk_int_t to sign extend, second cast to + * duk_uint_t to avoid signed left shift, and final cast to + * duk_int_t result type. + */ + t = (duk_int_t) ((((duk_uint_t) (duk_int_t) duk_hex_dectab[inp[i]]) << 4U) | + ((duk_uint_t) (duk_int_t) duk_hex_dectab[inp[i + 1]])); + if (DUK_UNLIKELY(t < 0)) { + goto type_error; + } + *p++ = (duk_uint8_t) t; + } +#else /* DUK_USE_HEX_FASTPATH */ + for (i = 0; i < len; i += 2) { + /* For invalid characters the value -1 gets extended to + * at least 16 bits. If either nybble is invalid, the + * resulting 't' will be < 0. + */ + t = (duk_int_t) ((((duk_uint_t) (duk_int_t) duk_hex_dectab[inp[i]]) << 4U) | + ((duk_uint_t) (duk_int_t) duk_hex_dectab[inp[i + 1]])); + if (DUK_UNLIKELY(t < 0)) { + goto type_error; + } + buf[i >> 1] = (duk_uint8_t) t; + } +#endif /* DUK_USE_HEX_FASTPATH */ + + duk_replace(thr, idx); + return; + +type_error: + DUK_ERROR_TYPE(thr, DUK_STR_HEX_DECODE_FAILED); + DUK_WO_NORETURN(return;); +} +#else /* DUK_USE_HEX_SUPPORT */ +DUK_EXTERNAL const char *duk_hex_encode(duk_hthread *thr, duk_idx_t idx) { + DUK_UNREF(idx); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return NULL;); +} +DUK_EXTERNAL void duk_hex_decode(duk_hthread *thr, duk_idx_t idx) { + DUK_UNREF(idx); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return;); +} +#endif /* DUK_USE_HEX_SUPPORT */ + +/* + * JSON + */ + +#if defined(DUK_USE_JSON_SUPPORT) +DUK_EXTERNAL const char *duk_json_encode(duk_hthread *thr, duk_idx_t idx) { +#if defined(DUK_USE_ASSERTIONS) + duk_idx_t top_at_entry; +#endif + const char *ret; + + DUK_ASSERT_API_ENTRY(thr); +#if defined(DUK_USE_ASSERTIONS) + top_at_entry = duk_get_top(thr); +#endif + + idx = duk_require_normalize_index(thr, idx); + duk_bi_json_stringify_helper(thr, + idx /*idx_value*/, + DUK_INVALID_INDEX /*idx_replacer*/, + DUK_INVALID_INDEX /*idx_space*/, + 0 /*flags*/); + DUK_ASSERT(duk_is_string(thr, -1)); + duk_replace(thr, idx); + ret = duk_get_string(thr, idx); + + DUK_ASSERT(duk_get_top(thr) == top_at_entry); + + return ret; +} + +DUK_EXTERNAL void duk_json_decode(duk_hthread *thr, duk_idx_t idx) { +#if defined(DUK_USE_ASSERTIONS) + duk_idx_t top_at_entry; +#endif + + DUK_ASSERT_API_ENTRY(thr); +#if defined(DUK_USE_ASSERTIONS) + top_at_entry = duk_get_top(thr); +#endif + + idx = duk_require_normalize_index(thr, idx); + duk_bi_json_parse_helper(thr, idx /*idx_value*/, DUK_INVALID_INDEX /*idx_reviver*/, 0 /*flags*/); + duk_replace(thr, idx); + + DUK_ASSERT(duk_get_top(thr) == top_at_entry); +} +#else /* DUK_USE_JSON_SUPPORT */ +DUK_EXTERNAL const char *duk_json_encode(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(idx); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return NULL;); +} + +DUK_EXTERNAL void duk_json_decode(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(idx); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return;); +} +#endif /* DUK_USE_JSON_SUPPORT */ +#line 1 "duk_api_compile.c" +/* + * Compilation and evaluation + */ + +/* #include duk_internal.h -> already included */ + +typedef struct duk__compile_raw_args duk__compile_raw_args; +struct duk__compile_raw_args { + duk_size_t src_length; /* should be first on 64-bit platforms */ + const duk_uint8_t *src_buffer; + duk_uint_t flags; +}; + +/* Eval is just a wrapper now. */ +DUK_EXTERNAL duk_int_t duk_eval_raw(duk_hthread *thr, const char *src_buffer, duk_size_t src_length, duk_uint_t flags) { + duk_int_t rc; + + DUK_ASSERT_API_ENTRY(thr); + + /* Note: strictness is *not* inherited from the current Duktape/C. + * This would be confusing because the current strictness state + * depends on whether we're running inside a Duktape/C activation + * (= strict mode) or outside of any activation (= non-strict mode). + * See tests/api/test-eval-strictness.c for more discussion. + */ + + /* [ ... source? filename? ] (depends on flags) */ + + rc = duk_compile_raw(thr, + src_buffer, + src_length, + flags | DUK_COMPILE_EVAL); /* may be safe, or non-safe depending on flags */ + + /* [ ... closure/error ] */ + + if (rc != DUK_EXEC_SUCCESS) { + rc = DUK_EXEC_ERROR; + goto got_rc; + } + + duk_push_global_object(thr); /* explicit 'this' binding, see GH-164 */ + + if (flags & DUK_COMPILE_SAFE) { + rc = duk_pcall_method(thr, 0); + } else { + duk_call_method(thr, 0); + rc = DUK_EXEC_SUCCESS; + } + + /* [ ... result/error ] */ + +got_rc: + if (flags & DUK_COMPILE_NORESULT) { + duk_pop(thr); + } + + return rc; +} + +/* Helper which can be called both directly and with duk_safe_call(). */ +DUK_LOCAL duk_ret_t duk__do_compile(duk_hthread *thr, void *udata) { + duk__compile_raw_args *comp_args; + duk_uint_t flags; + duk_hcompfunc *h_templ; + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(udata != NULL); + + /* Note: strictness is not inherited from the current Duktape/C + * context. Otherwise it would not be possible to compile + * non-strict code inside a Duktape/C activation (which is + * always strict now). See tests/api/test-eval-strictness.c + * for discussion. + */ + + /* [ ... source? filename? ] (depends on flags) */ + + comp_args = (duk__compile_raw_args *) udata; + flags = comp_args->flags; + + if (flags & DUK_COMPILE_NOFILENAME) { + /* Automatic filename: 'eval' or 'input'. */ + duk_push_hstring_stridx(thr, (flags & DUK_COMPILE_EVAL) ? DUK_STRIDX_EVAL : DUK_STRIDX_INPUT); + } + + /* [ ... source? filename ] */ + + if (!comp_args->src_buffer) { + duk_hstring *h_sourcecode; + + h_sourcecode = duk_get_hstring(thr, -2); + if ((flags & DUK_COMPILE_NOSOURCE) || /* args incorrect */ + (h_sourcecode == NULL)) { /* e.g. duk_push_string_file_raw() pushed undefined */ + DUK_ERROR_TYPE(thr, DUK_STR_NO_SOURCECODE); + DUK_WO_NORETURN(return 0;); + } + DUK_ASSERT(h_sourcecode != NULL); + comp_args->src_buffer = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_sourcecode); + comp_args->src_length = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h_sourcecode); + } + DUK_ASSERT(comp_args->src_buffer != NULL); + + if (flags & DUK_COMPILE_FUNCTION) { + flags |= DUK_COMPILE_EVAL | DUK_COMPILE_FUNCEXPR; + } + + /* [ ... source? filename ] */ + + duk_js_compile(thr, comp_args->src_buffer, comp_args->src_length, flags); + + /* [ ... source? func_template ] */ + + if (flags & DUK_COMPILE_NOSOURCE) { + ; + } else { + duk_remove_m2(thr); + } + + /* [ ... func_template ] */ + + h_templ = (duk_hcompfunc *) duk_known_hobject(thr, -1); + duk_js_push_closure(thr, + h_templ, + thr->builtins[DUK_BIDX_GLOBAL_ENV], + thr->builtins[DUK_BIDX_GLOBAL_ENV], + 1 /*add_auto_proto*/); + duk_remove_m2(thr); /* -> [ ... closure ] */ + + /* [ ... closure ] */ + + return 1; +} + +DUK_EXTERNAL duk_int_t duk_compile_raw(duk_hthread *thr, const char *src_buffer, duk_size_t src_length, duk_uint_t flags) { + duk__compile_raw_args comp_args_alloc; + duk__compile_raw_args *comp_args = &comp_args_alloc; + + DUK_ASSERT_API_ENTRY(thr); + + if ((flags & DUK_COMPILE_STRLEN) && (src_buffer != NULL)) { + /* String length is computed here to avoid multiple evaluation + * of a macro argument in the calling side. + */ + src_length = DUK_STRLEN(src_buffer); + } + + comp_args->src_buffer = (const duk_uint8_t *) src_buffer; + comp_args->src_length = src_length; + comp_args->flags = flags; + + /* [ ... source? filename? ] (depends on flags) */ + + if (flags & DUK_COMPILE_SAFE) { + duk_int_t rc; + duk_int_t nargs; + duk_int_t nrets = 1; + + /* Arguments can be: [ source? filename? &comp_args] so that + * nargs is 1 to 3. Call site encodes the correct nargs count + * directly into flags. + */ + nargs = flags & 0x07; + DUK_ASSERT(nargs == ((flags & DUK_COMPILE_NOSOURCE) ? 0 : 1) + ((flags & DUK_COMPILE_NOFILENAME) ? 0 : 1)); + rc = duk_safe_call(thr, duk__do_compile, (void *) comp_args, nargs, nrets); + + /* [ ... closure ] */ + return rc; + } + + (void) duk__do_compile(thr, (void *) comp_args); + + /* [ ... closure ] */ + return DUK_EXEC_SUCCESS; +} +#line 1 "duk_api_debug.c" +/* + * Debugging related API calls + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_JSON_SUPPORT) +DUK_EXTERNAL void duk_push_context_dump(duk_hthread *thr) { + duk_idx_t idx; + duk_idx_t top; + + DUK_ASSERT_API_ENTRY(thr); + + /* We don't duk_require_stack() here now, but rely on the caller having + * enough space. + */ + + top = duk_get_top(thr); + duk_push_bare_array(thr); + for (idx = 0; idx < top; idx++) { + duk_dup(thr, idx); + duk_put_prop_index(thr, -2, (duk_uarridx_t) idx); + } + + /* XXX: conversion errors should not propagate outwards. + * Perhaps values need to be coerced individually? + */ + duk_bi_json_stringify_helper(thr, + duk_get_top_index(thr), /*idx_value*/ + DUK_INVALID_INDEX, /*idx_replacer*/ + DUK_INVALID_INDEX, /*idx_space*/ + DUK_JSON_FLAG_EXT_CUSTOM | DUK_JSON_FLAG_ASCII_ONLY | + DUK_JSON_FLAG_AVOID_KEY_QUOTES /*flags*/); + + duk_push_sprintf(thr, "ctx: top=%ld, stack=%s", (long) top, (const char *) duk_safe_to_string(thr, -1)); + duk_replace(thr, -3); /* [ ... arr jsonx(arr) res ] -> [ ... res jsonx(arr) ] */ + duk_pop(thr); + DUK_ASSERT(duk_is_string(thr, -1)); +} +#else /* DUK_USE_JSON_SUPPORT */ +DUK_EXTERNAL void duk_push_context_dump(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return;); +} +#endif /* DUK_USE_JSON_SUPPORT */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + +DUK_EXTERNAL void duk_debugger_attach(duk_hthread *thr, + duk_debug_read_function read_cb, + duk_debug_write_function write_cb, + duk_debug_peek_function peek_cb, + duk_debug_read_flush_function read_flush_cb, + duk_debug_write_flush_function write_flush_cb, + duk_debug_request_function request_cb, + duk_debug_detached_function detached_cb, + void *udata) { + duk_heap *heap; + const char *str; + duk_size_t len; + + /* XXX: should there be an error or an automatic detach if + * already attached? + */ + + DUK_D(DUK_DPRINT("application called duk_debugger_attach()")); + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(read_cb != NULL); + DUK_ASSERT(write_cb != NULL); + /* Other callbacks are optional. */ + + heap = thr->heap; + heap->dbg_read_cb = read_cb; + heap->dbg_write_cb = write_cb; + heap->dbg_peek_cb = peek_cb; + heap->dbg_read_flush_cb = read_flush_cb; + heap->dbg_write_flush_cb = write_flush_cb; + heap->dbg_request_cb = request_cb; + heap->dbg_detached_cb = detached_cb; + heap->dbg_udata = udata; + heap->dbg_have_next_byte = 0; + + /* Start in paused state. */ + heap->dbg_processing = 0; + heap->dbg_state_dirty = 0; + heap->dbg_force_restart = 0; + heap->dbg_pause_flags = 0; + heap->dbg_pause_act = NULL; + heap->dbg_pause_startline = 0; + heap->dbg_exec_counter = 0; + heap->dbg_last_counter = 0; + heap->dbg_last_time = 0.0; + duk_debug_set_paused(heap); /* XXX: overlap with fields above */ + + /* Send version identification and flush right afterwards. Note that + * we must write raw, unframed bytes here. + */ + duk_push_sprintf(thr, + "%ld %ld %s %s\n", + (long) DUK_DEBUG_PROTOCOL_VERSION, + (long) DUK_VERSION, + (const char *) DUK_GIT_DESCRIBE, + (const char *) DUK_USE_TARGET_INFO); + str = duk_get_lstring(thr, -1, &len); + DUK_ASSERT(str != NULL); + duk_debug_write_bytes(thr, (const duk_uint8_t *) str, len); + duk_debug_write_flush(thr); + duk_pop(thr); +} + +DUK_EXTERNAL void duk_debugger_detach(duk_hthread *thr) { + DUK_D(DUK_DPRINT("application called duk_debugger_detach()")); + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->heap != NULL); + + /* Can be called multiple times with no harm. */ + duk_debug_do_detach(thr->heap); +} + +DUK_EXTERNAL void duk_debugger_cooperate(duk_hthread *thr) { + duk_bool_t processed_messages; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->heap != NULL); + + if (!duk_debug_is_attached(thr->heap)) { + return; + } + if (thr->callstack_curr != NULL || thr->heap->dbg_processing) { + /* Calling duk_debugger_cooperate() while Duktape is being + * called into is not supported. This is not a 100% check + * but prevents any damage in most cases. + */ + return; + } + + processed_messages = duk_debug_process_messages(thr, 1 /*no_block*/); + DUK_UNREF(processed_messages); +} + +DUK_EXTERNAL duk_bool_t duk_debugger_notify(duk_hthread *thr, duk_idx_t nvalues) { + duk_idx_t top; + duk_idx_t idx; + duk_bool_t ret = 0; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->heap != NULL); + + DUK_D(DUK_DPRINT("application called duk_debugger_notify() with nvalues=%ld", (long) nvalues)); + + top = duk_get_top(thr); + if (top < nvalues) { + DUK_ERROR_RANGE(thr, "not enough stack values for notify"); + DUK_WO_NORETURN(return 0;); + } + if (duk_debug_is_attached(thr->heap)) { + duk_debug_write_notify(thr, DUK_DBG_CMD_APPNOTIFY); + for (idx = top - nvalues; idx < top; idx++) { + duk_tval *tv = DUK_GET_TVAL_POSIDX(thr, idx); + duk_debug_write_tval(thr, tv); + } + duk_debug_write_eom(thr); + + /* Return non-zero (true) if we have a good reason to believe + * the notify was delivered; if we're still attached at least + * a transport error was not indicated by the transport write + * callback. This is not a 100% guarantee of course. + */ + if (duk_debug_is_attached(thr->heap)) { + ret = 1; + } + } + duk_pop_n(thr, nvalues); + return ret; +} + +DUK_EXTERNAL void duk_debugger_pause(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->heap != NULL); + + DUK_D(DUK_DPRINT("application called duk_debugger_pause()")); + + /* Treat like a debugger statement: ignore when not attached. */ + if (duk_debug_is_attached(thr->heap)) { + if (duk_debug_is_paused(thr->heap)) { + DUK_D(DUK_DPRINT("duk_debugger_pause() called when already paused; ignoring")); + } else { + duk_debug_set_paused(thr->heap); + + /* Pause on the next opcode executed. This is always safe to do even + * inside the debugger message loop: the interrupt counter will be reset + * to its proper value when the message loop exits. + */ + thr->interrupt_init = 1; + thr->interrupt_counter = 0; + } + } +} + +#else /* DUK_USE_DEBUGGER_SUPPORT */ + +DUK_EXTERNAL void duk_debugger_attach(duk_hthread *thr, + duk_debug_read_function read_cb, + duk_debug_write_function write_cb, + duk_debug_peek_function peek_cb, + duk_debug_read_flush_function read_flush_cb, + duk_debug_write_flush_function write_flush_cb, + duk_debug_request_function request_cb, + duk_debug_detached_function detached_cb, + void *udata) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(read_cb); + DUK_UNREF(write_cb); + DUK_UNREF(peek_cb); + DUK_UNREF(read_flush_cb); + DUK_UNREF(write_flush_cb); + DUK_UNREF(request_cb); + DUK_UNREF(detached_cb); + DUK_UNREF(udata); + DUK_ERROR_TYPE(thr, "no debugger support"); + DUK_WO_NORETURN(return;); +} + +DUK_EXTERNAL void duk_debugger_detach(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ERROR_TYPE(thr, "no debugger support"); + DUK_WO_NORETURN(return;); +} + +DUK_EXTERNAL void duk_debugger_cooperate(duk_hthread *thr) { + /* nop */ + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(thr); +} + +DUK_EXTERNAL duk_bool_t duk_debugger_notify(duk_hthread *thr, duk_idx_t nvalues) { + duk_idx_t top; + + DUK_ASSERT_API_ENTRY(thr); + + top = duk_get_top(thr); + if (top < nvalues) { + DUK_ERROR_RANGE_INVALID_COUNT(thr); + DUK_WO_NORETURN(return 0;); + } + + /* No debugger support, just pop values. */ + duk_pop_n(thr, nvalues); + return 0; +} + +DUK_EXTERNAL void duk_debugger_pause(duk_hthread *thr) { + /* Treat like debugger statement: nop */ + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(thr); +} + +#endif /* DUK_USE_DEBUGGER_SUPPORT */ +#line 1 "duk_api_heap.c" +/* + * Heap creation and destruction + */ + +/* #include duk_internal.h -> already included */ + +typedef struct duk_internal_thread_state duk_internal_thread_state; + +struct duk_internal_thread_state { + duk_ljstate lj; + duk_bool_t creating_error; + duk_hthread *curr_thread; + duk_uint8_t thread_state; + duk_int_t call_recursion_depth; +}; + +DUK_EXTERNAL duk_hthread *duk_create_heap(duk_alloc_function alloc_func, + duk_realloc_function realloc_func, + duk_free_function free_func, + void *heap_udata, + duk_fatal_function fatal_handler) { + duk_heap *heap = NULL; + duk_hthread *thr; + + /* Assume that either all memory funcs are NULL or non-NULL, mixed + * cases will now be unsafe. + */ + + /* XXX: just assert non-NULL values here and make caller arguments + * do the defaulting to the default implementations (smaller code)? + */ + + if (!alloc_func) { + DUK_ASSERT(realloc_func == NULL); + DUK_ASSERT(free_func == NULL); +#if defined(DUK_USE_PROVIDE_DEFAULT_ALLOC_FUNCTIONS) + alloc_func = duk_default_alloc_function; + realloc_func = duk_default_realloc_function; + free_func = duk_default_free_function; +#else + DUK_D(DUK_DPRINT("no allocation functions given and no default providers")); + return NULL; +#endif + } else { + DUK_ASSERT(realloc_func != NULL); + DUK_ASSERT(free_func != NULL); + } + + if (!fatal_handler) { + fatal_handler = duk_default_fatal_handler; + } + + DUK_ASSERT(alloc_func != NULL); + DUK_ASSERT(realloc_func != NULL); + DUK_ASSERT(free_func != NULL); + DUK_ASSERT(fatal_handler != NULL); + + heap = duk_heap_alloc(alloc_func, realloc_func, free_func, heap_udata, fatal_handler); + if (!heap) { + return NULL; + } + thr = heap->heap_thread; + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + return thr; +} + +DUK_EXTERNAL void duk_destroy_heap(duk_hthread *thr) { + duk_heap *heap; + + if (!thr) { + return; + } + DUK_ASSERT_API_ENTRY(thr); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + + duk_heap_free(heap); +} + +DUK_EXTERNAL void duk_suspend(duk_hthread *thr, duk_thread_state *state) { + duk_internal_thread_state *snapshot = (duk_internal_thread_state *) (void *) state; + duk_heap *heap; + duk_ljstate *lj; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(state != NULL); /* unvalidated */ + + /* Currently not supported when called from within a finalizer. + * If that is done, the finalizer will remain running indefinitely, + * preventing other finalizers from executing. The assert is a bit + * wider, checking that it would be OK to run pending finalizers. + */ + DUK_ASSERT(thr->heap->pf_prevent_count == 0); + + /* Currently not supported to duk_suspend() from an errCreate() + * call. + */ + DUK_ASSERT(thr->heap->creating_error == 0); + + heap = thr->heap; + lj = &heap->lj; + + duk_push_tval(thr, &lj->value1); + duk_push_tval(thr, &lj->value2); + + /* XXX: creating_error == 0 is asserted above, so no need to store. */ + duk_memcpy((void *) &snapshot->lj, (const void *) lj, sizeof(duk_ljstate)); + snapshot->creating_error = heap->creating_error; + snapshot->curr_thread = heap->curr_thread; + snapshot->thread_state = thr->state; + snapshot->call_recursion_depth = heap->call_recursion_depth; + + lj->jmpbuf_ptr = NULL; + lj->type = DUK_LJ_TYPE_UNKNOWN; + DUK_TVAL_SET_UNDEFINED(&lj->value1); + DUK_TVAL_SET_UNDEFINED(&lj->value2); + heap->creating_error = 0; + heap->curr_thread = NULL; + heap->call_recursion_depth = 0; + + thr->state = DUK_HTHREAD_STATE_INACTIVE; +} + +DUK_EXTERNAL void duk_resume(duk_hthread *thr, const duk_thread_state *state) { + const duk_internal_thread_state *snapshot = (const duk_internal_thread_state *) (const void *) state; + duk_heap *heap; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(state != NULL); /* unvalidated */ + + /* Shouldn't be necessary if duk_suspend() is called before + * duk_resume(), but assert in case API sequence is incorrect. + */ + DUK_ASSERT(thr->heap->pf_prevent_count == 0); + DUK_ASSERT(thr->heap->creating_error == 0); + + thr->state = snapshot->thread_state; + + heap = thr->heap; + + duk_memcpy((void *) &heap->lj, (const void *) &snapshot->lj, sizeof(duk_ljstate)); + heap->creating_error = snapshot->creating_error; + heap->curr_thread = snapshot->curr_thread; + heap->call_recursion_depth = snapshot->call_recursion_depth; + + duk_pop_2(thr); +} + +/* XXX: better place for this */ +DUK_EXTERNAL void duk_set_global_object(duk_hthread *thr) { + duk_hobject *h_glob; + duk_hobject *h_prev_glob; + duk_hobjenv *h_env; + duk_hobject *h_prev_env; + + DUK_ASSERT_API_ENTRY(thr); + + DUK_D(DUK_DPRINT("replace global object with: %!T", duk_get_tval(thr, -1))); + + h_glob = duk_require_hobject(thr, -1); + DUK_ASSERT(h_glob != NULL); + + /* + * Replace global object. + */ + + h_prev_glob = thr->builtins[DUK_BIDX_GLOBAL]; + DUK_UNREF(h_prev_glob); + thr->builtins[DUK_BIDX_GLOBAL] = h_glob; + DUK_HOBJECT_INCREF(thr, h_glob); + DUK_HOBJECT_DECREF_ALLOWNULL(thr, h_prev_glob); /* side effects, in theory (referenced by global env) */ + + /* + * Replace lexical environment for global scope + * + * Create a new object environment for the global lexical scope. + * We can't just reset the _Target property of the current one, + * because the lexical scope is shared by other threads with the + * same (initial) built-ins. + */ + + h_env = duk_hobjenv_alloc(thr, DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJENV)); + DUK_ASSERT(h_env != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) h_env) == NULL); + + DUK_ASSERT(h_env->target == NULL); + DUK_ASSERT(h_glob != NULL); + h_env->target = h_glob; + DUK_HOBJECT_INCREF(thr, h_glob); + DUK_ASSERT(h_env->has_this == 0); + + /* [ ... new_glob ] */ + + h_prev_env = thr->builtins[DUK_BIDX_GLOBAL_ENV]; + thr->builtins[DUK_BIDX_GLOBAL_ENV] = (duk_hobject *) h_env; + DUK_HOBJECT_INCREF(thr, (duk_hobject *) h_env); + DUK_HOBJECT_DECREF_ALLOWNULL(thr, h_prev_env); /* side effects */ + DUK_UNREF(h_env); /* without refcounts */ + DUK_UNREF(h_prev_env); + + /* [ ... new_glob ] */ + + duk_pop(thr); + + /* [ ... ] */ +} +#line 1 "duk_api_inspect.c" +/* + * Inspection + */ + +/* #include duk_internal.h -> already included */ + +/* For footprint efficient multiple value setting: arrays are much better than + * varargs, format string with parsing is often better than string pointer arrays. + */ +DUK_LOCAL void duk__inspect_multiple_uint(duk_hthread *thr, const char *fmt, duk_int_t *vals) { + duk_int_t val; + const char *p; + const char *p_curr; + duk_size_t len; + + for (p = fmt;;) { + len = DUK_STRLEN(p); + p_curr = p; + p += len + 1; + if (len == 0) { + /* Double NUL (= empty key) terminates. */ + break; + } + val = *vals++; + if (val >= 0) { + /* Negative values are markers to skip key. */ + duk_push_string(thr, p_curr); + duk_push_int(thr, val); + duk_put_prop(thr, -3); + } + } +} + +/* Raw helper to extract internal information / statistics about a value. + * The return value is an object with properties that are version specific. + * The properties must not expose anything that would lead to security + * issues (e.g. exposing compiled function 'data' buffer might be an issue). + * Currently only counts and sizes and such are given so there shouldn't + * be security implications. + */ + +#define DUK__IDX_TYPE 0 +#define DUK__IDX_ITAG 1 +#define DUK__IDX_REFC 2 +#define DUK__IDX_HBYTES 3 +#define DUK__IDX_CLASS 4 +#define DUK__IDX_PBYTES 5 +#define DUK__IDX_ESIZE 6 +#define DUK__IDX_ENEXT 7 +#define DUK__IDX_ASIZE 8 +#define DUK__IDX_HSIZE 9 +#define DUK__IDX_BCBYTES 10 +#define DUK__IDX_DBYTES 11 +#define DUK__IDX_TSTATE 12 +#define DUK__IDX_VARIANT 13 + +DUK_EXTERNAL void duk_inspect_value(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_heaphdr *h; + /* The temporary values should be in an array rather than individual + * variables which (in practice) ensures that the compiler won't map + * them to registers and emit a lot of unnecessary shuffling code. + */ + duk_int_t vals[14]; + + DUK_ASSERT_API_ENTRY(thr); + + /* Assume two's complement and set everything to -1. */ + duk_memset((void *) &vals, (int) 0xff, sizeof(vals)); + DUK_ASSERT(vals[DUK__IDX_TYPE] == -1); /* spot check one */ + + tv = duk_get_tval_or_unused(thr, idx); + h = (DUK_TVAL_IS_HEAP_ALLOCATED(tv) ? DUK_TVAL_GET_HEAPHDR(tv) : NULL); + + vals[DUK__IDX_TYPE] = duk_get_type_tval(tv); + vals[DUK__IDX_ITAG] = (duk_int_t) DUK_TVAL_GET_TAG(tv); + + duk_push_bare_object(thr); /* Invalidates 'tv'. */ + tv = NULL; + + if (h == NULL) { + goto finish; + } + duk_push_pointer(thr, (void *) h); + duk_put_prop_literal(thr, -2, "hptr"); + +#if 0 + /* Covers a lot of information, e.g. buffer and string variants. */ + duk_push_uint(thr, (duk_uint_t) DUK_HEAPHDR_GET_FLAGS(h)); + duk_put_prop_literal(thr, -2, "hflags"); +#endif + +#if defined(DUK_USE_REFERENCE_COUNTING) + vals[DUK__IDX_REFC] = (duk_int_t) DUK_HEAPHDR_GET_REFCOUNT(h); +#endif + vals[DUK__IDX_VARIANT] = 0; + + /* Heaphdr size and additional allocation size, followed by + * type specific stuff (with varying value count). + */ + switch ((duk_small_int_t) DUK_HEAPHDR_GET_TYPE(h)) { + case DUK_HTYPE_STRING: { + duk_hstring *h_str = (duk_hstring *) h; + vals[DUK__IDX_HBYTES] = (duk_int_t) (sizeof(duk_hstring) + DUK_HSTRING_GET_BYTELEN(h_str) + 1); +#if defined(DUK_USE_HSTRING_EXTDATA) + if (DUK_HSTRING_HAS_EXTDATA(h_str)) { + vals[DUK__IDX_VARIANT] = 1; + } +#endif + break; + } + case DUK_HTYPE_OBJECT: { + duk_hobject *h_obj = (duk_hobject *) h; + + /* XXX: variants here are maybe pointless; class is enough? */ + if (DUK_HOBJECT_IS_ARRAY(h_obj)) { + vals[DUK__IDX_HBYTES] = sizeof(duk_harray); + } else if (DUK_HOBJECT_IS_COMPFUNC(h_obj)) { + vals[DUK__IDX_HBYTES] = sizeof(duk_hcompfunc); + } else if (DUK_HOBJECT_IS_NATFUNC(h_obj)) { + vals[DUK__IDX_HBYTES] = sizeof(duk_hnatfunc); + } else if (DUK_HOBJECT_IS_THREAD(h_obj)) { + vals[DUK__IDX_HBYTES] = sizeof(duk_hthread); + vals[DUK__IDX_TSTATE] = ((duk_hthread *) h_obj)->state; +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + } else if (DUK_HOBJECT_IS_BUFOBJ(h_obj)) { + vals[DUK__IDX_HBYTES] = sizeof(duk_hbufobj); + /* XXX: some size information */ +#endif + } else { + vals[DUK__IDX_HBYTES] = (duk_small_uint_t) sizeof(duk_hobject); + } + + vals[DUK__IDX_CLASS] = (duk_int_t) DUK_HOBJECT_GET_CLASS_NUMBER(h_obj); + vals[DUK__IDX_PBYTES] = (duk_int_t) DUK_HOBJECT_P_ALLOC_SIZE(h_obj); + vals[DUK__IDX_ESIZE] = (duk_int_t) DUK_HOBJECT_GET_ESIZE(h_obj); + vals[DUK__IDX_ENEXT] = (duk_int_t) DUK_HOBJECT_GET_ENEXT(h_obj); + vals[DUK__IDX_ASIZE] = (duk_int_t) DUK_HOBJECT_GET_ASIZE(h_obj); + vals[DUK__IDX_HSIZE] = (duk_int_t) DUK_HOBJECT_GET_HSIZE(h_obj); + + /* Note: e_next indicates the number of gc-reachable entries + * in the entry part, and also indicates the index where the + * next new property would be inserted. It does *not* indicate + * the number of non-NULL keys present in the object. That + * value could be counted separately but requires a pass through + * the key list. + */ + + if (DUK_HOBJECT_IS_COMPFUNC(h_obj)) { + duk_hbuffer *h_data = (duk_hbuffer *) DUK_HCOMPFUNC_GET_DATA(thr->heap, (duk_hcompfunc *) h_obj); + vals[DUK__IDX_BCBYTES] = (duk_int_t) (h_data ? DUK_HBUFFER_GET_SIZE(h_data) : 0); + } + break; + } + case DUK_HTYPE_BUFFER: { + duk_hbuffer *h_buf = (duk_hbuffer *) h; + + if (DUK_HBUFFER_HAS_DYNAMIC(h_buf)) { + if (DUK_HBUFFER_HAS_EXTERNAL(h_buf)) { + vals[DUK__IDX_VARIANT] = 2; /* buffer variant 2: external */ + vals[DUK__IDX_HBYTES] = (duk_uint_t) (sizeof(duk_hbuffer_external)); + } else { + /* When alloc_size == 0 the second allocation may not + * actually exist. + */ + vals[DUK__IDX_VARIANT] = 1; /* buffer variant 1: dynamic */ + vals[DUK__IDX_HBYTES] = (duk_uint_t) (sizeof(duk_hbuffer_dynamic)); + } + vals[DUK__IDX_DBYTES] = (duk_int_t) (DUK_HBUFFER_GET_SIZE(h_buf)); + } else { + DUK_ASSERT(vals[DUK__IDX_VARIANT] == 0); /* buffer variant 0: fixed */ + vals[DUK__IDX_HBYTES] = (duk_int_t) (sizeof(duk_hbuffer_fixed) + DUK_HBUFFER_GET_SIZE(h_buf)); + } + break; + } + } + +finish: + duk__inspect_multiple_uint(thr, + "type" + "\x00" + "itag" + "\x00" + "refc" + "\x00" + "hbytes" + "\x00" + "class" + "\x00" + "pbytes" + "\x00" + "esize" + "\x00" + "enext" + "\x00" + "asize" + "\x00" + "hsize" + "\x00" + "bcbytes" + "\x00" + "dbytes" + "\x00" + "tstate" + "\x00" + "variant" + "\x00" + "\x00", + (duk_int_t *) &vals); +} + +DUK_EXTERNAL void duk_inspect_callstack_entry(duk_hthread *thr, duk_int_t level) { + duk_activation *act; + duk_uint_fast32_t pc; + duk_uint_fast32_t line; + + DUK_ASSERT_API_ENTRY(thr); + + /* -1 = top callstack entry + * -2 = caller of level -1 + * etc + */ + act = duk_hthread_get_activation_for_level(thr, level); + if (act == NULL) { + duk_push_undefined(thr); + return; + } + duk_push_bare_object(thr); + + /* Relevant PC is just before current one because PC is + * post-incremented. This should match what error augment + * code does. + */ + pc = duk_hthread_get_act_prev_pc(thr, act); + + duk_push_tval(thr, &act->tv_func); + + duk_push_uint(thr, (duk_uint_t) pc); + duk_put_prop_stridx_short(thr, -3, DUK_STRIDX_PC); + +#if defined(DUK_USE_PC2LINE) + line = duk_hobject_pc2line_query(thr, -1, pc); +#else + line = 0; +#endif + duk_push_uint(thr, (duk_uint_t) line); + duk_put_prop_stridx_short(thr, -3, DUK_STRIDX_LINE_NUMBER); + + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_LC_FUNCTION); + /* Providing access to e.g. act->lex_env would be dangerous: these + * internal structures must never be accessible to the application. + * Duktape relies on them having consistent data, and this consistency + * is only asserted for, not checked for. + */ +} + +/* automatic undefs */ +#undef DUK__IDX_ASIZE +#undef DUK__IDX_BCBYTES +#undef DUK__IDX_CLASS +#undef DUK__IDX_DBYTES +#undef DUK__IDX_ENEXT +#undef DUK__IDX_ESIZE +#undef DUK__IDX_HBYTES +#undef DUK__IDX_HSIZE +#undef DUK__IDX_ITAG +#undef DUK__IDX_PBYTES +#undef DUK__IDX_REFC +#undef DUK__IDX_TSTATE +#undef DUK__IDX_TYPE +#undef DUK__IDX_VARIANT +#line 1 "duk_api_memory.c" +/* + * Memory calls. + */ + +/* #include duk_internal.h -> already included */ + +DUK_EXTERNAL void *duk_alloc_raw(duk_hthread *thr, duk_size_t size) { + DUK_ASSERT_API_ENTRY(thr); + + return DUK_ALLOC_RAW(thr->heap, size); +} + +DUK_EXTERNAL void duk_free_raw(duk_hthread *thr, void *ptr) { + DUK_ASSERT_API_ENTRY(thr); + + DUK_FREE_RAW(thr->heap, ptr); +} + +DUK_EXTERNAL void *duk_realloc_raw(duk_hthread *thr, void *ptr, duk_size_t size) { + DUK_ASSERT_API_ENTRY(thr); + + return DUK_REALLOC_RAW(thr->heap, ptr, size); +} + +DUK_EXTERNAL void *duk_alloc(duk_hthread *thr, duk_size_t size) { + DUK_ASSERT_API_ENTRY(thr); + + return DUK_ALLOC(thr->heap, size); +} + +DUK_EXTERNAL void duk_free(duk_hthread *thr, void *ptr) { + DUK_ASSERT_API_ENTRY(thr); + + DUK_FREE_CHECKED(thr, ptr); +} + +DUK_EXTERNAL void *duk_realloc(duk_hthread *thr, void *ptr, duk_size_t size) { + DUK_ASSERT_API_ENTRY(thr); + + /* + * Note: since this is an exposed API call, there should be + * no way a mark-and-sweep could have a side effect on the + * memory allocation behind 'ptr'; the pointer should never + * be something that Duktape wants to change. + * + * Thus, no need to use DUK_REALLOC_INDIRECT (and we don't + * have the storage location here anyway). + */ + + return DUK_REALLOC(thr->heap, ptr, size); +} + +DUK_EXTERNAL void duk_get_memory_functions(duk_hthread *thr, duk_memory_functions *out_funcs) { + duk_heap *heap; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(out_funcs != NULL); + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + + heap = thr->heap; + out_funcs->alloc_func = heap->alloc_func; + out_funcs->realloc_func = heap->realloc_func; + out_funcs->free_func = heap->free_func; + out_funcs->udata = heap->heap_udata; +} + +DUK_EXTERNAL void duk_gc(duk_hthread *thr, duk_uint_t flags) { + duk_heap *heap; + duk_small_uint_t ms_flags; + + DUK_ASSERT_API_ENTRY(thr); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + + DUK_D(DUK_DPRINT("mark-and-sweep requested by application")); + DUK_ASSERT(DUK_GC_COMPACT == DUK_MS_FLAG_EMERGENCY); /* Compact flag is 1:1 with emergency flag which forces compaction. */ + ms_flags = (duk_small_uint_t) flags; + duk_heap_mark_and_sweep(heap, ms_flags); +} +#line 1 "duk_api_object.c" +/* + * Object handling: property access and other support functions. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Property handling + * + * The API exposes only the most common property handling functions. + * The caller can invoke ECMAScript built-ins for full control (e.g. + * defineProperty, getOwnPropertyDescriptor). + */ + +DUK_EXTERNAL duk_bool_t duk_get_prop(duk_hthread *thr, duk_idx_t obj_idx) { + duk_tval *tv_obj; + duk_tval *tv_key; + duk_bool_t rc; + + DUK_ASSERT_API_ENTRY(thr); + + /* Note: copying tv_obj and tv_key to locals to shield against a valstack + * resize is not necessary for a property get right now. + */ + + tv_obj = duk_require_tval(thr, obj_idx); + tv_key = duk_require_tval(thr, -1); + + rc = duk_hobject_getprop(thr, tv_obj, tv_key); + DUK_ASSERT(rc == 0 || rc == 1); + /* a value is left on stack regardless of rc */ + + duk_remove_m2(thr); /* remove key */ + DUK_ASSERT(duk_is_undefined(thr, -1) || rc == 1); + return rc; /* 1 if property found, 0 otherwise */ +} + +DUK_EXTERNAL duk_bool_t duk_get_prop_string(duk_hthread *thr, duk_idx_t obj_idx, const char *key) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_string(thr, key); + return duk_get_prop(thr, obj_idx); +} + +DUK_EXTERNAL duk_bool_t duk_get_prop_lstring(duk_hthread *thr, duk_idx_t obj_idx, const char *key, duk_size_t key_len) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_lstring(thr, key, key_len); + return duk_get_prop(thr, obj_idx); +} + +#if !defined(DUK_USE_PREFER_SIZE) +DUK_EXTERNAL duk_bool_t duk_get_prop_literal_raw(duk_hthread *thr, duk_idx_t obj_idx, const char *key, duk_size_t key_len) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + DUK_ASSERT(key[key_len] == (char) 0); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_literal_raw(thr, key, key_len); + return duk_get_prop(thr, obj_idx); +} +#endif + +DUK_EXTERNAL duk_bool_t duk_get_prop_index(duk_hthread *thr, duk_idx_t obj_idx, duk_uarridx_t arr_idx) { + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + duk_push_uarridx(thr, arr_idx); + return duk_get_prop(thr, obj_idx); +} + +DUK_EXTERNAL duk_bool_t duk_get_prop_heapptr(duk_hthread *thr, duk_idx_t obj_idx, void *ptr) { + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_heapptr(thr, ptr); /* NULL -> 'undefined' */ + return duk_get_prop(thr, obj_idx); +} + +DUK_INTERNAL duk_bool_t duk_get_prop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_STRIDX_VALID(stridx); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_hstring(thr, DUK_HTHREAD_GET_STRING(thr, stridx)); + return duk_get_prop(thr, obj_idx); +} + +DUK_INTERNAL duk_bool_t duk_get_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args) { + return duk_get_prop_stridx(thr, (duk_idx_t) (duk_int16_t) (packed_args >> 16), (duk_small_uint_t) (packed_args & 0xffffUL)); +} + +DUK_INTERNAL duk_bool_t duk_get_prop_stridx_boolean(duk_hthread *thr, + duk_idx_t obj_idx, + duk_small_uint_t stridx, + duk_bool_t *out_has_prop) { + duk_bool_t rc; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_STRIDX_VALID(stridx); + + rc = duk_get_prop_stridx(thr, obj_idx, stridx); + if (out_has_prop) { + *out_has_prop = rc; + } + return duk_to_boolean_top_pop(thr); +} + +/* This get variant is for internal use, it differs from standard + * duk_get_prop() in that: + * - Object argument must be an object (primitive values not supported). + * - Key argument must be a string (no coercion). + * - Only own properties are checked (no inheritance). Only "entry part" + * properties are checked (not array index properties). + * - Property must be a plain data property, not a getter. + * - Proxy traps are not triggered. + */ +DUK_INTERNAL duk_bool_t duk_xget_owndataprop(duk_hthread *thr, duk_idx_t obj_idx) { + duk_hobject *h_obj; + duk_hstring *h_key; + duk_tval *tv_val; + + DUK_ASSERT_API_ENTRY(thr); + + /* Note: copying tv_obj and tv_key to locals to shield against a valstack + * resize is not necessary for a property get right now. + */ + + h_obj = duk_get_hobject(thr, obj_idx); + if (h_obj == NULL) { + return 0; + } + h_key = duk_require_hstring(thr, -1); + + tv_val = duk_hobject_find_entry_tval_ptr(thr->heap, h_obj, h_key); + if (tv_val == NULL) { + return 0; + } + + duk_push_tval(thr, tv_val); + duk_remove_m2(thr); /* remove key */ + + return 1; +} + +DUK_INTERNAL duk_bool_t duk_xget_owndataprop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_STRIDX_VALID(stridx); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_hstring(thr, DUK_HTHREAD_GET_STRING(thr, stridx)); + return duk_xget_owndataprop(thr, obj_idx); +} + +DUK_INTERNAL duk_bool_t duk_xget_owndataprop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args) { + return duk_xget_owndataprop_stridx(thr, + (duk_idx_t) (duk_int16_t) (packed_args >> 16), + (duk_small_uint_t) (packed_args & 0xffffUL)); +} + +DUK_LOCAL duk_bool_t duk__put_prop_shared(duk_hthread *thr, duk_idx_t obj_idx, duk_idx_t idx_key) { + duk_tval *tv_obj; + duk_tval *tv_key; + duk_tval *tv_val; + duk_bool_t throw_flag; + duk_bool_t rc; + + /* Note: copying tv_obj and tv_key to locals to shield against a valstack + * resize is not necessary for a property put right now (putprop protects + * against it internally). + */ + + /* Key and value indices are either (-2, -1) or (-1, -2). Given idx_key, + * idx_val is always (idx_key ^ 0x01). + */ + DUK_ASSERT((idx_key == -2 && (idx_key ^ 1) == -1) || (idx_key == -1 && (idx_key ^ 1) == -2)); + /* XXX: Direct access; faster validation. */ + tv_obj = duk_require_tval(thr, obj_idx); + tv_key = duk_require_tval(thr, idx_key); + tv_val = duk_require_tval(thr, idx_key ^ 1); + throw_flag = duk_is_strict_call(thr); + + rc = duk_hobject_putprop(thr, tv_obj, tv_key, tv_val, throw_flag); + DUK_ASSERT(rc == 0 || rc == 1); + + duk_pop_2(thr); /* remove key and value */ + return rc; /* 1 if property found, 0 otherwise */ +} + +DUK_EXTERNAL duk_bool_t duk_put_prop(duk_hthread *thr, duk_idx_t obj_idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__put_prop_shared(thr, obj_idx, -2); +} + +DUK_EXTERNAL duk_bool_t duk_put_prop_string(duk_hthread *thr, duk_idx_t obj_idx, const char *key) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + + /* Careful here and with other duk_put_prop_xxx() helpers: the + * target object and the property value may be in the same value + * stack slot (unusual, but still conceptually clear). + */ + obj_idx = duk_normalize_index(thr, obj_idx); + (void) duk_push_string(thr, key); + return duk__put_prop_shared(thr, obj_idx, -1); +} + +DUK_EXTERNAL duk_bool_t duk_put_prop_lstring(duk_hthread *thr, duk_idx_t obj_idx, const char *key, duk_size_t key_len) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + + obj_idx = duk_normalize_index(thr, obj_idx); + (void) duk_push_lstring(thr, key, key_len); + return duk__put_prop_shared(thr, obj_idx, -1); +} + +#if !defined(DUK_USE_PREFER_SIZE) +DUK_EXTERNAL duk_bool_t duk_put_prop_literal_raw(duk_hthread *thr, duk_idx_t obj_idx, const char *key, duk_size_t key_len) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + DUK_ASSERT(key[key_len] == (char) 0); + + obj_idx = duk_normalize_index(thr, obj_idx); + (void) duk_push_literal_raw(thr, key, key_len); + return duk__put_prop_shared(thr, obj_idx, -1); +} +#endif + +DUK_EXTERNAL duk_bool_t duk_put_prop_index(duk_hthread *thr, duk_idx_t obj_idx, duk_uarridx_t arr_idx) { + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + duk_push_uarridx(thr, arr_idx); + return duk__put_prop_shared(thr, obj_idx, -1); +} + +DUK_EXTERNAL duk_bool_t duk_put_prop_heapptr(duk_hthread *thr, duk_idx_t obj_idx, void *ptr) { + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_heapptr(thr, ptr); /* NULL -> 'undefined' */ + return duk__put_prop_shared(thr, obj_idx, -1); +} + +DUK_INTERNAL duk_bool_t duk_put_prop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_STRIDX_VALID(stridx); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + duk_push_hstring(thr, DUK_HTHREAD_GET_STRING(thr, stridx)); + return duk__put_prop_shared(thr, obj_idx, -1); +} + +DUK_INTERNAL duk_bool_t duk_put_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args) { + return duk_put_prop_stridx(thr, (duk_idx_t) (duk_int16_t) (packed_args >> 16), (duk_small_uint_t) (packed_args & 0xffffUL)); +} + +DUK_EXTERNAL duk_bool_t duk_del_prop(duk_hthread *thr, duk_idx_t obj_idx) { + duk_tval *tv_obj; + duk_tval *tv_key; + duk_bool_t throw_flag; + duk_bool_t rc; + + DUK_ASSERT_API_ENTRY(thr); + + /* Note: copying tv_obj and tv_key to locals to shield against a valstack + * resize is not necessary for a property delete right now. + */ + + tv_obj = duk_require_tval(thr, obj_idx); + tv_key = duk_require_tval(thr, -1); + throw_flag = duk_is_strict_call(thr); + + rc = duk_hobject_delprop(thr, tv_obj, tv_key, throw_flag); + DUK_ASSERT(rc == 0 || rc == 1); + + duk_pop(thr); /* remove key */ + return rc; +} + +DUK_EXTERNAL duk_bool_t duk_del_prop_string(duk_hthread *thr, duk_idx_t obj_idx, const char *key) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_string(thr, key); + return duk_del_prop(thr, obj_idx); +} + +DUK_EXTERNAL duk_bool_t duk_del_prop_lstring(duk_hthread *thr, duk_idx_t obj_idx, const char *key, duk_size_t key_len) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_lstring(thr, key, key_len); + return duk_del_prop(thr, obj_idx); +} + +#if !defined(DUK_USE_PREFER_SIZE) +DUK_EXTERNAL duk_bool_t duk_del_prop_literal_raw(duk_hthread *thr, duk_idx_t obj_idx, const char *key, duk_size_t key_len) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + DUK_ASSERT(key[key_len] == (char) 0); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_literal_raw(thr, key, key_len); + return duk_del_prop(thr, obj_idx); +} +#endif + +DUK_EXTERNAL duk_bool_t duk_del_prop_index(duk_hthread *thr, duk_idx_t obj_idx, duk_uarridx_t arr_idx) { + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + duk_push_uarridx(thr, arr_idx); + return duk_del_prop(thr, obj_idx); +} + +DUK_EXTERNAL duk_bool_t duk_del_prop_heapptr(duk_hthread *thr, duk_idx_t obj_idx, void *ptr) { + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_heapptr(thr, ptr); /* NULL -> 'undefined' */ + return duk_del_prop(thr, obj_idx); +} + +DUK_INTERNAL duk_bool_t duk_del_prop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_STRIDX_VALID(stridx); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + duk_push_hstring(thr, DUK_HTHREAD_GET_STRING(thr, stridx)); + return duk_del_prop(thr, obj_idx); +} + +#if 0 +DUK_INTERNAL duk_bool_t duk_del_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args) { + return duk_del_prop_stridx(thr, (duk_idx_t) (duk_int16_t) (packed_args >> 16), + (duk_small_uint_t) (packed_args & 0xffffUL)); +} +#endif + +DUK_EXTERNAL duk_bool_t duk_has_prop(duk_hthread *thr, duk_idx_t obj_idx) { + duk_tval *tv_obj; + duk_tval *tv_key; + duk_bool_t rc; + + DUK_ASSERT_API_ENTRY(thr); + + /* Note: copying tv_obj and tv_key to locals to shield against a valstack + * resize is not necessary for a property existence check right now. + */ + + tv_obj = duk_require_tval(thr, obj_idx); + tv_key = duk_require_tval(thr, -1); + + rc = duk_hobject_hasprop(thr, tv_obj, tv_key); + DUK_ASSERT(rc == 0 || rc == 1); + + duk_pop(thr); /* remove key */ + return rc; /* 1 if property found, 0 otherwise */ +} + +DUK_EXTERNAL duk_bool_t duk_has_prop_string(duk_hthread *thr, duk_idx_t obj_idx, const char *key) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_string(thr, key); + return duk_has_prop(thr, obj_idx); +} + +DUK_EXTERNAL duk_bool_t duk_has_prop_lstring(duk_hthread *thr, duk_idx_t obj_idx, const char *key, duk_size_t key_len) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_lstring(thr, key, key_len); + return duk_has_prop(thr, obj_idx); +} + +#if !defined(DUK_USE_PREFER_SIZE) +DUK_EXTERNAL duk_bool_t duk_has_prop_literal_raw(duk_hthread *thr, duk_idx_t obj_idx, const char *key, duk_size_t key_len) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(key != NULL); + DUK_ASSERT(key[key_len] == (char) 0); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_literal_raw(thr, key, key_len); + return duk_has_prop(thr, obj_idx); +} +#endif + +DUK_EXTERNAL duk_bool_t duk_has_prop_index(duk_hthread *thr, duk_idx_t obj_idx, duk_uarridx_t arr_idx) { + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + duk_push_uarridx(thr, arr_idx); + return duk_has_prop(thr, obj_idx); +} + +DUK_EXTERNAL duk_bool_t duk_has_prop_heapptr(duk_hthread *thr, duk_idx_t obj_idx, void *ptr) { + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + (void) duk_push_heapptr(thr, ptr); /* NULL -> 'undefined' */ + return duk_has_prop(thr, obj_idx); +} + +DUK_INTERNAL duk_bool_t duk_has_prop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_STRIDX_VALID(stridx); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + duk_push_hstring(thr, DUK_HTHREAD_GET_STRING(thr, stridx)); + return duk_has_prop(thr, obj_idx); +} + +#if 0 +DUK_INTERNAL duk_bool_t duk_has_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args) { + return duk_has_prop_stridx(thr, (duk_idx_t) (duk_int16_t) (packed_args >> 16), + (duk_small_uint_t) (packed_args & 0xffffUL)); +} +#endif + +/* Define own property without inheritance lookups and such. This differs from + * [[DefineOwnProperty]] because special behaviors (like Array 'length') are + * not invoked by this method. The caller must be careful to invoke any such + * behaviors if necessary. + */ +DUK_INTERNAL void duk_xdef_prop(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t desc_flags) { + duk_hobject *obj; + duk_hstring *key; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_require_hobject(thr, obj_idx); + DUK_ASSERT(obj != NULL); + key = duk_to_property_key_hstring(thr, -2); + DUK_ASSERT(key != NULL); + DUK_ASSERT(duk_require_tval(thr, -1) != NULL); + + duk_hobject_define_property_internal(thr, obj, key, desc_flags); + + duk_pop(thr); /* pop key */ +} + +DUK_INTERNAL void duk_xdef_prop_index(duk_hthread *thr, duk_idx_t obj_idx, duk_uarridx_t arr_idx, duk_small_uint_t desc_flags) { + duk_hobject *obj; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_require_hobject(thr, obj_idx); + DUK_ASSERT(obj != NULL); + + duk_hobject_define_property_internal_arridx(thr, obj, arr_idx, desc_flags); + /* value popped by call */ +} + +DUK_INTERNAL void duk_xdef_prop_stridx(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx, duk_small_uint_t desc_flags) { + duk_hobject *obj; + duk_hstring *key; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_STRIDX_VALID(stridx); + + obj = duk_require_hobject(thr, obj_idx); + DUK_ASSERT(obj != NULL); + key = DUK_HTHREAD_GET_STRING(thr, stridx); + DUK_ASSERT(key != NULL); + DUK_ASSERT(duk_require_tval(thr, -1) != NULL); + + duk_hobject_define_property_internal(thr, obj, key, desc_flags); + /* value popped by call */ +} + +DUK_INTERNAL void duk_xdef_prop_stridx_short_raw(duk_hthread *thr, duk_uint_t packed_args) { + duk_xdef_prop_stridx(thr, + (duk_idx_t) (duk_int8_t) (packed_args >> 24), + (duk_small_uint_t) (packed_args >> 8) & 0xffffUL, + (duk_small_uint_t) (packed_args & 0xffL)); +} + +#if 0 /*unused*/ +DUK_INTERNAL void duk_xdef_prop_stridx_builtin(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx, duk_small_int_t builtin_idx, duk_small_uint_t desc_flags) { + duk_hobject *obj; + duk_hstring *key; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_STRIDX_VALID(stridx); + DUK_ASSERT_BIDX_VALID(builtin_idx); + + obj = duk_require_hobject(thr, obj_idx); + DUK_ASSERT(obj != NULL); + key = DUK_HTHREAD_GET_STRING(thr, stridx); + DUK_ASSERT(key != NULL); + + duk_push_hobject(thr, thr->builtins[builtin_idx]); + duk_hobject_define_property_internal(thr, obj, key, desc_flags); + /* value popped by call */ +} +#endif + +/* This is a rare property helper; it sets the global thrower (E5 Section 13.2.3) + * setter/getter into an object property. This is needed by the 'arguments' + * object creation code, function instance creation code, and Function.prototype.bind(). + */ + +DUK_INTERNAL void duk_xdef_prop_stridx_thrower(duk_hthread *thr, duk_idx_t obj_idx, duk_small_uint_t stridx) { + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + duk_push_hstring_stridx(thr, stridx); + duk_push_hobject_bidx(thr, DUK_BIDX_TYPE_ERROR_THROWER); + duk_dup_top(thr); + duk_def_prop(thr, obj_idx, DUK_DEFPROP_HAVE_SETTER | DUK_DEFPROP_HAVE_GETTER | DUK_DEFPROP_FORCE); /* attributes always 0 */ +} + +/* Object.getOwnPropertyDescriptor() equivalent C binding. */ +DUK_EXTERNAL void duk_get_prop_desc(duk_hthread *thr, duk_idx_t obj_idx, duk_uint_t flags) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(flags); /* no flags defined yet */ + + duk_hobject_object_get_own_property_descriptor(thr, obj_idx); /* [ ... key ] -> [ ... desc ] */ +} + +/* Object.defineProperty() equivalent C binding. */ +DUK_EXTERNAL void duk_def_prop(duk_hthread *thr, duk_idx_t obj_idx, duk_uint_t flags) { + duk_idx_t idx_base; + duk_hobject *obj; + duk_hstring *key; + duk_idx_t idx_value; + duk_hobject *get; + duk_hobject *set; + duk_uint_t is_data_desc; + duk_uint_t is_acc_desc; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_require_hobject(thr, obj_idx); + + is_data_desc = flags & (DUK_DEFPROP_HAVE_VALUE | DUK_DEFPROP_HAVE_WRITABLE); + is_acc_desc = flags & (DUK_DEFPROP_HAVE_GETTER | DUK_DEFPROP_HAVE_SETTER); + if (is_data_desc && is_acc_desc) { + /* "Have" flags must not be conflicting so that they would + * apply to both a plain property and an accessor at the same + * time. + */ + goto fail_invalid_desc; + } + + idx_base = duk_get_top_index(thr); + if (flags & DUK_DEFPROP_HAVE_SETTER) { + duk_require_type_mask(thr, idx_base, DUK_TYPE_MASK_UNDEFINED | DUK_TYPE_MASK_OBJECT | DUK_TYPE_MASK_LIGHTFUNC); + set = duk_get_hobject_promote_lfunc(thr, idx_base); + if (set != NULL && !DUK_HOBJECT_IS_CALLABLE(set)) { + goto fail_not_callable; + } + idx_base--; + } else { + set = NULL; + } + if (flags & DUK_DEFPROP_HAVE_GETTER) { + duk_require_type_mask(thr, idx_base, DUK_TYPE_MASK_UNDEFINED | DUK_TYPE_MASK_OBJECT | DUK_TYPE_MASK_LIGHTFUNC); + get = duk_get_hobject_promote_lfunc(thr, idx_base); + if (get != NULL && !DUK_HOBJECT_IS_CALLABLE(get)) { + goto fail_not_callable; + } + idx_base--; + } else { + get = NULL; + } + if (flags & DUK_DEFPROP_HAVE_VALUE) { + idx_value = idx_base; + idx_base--; + } else { + idx_value = (duk_idx_t) -1; + } + key = duk_to_property_key_hstring(thr, idx_base); + DUK_ASSERT(key != NULL); + + duk_require_valid_index(thr, idx_base); + + duk_hobject_define_property_helper(thr, flags /*defprop_flags*/, obj, key, idx_value, get, set, 1 /*throw_flag*/); + + /* Clean up stack */ + + duk_set_top(thr, idx_base); + + /* [ ... obj ... ] */ + + return; + +fail_invalid_desc: + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_DESCRIPTOR); + DUK_WO_NORETURN(return;); + +fail_not_callable: + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CALLABLE); + DUK_WO_NORETURN(return;); +} + +/* + * Object related + */ + +DUK_EXTERNAL void duk_compact(duk_hthread *thr, duk_idx_t obj_idx) { + duk_hobject *obj; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_get_hobject(thr, obj_idx); + if (obj) { + /* Note: this may fail, caller should protect the call if necessary */ + duk_hobject_compact_props(thr, obj); + } +} + +DUK_INTERNAL void duk_compact_m1(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + duk_compact(thr, -1); +} + +/* XXX: the duk_hobject_enum.c stack APIs should be reworked */ + +DUK_EXTERNAL void duk_enum(duk_hthread *thr, duk_idx_t obj_idx, duk_uint_t enum_flags) { + DUK_ASSERT_API_ENTRY(thr); + + duk_dup(thr, obj_idx); + duk_require_hobject_promote_mask(thr, -1, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + duk_hobject_enumerator_create(thr, enum_flags); /* [target] -> [enum] */ +} + +DUK_EXTERNAL duk_bool_t duk_next(duk_hthread *thr, duk_idx_t enum_index, duk_bool_t get_value) { + DUK_ASSERT_API_ENTRY(thr); + + duk_require_hobject(thr, enum_index); + duk_dup(thr, enum_index); + return duk_hobject_enumerator_next(thr, get_value); +} + +DUK_INTERNAL void duk_seal_freeze_raw(duk_hthread *thr, duk_idx_t obj_idx, duk_bool_t is_freeze) { + duk_tval *tv; + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, obj_idx); + DUK_ASSERT(tv != NULL); + + /* Seal/freeze are quite rare in practice so it'd be nice to get the + * correct behavior simply via automatic promotion (at the cost of some + * memory churn). However, the promoted objects don't behave the same, + * e.g. promoted lightfuncs are extensible. + */ + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_BUFFER: + /* Plain buffer: already sealed, but not frozen (and can't be frozen + * because index properties can't be made non-writable. + */ + if (is_freeze) { + goto fail_cannot_freeze; + } + break; + case DUK_TAG_LIGHTFUNC: + /* Lightfunc: already sealed and frozen, success. */ + break; + case DUK_TAG_OBJECT: + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + if (is_freeze && DUK_HOBJECT_IS_BUFOBJ(h)) { + /* Buffer objects cannot be frozen because there's no internal + * support for making virtual array indices non-writable. + */ + DUK_DD(DUK_DDPRINT("cannot freeze a buffer object")); + goto fail_cannot_freeze; + } + duk_hobject_object_seal_freeze_helper(thr, h, is_freeze); + + /* Sealed and frozen objects cannot gain any more properties, + * so this is a good time to compact them. + */ + duk_hobject_compact_props(thr, h); + break; + default: + /* ES2015 Sections 19.1.2.5, 19.1.2.17 */ + break; + } + return; + +fail_cannot_freeze: + DUK_ERROR_TYPE_INVALID_ARGS(thr); /* XXX: proper error message */ + DUK_WO_NORETURN(return;); +} + +DUK_EXTERNAL void duk_seal(duk_hthread *thr, duk_idx_t obj_idx) { + DUK_ASSERT_API_ENTRY(thr); + + duk_seal_freeze_raw(thr, obj_idx, 0 /*is_freeze*/); +} + +DUK_EXTERNAL void duk_freeze(duk_hthread *thr, duk_idx_t obj_idx) { + DUK_ASSERT_API_ENTRY(thr); + + duk_seal_freeze_raw(thr, obj_idx, 1 /*is_freeze*/); +} + +/* + * Helpers for writing multiple properties + */ + +DUK_EXTERNAL void duk_put_function_list(duk_hthread *thr, duk_idx_t obj_idx, const duk_function_list_entry *funcs) { + const duk_function_list_entry *ent = funcs; + + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + if (ent != NULL) { + while (ent->key != NULL) { + duk_push_c_function(thr, ent->value, ent->nargs); + duk_put_prop_string(thr, obj_idx, ent->key); + ent++; + } + } +} + +DUK_EXTERNAL void duk_put_number_list(duk_hthread *thr, duk_idx_t obj_idx, const duk_number_list_entry *numbers) { + const duk_number_list_entry *ent = numbers; + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + obj_idx = duk_require_normalize_index(thr, obj_idx); + if (ent != NULL) { + while (ent->key != NULL) { + tv = thr->valstack_top++; + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(tv)); /* value stack init policy */ + DUK_TVAL_SET_NUMBER_CHKFAST_SLOW(tv, ent->value); /* no need for decref/incref */ + duk_put_prop_string(thr, obj_idx, ent->key); + ent++; + } + } +} + +/* + * Shortcut for accessing global object properties + */ + +DUK_EXTERNAL duk_bool_t duk_get_global_string(duk_hthread *thr, const char *key) { + duk_bool_t ret; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + + /* XXX: direct implementation */ + + duk_push_hobject(thr, thr->builtins[DUK_BIDX_GLOBAL]); + ret = duk_get_prop_string(thr, -1, key); + duk_remove_m2(thr); + return ret; +} + +DUK_EXTERNAL duk_bool_t duk_get_global_lstring(duk_hthread *thr, const char *key, duk_size_t key_len) { + duk_bool_t ret; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + + /* XXX: direct implementation */ + + duk_push_hobject(thr, thr->builtins[DUK_BIDX_GLOBAL]); + ret = duk_get_prop_lstring(thr, -1, key, key_len); + duk_remove_m2(thr); + return ret; +} + +#if !defined(DUK_USE_PREFER_SIZE) +DUK_EXTERNAL duk_bool_t duk_get_global_literal_raw(duk_hthread *thr, const char *key, duk_size_t key_len) { + duk_bool_t ret; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + DUK_ASSERT(key[key_len] == (char) 0); + + /* XXX: direct implementation */ + + duk_push_hobject(thr, thr->builtins[DUK_BIDX_GLOBAL]); + ret = duk_get_prop_literal_raw(thr, -1, key, key_len); + duk_remove_m2(thr); + return ret; +} +#endif + +DUK_EXTERNAL duk_bool_t duk_get_global_heapptr(duk_hthread *thr, void *ptr) { + duk_bool_t ret; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + + /* XXX: direct implementation */ + + duk_push_hobject(thr, thr->builtins[DUK_BIDX_GLOBAL]); + ret = duk_get_prop_heapptr(thr, -1, ptr); + duk_remove_m2(thr); + return ret; +} + +DUK_EXTERNAL duk_bool_t duk_put_global_string(duk_hthread *thr, const char *key) { + duk_bool_t ret; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + + /* XXX: direct implementation */ + + duk_push_hobject(thr, thr->builtins[DUK_BIDX_GLOBAL]); + duk_insert(thr, -2); + ret = duk_put_prop_string(thr, -2, key); /* [ ... global val ] -> [ ... global ] */ + duk_pop(thr); + return ret; +} + +DUK_EXTERNAL duk_bool_t duk_put_global_lstring(duk_hthread *thr, const char *key, duk_size_t key_len) { + duk_bool_t ret; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + + /* XXX: direct implementation */ + + duk_push_hobject(thr, thr->builtins[DUK_BIDX_GLOBAL]); + duk_insert(thr, -2); + ret = duk_put_prop_lstring(thr, -2, key, key_len); /* [ ... global val ] -> [ ... global ] */ + duk_pop(thr); + return ret; +} + +#if !defined(DUK_USE_PREFER_SIZE) +DUK_EXTERNAL duk_bool_t duk_put_global_literal_raw(duk_hthread *thr, const char *key, duk_size_t key_len) { + duk_bool_t ret; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + DUK_ASSERT(key[key_len] == (char) 0); + + /* XXX: direct implementation */ + + duk_push_hobject(thr, thr->builtins[DUK_BIDX_GLOBAL]); + duk_insert(thr, -2); + ret = duk_put_prop_literal_raw(thr, -2, key, key_len); /* [ ... global val ] -> [ ... global ] */ + duk_pop(thr); + return ret; +} +#endif + +DUK_EXTERNAL duk_bool_t duk_put_global_heapptr(duk_hthread *thr, void *ptr) { + duk_bool_t ret; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + + /* XXX: direct implementation */ + + duk_push_hobject(thr, thr->builtins[DUK_BIDX_GLOBAL]); + duk_insert(thr, -2); + ret = duk_put_prop_heapptr(thr, -2, ptr); /* [ ... global val ] -> [ ... global ] */ + duk_pop(thr); + return ret; +} + +/* + * ES2015 GetMethod() + */ + +DUK_INTERNAL duk_bool_t duk_get_method_stridx(duk_hthread *thr, duk_idx_t idx, duk_small_uint_t stridx) { + (void) duk_get_prop_stridx(thr, idx, stridx); + if (duk_is_null_or_undefined(thr, -1)) { + duk_pop_nodecref_unsafe(thr); + return 0; + } + if (!duk_is_callable(thr, -1)) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CALLABLE); + DUK_WO_NORETURN(return 0;); + } + return 1; +} + +/* + * Object prototype + */ + +DUK_EXTERNAL void duk_get_prototype(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *obj; + duk_hobject *proto; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_require_hobject(thr, idx); + DUK_ASSERT(obj != NULL); + + /* XXX: shared helper for duk_push_hobject_or_undefined()? */ + proto = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, obj); + if (proto) { + duk_push_hobject(thr, proto); + } else { + duk_push_undefined(thr); + } +} + +DUK_EXTERNAL void duk_set_prototype(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *obj; + duk_hobject *proto; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_require_hobject(thr, idx); + DUK_ASSERT(obj != NULL); + duk_require_type_mask(thr, -1, DUK_TYPE_MASK_UNDEFINED | DUK_TYPE_MASK_OBJECT); + proto = duk_get_hobject(thr, -1); + /* proto can also be NULL here (allowed explicitly) */ + +#if defined(DUK_USE_ROM_OBJECTS) + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CONFIGURABLE); /* XXX: "read only object"? */ + DUK_WO_NORETURN(return;); + } +#endif + + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, obj, proto); + + duk_pop(thr); +} + +DUK_INTERNAL void duk_clear_prototype(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *obj; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_require_hobject(thr, idx); + DUK_ASSERT(obj != NULL); + +#if defined(DUK_USE_ROM_OBJECTS) + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CONFIGURABLE); /* XXX: "read only object"? */ + DUK_WO_NORETURN(return;); + } +#endif + + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, obj, NULL); +} + +DUK_INTERNAL duk_bool_t duk_is_bare_object(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *obj; + duk_hobject *proto; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_require_hobject(thr, idx); + DUK_ASSERT(obj != NULL); + + proto = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, obj); + return (proto == NULL); +} + +/* + * Object finalizer + */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) +/* XXX: these could be implemented as macros calling an internal function + * directly. + * XXX: same issue as with Duktape.fin: there's no way to delete the property + * now (just set it to undefined). + */ +DUK_EXTERNAL void duk_get_finalizer(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + /* This get intentionally walks the inheritance chain at present, + * which matches how the effective finalizer property is also + * looked up in GC. + */ + duk_get_prop_stridx(thr, idx, DUK_STRIDX_INT_FINALIZER); +} + +DUK_EXTERNAL void duk_set_finalizer(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + duk_bool_t callable; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_require_hobject(thr, idx); /* Get before 'put' so that 'idx' is correct. */ + callable = duk_is_callable(thr, -1); + + /* At present finalizer is stored as a hidden Symbol, with normal + * inheritance and access control. As a result, finalizer cannot + * currently be set on a non-extensible (sealed or frozen) object. + * It might be useful to allow it. + */ + duk_put_prop_stridx(thr, idx, DUK_STRIDX_INT_FINALIZER); + + /* In addition to setting the finalizer property, keep a "have + * finalizer" flag in duk_hobject in sync so that refzero can do + * a very quick finalizer check by walking the prototype chain + * and checking the flag alone. (Note that this means that just + * setting _Finalizer on an object won't affect finalizer checks.) + * + * NOTE: if the argument is a Proxy object, this flag will be set + * on the Proxy, not the target. As a result, the target won't get + * a finalizer flag and the Proxy also won't be finalized as there's + * an explicit Proxy check in finalization now. + */ + if (callable) { + DUK_HOBJECT_SET_HAVE_FINALIZER(h); + } else { + DUK_HOBJECT_CLEAR_HAVE_FINALIZER(h); + } +} +#else /* DUK_USE_FINALIZER_SUPPORT */ +DUK_EXTERNAL void duk_get_finalizer(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(idx); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return;); +} + +DUK_EXTERNAL void duk_set_finalizer(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(idx); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return;); +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ +#line 1 "duk_api_random.c" +/* + * Random numbers + */ + +/* #include duk_internal.h -> already included */ + +DUK_EXTERNAL duk_double_t duk_random(duk_hthread *thr) { + return (duk_double_t) duk_util_get_random_double(thr); +} +#line 1 "duk_api_stack.c" +/* + * API calls related to general value stack manipulation: resizing the value + * stack, pushing and popping values, type checking and reading values, + * coercing values, etc. + * + * Also contains internal functions (such as duk_get_tval()), defined + * in duk_api_internal.h, with semantics similar to the public API. + */ + +/* XXX: repetition of stack pre-checks -> helper or macro or inline */ +/* XXX: shared api error strings, and perhaps even throw code for rare cases? */ + +/* #include duk_internal.h -> already included */ + +/* + * Forward declarations + */ + +DUK_LOCAL_DECL duk_idx_t +duk__push_c_function_raw(duk_hthread *thr, duk_c_function func, duk_idx_t nargs, duk_uint_t flags, duk_small_uint_t proto_bidx); + +/* + * Global state for working around missing variadic macros + */ + +#if !defined(DUK_USE_VARIADIC_MACROS) +DUK_EXTERNAL const char *duk_api_global_filename = NULL; +DUK_EXTERNAL duk_int_t duk_api_global_line = 0; +#endif + +/* + * Misc helpers + */ + +DUK_LOCAL const char * const duk__symbol_type_strings[4] = { "hidden", "global", "local", "wellknown" }; + +#if !defined(DUK_USE_PACKED_TVAL) +DUK_LOCAL const duk_uint_t duk__type_from_tag[] = { + DUK_TYPE_NUMBER, DUK_TYPE_NUMBER, /* fastint */ + DUK_TYPE_UNDEFINED, DUK_TYPE_NULL, DUK_TYPE_BOOLEAN, DUK_TYPE_POINTER, DUK_TYPE_LIGHTFUNC, + DUK_TYPE_NONE, DUK_TYPE_STRING, DUK_TYPE_OBJECT, DUK_TYPE_BUFFER, +}; +DUK_LOCAL const duk_uint_t duk__type_mask_from_tag[] = { + DUK_TYPE_MASK_NUMBER, DUK_TYPE_MASK_NUMBER, /* fastint */ + DUK_TYPE_MASK_UNDEFINED, DUK_TYPE_MASK_NULL, DUK_TYPE_MASK_BOOLEAN, DUK_TYPE_MASK_POINTER, DUK_TYPE_MASK_LIGHTFUNC, + DUK_TYPE_MASK_NONE, DUK_TYPE_MASK_STRING, DUK_TYPE_MASK_OBJECT, DUK_TYPE_MASK_BUFFER, +}; +#endif /* !DUK_USE_PACKED_TVAL */ + +/* Assert that there's room for one value. */ +#define DUK__ASSERT_SPACE() \ + do { \ + DUK_ASSERT(!(thr->valstack_top >= thr->valstack_end)); \ + } while (0) + +/* Check that there's room to push one value. */ +#if defined(DUK_USE_VALSTACK_UNSAFE) +/* Faster but value stack overruns are memory unsafe. */ +#define DUK__CHECK_SPACE() DUK__ASSERT_SPACE() +#else +#define DUK__CHECK_SPACE() \ + do { \ + if (DUK_UNLIKELY(thr->valstack_top >= thr->valstack_end)) { \ + DUK_ERROR_RANGE_PUSH_BEYOND(thr); \ + } \ + } while (0) +#endif + +DUK_LOCAL duk_small_uint_t duk__get_symbol_type(duk_hstring *h) { + const duk_uint8_t *data; + duk_size_t len; + + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HSTRING_HAS_SYMBOL(h)); + DUK_ASSERT(DUK_HSTRING_GET_BYTELEN(h) >= 1); /* always true, symbol prefix */ + + data = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h); + len = DUK_HSTRING_GET_BYTELEN(h); + DUK_ASSERT(len >= 1); + + /* XXX: differentiate between 0x82 and 0xff (hidden vs. internal?)? */ + + if (data[0] == 0xffU) { + return DUK_SYMBOL_TYPE_HIDDEN; + } else if (data[0] == 0x82U) { + return DUK_SYMBOL_TYPE_HIDDEN; + } else if (data[0] == 0x80U) { + return DUK_SYMBOL_TYPE_GLOBAL; + } else if (data[len - 1] != 0xffU) { + return DUK_SYMBOL_TYPE_LOCAL; + } else { + return DUK_SYMBOL_TYPE_WELLKNOWN; + } +} + +DUK_LOCAL const char *duk__get_symbol_type_string(duk_hstring *h) { + duk_small_uint_t idx; + idx = duk__get_symbol_type(h); + DUK_ASSERT(idx < sizeof(duk__symbol_type_strings)); + return duk__symbol_type_strings[idx]; +} + +DUK_LOCAL_DECL duk_heaphdr *duk__get_tagged_heaphdr_raw(duk_hthread *thr, duk_idx_t idx, duk_uint_t tag); + +DUK_LOCAL duk_int_t duk__api_coerce_d2i(duk_hthread *thr, duk_idx_t idx, duk_int_t def_value, duk_bool_t require) { + duk_tval *tv; + duk_small_int_t c; + duk_double_t d; + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + + /* + * Special cases like NaN and +/- Infinity are handled explicitly + * because a plain C coercion from double to int handles these cases + * in undesirable ways. For instance, NaN may coerce to INT_MIN + * (not zero), and INT_MAX + 1 may coerce to INT_MIN (not INT_MAX). + * + * This double-to-int coercion differs from ToInteger() because it + * has a finite range (ToInteger() allows e.g. +/- Infinity). It + * also differs from ToInt32() because the INT_MIN/INT_MAX clamping + * depends on the size of the int type on the platform. In particular, + * on platforms with a 64-bit int type, the full range is allowed. + */ + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv)) { + duk_int64_t t = DUK_TVAL_GET_FASTINT(tv); +#if (DUK_INT_MAX <= 0x7fffffffL) + /* Clamping only necessary for 32-bit ints. */ + if (t < DUK_INT_MIN) { + t = DUK_INT_MIN; + } else if (t > DUK_INT_MAX) { + t = DUK_INT_MAX; + } +#endif + return (duk_int_t) t; + } +#endif + + if (DUK_TVAL_IS_NUMBER(tv)) { + d = DUK_TVAL_GET_NUMBER(tv); + c = (duk_small_int_t) DUK_FPCLASSIFY(d); + if (c == DUK_FP_NAN) { + return 0; + } else if (d < (duk_double_t) DUK_INT_MIN) { + /* covers -Infinity */ + return DUK_INT_MIN; + } else if (d > (duk_double_t) DUK_INT_MAX) { + /* covers +Infinity */ + return DUK_INT_MAX; + } else { + /* coerce towards zero */ + return (duk_int_t) d; + } + } + + if (require) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "number", DUK_STR_NOT_NUMBER); + DUK_WO_NORETURN(return 0;); + } + + return def_value; +} + +DUK_LOCAL duk_uint_t duk__api_coerce_d2ui(duk_hthread *thr, duk_idx_t idx, duk_uint_t def_value, duk_bool_t require) { + duk_tval *tv; + duk_small_int_t c; + duk_double_t d; + + /* Same as above but for unsigned int range. */ + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv)) { + duk_int64_t t = DUK_TVAL_GET_FASTINT(tv); + if (t < 0) { + t = 0; + } +#if (DUK_UINT_MAX <= 0xffffffffUL) + /* Clamping only necessary for 32-bit ints. */ + else if (t > DUK_UINT_MAX) { + t = DUK_UINT_MAX; + } +#endif + return (duk_uint_t) t; + } +#endif + + if (DUK_TVAL_IS_NUMBER(tv)) { + d = DUK_TVAL_GET_NUMBER(tv); + c = (duk_small_int_t) DUK_FPCLASSIFY(d); + if (c == DUK_FP_NAN) { + return 0; + } else if (d < 0.0) { + /* covers -Infinity */ + return (duk_uint_t) 0; + } else if (d > (duk_double_t) DUK_UINT_MAX) { + /* covers +Infinity */ + return (duk_uint_t) DUK_UINT_MAX; + } else { + /* coerce towards zero */ + return (duk_uint_t) d; + } + } + + if (require) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "number", DUK_STR_NOT_NUMBER); + DUK_WO_NORETURN(return 0;); + } + + return def_value; +} + +/* + * Stack index validation/normalization and getting a stack duk_tval ptr. + * + * These are called by many API entrypoints so the implementations must be + * fast and "inlined". + * + * There's some repetition because of this; keep the functions in sync. + */ + +DUK_EXTERNAL duk_idx_t duk_normalize_index(duk_hthread *thr, duk_idx_t idx) { + duk_uidx_t vs_size; + duk_uidx_t uidx; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(DUK_INVALID_INDEX < 0); + + /* Care must be taken to avoid pointer wrapping in the index + * validation. For instance, on a 32-bit platform with 8-byte + * duk_tval the index 0x20000000UL would wrap the memory space + * once. + */ + + /* Assume value stack sizes (in elements) fits into duk_idx_t. */ + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + vs_size = (duk_uidx_t) (thr->valstack_top - thr->valstack_bottom); + DUK_ASSERT_DISABLE(vs_size >= 0); /* unsigned */ + + if (idx < 0) { + uidx = vs_size + (duk_uidx_t) idx; + } else { + /* since index non-negative */ + DUK_ASSERT(idx != DUK_INVALID_INDEX); + uidx = (duk_uidx_t) idx; + } + + /* DUK_INVALID_INDEX won't be accepted as a valid index. */ + DUK_ASSERT(vs_size + (duk_uidx_t) DUK_INVALID_INDEX >= vs_size); + + if (DUK_LIKELY(uidx < vs_size)) { + return (duk_idx_t) uidx; + } + return DUK_INVALID_INDEX; +} + +DUK_EXTERNAL duk_idx_t duk_require_normalize_index(duk_hthread *thr, duk_idx_t idx) { + duk_uidx_t vs_size; + duk_uidx_t uidx; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(DUK_INVALID_INDEX < 0); + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + vs_size = (duk_uidx_t) (thr->valstack_top - thr->valstack_bottom); + DUK_ASSERT_DISABLE(vs_size >= 0); /* unsigned */ + + if (idx < 0) { + uidx = vs_size + (duk_uidx_t) idx; + } else { + DUK_ASSERT(idx != DUK_INVALID_INDEX); + uidx = (duk_uidx_t) idx; + } + + /* DUK_INVALID_INDEX won't be accepted as a valid index. */ + DUK_ASSERT(vs_size + (duk_uidx_t) DUK_INVALID_INDEX >= vs_size); + + if (DUK_LIKELY(uidx < vs_size)) { + return (duk_idx_t) uidx; + } + DUK_ERROR_RANGE_INDEX(thr, idx); + DUK_WO_NORETURN(return 0;); +} + +DUK_INTERNAL duk_tval *duk_get_tval(duk_hthread *thr, duk_idx_t idx) { + duk_uidx_t vs_size; + duk_uidx_t uidx; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(DUK_INVALID_INDEX < 0); + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + vs_size = (duk_uidx_t) (thr->valstack_top - thr->valstack_bottom); + DUK_ASSERT_DISABLE(vs_size >= 0); /* unsigned */ + + if (idx < 0) { + uidx = vs_size + (duk_uidx_t) idx; + } else { + DUK_ASSERT(idx != DUK_INVALID_INDEX); + uidx = (duk_uidx_t) idx; + } + + /* DUK_INVALID_INDEX won't be accepted as a valid index. */ + DUK_ASSERT(vs_size + (duk_uidx_t) DUK_INVALID_INDEX >= vs_size); + + if (DUK_LIKELY(uidx < vs_size)) { + return thr->valstack_bottom + uidx; + } + return NULL; +} + +/* Variant of duk_get_tval() which is guaranteed to return a valid duk_tval + * pointer. When duk_get_tval() would return NULL, this variant returns a + * pointer to a duk_tval with tag DUK_TAG_UNUSED. This allows the call site + * to avoid an unnecessary NULL check which sometimes leads to better code. + * The return duk_tval is read only (at least for the UNUSED value). + */ +DUK_LOCAL const duk_tval_unused duk__const_tval_unused = DUK_TVAL_UNUSED_INITIALIZER(); + +DUK_INTERNAL duk_tval *duk_get_tval_or_unused(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval(thr, idx); + if (tv != NULL) { + return tv; + } + return (duk_tval *) DUK_LOSE_CONST(&duk__const_tval_unused); +} + +DUK_INTERNAL duk_tval *duk_require_tval(duk_hthread *thr, duk_idx_t idx) { + duk_uidx_t vs_size; + duk_uidx_t uidx; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(DUK_INVALID_INDEX < 0); + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + vs_size = (duk_uidx_t) (thr->valstack_top - thr->valstack_bottom); + DUK_ASSERT_DISABLE(vs_size >= 0); /* unsigned */ + + /* Use unsigned arithmetic to optimize comparison. */ + if (idx < 0) { + uidx = vs_size + (duk_uidx_t) idx; + } else { + DUK_ASSERT(idx != DUK_INVALID_INDEX); + uidx = (duk_uidx_t) idx; + } + + /* DUK_INVALID_INDEX won't be accepted as a valid index. */ + DUK_ASSERT(vs_size + (duk_uidx_t) DUK_INVALID_INDEX >= vs_size); + + if (DUK_LIKELY(uidx < vs_size)) { + return thr->valstack_bottom + uidx; + } + DUK_ERROR_RANGE_INDEX(thr, idx); + DUK_WO_NORETURN(return NULL;); +} + +/* Non-critical. */ +DUK_EXTERNAL duk_bool_t duk_is_valid_index(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(DUK_INVALID_INDEX < 0); + + return (duk_normalize_index(thr, idx) >= 0); +} + +/* Non-critical. */ +DUK_EXTERNAL void duk_require_valid_index(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(DUK_INVALID_INDEX < 0); + + if (DUK_UNLIKELY(duk_normalize_index(thr, idx) < 0)) { + DUK_ERROR_RANGE_INDEX(thr, idx); + DUK_WO_NORETURN(return;); + } +} + +/* + * Value stack top handling + */ + +DUK_EXTERNAL duk_idx_t duk_get_top(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + return (duk_idx_t) (thr->valstack_top - thr->valstack_bottom); +} + +/* Internal helper to get current top but to require a minimum top value + * (TypeError if not met). + */ +DUK_INTERNAL duk_idx_t duk_get_top_require_min(duk_hthread *thr, duk_idx_t min_top) { + duk_idx_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + ret = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom); + if (DUK_UNLIKELY(ret < min_top)) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return 0;); + } + return ret; +} + +/* Set stack top within currently allocated range, but don't reallocate. + * This is performance critical especially for call handling, so whenever + * changing, profile and look at generated code. + */ +DUK_EXTERNAL void duk_set_top(duk_hthread *thr, duk_idx_t idx) { + duk_uidx_t vs_size; + duk_uidx_t vs_limit; + duk_uidx_t uidx; + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(DUK_INVALID_INDEX < 0); + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT(thr->valstack_end >= thr->valstack_bottom); + vs_size = (duk_uidx_t) (thr->valstack_top - thr->valstack_bottom); + vs_limit = (duk_uidx_t) (thr->valstack_end - thr->valstack_bottom); + + if (idx < 0) { + /* Negative indices are always within allocated stack but + * must not go below zero index. + */ + uidx = vs_size + (duk_uidx_t) idx; + } else { + /* Positive index can be higher than valstack top but must + * not go above allocated stack (equality is OK). + */ + uidx = (duk_uidx_t) idx; + } + + /* DUK_INVALID_INDEX won't be accepted as a valid index. */ + DUK_ASSERT(vs_size + (duk_uidx_t) DUK_INVALID_INDEX >= vs_size); + DUK_ASSERT(vs_size + (duk_uidx_t) DUK_INVALID_INDEX >= vs_limit); + +#if defined(DUK_USE_VALSTACK_UNSAFE) + DUK_ASSERT(uidx <= vs_limit); + DUK_UNREF(vs_limit); +#else + if (DUK_UNLIKELY(uidx > vs_limit)) { + DUK_ERROR_RANGE_INDEX(thr, idx); + DUK_WO_NORETURN(return;); + } +#endif + DUK_ASSERT(uidx <= vs_limit); + + /* Handle change in value stack top. Respect value stack + * initialization policy: 'undefined' above top. Note that + * DECREF may cause a side effect that reallocates valstack, + * so must relookup after DECREF. + */ + + if (uidx >= vs_size) { + /* Stack size increases or stays the same. */ +#if defined(DUK_USE_ASSERTIONS) + duk_uidx_t count; + + count = uidx - vs_size; + while (count != 0) { + count--; + tv = thr->valstack_top + count; + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(tv)); + } +#endif + thr->valstack_top = thr->valstack_bottom + uidx; + } else { + /* Stack size decreases. */ +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_uidx_t count; + duk_tval *tv_end; + + count = vs_size - uidx; + DUK_ASSERT(count > 0); + tv = thr->valstack_top; + tv_end = tv - count; + DUK_ASSERT(tv > tv_end); /* Because count > 0. */ + do { + tv--; + DUK_ASSERT(tv >= thr->valstack_bottom); + DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ(thr, tv); + } while (tv != tv_end); + thr->valstack_top = tv_end; + DUK_REFZERO_CHECK_FAST(thr); +#else /* DUK_USE_REFERENCE_COUNTING */ + duk_uidx_t count; + duk_tval *tv_end; + + count = vs_size - uidx; + tv = thr->valstack_top; + tv_end = tv - count; + DUK_ASSERT(tv > tv_end); + do { + tv--; + DUK_TVAL_SET_UNDEFINED(tv); + } while (tv != tv_end); + thr->valstack_top = tv_end; +#endif /* DUK_USE_REFERENCE_COUNTING */ + } +} + +/* Internal variant with a non-negative index and no runtime size checks. */ +#if defined(DUK_USE_PREFER_SIZE) +DUK_INTERNAL void duk_set_top_unsafe(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + duk_set_top(thr, idx); +} +#else /* DUK_USE_PREFER_SIZE */ +DUK_INTERNAL void duk_set_top_unsafe(duk_hthread *thr, duk_idx_t idx) { + duk_uidx_t uidx; + duk_uidx_t vs_size; + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT(thr->valstack_end >= thr->valstack_bottom); + DUK_ASSERT(idx >= 0); + DUK_ASSERT(idx <= (duk_idx_t) (thr->valstack_end - thr->valstack_bottom)); + + /* XXX: byte arithmetic */ + uidx = (duk_uidx_t) idx; + vs_size = (duk_uidx_t) (thr->valstack_top - thr->valstack_bottom); + + if (uidx >= vs_size) { + /* Stack size increases or stays the same. */ +#if defined(DUK_USE_ASSERTIONS) + duk_uidx_t count; + + count = uidx - vs_size; + while (count != 0) { + count--; + tv = thr->valstack_top + count; + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(tv)); + } +#endif + thr->valstack_top = thr->valstack_bottom + uidx; + } else { + /* Stack size decreases. */ +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_uidx_t count; + duk_tval *tv_end; + + count = vs_size - uidx; + DUK_ASSERT(count > 0); + tv = thr->valstack_top; + tv_end = tv - count; + DUK_ASSERT(tv > tv_end); /* Because count > 0. */ + do { + tv--; + DUK_ASSERT(tv >= thr->valstack_bottom); + DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ(thr, tv); + } while (tv != tv_end); + thr->valstack_top = tv_end; + DUK_REFZERO_CHECK_FAST(thr); +#else /* DUK_USE_REFERENCE_COUNTING */ + duk_uidx_t count; + duk_tval *tv_end; + + count = vs_size - uidx; + tv = thr->valstack_top; + tv_end = tv - count; + DUK_ASSERT(tv > tv_end); + do { + tv--; + DUK_TVAL_SET_UNDEFINED(tv); + } while (tv != tv_end); + thr->valstack_top = tv_end; +#endif /* DUK_USE_REFERENCE_COUNTING */ + } +} +#endif /* DUK_USE_PREFER_SIZE */ + +/* Internal helper: set top to 'top', and set [idx_wipe_start,top[ to + * 'undefined' (doing nothing if idx_wipe_start == top). Indices are + * positive and within value stack reserve. This is used by call handling. + */ +DUK_INTERNAL void duk_set_top_and_wipe(duk_hthread *thr, duk_idx_t top, duk_idx_t idx_wipe_start) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(top >= 0); + DUK_ASSERT(idx_wipe_start >= 0); + DUK_ASSERT(idx_wipe_start <= top); + DUK_ASSERT(thr->valstack_bottom + top <= thr->valstack_end); + DUK_ASSERT(thr->valstack_bottom + idx_wipe_start <= thr->valstack_end); + + duk_set_top_unsafe(thr, idx_wipe_start); + duk_set_top_unsafe(thr, top); +} + +DUK_EXTERNAL duk_idx_t duk_get_top_index(duk_hthread *thr) { + duk_idx_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + ret = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom) - 1; + if (DUK_UNLIKELY(ret < 0)) { + /* Return invalid index; if caller uses this without checking + * in another API call, the index won't map to a valid stack + * entry. + */ + return DUK_INVALID_INDEX; + } + return ret; +} + +/* Internal variant: call assumes there is at least one element on the value + * stack frame; this is only asserted for. + */ +DUK_INTERNAL duk_idx_t duk_get_top_index_unsafe(duk_hthread *thr) { + duk_idx_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + ret = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom) - 1; + return ret; +} + +DUK_EXTERNAL duk_idx_t duk_require_top_index(duk_hthread *thr) { + duk_idx_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + ret = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom) - 1; + if (DUK_UNLIKELY(ret < 0)) { + DUK_ERROR_RANGE_INDEX(thr, -1); + DUK_WO_NORETURN(return 0;); + } + return ret; +} + +/* + * Value stack resizing. + * + * This resizing happens above the current "top": the value stack can be + * grown or shrunk, but the "top" is not affected. The value stack cannot + * be resized to a size below the current reserve. + * + * The low level reallocation primitive must carefully recompute all value + * stack pointers, and must also work if ALL pointers are NULL. The resize + * is quite tricky because the valstack realloc may cause a mark-and-sweep, + * which may run finalizers. Running finalizers may resize the valstack + * recursively (the same value stack we're working on). So, after realloc + * returns, we know that the valstack bottom, top, and reserve should still + * be the same (there should not be live values above the "top"), but its + * underlying size, alloc_end, and base pointer may have changed. + * + * 'new_size' is known to be <= DUK_USE_VALSTACK_LIMIT, which ensures that + * size_t and pointer arithmetic won't wrap in duk__resize_valstack(). + */ + +/* Low level valstack resize primitive, used for both grow and shrink. All + * adjustments for slack etc have already been done. Doesn't throw but does + * have allocation side effects. + */ +DUK_LOCAL DUK_COLD DUK_NOINLINE duk_bool_t duk__resize_valstack(duk_hthread *thr, duk_size_t new_size) { + duk_tval *pre_valstack; + duk_tval *pre_bottom; + duk_tval *pre_top; + duk_tval *pre_end; + duk_tval *pre_alloc_end; + duk_ptrdiff_t ptr_diff; + duk_tval *new_valstack; + duk_size_t new_alloc_size; + duk_tval *tv_prev_alloc_end; + duk_tval *p; + + DUK_HTHREAD_ASSERT_VALID(thr); + DUK_ASSERT(thr->valstack_bottom >= thr->valstack); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT(thr->valstack_end >= thr->valstack_top); + DUK_ASSERT(thr->valstack_alloc_end >= thr->valstack_end); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack) <= new_size); /* can't resize below 'top' */ + DUK_ASSERT(new_size <= DUK_USE_VALSTACK_LIMIT); /* valstack limit caller has check, prevents wrapping */ + DUK_ASSERT(new_size <= DUK_SIZE_MAX / sizeof(duk_tval)); /* specific assert for wrapping */ + + /* Pre-realloc pointer copies for asserts and debug logs. */ + pre_valstack = thr->valstack; + pre_bottom = thr->valstack_bottom; + pre_top = thr->valstack_top; + pre_end = thr->valstack_end; + pre_alloc_end = thr->valstack_alloc_end; + + DUK_UNREF(pre_valstack); + DUK_UNREF(pre_bottom); + DUK_UNREF(pre_top); + DUK_UNREF(pre_end); + DUK_UNREF(pre_alloc_end); + + /* If finalizer torture enabled, force base pointer change every time + * when it would be allowed. + */ +#if defined(DUK_USE_FINALIZER_TORTURE) + if (thr->heap->pf_prevent_count == 0) { + duk_hthread_valstack_torture_realloc(thr); + } +#endif + + /* Allocate a new valstack using DUK_REALLOC_DIRECT() to deal with + * a side effect changing the base pointer. + */ + new_alloc_size = sizeof(duk_tval) * new_size; + new_valstack = (duk_tval *) DUK_REALLOC_INDIRECT(thr->heap, duk_hthread_get_valstack_ptr, (void *) thr, new_alloc_size); + if (DUK_UNLIKELY(new_valstack == NULL)) { + /* Because new_size != 0, if condition doesn't need to be + * (new_valstack != NULL || new_size == 0). + */ + DUK_ASSERT(new_size != 0); + DUK_D(DUK_DPRINT("failed to resize valstack to %lu entries (%lu bytes)", + (unsigned long) new_size, + (unsigned long) new_alloc_size)); + return 0; + } + + /* Debug log any changes in pointer(s) by side effects. These don't + * necessarily imply any incorrect behavior, but should be rare in + * practice. + */ +#if defined(DUK_USE_DEBUG) + if (thr->valstack != pre_valstack) { + DUK_D(DUK_DPRINT("valstack base pointer changed during valstack resize: %p -> %p", + (void *) pre_valstack, + (void *) thr->valstack)); + } + if (thr->valstack_bottom != pre_bottom) { + DUK_D(DUK_DPRINT("valstack bottom pointer changed during valstack resize: %p -> %p", + (void *) pre_bottom, + (void *) thr->valstack_bottom)); + } + if (thr->valstack_top != pre_top) { + DUK_D(DUK_DPRINT("valstack top pointer changed during valstack resize: %p -> %p", + (void *) pre_top, + (void *) thr->valstack_top)); + } + if (thr->valstack_end != pre_end) { + DUK_D(DUK_DPRINT("valstack end pointer changed during valstack resize: %p -> %p", + (void *) pre_end, + (void *) thr->valstack_end)); + } + if (thr->valstack_alloc_end != pre_alloc_end) { + DUK_D(DUK_DPRINT("valstack alloc_end pointer changed during valstack resize: %p -> %p", + (void *) pre_alloc_end, + (void *) thr->valstack_alloc_end)); + } +#endif + + /* Assertions: offsets for bottom, top, and end (reserve) must not + * have changed even with side effects because they are always + * restored in unwind. For alloc_end there's no guarantee: it may + * have grown or shrunk (but remain above 'end'). + */ + DUK_ASSERT(thr->valstack_bottom - thr->valstack == pre_bottom - pre_valstack); + DUK_ASSERT(thr->valstack_top - thr->valstack == pre_top - pre_valstack); + DUK_ASSERT(thr->valstack_end - thr->valstack == pre_end - pre_valstack); + DUK_ASSERT(thr->valstack_alloc_end >= thr->valstack_end); + + /* Write new pointers. Most pointers can be handled as a pointer + * difference. + */ + ptr_diff = (duk_ptrdiff_t) ((duk_uint8_t *) new_valstack - (duk_uint8_t *) thr->valstack); + tv_prev_alloc_end = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack_alloc_end + ptr_diff); + thr->valstack = new_valstack; + thr->valstack_bottom = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack_bottom + ptr_diff); + thr->valstack_top = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack_top + ptr_diff); + thr->valstack_end = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack_end + ptr_diff); + thr->valstack_alloc_end = (duk_tval *) (void *) ((duk_uint8_t *) new_valstack + new_alloc_size); + + /* Assertions: pointer sanity after pointer updates. */ + DUK_ASSERT(thr->valstack_bottom >= thr->valstack); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT(thr->valstack_end >= thr->valstack_top); + DUK_ASSERT(thr->valstack_alloc_end >= thr->valstack_end); + + DUK_D(DUK_DPRINT("resized valstack %lu -> %lu elements (%lu -> %lu bytes): " + "base=%p -> %p, bottom=%p -> %p (%ld), top=%p -> %p (%ld), " + "end=%p -> %p (%ld), alloc_end=%p -> %p (%ld);" + " tv_prev_alloc_end=%p (-> %ld inits; <0 means shrink)", + (unsigned long) (pre_alloc_end - pre_valstack), + (unsigned long) new_size, + (unsigned long) ((duk_uint8_t *) pre_alloc_end - (duk_uint8_t *) pre_valstack), + (unsigned long) new_alloc_size, + (void *) pre_valstack, + (void *) thr->valstack, + (void *) pre_bottom, + (void *) thr->valstack_bottom, + (long) (thr->valstack_bottom - thr->valstack), + (void *) pre_top, + (void *) thr->valstack_top, + (long) (thr->valstack_top - thr->valstack), + (void *) pre_end, + (void *) thr->valstack_end, + (long) (thr->valstack_end - thr->valstack), + (void *) pre_alloc_end, + (void *) thr->valstack_alloc_end, + (long) (thr->valstack_alloc_end - thr->valstack), + (void *) tv_prev_alloc_end, + (long) (thr->valstack_alloc_end - tv_prev_alloc_end))); + + /* If allocation grew, init any new slots to 'undefined'. */ + p = tv_prev_alloc_end; + while (p < thr->valstack_alloc_end) { + /* Never executed if new size is smaller. */ + DUK_TVAL_SET_UNDEFINED(p); + p++; + } + + /* Assert for value stack initialization policy. */ +#if defined(DUK_USE_ASSERTIONS) + p = thr->valstack_top; + while (p < thr->valstack_alloc_end) { + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(p)); + p++; + } +#endif + + return 1; +} + +DUK_LOCAL DUK_COLD DUK_NOINLINE duk_bool_t duk__valstack_grow(duk_hthread *thr, duk_size_t min_bytes, duk_bool_t throw_on_error) { + duk_size_t min_size; + duk_size_t new_size; + + DUK_ASSERT(min_bytes / sizeof(duk_tval) * sizeof(duk_tval) == min_bytes); + min_size = min_bytes / sizeof(duk_tval); /* from bytes to slots */ + +#if defined(DUK_USE_VALSTACK_GROW_SHIFT) + /* New size is minimum size plus a proportional slack, e.g. shift of + * 2 means a 25% slack. + */ + new_size = min_size + (min_size >> DUK_USE_VALSTACK_GROW_SHIFT); +#else + /* New size is tight with no slack. This is sometimes preferred in + * low memory environments. + */ + new_size = min_size; +#endif + + if (DUK_UNLIKELY(new_size > DUK_USE_VALSTACK_LIMIT || new_size < min_size /*wrap*/)) { + /* Note: may be triggered even if minimal new_size would not reach the limit, + * plan limit accordingly. + */ + if (throw_on_error) { + DUK_ERROR_RANGE(thr, DUK_STR_VALSTACK_LIMIT); + DUK_WO_NORETURN(return 0;); + } + return 0; + } + + if (duk__resize_valstack(thr, new_size) == 0) { + if (throw_on_error) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return 0;); + } + return 0; + } + + thr->valstack_end = thr->valstack + min_size; + DUK_ASSERT(thr->valstack_alloc_end >= thr->valstack_end); + + return 1; +} + +/* Hot, inlined value stack grow check. Because value stack almost never + * grows, the actual resize call is in a NOINLINE helper. + */ +DUK_INTERNAL DUK_INLINE void duk_valstack_grow_check_throw(duk_hthread *thr, duk_size_t min_bytes) { + duk_tval *tv; + + tv = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + min_bytes); + if (DUK_LIKELY(thr->valstack_end >= tv)) { + return; + } + if (DUK_LIKELY(thr->valstack_alloc_end >= tv)) { + /* Values in [valstack_top,valstack_alloc_end[ are initialized + * to 'undefined' so we can just move the end pointer. + */ + thr->valstack_end = tv; + return; + } + (void) duk__valstack_grow(thr, min_bytes, 1 /*throw_on_error*/); +} + +/* Hot, inlined value stack grow check which doesn't throw. */ +DUK_INTERNAL DUK_INLINE duk_bool_t duk_valstack_grow_check_nothrow(duk_hthread *thr, duk_size_t min_bytes) { + duk_tval *tv; + + tv = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + min_bytes); + if (DUK_LIKELY(thr->valstack_end >= tv)) { + return 1; + } + if (DUK_LIKELY(thr->valstack_alloc_end >= tv)) { + thr->valstack_end = tv; + return 1; + } + return duk__valstack_grow(thr, min_bytes, 0 /*throw_on_error*/); +} + +/* Value stack shrink check, called from mark-and-sweep. */ +DUK_INTERNAL void duk_valstack_shrink_check_nothrow(duk_hthread *thr, duk_bool_t snug) { + duk_size_t alloc_bytes; + duk_size_t reserve_bytes; + duk_size_t shrink_bytes; + + alloc_bytes = (duk_size_t) ((duk_uint8_t *) thr->valstack_alloc_end - (duk_uint8_t *) thr->valstack); + reserve_bytes = (duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack); + DUK_ASSERT(alloc_bytes >= reserve_bytes); + + /* We're free to shrink the value stack allocation down to + * reserve_bytes but not more. If 'snug' (emergency GC) + * shrink whatever we can. Otherwise only shrink if the new + * size would be considerably smaller. + */ + +#if defined(DUK_USE_VALSTACK_SHRINK_CHECK_SHIFT) + if (snug) { + shrink_bytes = reserve_bytes; + } else { + duk_size_t proportion, slack; + + /* Require that value stack shrinks by at least X% of its + * current size. For example, shift of 2 means at least + * 25%. The proportion is computed as bytes and may not + * be a multiple of sizeof(duk_tval); that's OK here. + */ + proportion = alloc_bytes >> DUK_USE_VALSTACK_SHRINK_CHECK_SHIFT; + if (alloc_bytes - reserve_bytes < proportion) { + /* Too little would be freed, do nothing. */ + return; + } + + /* Keep a slack after shrinking. The slack is again a + * proportion of the current size (the proportion should + * of course be smaller than the check proportion above). + */ +#if defined(DUK_USE_VALSTACK_SHRINK_SLACK_SHIFT) + DUK_ASSERT(DUK_USE_VALSTACK_SHRINK_SLACK_SHIFT > DUK_USE_VALSTACK_SHRINK_CHECK_SHIFT); + slack = alloc_bytes >> DUK_USE_VALSTACK_SHRINK_SLACK_SHIFT; +#else + slack = 0; +#endif + shrink_bytes = reserve_bytes + slack / sizeof(duk_tval) * sizeof(duk_tval); /* multiple of duk_tval */ + } +#else /* DUK_USE_VALSTACK_SHRINK_CHECK_SHIFT */ + /* Always snug, useful in some low memory environments. */ + DUK_UNREF(snug); + shrink_bytes = reserve_bytes; +#endif /* DUK_USE_VALSTACK_SHRINK_CHECK_SHIFT */ + + DUK_D(DUK_DPRINT("valstack shrink check: alloc_bytes=%ld, reserve_bytes=%ld, shrink_bytes=%ld (unvalidated)", + (long) alloc_bytes, + (long) reserve_bytes, + (long) shrink_bytes)); + DUK_ASSERT(shrink_bytes >= reserve_bytes); + if (shrink_bytes >= alloc_bytes) { + /* Skip if shrink target is same as current one (or higher, + * though that shouldn't happen in practice). + */ + return; + } + DUK_ASSERT(shrink_bytes / sizeof(duk_tval) * sizeof(duk_tval) == shrink_bytes); + + DUK_D(DUK_DPRINT("valstack shrink check: decided to shrink, snug: %ld", (long) snug)); + + duk__resize_valstack(thr, shrink_bytes / sizeof(duk_tval)); +} + +DUK_EXTERNAL duk_bool_t duk_check_stack(duk_hthread *thr, duk_idx_t extra) { + duk_size_t min_new_bytes; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr != NULL); + + if (DUK_UNLIKELY(extra < 0 || extra > DUK_USE_VALSTACK_LIMIT)) { + if (extra < 0) { + /* Clamping to zero makes the API more robust to calling code + * calculation errors. + */ + extra = 0; + } else { + /* Cause grow check to fail without wrapping arithmetic. */ + extra = DUK_USE_VALSTACK_LIMIT; + } + } + + min_new_bytes = (duk_size_t) ((duk_uint8_t *) thr->valstack_top - (duk_uint8_t *) thr->valstack) + + sizeof(duk_tval) * ((duk_size_t) extra + DUK_VALSTACK_INTERNAL_EXTRA); + return duk_valstack_grow_check_nothrow(thr, min_new_bytes); +} + +DUK_EXTERNAL void duk_require_stack(duk_hthread *thr, duk_idx_t extra) { + duk_size_t min_new_bytes; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr != NULL); + + if (DUK_UNLIKELY(extra < 0 || extra > DUK_USE_VALSTACK_LIMIT)) { + if (extra < 0) { + /* Clamping to zero makes the API more robust to calling code + * calculation errors. + */ + extra = 0; + } else { + /* Cause grow check to fail without wrapping arithmetic. */ + extra = DUK_USE_VALSTACK_LIMIT; + } + } + + min_new_bytes = (duk_size_t) ((duk_uint8_t *) thr->valstack_top - (duk_uint8_t *) thr->valstack) + + sizeof(duk_tval) * ((duk_size_t) extra + DUK_VALSTACK_INTERNAL_EXTRA); + duk_valstack_grow_check_throw(thr, min_new_bytes); +} + +DUK_EXTERNAL duk_bool_t duk_check_stack_top(duk_hthread *thr, duk_idx_t top) { + duk_size_t min_new_bytes; + + DUK_ASSERT_API_ENTRY(thr); + + if (DUK_UNLIKELY(top < 0 || top > DUK_USE_VALSTACK_LIMIT)) { + if (top < 0) { + /* Clamping to zero makes the API more robust to calling code + * calculation errors. + */ + top = 0; + } else { + /* Cause grow check to fail without wrapping arithmetic. */ + top = DUK_USE_VALSTACK_LIMIT; + } + } + + DUK_ASSERT(top >= 0); + min_new_bytes = (duk_size_t) ((duk_uint8_t *) thr->valstack_bottom - (duk_uint8_t *) thr->valstack) + + sizeof(duk_tval) * ((duk_size_t) top + DUK_VALSTACK_INTERNAL_EXTRA); + return duk_valstack_grow_check_nothrow(thr, min_new_bytes); +} + +DUK_EXTERNAL void duk_require_stack_top(duk_hthread *thr, duk_idx_t top) { + duk_size_t min_new_bytes; + + DUK_ASSERT_API_ENTRY(thr); + + if (DUK_UNLIKELY(top < 0 || top > DUK_USE_VALSTACK_LIMIT)) { + if (top < 0) { + /* Clamping to zero makes the API more robust to calling code + * calculation errors. + */ + top = 0; + } else { + /* Cause grow check to fail without wrapping arithmetic. */ + top = DUK_USE_VALSTACK_LIMIT; + } + } + + DUK_ASSERT(top >= 0); + min_new_bytes = (duk_size_t) ((duk_uint8_t *) thr->valstack_bottom - (duk_uint8_t *) thr->valstack) + + sizeof(duk_tval) * ((duk_size_t) top + DUK_VALSTACK_INTERNAL_EXTRA); + duk_valstack_grow_check_throw(thr, min_new_bytes); +} + +/* + * Basic stack manipulation: swap, dup, insert, replace, etc + */ + +DUK_EXTERNAL void duk_swap(duk_hthread *thr, duk_idx_t idx1, duk_idx_t idx2) { + duk_tval *tv1; + duk_tval *tv2; + duk_tval tv_tmp; + + DUK_ASSERT_API_ENTRY(thr); + + tv1 = duk_require_tval(thr, idx1); + DUK_ASSERT(tv1 != NULL); + tv2 = duk_require_tval(thr, idx2); + DUK_ASSERT(tv2 != NULL); + + /* If tv1==tv2 this is a NOP, no check is needed */ + DUK_TVAL_SET_TVAL(&tv_tmp, tv1); + DUK_TVAL_SET_TVAL(tv1, tv2); + DUK_TVAL_SET_TVAL(tv2, &tv_tmp); +} + +DUK_EXTERNAL void duk_swap_top(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + duk_swap(thr, idx, -1); +} + +DUK_EXTERNAL void duk_dup(duk_hthread *thr, duk_idx_t from_idx) { + duk_tval *tv_from; + duk_tval *tv_to; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + + tv_from = duk_require_tval(thr, from_idx); + tv_to = thr->valstack_top++; + DUK_ASSERT(tv_from != NULL); + DUK_ASSERT(tv_to != NULL); + DUK_TVAL_SET_TVAL(tv_to, tv_from); + DUK_TVAL_INCREF(thr, tv_to); /* no side effects */ +} + +DUK_EXTERNAL void duk_dup_top(duk_hthread *thr) { +#if defined(DUK_USE_PREFER_SIZE) + duk_dup(thr, -1); +#else + duk_tval *tv_from; + duk_tval *tv_to; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + + if (DUK_UNLIKELY(thr->valstack_top - thr->valstack_bottom <= 0)) { + DUK_ERROR_RANGE_INDEX(thr, -1); + DUK_WO_NORETURN(return;); + } + tv_from = thr->valstack_top - 1; + tv_to = thr->valstack_top++; + DUK_ASSERT(tv_from != NULL); + DUK_ASSERT(tv_to != NULL); + DUK_TVAL_SET_TVAL(tv_to, tv_from); + DUK_TVAL_INCREF(thr, tv_to); /* no side effects */ +#endif +} + +DUK_INTERNAL void duk_dup_0(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_dup(thr, 0); +} +DUK_INTERNAL void duk_dup_1(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_dup(thr, 1); +} +DUK_INTERNAL void duk_dup_2(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_dup(thr, 2); +} +DUK_INTERNAL void duk_dup_m2(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_dup(thr, -2); +} +DUK_INTERNAL void duk_dup_m3(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_dup(thr, -3); +} +DUK_INTERNAL void duk_dup_m4(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_dup(thr, -4); +} + +DUK_EXTERNAL void duk_insert(duk_hthread *thr, duk_idx_t to_idx) { + duk_tval *p; + duk_tval *q; + duk_tval tv_tmp; + duk_size_t nbytes; + + DUK_ASSERT_API_ENTRY(thr); + + p = duk_require_tval(thr, to_idx); + DUK_ASSERT(p != NULL); + q = duk_require_tval(thr, -1); + DUK_ASSERT(q != NULL); + + DUK_ASSERT(q >= p); + + /* nbytes + * <---------> + * [ ... | p | x | x | q ] + * => [ ... | q | p | x | x ] + */ + + nbytes = (duk_size_t) (((duk_uint8_t *) q) - ((duk_uint8_t *) p)); + + DUK_DDD(DUK_DDDPRINT("duk_insert: to_idx=%ld, p=%p, q=%p, nbytes=%lu", + (long) to_idx, + (void *) p, + (void *) q, + (unsigned long) nbytes)); + + /* No net refcount changes. No need to special case nbytes == 0 + * (p == q). + */ + DUK_TVAL_SET_TVAL(&tv_tmp, q); + duk_memmove((void *) (p + 1), (const void *) p, (size_t) nbytes); + DUK_TVAL_SET_TVAL(p, &tv_tmp); +} + +DUK_INTERNAL void duk_insert_undefined(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(idx >= 0); /* Doesn't support negative indices. */ + + duk_push_undefined(thr); + duk_insert(thr, idx); +} + +DUK_INTERNAL void duk_insert_undefined_n(duk_hthread *thr, duk_idx_t idx, duk_idx_t count) { + duk_tval *tv, *tv_end; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(idx >= 0); /* Doesn't support negative indices or count. */ + DUK_ASSERT(count >= 0); + + tv = duk_reserve_gap(thr, idx, count); + tv_end = tv + count; + while (tv != tv_end) { + DUK_TVAL_SET_UNDEFINED(tv); + tv++; + } +} + +DUK_EXTERNAL void duk_pull(duk_hthread *thr, duk_idx_t from_idx) { + duk_tval *p; + duk_tval *q; + duk_tval tv_tmp; + duk_size_t nbytes; + + DUK_ASSERT_API_ENTRY(thr); + + /* nbytes + * <---------> + * [ ... | x | x | p | y | y | q ] + * => [ ... | x | x | y | y | q | p ] + */ + + p = duk_require_tval(thr, from_idx); + DUK_ASSERT(p != NULL); + q = duk_require_tval(thr, -1); + DUK_ASSERT(q != NULL); + + DUK_ASSERT(q >= p); + + nbytes = (duk_size_t) (((duk_uint8_t *) q) - ((duk_uint8_t *) p)); + + DUK_DDD(DUK_DDDPRINT("duk_pull: from_idx=%ld, p=%p, q=%p, nbytes=%lu", + (long) from_idx, + (void *) p, + (void *) q, + (unsigned long) nbytes)); + + /* No net refcount changes. No need to special case nbytes == 0 + * (p == q). + */ + DUK_TVAL_SET_TVAL(&tv_tmp, p); + duk_memmove((void *) p, (const void *) (p + 1), (size_t) nbytes); + DUK_TVAL_SET_TVAL(q, &tv_tmp); +} + +DUK_EXTERNAL void duk_replace(duk_hthread *thr, duk_idx_t to_idx) { + duk_tval *tv1; + duk_tval *tv2; + duk_tval tv_tmp; + + DUK_ASSERT_API_ENTRY(thr); + + tv1 = duk_require_tval(thr, -1); + DUK_ASSERT(tv1 != NULL); + tv2 = duk_require_tval(thr, to_idx); + DUK_ASSERT(tv2 != NULL); + + /* For tv1 == tv2, both pointing to stack top, the end result + * is same as duk_pop(thr). + */ + DUK_TVAL_SET_TVAL(&tv_tmp, tv2); + DUK_TVAL_SET_TVAL(tv2, tv1); + DUK_TVAL_SET_UNDEFINED(tv1); + thr->valstack_top--; + DUK_TVAL_DECREF(thr, &tv_tmp); /* side effects */ +} + +DUK_EXTERNAL void duk_copy(duk_hthread *thr, duk_idx_t from_idx, duk_idx_t to_idx) { + duk_tval *tv1; + duk_tval *tv2; + + DUK_ASSERT_API_ENTRY(thr); + + tv1 = duk_require_tval(thr, from_idx); + DUK_ASSERT(tv1 != NULL); + tv2 = duk_require_tval(thr, to_idx); + DUK_ASSERT(tv2 != NULL); + + /* For tv1 == tv2, this is a no-op (no explicit check needed). */ + DUK_TVAL_SET_TVAL_UPDREF(thr, tv2, tv1); /* side effects */ +} + +DUK_EXTERNAL void duk_remove(duk_hthread *thr, duk_idx_t idx) { + duk_tval *p; + duk_tval *q; +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_tval tv_tmp; +#endif + duk_size_t nbytes; + + DUK_ASSERT_API_ENTRY(thr); + + p = duk_require_tval(thr, idx); + DUK_ASSERT(p != NULL); + q = duk_require_tval(thr, -1); + DUK_ASSERT(q != NULL); + + DUK_ASSERT(q >= p); + + /* nbytes zero size case + * <---------> + * [ ... | p | x | x | q ] [ ... | p==q ] + * => [ ... | x | x | q ] [ ... ] + */ + +#if defined(DUK_USE_REFERENCE_COUNTING) + /* use a temp: decref only when valstack reachable values are correct */ + DUK_TVAL_SET_TVAL(&tv_tmp, p); +#endif + + nbytes = (duk_size_t) (((duk_uint8_t *) q) - ((duk_uint8_t *) p)); /* Note: 'q' is top-1 */ + duk_memmove((void *) p, (const void *) (p + 1), (size_t) nbytes); + + DUK_TVAL_SET_UNDEFINED(q); + thr->valstack_top--; + +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_TVAL_DECREF(thr, &tv_tmp); /* side effects */ +#endif +} + +DUK_INTERNAL void duk_remove_unsafe(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + duk_remove(thr, idx); /* XXX: no optimization for now */ +} + +DUK_INTERNAL void duk_remove_m2(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + duk_remove(thr, -2); +} + +DUK_INTERNAL void duk_remove_n(duk_hthread *thr, duk_idx_t idx, duk_idx_t count) { +#if defined(DUK_USE_PREFER_SIZE) + /* XXX: maybe too slow even when preferring size? */ + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(count >= 0); + DUK_ASSERT(idx >= 0); + + while (count-- > 0) { + duk_remove(thr, idx); + } +#else /* DUK_USE_PREFER_SIZE */ + duk_tval *tv_src; + duk_tval *tv_dst; + duk_tval *tv_newtop; + duk_tval *tv; + duk_size_t bytes; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(count >= 0); + DUK_ASSERT(idx >= 0); + + tv_dst = thr->valstack_bottom + idx; + DUK_ASSERT(tv_dst <= thr->valstack_top); + tv_src = tv_dst + count; + DUK_ASSERT(tv_src <= thr->valstack_top); + bytes = (duk_size_t) ((duk_uint8_t *) thr->valstack_top - (duk_uint8_t *) tv_src); + + for (tv = tv_dst; tv < tv_src; tv++) { + DUK_TVAL_DECREF_NORZ(thr, tv); + } + + duk_memmove((void *) tv_dst, (const void *) tv_src, bytes); + + tv_newtop = thr->valstack_top - count; + for (tv = tv_newtop; tv < thr->valstack_top; tv++) { + DUK_TVAL_SET_UNDEFINED(tv); + } + thr->valstack_top = tv_newtop; + + /* When not preferring size, only NORZ macros are used; caller + * is expected to DUK_REFZERO_CHECK(). + */ +#endif /* DUK_USE_PREFER_SIZE */ +} + +DUK_INTERNAL void duk_remove_n_unsafe(duk_hthread *thr, duk_idx_t idx, duk_idx_t count) { + DUK_ASSERT_API_ENTRY(thr); + + duk_remove_n(thr, idx, count); /* XXX: no optimization for now */ +} + +/* + * Stack slice primitives + */ + +DUK_EXTERNAL void duk_xcopymove_raw(duk_hthread *to_thr, duk_hthread *from_thr, duk_idx_t count, duk_bool_t is_copy) { + void *src; + duk_size_t nbytes; + duk_tval *p; + duk_tval *q; + + /* XXX: several pointer comparison issues here */ + + DUK_ASSERT_API_ENTRY(to_thr); + DUK_CTX_ASSERT_VALID(to_thr); + DUK_CTX_ASSERT_VALID(from_thr); + DUK_ASSERT(to_thr->heap == from_thr->heap); + + if (DUK_UNLIKELY(to_thr == from_thr)) { + DUK_ERROR_TYPE(to_thr, DUK_STR_INVALID_CONTEXT); + DUK_WO_NORETURN(return;); + } + if (DUK_UNLIKELY((duk_uidx_t) count > (duk_uidx_t) DUK_USE_VALSTACK_LIMIT)) { + /* Maximum value check ensures 'nbytes' won't wrap below. + * Also handles negative count. + */ + DUK_ERROR_RANGE_INVALID_COUNT(to_thr); + DUK_WO_NORETURN(return;); + } + DUK_ASSERT(count >= 0); + + nbytes = sizeof(duk_tval) * (duk_size_t) count; + if (DUK_UNLIKELY(nbytes == 0)) { + return; + } + DUK_ASSERT(to_thr->valstack_top <= to_thr->valstack_end); + if (DUK_UNLIKELY((duk_size_t) ((duk_uint8_t *) to_thr->valstack_end - (duk_uint8_t *) to_thr->valstack_top) < nbytes)) { + DUK_ERROR_RANGE_PUSH_BEYOND(to_thr); + DUK_WO_NORETURN(return;); + } + src = (void *) ((duk_uint8_t *) from_thr->valstack_top - nbytes); + if (DUK_UNLIKELY(src < (void *) from_thr->valstack_bottom)) { + DUK_ERROR_RANGE_INVALID_COUNT(to_thr); + DUK_WO_NORETURN(return;); + } + + /* Copy values (no overlap even if to_thr == from_thr; that's not + * allowed now anyway). + */ + DUK_ASSERT(nbytes > 0); + duk_memcpy((void *) to_thr->valstack_top, (const void *) src, (size_t) nbytes); + + p = to_thr->valstack_top; + to_thr->valstack_top = (duk_tval *) (void *) (((duk_uint8_t *) p) + nbytes); + + if (is_copy) { + /* Incref copies, keep originals. */ + q = to_thr->valstack_top; + while (p < q) { + DUK_TVAL_INCREF(to_thr, p); /* no side effects */ + p++; + } + } else { + /* No net refcount change. */ + p = from_thr->valstack_top; + q = (duk_tval *) (void *) (((duk_uint8_t *) p) - nbytes); + from_thr->valstack_top = q; + + while (p > q) { + p--; + DUK_TVAL_SET_UNDEFINED(p); + /* XXX: fast primitive to set a bunch of values to UNDEFINED */ + } + } +} + +/* Internal helper: reserve a gap of 'count' elements at 'idx_base' and return a + * pointer to the gap. Values in the gap are garbage and MUST be initialized by + * the caller before any side effects may occur. The caller must ensure there's + * enough stack reserve for 'count' values. + */ +DUK_INTERNAL duk_tval *duk_reserve_gap(duk_hthread *thr, duk_idx_t idx_base, duk_idx_t count) { + duk_tval *tv_src; + duk_tval *tv_dst; + duk_size_t gap_bytes; + duk_size_t copy_bytes; + + /* Caller is responsible for ensuring there's enough preallocated + * value stack. + */ + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(count >= 0); + DUK_ASSERT((duk_size_t) (thr->valstack_end - thr->valstack_top) >= (duk_size_t) count); + + tv_src = thr->valstack_bottom + idx_base; + gap_bytes = (duk_size_t) count * sizeof(duk_tval); + tv_dst = (duk_tval *) (void *) ((duk_uint8_t *) tv_src + gap_bytes); + copy_bytes = (duk_size_t) ((duk_uint8_t *) thr->valstack_top - (duk_uint8_t *) tv_src); + thr->valstack_top = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack_top + gap_bytes); + duk_memmove((void *) tv_dst, (const void *) tv_src, copy_bytes); + + /* Values in the gap are left as garbage: caller must fill them in + * and INCREF them before any side effects. + */ + return tv_src; +} + +/* + * Get/opt/require + */ + +DUK_EXTERNAL void duk_require_undefined(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_UNLIKELY(!DUK_TVAL_IS_UNDEFINED(tv))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "undefined", DUK_STR_NOT_UNDEFINED); + DUK_WO_NORETURN(return;); + } +} + +DUK_EXTERNAL void duk_require_null(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_UNLIKELY(!DUK_TVAL_IS_NULL(tv))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "null", DUK_STR_NOT_NULL); + DUK_WO_NORETURN(return;); + } +} + +DUK_LOCAL DUK_ALWAYS_INLINE duk_bool_t duk__get_boolean_raw(duk_hthread *thr, duk_idx_t idx, duk_bool_t def_value) { + duk_bool_t ret; + duk_tval *tv; + + DUK_CTX_ASSERT_VALID(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_TVAL_IS_BOOLEAN(tv)) { + ret = DUK_TVAL_GET_BOOLEAN(tv); + DUK_ASSERT(ret == 0 || ret == 1); + } else { + ret = def_value; + /* Not guaranteed to be 0 or 1. */ + } + + return ret; +} + +DUK_EXTERNAL duk_bool_t duk_get_boolean(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + return duk__get_boolean_raw(thr, idx, 0); /* default: false */ +} + +DUK_EXTERNAL duk_bool_t duk_get_boolean_default(duk_hthread *thr, duk_idx_t idx, duk_bool_t def_value) { + DUK_ASSERT_API_ENTRY(thr); + + return duk__get_boolean_raw(thr, idx, def_value); +} + +DUK_EXTERNAL duk_bool_t duk_require_boolean(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_bool_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_LIKELY(DUK_TVAL_IS_BOOLEAN(tv))) { + ret = DUK_TVAL_GET_BOOLEAN(tv); + DUK_ASSERT(ret == 0 || ret == 1); + return ret; + } else { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "boolean", DUK_STR_NOT_BOOLEAN); + DUK_WO_NORETURN(return 0;); + } +} + +DUK_EXTERNAL duk_bool_t duk_opt_boolean(duk_hthread *thr, duk_idx_t idx, duk_bool_t def_value) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + return def_value; + } + return duk_require_boolean(thr, idx); +} + +DUK_LOCAL DUK_ALWAYS_INLINE duk_double_t duk__get_number_raw(duk_hthread *thr, duk_idx_t idx, duk_double_t def_value) { + duk_double_union ret; + duk_tval *tv; + + DUK_CTX_ASSERT_VALID(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv)) { + ret.d = (duk_double_t) DUK_TVAL_GET_FASTINT(tv); /* XXX: cast trick */ + } else +#endif + if (DUK_TVAL_IS_DOUBLE(tv)) { + /* When using packed duk_tval, number must be in NaN-normalized form + * for it to be a duk_tval, so no need to normalize. NOP for unpacked + * duk_tval. + */ + ret.d = DUK_TVAL_GET_DOUBLE(tv); + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&ret)); + } else { + ret.d = def_value; + /* Default value (including NaN) may not be normalized. */ + } + + return ret.d; +} + +DUK_EXTERNAL duk_double_t duk_get_number(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__get_number_raw(thr, idx, DUK_DOUBLE_NAN); /* default: NaN */ +} + +DUK_EXTERNAL duk_double_t duk_get_number_default(duk_hthread *thr, duk_idx_t idx, duk_double_t def_value) { + DUK_ASSERT_API_ENTRY(thr); + return duk__get_number_raw(thr, idx, def_value); +} + +DUK_EXTERNAL duk_double_t duk_require_number(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_double_union ret; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_UNLIKELY(!DUK_TVAL_IS_NUMBER(tv))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "number", DUK_STR_NOT_NUMBER); + DUK_WO_NORETURN(return 0.0;); + } + + ret.d = DUK_TVAL_GET_NUMBER(tv); + + /* When using packed duk_tval, number must be in NaN-normalized form + * for it to be a duk_tval, so no need to normalize. NOP for unpacked + * duk_tval. + */ + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&ret)); + return ret.d; +} + +DUK_EXTERNAL duk_double_t duk_opt_number(duk_hthread *thr, duk_idx_t idx, duk_double_t def_value) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + /* User provided default is not NaN normalized. */ + return def_value; + } + return duk_require_number(thr, idx); +} + +DUK_EXTERNAL duk_int_t duk_get_int(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + return (duk_int_t) duk__api_coerce_d2i(thr, idx, 0 /*def_value*/, 0 /*require*/); +} + +DUK_EXTERNAL duk_uint_t duk_get_uint(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + return (duk_uint_t) duk__api_coerce_d2ui(thr, idx, 0 /*def_value*/, 0 /*require*/); +} + +DUK_EXTERNAL duk_int_t duk_get_int_default(duk_hthread *thr, duk_idx_t idx, duk_int_t def_value) { + DUK_ASSERT_API_ENTRY(thr); + + return (duk_int_t) duk__api_coerce_d2i(thr, idx, def_value, 0 /*require*/); +} + +DUK_EXTERNAL duk_uint_t duk_get_uint_default(duk_hthread *thr, duk_idx_t idx, duk_uint_t def_value) { + DUK_ASSERT_API_ENTRY(thr); + + return (duk_uint_t) duk__api_coerce_d2ui(thr, idx, def_value, 0 /*require*/); +} + +DUK_EXTERNAL duk_int_t duk_require_int(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + return (duk_int_t) duk__api_coerce_d2i(thr, idx, 0 /*def_value*/, 1 /*require*/); +} + +DUK_EXTERNAL duk_uint_t duk_require_uint(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + return (duk_uint_t) duk__api_coerce_d2ui(thr, idx, 0 /*def_value*/, 1 /*require*/); +} + +DUK_EXTERNAL duk_int_t duk_opt_int(duk_hthread *thr, duk_idx_t idx, duk_int_t def_value) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + return def_value; + } + return duk_require_int(thr, idx); +} + +DUK_EXTERNAL duk_uint_t duk_opt_uint(duk_hthread *thr, duk_idx_t idx, duk_uint_t def_value) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + return def_value; + } + return duk_require_uint(thr, idx); +} + +DUK_EXTERNAL const char *duk_get_lstring(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_len) { + duk_hstring *h; + const char *ret; + duk_size_t len; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_get_hstring(thr, idx); + if (h != NULL) { + len = DUK_HSTRING_GET_BYTELEN(h); + ret = (const char *) DUK_HSTRING_GET_DATA(h); + } else { + len = 0; + ret = NULL; + } + + if (out_len != NULL) { + *out_len = len; + } + return ret; +} + +DUK_EXTERNAL const char *duk_require_lstring(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_len) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_require_hstring(thr, idx); + DUK_ASSERT(h != NULL); + if (out_len) { + *out_len = DUK_HSTRING_GET_BYTELEN(h); + } + return (const char *) DUK_HSTRING_GET_DATA(h); +} + +DUK_INTERNAL const char *duk_require_lstring_notsymbol(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_len) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_require_hstring_notsymbol(thr, idx); + DUK_ASSERT(h != NULL); + if (out_len) { + *out_len = DUK_HSTRING_GET_BYTELEN(h); + } + return (const char *) DUK_HSTRING_GET_DATA(h); +} + +DUK_EXTERNAL const char *duk_get_string(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_get_hstring(thr, idx); + if (h != NULL) { + return (const char *) DUK_HSTRING_GET_DATA(h); + } else { + return NULL; + } +} + +DUK_EXTERNAL const char *duk_opt_lstring(duk_hthread *thr, + duk_idx_t idx, + duk_size_t *out_len, + const char *def_ptr, + duk_size_t def_len) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + if (out_len != NULL) { + *out_len = def_len; + } + return def_ptr; + } + return duk_require_lstring(thr, idx, out_len); +} + +DUK_EXTERNAL const char *duk_opt_string(duk_hthread *thr, duk_idx_t idx, const char *def_ptr) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + return def_ptr; + } + return duk_require_string(thr, idx); +} + +DUK_EXTERNAL const char *duk_get_lstring_default(duk_hthread *thr, + duk_idx_t idx, + duk_size_t *out_len, + const char *def_ptr, + duk_size_t def_len) { + duk_hstring *h; + const char *ret; + duk_size_t len; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_get_hstring(thr, idx); + if (h != NULL) { + len = DUK_HSTRING_GET_BYTELEN(h); + ret = (const char *) DUK_HSTRING_GET_DATA(h); + } else { + len = def_len; + ret = def_ptr; + } + + if (out_len != NULL) { + *out_len = len; + } + return ret; +} + +DUK_EXTERNAL const char *duk_get_string_default(duk_hthread *thr, duk_idx_t idx, const char *def_value) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_get_hstring(thr, idx); + if (h != NULL) { + return (const char *) DUK_HSTRING_GET_DATA(h); + } else { + return def_value; + } +} + +DUK_INTERNAL const char *duk_get_string_notsymbol(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_get_hstring_notsymbol(thr, idx); + if (h) { + return (const char *) DUK_HSTRING_GET_DATA(h); + } else { + return NULL; + } +} + +DUK_EXTERNAL const char *duk_require_string(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + return duk_require_lstring(thr, idx, NULL); +} + +DUK_INTERNAL const char *duk_require_string_notsymbol(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_require_hstring_notsymbol(thr, idx); + DUK_ASSERT(h != NULL); + return (const char *) DUK_HSTRING_GET_DATA(h); +} + +DUK_EXTERNAL void duk_require_object(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_UNLIKELY(!DUK_TVAL_IS_OBJECT(tv))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "object", DUK_STR_NOT_OBJECT); + DUK_WO_NORETURN(return;); + } +} + +DUK_LOCAL void *duk__get_pointer_raw(duk_hthread *thr, duk_idx_t idx, void *def_value) { + duk_tval *tv; + void *p; + + DUK_CTX_ASSERT_VALID(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (!DUK_TVAL_IS_POINTER(tv)) { + return def_value; + } + + p = DUK_TVAL_GET_POINTER(tv); /* may be NULL */ + return p; +} + +DUK_EXTERNAL void *duk_get_pointer(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__get_pointer_raw(thr, idx, NULL /*def_value*/); +} + +DUK_EXTERNAL void *duk_opt_pointer(duk_hthread *thr, duk_idx_t idx, void *def_value) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + return def_value; + } + return duk_require_pointer(thr, idx); +} + +DUK_EXTERNAL void *duk_get_pointer_default(duk_hthread *thr, duk_idx_t idx, void *def_value) { + DUK_ASSERT_API_ENTRY(thr); + return duk__get_pointer_raw(thr, idx, def_value); +} + +DUK_EXTERNAL void *duk_require_pointer(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + void *p; + + DUK_ASSERT_API_ENTRY(thr); + + /* Note: here we must be wary of the fact that a pointer may be + * valid and be a NULL. + */ + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_UNLIKELY(!DUK_TVAL_IS_POINTER(tv))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "pointer", DUK_STR_NOT_POINTER); + DUK_WO_NORETURN(return NULL;); + } + p = DUK_TVAL_GET_POINTER(tv); /* may be NULL */ + return p; +} + +#if 0 /*unused*/ +DUK_INTERNAL void *duk_get_voidptr(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_heaphdr *h; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (!DUK_TVAL_IS_HEAP_ALLOCATED(tv)) { + return NULL; + } + + h = DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(h != NULL); + return (void *) h; +} +#endif + +DUK_LOCAL void *duk__get_buffer_helper(duk_hthread *thr, + duk_idx_t idx, + duk_size_t *out_size, + void *def_ptr, + duk_size_t def_size, + duk_bool_t throw_flag) { + duk_hbuffer *h; + void *ret; + duk_size_t len; + duk_tval *tv; + + DUK_CTX_ASSERT_VALID(thr); + + if (out_size != NULL) { + *out_size = 0; + } + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_LIKELY(DUK_TVAL_IS_BUFFER(tv))) { + h = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h != NULL); + + len = DUK_HBUFFER_GET_SIZE(h); + ret = DUK_HBUFFER_GET_DATA_PTR(thr->heap, h); + } else { + if (throw_flag) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "buffer", DUK_STR_NOT_BUFFER); + DUK_WO_NORETURN(return NULL;); + } + len = def_size; + ret = def_ptr; + } + + if (out_size != NULL) { + *out_size = len; + } + return ret; +} + +DUK_EXTERNAL void *duk_get_buffer(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_size) { + DUK_ASSERT_API_ENTRY(thr); + + return duk__get_buffer_helper(thr, idx, out_size, NULL /*def_ptr*/, 0 /*def_size*/, 0 /*throw_flag*/); +} + +DUK_EXTERNAL void *duk_opt_buffer(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_size, void *def_ptr, duk_size_t def_size) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + if (out_size != NULL) { + *out_size = def_size; + } + return def_ptr; + } + return duk_require_buffer(thr, idx, out_size); +} + +DUK_EXTERNAL void *duk_get_buffer_default(duk_hthread *thr, + duk_idx_t idx, + duk_size_t *out_size, + void *def_ptr, + duk_size_t def_len) { + DUK_ASSERT_API_ENTRY(thr); + + return duk__get_buffer_helper(thr, idx, out_size, def_ptr, def_len, 0 /*throw_flag*/); +} + +DUK_EXTERNAL void *duk_require_buffer(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_size) { + DUK_ASSERT_API_ENTRY(thr); + + return duk__get_buffer_helper(thr, idx, out_size, NULL /*def_ptr*/, 0 /*def_size*/, 1 /*throw_flag*/); +} + +/* Get the active buffer data area for a plain buffer or a buffer object. + * Return NULL if the the value is not a buffer. Note that a buffer may + * have a NULL data pointer when its size is zero, the optional 'out_isbuffer' + * argument allows caller to detect this reliably. + */ +DUK_INTERNAL void *duk_get_buffer_data_raw(duk_hthread *thr, + duk_idx_t idx, + duk_size_t *out_size, + void *def_ptr, + duk_size_t def_size, + duk_bool_t throw_flag, + duk_bool_t *out_isbuffer) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + if (out_isbuffer != NULL) { + *out_isbuffer = 0; + } + if (out_size != NULL) { + *out_size = def_size; + } + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_IS_BUFFER(tv)) { + duk_hbuffer *h = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h != NULL); + if (out_size != NULL) { + *out_size = DUK_HBUFFER_GET_SIZE(h); + } + if (out_isbuffer != NULL) { + *out_isbuffer = 1; + } + return (void *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h); /* may be NULL (but only if size is 0) */ + } +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + else if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + if (DUK_HOBJECT_IS_BUFOBJ(h)) { + /* XXX: this is probably a useful shared helper: for a + * duk_hbufobj, get a validated buffer pointer/length. + */ + duk_hbufobj *h_bufobj = (duk_hbufobj *) h; + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + + if (h_bufobj->buf != NULL && DUK_HBUFOBJ_VALID_SLICE(h_bufobj)) { + duk_uint8_t *p; + + p = (duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_bufobj->buf); + if (out_size != NULL) { + *out_size = (duk_size_t) h_bufobj->length; + } + if (out_isbuffer != NULL) { + *out_isbuffer = 1; + } + return (void *) (p + h_bufobj->offset); + } + /* if slice not fully valid, treat as error */ + } + } +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + + if (throw_flag) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "buffer", DUK_STR_NOT_BUFFER); + DUK_WO_NORETURN(return NULL;); + } + return def_ptr; +} + +DUK_EXTERNAL void *duk_get_buffer_data(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_size) { + DUK_ASSERT_API_ENTRY(thr); + return duk_get_buffer_data_raw(thr, idx, out_size, NULL /*def_ptr*/, 0 /*def_size*/, 0 /*throw_flag*/, NULL); +} + +DUK_EXTERNAL void *duk_get_buffer_data_default(duk_hthread *thr, + duk_idx_t idx, + duk_size_t *out_size, + void *def_ptr, + duk_size_t def_size) { + DUK_ASSERT_API_ENTRY(thr); + return duk_get_buffer_data_raw(thr, idx, out_size, def_ptr, def_size, 0 /*throw_flag*/, NULL); +} + +DUK_EXTERNAL void *duk_opt_buffer_data(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_size, void *def_ptr, duk_size_t def_size) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + if (out_size != NULL) { + *out_size = def_size; + } + return def_ptr; + } + return duk_require_buffer_data(thr, idx, out_size); +} + +DUK_EXTERNAL void *duk_require_buffer_data(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_size) { + DUK_ASSERT_API_ENTRY(thr); + return duk_get_buffer_data_raw(thr, idx, out_size, NULL /*def_ptr*/, 0 /*def_size*/, 1 /*throw_flag*/, NULL); +} + +/* Raw helper for getting a value from the stack, checking its tag. + * The tag cannot be a number because numbers don't have an internal + * tag in the packed representation. + */ + +DUK_LOCAL duk_heaphdr *duk__get_tagged_heaphdr_raw(duk_hthread *thr, duk_idx_t idx, duk_uint_t tag) { + duk_tval *tv; + duk_heaphdr *ret; + + DUK_CTX_ASSERT_VALID(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_TVAL_GET_TAG(tv) != tag) { + return (duk_heaphdr *) NULL; + } + + ret = DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(ret != NULL); /* tagged null pointers should never occur */ + return ret; +} + +DUK_INTERNAL duk_hstring *duk_get_hstring(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return (duk_hstring *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_STRING); +} + +DUK_INTERNAL duk_hstring *duk_get_hstring_notsymbol(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hstring *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_STRING); + if (DUK_UNLIKELY(h && DUK_HSTRING_HAS_SYMBOL(h))) { + return NULL; + } + return h; +} + +DUK_INTERNAL duk_hstring *duk_require_hstring(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hstring *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_STRING); + if (DUK_UNLIKELY(h == NULL)) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "string", DUK_STR_NOT_STRING); + DUK_WO_NORETURN(return NULL;); + } + return h; +} + +DUK_INTERNAL duk_hstring *duk_require_hstring_notsymbol(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hstring *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_STRING); + if (DUK_UNLIKELY(h == NULL || DUK_HSTRING_HAS_SYMBOL(h))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "string", DUK_STR_NOT_STRING); + DUK_WO_NORETURN(return NULL;); + } + return h; +} + +DUK_INTERNAL duk_hobject *duk_get_hobject(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); +} + +DUK_INTERNAL duk_hobject *duk_require_hobject(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); + if (DUK_UNLIKELY(h == NULL)) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "object", DUK_STR_NOT_OBJECT); + DUK_WO_NORETURN(return NULL;); + } + return h; +} + +DUK_INTERNAL duk_hbuffer *duk_get_hbuffer(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return (duk_hbuffer *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_BUFFER); +} + +DUK_INTERNAL duk_hbuffer *duk_require_hbuffer(duk_hthread *thr, duk_idx_t idx) { + duk_hbuffer *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hbuffer *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_BUFFER); + if (DUK_UNLIKELY(h == NULL)) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "buffer", DUK_STR_NOT_BUFFER); + DUK_WO_NORETURN(return NULL;); + } + return h; +} + +DUK_INTERNAL duk_hthread *duk_get_hthread(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); + if (DUK_UNLIKELY(h != NULL && !DUK_HOBJECT_IS_THREAD(h))) { + h = NULL; + } + return (duk_hthread *) h; +} + +DUK_INTERNAL duk_hthread *duk_require_hthread(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); + if (DUK_UNLIKELY(!(h != NULL && DUK_HOBJECT_IS_THREAD(h)))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "thread", DUK_STR_NOT_THREAD); + DUK_WO_NORETURN(return NULL;); + } + return (duk_hthread *) h; +} + +DUK_INTERNAL duk_hcompfunc *duk_get_hcompfunc(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); + if (DUK_UNLIKELY(h != NULL && !DUK_HOBJECT_IS_COMPFUNC(h))) { + h = NULL; + } + return (duk_hcompfunc *) h; +} + +DUK_INTERNAL duk_hcompfunc *duk_require_hcompfunc(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); + if (DUK_UNLIKELY(!(h != NULL && DUK_HOBJECT_IS_COMPFUNC(h)))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "compiledfunction", DUK_STR_NOT_COMPFUNC); + DUK_WO_NORETURN(return NULL;); + } + return (duk_hcompfunc *) h; +} + +DUK_INTERNAL duk_hnatfunc *duk_get_hnatfunc(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); + if (DUK_UNLIKELY(h != NULL && !DUK_HOBJECT_IS_NATFUNC(h))) { + h = NULL; + } + return (duk_hnatfunc *) h; +} + +DUK_INTERNAL duk_hnatfunc *duk_require_hnatfunc(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); + if (DUK_UNLIKELY(!(h != NULL && DUK_HOBJECT_IS_NATFUNC(h)))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "nativefunction", DUK_STR_NOT_NATFUNC); + DUK_WO_NORETURN(return NULL;); + } + return (duk_hnatfunc *) h; +} + +DUK_EXTERNAL duk_c_function duk_get_c_function(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_hobject *h; + duk_hnatfunc *f; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_UNLIKELY(!DUK_TVAL_IS_OBJECT(tv))) { + return NULL; + } + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + + if (DUK_UNLIKELY(!DUK_HOBJECT_IS_NATFUNC(h))) { + return NULL; + } + DUK_ASSERT(DUK_HOBJECT_HAS_NATFUNC(h)); + f = (duk_hnatfunc *) h; + + return f->func; +} + +DUK_EXTERNAL duk_c_function duk_opt_c_function(duk_hthread *thr, duk_idx_t idx, duk_c_function def_value) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + return def_value; + } + return duk_require_c_function(thr, idx); +} + +DUK_EXTERNAL duk_c_function duk_get_c_function_default(duk_hthread *thr, duk_idx_t idx, duk_c_function def_value) { + duk_c_function ret; + + DUK_ASSERT_API_ENTRY(thr); + + ret = duk_get_c_function(thr, idx); + if (ret != NULL) { + return ret; + } + + return def_value; +} + +DUK_EXTERNAL duk_c_function duk_require_c_function(duk_hthread *thr, duk_idx_t idx) { + duk_c_function ret; + + DUK_ASSERT_API_ENTRY(thr); + + ret = duk_get_c_function(thr, idx); + if (DUK_UNLIKELY(!ret)) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "nativefunction", DUK_STR_NOT_NATFUNC); + DUK_WO_NORETURN(return ret;); + } + return ret; +} + +DUK_EXTERNAL void duk_require_function(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + if (DUK_UNLIKELY(!duk_is_function(thr, idx))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "function", DUK_STR_NOT_FUNCTION); + DUK_WO_NORETURN(return;); + } +} + +DUK_EXTERNAL void duk_require_constructable(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_require_hobject_accept_mask(thr, idx, DUK_TYPE_MASK_LIGHTFUNC); + if (DUK_UNLIKELY(h != NULL && !DUK_HOBJECT_HAS_CONSTRUCTABLE(h))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "constructable", DUK_STR_NOT_CONSTRUCTABLE); + DUK_WO_NORETURN(return;); + } + /* Lightfuncs (h == NULL) are constructable. */ +} + +DUK_EXTERNAL duk_hthread *duk_get_context(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + return duk_get_hthread(thr, idx); +} + +DUK_EXTERNAL duk_hthread *duk_require_context(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + return duk_require_hthread(thr, idx); +} + +DUK_EXTERNAL duk_hthread *duk_opt_context(duk_hthread *thr, duk_idx_t idx, duk_hthread *def_value) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + return def_value; + } + return duk_require_context(thr, idx); +} + +DUK_EXTERNAL duk_hthread *duk_get_context_default(duk_hthread *thr, duk_idx_t idx, duk_hthread *def_value) { + duk_hthread *ret; + + DUK_ASSERT_API_ENTRY(thr); + + ret = duk_get_context(thr, idx); + if (ret != NULL) { + return ret; + } + + return def_value; +} + +DUK_EXTERNAL void *duk_get_heapptr(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + void *ret; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_UNLIKELY(!DUK_TVAL_IS_HEAP_ALLOCATED(tv))) { + return (void *) NULL; + } + + ret = (void *) DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(ret != NULL); + return ret; +} + +DUK_EXTERNAL void *duk_opt_heapptr(duk_hthread *thr, duk_idx_t idx, void *def_value) { + DUK_ASSERT_API_ENTRY(thr); + + if (duk_check_type_mask(thr, idx, DUK_TYPE_MASK_NONE | DUK_TYPE_MASK_UNDEFINED)) { + return def_value; + } + return duk_require_heapptr(thr, idx); +} + +DUK_EXTERNAL void *duk_get_heapptr_default(duk_hthread *thr, duk_idx_t idx, void *def_value) { + void *ret; + + DUK_ASSERT_API_ENTRY(thr); + + ret = duk_get_heapptr(thr, idx); + if (ret != NULL) { + return ret; + } + + return def_value; +} + +DUK_EXTERNAL void *duk_require_heapptr(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + void *ret; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_UNLIKELY(!DUK_TVAL_IS_HEAP_ALLOCATED(tv))) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "heapobject", DUK_STR_UNEXPECTED_TYPE); + DUK_WO_NORETURN(return NULL;); + } + + ret = (void *) DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(ret != NULL); + return ret; +} + +/* Internal helper for getting/requiring a duk_hobject with possible promotion. */ +DUK_LOCAL duk_hobject *duk__get_hobject_promote_mask_raw(duk_hthread *thr, duk_idx_t idx, duk_uint_t type_mask) { + duk_uint_t val_mask; + duk_hobject *res; + + DUK_CTX_ASSERT_VALID(thr); + + res = duk_get_hobject(thr, idx); /* common case, not promoted */ + if (DUK_LIKELY(res != NULL)) { + DUK_ASSERT(res != NULL); + return res; + } + + val_mask = duk_get_type_mask(thr, idx); + if (val_mask & type_mask) { + if (type_mask & DUK_TYPE_MASK_PROMOTE) { + res = duk_to_hobject(thr, idx); + DUK_ASSERT(res != NULL); + return res; + } else { + return NULL; /* accept without promoting */ + } + } + + if (type_mask & DUK_TYPE_MASK_THROW) { + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, "object", DUK_STR_NOT_OBJECT); + DUK_WO_NORETURN(return NULL;); + } + return NULL; +} + +/* Get a duk_hobject * at 'idx'; if the value is not an object but matches the + * supplied 'type_mask', promote it to an object and return the duk_hobject *. + * This is useful for call sites which want an object but also accept a plain + * buffer and/or a lightfunc which gets automatically promoted to an object. + * Return value is NULL if value is neither an object nor a plain type allowed + * by the mask. + */ +DUK_INTERNAL duk_hobject *duk_get_hobject_promote_mask(duk_hthread *thr, duk_idx_t idx, duk_uint_t type_mask) { + DUK_ASSERT_API_ENTRY(thr); + return duk__get_hobject_promote_mask_raw(thr, idx, type_mask | DUK_TYPE_MASK_PROMOTE); +} + +/* Like duk_get_hobject_promote_mask() but throw a TypeError instead of + * returning a NULL. + */ +DUK_INTERNAL duk_hobject *duk_require_hobject_promote_mask(duk_hthread *thr, duk_idx_t idx, duk_uint_t type_mask) { + DUK_ASSERT_API_ENTRY(thr); + return duk__get_hobject_promote_mask_raw(thr, idx, type_mask | DUK_TYPE_MASK_THROW | DUK_TYPE_MASK_PROMOTE); +} + +/* Require a duk_hobject * at 'idx'; if the value is not an object but matches the + * supplied 'type_mask', return a NULL instead. Otherwise throw a TypeError. + */ +DUK_INTERNAL duk_hobject *duk_require_hobject_accept_mask(duk_hthread *thr, duk_idx_t idx, duk_uint_t type_mask) { + DUK_ASSERT_API_ENTRY(thr); + return duk__get_hobject_promote_mask_raw(thr, idx, type_mask | DUK_TYPE_MASK_THROW); +} + +DUK_INTERNAL duk_hobject *duk_get_hobject_with_class(duk_hthread *thr, duk_idx_t idx, duk_small_uint_t classnum) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_DISABLE(classnum >= 0); /* unsigned */ + DUK_ASSERT(classnum <= DUK_HOBJECT_CLASS_MAX); + + h = (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); + if (DUK_UNLIKELY(h != NULL && DUK_HOBJECT_GET_CLASS_NUMBER(h) != classnum)) { + h = NULL; + } + return h; +} + +DUK_INTERNAL duk_hobject *duk_require_hobject_with_class(duk_hthread *thr, duk_idx_t idx, duk_small_uint_t classnum) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_DISABLE(classnum >= 0); /* unsigned */ + DUK_ASSERT(classnum <= DUK_HOBJECT_CLASS_MAX); + + h = (duk_hobject *) duk__get_tagged_heaphdr_raw(thr, idx, DUK_TAG_OBJECT); + if (DUK_UNLIKELY(!(h != NULL && DUK_HOBJECT_GET_CLASS_NUMBER(h) == classnum))) { + duk_hstring *h_class; + h_class = DUK_HTHREAD_GET_STRING(thr, DUK_HOBJECT_CLASS_NUMBER_TO_STRIDX(classnum)); + DUK_UNREF(h_class); + + DUK_ERROR_REQUIRE_TYPE_INDEX(thr, idx, (const char *) DUK_HSTRING_GET_DATA(h_class), DUK_STR_UNEXPECTED_TYPE); + DUK_WO_NORETURN(return NULL;); + } + return h; +} + +DUK_EXTERNAL duk_size_t duk_get_length(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNDEFINED: + case DUK_TAG_NULL: + case DUK_TAG_BOOLEAN: + case DUK_TAG_POINTER: + return 0; +#if defined(DUK_USE_PREFER_SIZE) + /* String and buffer have a virtual non-configurable .length property + * which is within size_t range so it can be looked up without specific + * type checks. Lightfuncs inherit from %NativeFunctionPrototype% + * which provides an inherited .length accessor; it could be overwritten + * to produce unexpected types or values, but just number convert and + * duk_size_t cast for now. + */ + case DUK_TAG_STRING: + case DUK_TAG_BUFFER: + case DUK_TAG_LIGHTFUNC: { + duk_size_t ret; + duk_get_prop_stridx(thr, idx, DUK_STRIDX_LENGTH); + ret = (duk_size_t) duk_to_number_m1(thr); + duk_pop_unsafe(thr); + return ret; + } +#else /* DUK_USE_PREFER_SIZE */ + case DUK_TAG_STRING: { + duk_hstring *h = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h != NULL); + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + return 0; + } + return (duk_size_t) DUK_HSTRING_GET_CHARLEN(h); + } + case DUK_TAG_BUFFER: { + duk_hbuffer *h = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h != NULL); + return (duk_size_t) DUK_HBUFFER_GET_SIZE(h); + } + case DUK_TAG_LIGHTFUNC: { + /* We could look up the length from the lightfunc duk_tval, + * but since Duktape 2.2 lightfunc .length comes from + * %NativeFunctionPrototype% which can be overridden, so + * look up the property explicitly. + */ + duk_size_t ret; + duk_get_prop_stridx(thr, idx, DUK_STRIDX_LENGTH); + ret = (duk_size_t) duk_to_number_m1(thr); + duk_pop_unsafe(thr); + return ret; + } +#endif /* DUK_USE_PREFER_SIZE */ + case DUK_TAG_OBJECT: { + duk_hobject *h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + return (duk_size_t) duk_hobject_get_length(thr, h); + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: + /* number or 'unused' */ + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv) || DUK_TVAL_IS_UNUSED(tv)); + return 0; + } + + DUK_UNREACHABLE(); +} + +/* + * duk_known_xxx() helpers + * + * Used internally when we're 100% sure that a certain index is valid and + * contains an object of a certain type. For example, if we duk_push_object() + * we can then safely duk_known_hobject(thr, -1). These helpers just assert + * for the index and type, and if the assumptions are not valid, memory unsafe + * behavior happens. + */ + +DUK_LOCAL duk_heaphdr *duk__known_heaphdr(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_heaphdr *h; + + DUK_CTX_ASSERT_VALID(thr); + if (idx < 0) { + tv = thr->valstack_top + idx; + } else { + tv = thr->valstack_bottom + idx; + } + DUK_ASSERT(tv >= thr->valstack_bottom); + DUK_ASSERT(tv < thr->valstack_top); + h = DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(h != NULL); + return h; +} + +DUK_INTERNAL duk_hstring *duk_known_hstring(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(duk_get_hstring(thr, idx) != NULL); + return (duk_hstring *) duk__known_heaphdr(thr, idx); +} + +DUK_INTERNAL duk_hobject *duk_known_hobject(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(duk_get_hobject(thr, idx) != NULL); + return (duk_hobject *) duk__known_heaphdr(thr, idx); +} + +DUK_INTERNAL duk_hbuffer *duk_known_hbuffer(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(duk_get_hbuffer(thr, idx) != NULL); + return (duk_hbuffer *) duk__known_heaphdr(thr, idx); +} + +DUK_INTERNAL duk_hcompfunc *duk_known_hcompfunc(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(duk_get_hcompfunc(thr, idx) != NULL); + return (duk_hcompfunc *) duk__known_heaphdr(thr, idx); +} + +DUK_INTERNAL duk_hnatfunc *duk_known_hnatfunc(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(duk_get_hnatfunc(thr, idx) != NULL); + return (duk_hnatfunc *) duk__known_heaphdr(thr, idx); +} + +DUK_EXTERNAL void duk_set_length(duk_hthread *thr, duk_idx_t idx, duk_size_t len) { + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_normalize_index(thr, idx); + duk_push_uint(thr, (duk_uint_t) len); + duk_put_prop_stridx(thr, idx, DUK_STRIDX_LENGTH); +} + +/* + * Conversions and coercions + * + * The conversion/coercions are in-place operations on the value stack. + * Some operations are implemented here directly, while others call a + * helper in duk_js_ops.c after validating arguments. + */ + +/* E5 Section 8.12.8 */ + +DUK_LOCAL duk_bool_t duk__defaultvalue_coerce_attempt(duk_hthread *thr, duk_idx_t idx, duk_small_uint_t func_stridx) { + if (duk_get_prop_stridx(thr, idx, func_stridx)) { + /* [ ... func ] */ + if (duk_is_callable(thr, -1)) { + duk_dup(thr, idx); /* -> [ ... func this ] */ + duk_call_method(thr, 0); /* -> [ ... retval ] */ + if (duk_is_primitive(thr, -1)) { + duk_replace(thr, idx); + return 1; + } + /* [ ... retval ]; popped below */ + } + } + duk_pop_unsafe(thr); /* [ ... func/retval ] -> [ ... ] */ + return 0; +} + +DUK_EXTERNAL void duk_to_undefined(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, idx); + DUK_ASSERT(tv != NULL); + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, tv); /* side effects */ +} + +DUK_EXTERNAL void duk_to_null(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, idx); + DUK_ASSERT(tv != NULL); + DUK_TVAL_SET_NULL_UPDREF(thr, tv); /* side effects */ +} + +/* E5 Section 9.1 */ +DUK_LOCAL const char * const duk__toprim_hint_strings[3] = { "default", "string", "number" }; +DUK_LOCAL void duk__to_primitive_helper(duk_hthread *thr, duk_idx_t idx, duk_int_t hint, duk_bool_t check_symbol) { + /* Inline initializer for coercers[] is not allowed by old compilers like BCC. */ + duk_small_uint_t coercers[2]; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(hint == DUK_HINT_NONE || hint == DUK_HINT_NUMBER || hint == DUK_HINT_STRING); + + idx = duk_require_normalize_index(thr, idx); + + /* If already primitive, return as is. */ + if (!duk_check_type_mask(thr, idx, DUK_TYPE_MASK_OBJECT | DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER)) { + DUK_ASSERT(!duk_is_buffer(thr, idx)); /* duk_to_string() relies on this behavior */ + return; + } + + /* @@toPrimitive lookup. Also do for plain buffers and lightfuncs + * which mimic objects. + */ + if (check_symbol && duk_get_method_stridx(thr, idx, DUK_STRIDX_WELLKNOWN_SYMBOL_TO_PRIMITIVE)) { + DUK_ASSERT(hint >= 0 && (duk_size_t) hint < sizeof(duk__toprim_hint_strings) / sizeof(const char *)); + duk_dup(thr, idx); + duk_push_string(thr, duk__toprim_hint_strings[hint]); + duk_call_method(thr, 1); /* [ ... method value hint ] -> [ ... res] */ + if (duk_check_type_mask(thr, -1, DUK_TYPE_MASK_OBJECT | DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER)) { + goto fail; + } + duk_replace(thr, idx); + return; + } + + /* Objects are coerced based on E5 specification. + * Lightfuncs are coerced because they behave like + * objects even if they're internally a primitive + * type. Same applies to plain buffers, which behave + * like ArrayBuffer objects since Duktape 2.x. + */ + + /* Hint magic for Date is unnecessary in ES2015 because of + * Date.prototype[@@toPrimitive]. However, it is needed if + * symbol support is not enabled. + */ +#if defined(DUK_USE_SYMBOL_BUILTIN) + if (hint == DUK_HINT_NONE) { + hint = DUK_HINT_NUMBER; + } +#else /* DUK_USE_SYMBOL_BUILTIN */ + if (hint == DUK_HINT_NONE) { + duk_small_uint_t class_number; + + class_number = duk_get_class_number(thr, idx); + if (class_number == DUK_HOBJECT_CLASS_DATE) { + hint = DUK_HINT_STRING; + } else { + hint = DUK_HINT_NUMBER; + } + } +#endif /* DUK_USE_SYMBOL_BUILTIN */ + + coercers[0] = DUK_STRIDX_VALUE_OF; + coercers[1] = DUK_STRIDX_TO_STRING; + if (hint == DUK_HINT_STRING) { + coercers[0] = DUK_STRIDX_TO_STRING; + coercers[1] = DUK_STRIDX_VALUE_OF; + } + + if (duk__defaultvalue_coerce_attempt(thr, idx, coercers[0])) { + DUK_ASSERT(!duk_is_buffer(thr, idx)); /* duk_to_string() relies on this behavior */ + return; + } + + if (duk__defaultvalue_coerce_attempt(thr, idx, coercers[1])) { + DUK_ASSERT(!duk_is_buffer(thr, idx)); /* duk_to_string() relies on this behavior */ + return; + } + +fail: + DUK_ERROR_TYPE(thr, DUK_STR_TOPRIMITIVE_FAILED); + DUK_WO_NORETURN(return;); +} + +DUK_EXTERNAL void duk_to_primitive(duk_hthread *thr, duk_idx_t idx, duk_int_t hint) { + duk__to_primitive_helper(thr, idx, hint, 1 /*check_symbol*/); +} + +#if defined(DUK_USE_SYMBOL_BUILTIN) +DUK_INTERNAL void duk_to_primitive_ordinary(duk_hthread *thr, duk_idx_t idx, duk_int_t hint) { + duk__to_primitive_helper(thr, idx, hint, 0 /*check_symbol*/); +} +#endif + +/* E5 Section 9.2 */ +DUK_EXTERNAL duk_bool_t duk_to_boolean(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_bool_t val; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + tv = DUK_GET_TVAL_POSIDX(thr, idx); + DUK_ASSERT(tv != NULL); + + val = duk_js_toboolean(tv); + DUK_ASSERT(val == 0 || val == 1); + + /* Note: no need to re-lookup tv, conversion is side effect free. */ + DUK_ASSERT(tv != NULL); + DUK_TVAL_SET_BOOLEAN_UPDREF(thr, tv, val); /* side effects */ + return val; +} + +DUK_INTERNAL duk_bool_t duk_to_boolean_top_pop(duk_hthread *thr) { + duk_tval *tv; + duk_bool_t val; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, -1); + DUK_ASSERT(tv != NULL); + + val = duk_js_toboolean(tv); + DUK_ASSERT(val == 0 || val == 1); + + duk_pop_unsafe(thr); + return val; +} + +DUK_EXTERNAL duk_double_t duk_to_number(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_double_t d; + + DUK_ASSERT_API_ENTRY(thr); + + /* XXX: No need to normalize; the whole operation could be inlined here to + * avoid 'tv' re-lookup. + */ + idx = duk_require_normalize_index(thr, idx); + tv = DUK_GET_TVAL_POSIDX(thr, idx); + DUK_ASSERT(tv != NULL); + d = duk_js_tonumber(thr, tv); /* XXX: fastint coercion? now result will always be a non-fastint */ + + /* ToNumber() may have side effects so must relookup 'tv'. */ + tv = DUK_GET_TVAL_POSIDX(thr, idx); + DUK_TVAL_SET_NUMBER_UPDREF(thr, tv, d); /* side effects */ + return d; +} + +DUK_INTERNAL duk_double_t duk_to_number_m1(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + return duk_to_number(thr, -1); +} +DUK_INTERNAL duk_double_t duk_to_number_m2(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + return duk_to_number(thr, -2); +} + +DUK_INTERNAL duk_double_t duk_to_number_tval(duk_hthread *thr, duk_tval *tv) { +#if defined(DUK_USE_PREFER_SIZE) + duk_double_t res; + + DUK_ASSERT_API_ENTRY(thr); + + duk_push_tval(thr, tv); + res = duk_to_number_m1(thr); + duk_pop_unsafe(thr); + return res; +#else + duk_double_t res; + duk_tval *tv_dst; + + DUK_ASSERT_API_ENTRY(thr); + DUK__ASSERT_SPACE(); + + tv_dst = thr->valstack_top++; + DUK_TVAL_SET_TVAL(tv_dst, tv); + DUK_TVAL_INCREF(thr, tv_dst); /* decref not necessary */ + res = duk_to_number_m1(thr); /* invalidates tv_dst */ + + tv_dst = --thr->valstack_top; + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_dst)); + DUK_ASSERT(!DUK_TVAL_NEEDS_REFCOUNT_UPDATE(tv_dst)); /* plain number */ + DUK_TVAL_SET_UNDEFINED(tv_dst); /* valstack init policy */ + + return res; +#endif +} + +/* XXX: combine all the integer conversions: they share everything + * but the helper function for coercion. + */ + +typedef duk_double_t (*duk__toint_coercer)(duk_hthread *thr, duk_tval *tv); + +DUK_LOCAL duk_double_t duk__to_int_uint_helper(duk_hthread *thr, duk_idx_t idx, duk__toint_coercer coerce_func) { + duk_tval *tv; + duk_double_t d; + + DUK_CTX_ASSERT_VALID(thr); + + tv = duk_require_tval(thr, idx); + DUK_ASSERT(tv != NULL); + +#if defined(DUK_USE_FASTINT) + /* If argument is a fastint, guarantee that it remains one. + * There's no downgrade check for other cases. + */ + if (DUK_TVAL_IS_FASTINT(tv)) { + /* XXX: Unnecessary conversion back and forth. */ + return (duk_double_t) DUK_TVAL_GET_FASTINT(tv); + } +#endif + d = coerce_func(thr, tv); + + /* XXX: fastint? */ + + /* Relookup in case coerce_func() has side effects, e.g. ends up coercing an object */ + tv = duk_require_tval(thr, idx); + DUK_TVAL_SET_NUMBER_UPDREF(thr, tv, d); /* side effects */ + return d; +} + +DUK_EXTERNAL duk_int_t duk_to_int(duk_hthread *thr, duk_idx_t idx) { + /* Value coercion (in stack): ToInteger(), E5 Section 9.4, + * API return value coercion: custom. + */ + DUK_ASSERT_API_ENTRY(thr); + (void) duk__to_int_uint_helper(thr, idx, duk_js_tointeger); + return (duk_int_t) duk__api_coerce_d2i(thr, idx, 0 /*def_value*/, 0 /*require*/); +} + +DUK_EXTERNAL duk_uint_t duk_to_uint(duk_hthread *thr, duk_idx_t idx) { + /* Value coercion (in stack): ToInteger(), E5 Section 9.4, + * API return value coercion: custom. + */ + DUK_ASSERT_API_ENTRY(thr); + (void) duk__to_int_uint_helper(thr, idx, duk_js_tointeger); + return (duk_uint_t) duk__api_coerce_d2ui(thr, idx, 0 /*def_value*/, 0 /*require*/); +} + +DUK_EXTERNAL duk_int32_t duk_to_int32(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_int32_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, idx); + DUK_ASSERT(tv != NULL); + ret = duk_js_toint32(thr, tv); + + /* Relookup in case coerce_func() has side effects, e.g. ends up coercing an object */ + tv = duk_require_tval(thr, idx); + DUK_TVAL_SET_I32_UPDREF(thr, tv, ret); /* side effects */ + return ret; +} + +DUK_EXTERNAL duk_uint32_t duk_to_uint32(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_uint32_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, idx); + DUK_ASSERT(tv != NULL); + ret = duk_js_touint32(thr, tv); + + /* Relookup in case coerce_func() has side effects, e.g. ends up coercing an object */ + tv = duk_require_tval(thr, idx); + DUK_TVAL_SET_U32_UPDREF(thr, tv, ret); /* side effects */ + return ret; +} + +DUK_EXTERNAL duk_uint16_t duk_to_uint16(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_uint16_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, idx); + DUK_ASSERT(tv != NULL); + ret = duk_js_touint16(thr, tv); + + /* Relookup in case coerce_func() has side effects, e.g. ends up coercing an object */ + tv = duk_require_tval(thr, idx); + DUK_TVAL_SET_U32_UPDREF(thr, tv, ret); /* side effects */ + return ret; +} + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +/* Special coercion for Uint8ClampedArray. */ +DUK_INTERNAL duk_uint8_t duk_to_uint8clamped(duk_hthread *thr, duk_idx_t idx) { + duk_double_t d; + duk_double_t t; + duk_uint8_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + /* XXX: Simplify this algorithm, should be possible to come up with + * a shorter and faster algorithm by inspecting IEEE representation + * directly. + */ + + d = duk_to_number(thr, idx); + if (d <= 0.0) { + return 0; + } else if (d >= 255) { + return 255; + } else if (DUK_ISNAN(d)) { + /* Avoid NaN-to-integer coercion as it is compiler specific. */ + return 0; + } + + t = d - DUK_FLOOR(d); + if (duk_double_equals(t, 0.5)) { + /* Exact halfway, round to even. */ + ret = (duk_uint8_t) d; + ret = (ret + 1) & 0xfe; /* Example: d=3.5, t=0.5 -> ret = (3 + 1) & 0xfe = 4 & 0xfe = 4 + * Example: d=4.5, t=0.5 -> ret = (4 + 1) & 0xfe = 5 & 0xfe = 4 + */ + } else { + /* Not halfway, round to nearest. */ + ret = (duk_uint8_t) (d + 0.5); + } + return ret; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +DUK_EXTERNAL const char *duk_to_lstring(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_len) { + DUK_ASSERT_API_ENTRY(thr); + + (void) duk_to_string(thr, idx); + DUK_ASSERT(duk_is_string(thr, idx)); + return duk_require_lstring(thr, idx, out_len); +} + +DUK_LOCAL duk_ret_t duk__safe_to_string_raw(duk_hthread *thr, void *udata) { + DUK_CTX_ASSERT_VALID(thr); + DUK_UNREF(udata); + + (void) duk_to_string(thr, -1); + return 1; +} + +DUK_EXTERNAL const char *duk_safe_to_lstring(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_len) { + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + + /* We intentionally ignore the duk_safe_call() return value and only + * check the output type. This way we don't also need to check that + * the returned value is indeed a string in the success case. + */ + + duk_dup(thr, idx); + (void) duk_safe_call(thr, duk__safe_to_string_raw, NULL /*udata*/, 1 /*nargs*/, 1 /*nrets*/); + if (!duk_is_string(thr, -1)) { + /* Error: try coercing error to string once. */ + (void) duk_safe_call(thr, duk__safe_to_string_raw, NULL /*udata*/, 1 /*nargs*/, 1 /*nrets*/); + if (!duk_is_string(thr, -1)) { + /* Double error */ + duk_pop_unsafe(thr); + duk_push_hstring_stridx(thr, DUK_STRIDX_UC_ERROR); + } else { + ; + } + } else { + /* String; may be a symbol, accepted. */ + ; + } + DUK_ASSERT(duk_is_string(thr, -1)); + + duk_replace(thr, idx); + DUK_ASSERT(duk_get_string(thr, idx) != NULL); + return duk_get_lstring(thr, idx, out_len); +} + +DUK_EXTERNAL const char *duk_to_stacktrace(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + idx = duk_require_normalize_index(thr, idx); + + /* The expected argument to the call is an Error object. The stack + * trace is extracted without an inheritance-based instanceof check + * so that one can also extract the stack trace of a foreign error + * created in another Realm. Accept only a string .stack property. + */ + if (duk_is_object(thr, idx)) { + (void) duk_get_prop_string(thr, idx, "stack"); + if (duk_is_string(thr, -1)) { + duk_replace(thr, idx); + } else { + duk_pop(thr); + } + } + + return duk_to_string(thr, idx); +} + +DUK_LOCAL duk_ret_t duk__safe_to_stacktrace_raw(duk_hthread *thr, void *udata) { + DUK_CTX_ASSERT_VALID(thr); + DUK_UNREF(udata); + + (void) duk_to_stacktrace(thr, -1); + + return 1; +} + +DUK_EXTERNAL const char *duk_safe_to_stacktrace(duk_hthread *thr, duk_idx_t idx) { + duk_int_t rc; + + DUK_ASSERT_API_ENTRY(thr); + idx = duk_require_normalize_index(thr, idx); + + duk_dup(thr, idx); + rc = duk_safe_call(thr, duk__safe_to_stacktrace_raw, NULL /*udata*/, 1 /*nargs*/, 1 /*nrets*/); + if (rc != 0) { + /* Coercion failed. Try to coerce the coercion itself error + * to a stack trace once. If that also fails, return a fixed, + * preallocated 'Error' string to avoid potential infinite loop. + */ + rc = duk_safe_call(thr, duk__safe_to_stacktrace_raw, NULL /*udata*/, 1 /*nargs*/, 1 /*nrets*/); + if (rc != 0) { + duk_pop_unsafe(thr); + duk_push_hstring_stridx(thr, DUK_STRIDX_UC_ERROR); + } + } + duk_replace(thr, idx); + + return duk_get_string(thr, idx); +} + +DUK_INTERNAL duk_hstring *duk_to_property_key_hstring(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + + duk_to_primitive(thr, idx, DUK_HINT_STRING); /* needed for e.g. Symbol objects */ + h = duk_get_hstring(thr, idx); + if (h == NULL) { + /* The "is string?" check may seem unnecessary, but as things + * are duk_to_hstring() invokes ToString() which fails for + * symbols. But since symbols are already strings for Duktape + * C API, we check for that before doing the coercion. + */ + h = duk_to_hstring(thr, idx); + } + DUK_ASSERT(h != NULL); + return h; +} + +#if defined(DUK_USE_DEBUGGER_SUPPORT) /* only needed by debugger for now */ +DUK_INTERNAL duk_hstring *duk_safe_to_hstring(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + (void) duk_safe_to_string(thr, idx); + DUK_ASSERT(duk_is_string(thr, idx)); + DUK_ASSERT(duk_get_hstring(thr, idx) != NULL); + return duk_known_hstring(thr, idx); +} +#endif + +/* Push Object.prototype.toString() output for 'tv'. */ +DUK_INTERNAL void duk_push_class_string_tval(duk_hthread *thr, duk_tval *tv, duk_bool_t avoid_side_effects) { + duk_hobject *h_obj; + duk_small_uint_t classnum; + duk_small_uint_t stridx; + duk_tval tv_tmp; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(tv != NULL); + + /* Stabilize 'tv', duk_push_literal() may trigger side effects. */ + DUK_TVAL_SET_TVAL(&tv_tmp, tv); + tv = &tv_tmp; + + /* Conceptually for any non-undefined/null value we should do a + * ToObject() coercion and look up @@toStringTag (from the object + * prototype) to see if a custom result should be used, with the + * exception of Arrays which are handled specially first. + * + * We'd like to avoid the actual conversion, but even for primitive + * types the prototype may have @@toStringTag. What's worse, the + * @@toStringTag property may be a getter that must get the object + * coerced value (not the prototype) as its 'this' binding. + * + * For now, do an actual object coercion. This could be avoided by + * doing a side effect free lookup to see if a getter would be invoked. + * If not, the value can be read directly and the object coercion could + * be avoided. This may not be worth it in practice, because + * Object.prototype.toString() is usually not performance critical. + */ + + duk_push_literal(thr, "[object "); /* -> [ ... "[object" ] */ + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNUSED: /* Treat like 'undefined', shouldn't happen. */ + case DUK_TAG_UNDEFINED: { + duk_push_hstring_stridx(thr, DUK_STRIDX_UC_UNDEFINED); + goto finish; + } + case DUK_TAG_NULL: { + duk_push_hstring_stridx(thr, DUK_STRIDX_UC_NULL); + goto finish; + } + } + + duk_push_tval(thr, tv); + tv = NULL; /* Invalidated by ToObject(). */ + h_obj = duk_to_hobject(thr, -1); + DUK_ASSERT(h_obj != NULL); + if (duk_js_isarray_hobject(h_obj)) { + stridx = DUK_STRIDX_UC_ARRAY; + } else { + /* [ ... "[object" obj ] */ + +#if defined(DUK_USE_SYMBOL_BUILTIN) + /* XXX: better handling with avoid_side_effects == 1; lookup tval + * without Proxy or getter side effects, and use it in sanitized + * form if it's a string. + */ + if (!avoid_side_effects) { + (void) duk_get_prop_stridx(thr, -1, DUK_STRIDX_WELLKNOWN_SYMBOL_TO_STRING_TAG); + if (duk_is_string_notsymbol(thr, -1)) { + duk_remove_m2(thr); + goto finish; + } + duk_pop_unsafe(thr); + } +#else + DUK_UNREF(avoid_side_effects); +#endif + + classnum = DUK_HOBJECT_GET_CLASS_NUMBER(h_obj); + stridx = DUK_HOBJECT_CLASS_NUMBER_TO_STRIDX(classnum); + } + duk_pop_unsafe(thr); + duk_push_hstring_stridx(thr, stridx); + +finish: + /* [ ... "[object" tag ] */ + duk_push_literal(thr, "]"); + duk_concat(thr, 3); /* [ ... "[object" tag "]" ] -> [ ... res ] */ +} + +/* XXX: other variants like uint, u32 etc */ +DUK_INTERNAL duk_int_t +duk_to_int_clamped_raw(duk_hthread *thr, duk_idx_t idx, duk_int_t minval, duk_int_t maxval, duk_bool_t *out_clamped) { + duk_tval *tv; + duk_tval tv_tmp; + duk_double_t d, dmin, dmax; + duk_int_t res; + duk_bool_t clamped = 0; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, idx); + DUK_ASSERT(tv != NULL); + d = duk_js_tointeger(thr, tv); /* E5 Section 9.4, ToInteger() */ + + dmin = (duk_double_t) minval; + dmax = (duk_double_t) maxval; + + if (d < dmin) { + clamped = 1; + res = minval; + d = dmin; + } else if (d > dmax) { + clamped = 1; + res = maxval; + d = dmax; + } else { + res = (duk_int_t) d; + } + DUK_UNREF(d); /* SCANBUILD: with suitable dmin/dmax limits 'd' is unused */ + /* 'd' and 'res' agree here */ + + /* Relookup in case duk_js_tointeger() ends up e.g. coercing an object. */ + tv = duk_get_tval(thr, idx); + DUK_ASSERT(tv != NULL); /* not popped by side effect */ + DUK_TVAL_SET_TVAL(&tv_tmp, tv); +#if defined(DUK_USE_FASTINT) +#if (DUK_INT_MAX <= 0x7fffffffL) + DUK_TVAL_SET_I32(tv, res); +#else + /* Clamping needed if duk_int_t is 64 bits. */ + if (res >= DUK_FASTINT_MIN && res <= DUK_FASTINT_MAX) { + DUK_TVAL_SET_FASTINT(tv, res); + } else { + DUK_TVAL_SET_NUMBER(tv, d); + } +#endif +#else + DUK_TVAL_SET_NUMBER(tv, d); /* no need to incref */ +#endif + DUK_TVAL_DECREF(thr, &tv_tmp); /* side effects */ + + if (out_clamped) { + *out_clamped = clamped; + } else { + /* coerced value is updated to value stack even when RangeError thrown */ + if (clamped) { + DUK_ERROR_RANGE(thr, DUK_STR_NUMBER_OUTSIDE_RANGE); + DUK_WO_NORETURN(return 0;); + } + } + + return res; +} + +DUK_INTERNAL duk_int_t duk_to_int_clamped(duk_hthread *thr, duk_idx_t idx, duk_idx_t minval, duk_idx_t maxval) { + duk_bool_t dummy; + + DUK_ASSERT_API_ENTRY(thr); + + return duk_to_int_clamped_raw(thr, idx, minval, maxval, &dummy); +} + +DUK_INTERNAL duk_int_t duk_to_int_check_range(duk_hthread *thr, duk_idx_t idx, duk_int_t minval, duk_int_t maxval) { + DUK_ASSERT_API_ENTRY(thr); + return duk_to_int_clamped_raw(thr, idx, minval, maxval, NULL); /* out_clamped==NULL -> RangeError if outside range */ +} + +DUK_EXTERNAL const char *duk_to_string(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + tv = DUK_GET_TVAL_POSIDX(thr, idx); + DUK_ASSERT(tv != NULL); + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNDEFINED: { + duk_push_hstring_stridx(thr, DUK_STRIDX_LC_UNDEFINED); + break; + } + case DUK_TAG_NULL: { + duk_push_hstring_stridx(thr, DUK_STRIDX_LC_NULL); + break; + } + case DUK_TAG_BOOLEAN: { + if (DUK_TVAL_GET_BOOLEAN(tv)) { + duk_push_hstring_stridx(thr, DUK_STRIDX_TRUE); + } else { + duk_push_hstring_stridx(thr, DUK_STRIDX_FALSE); + } + break; + } + case DUK_TAG_STRING: { + /* Nop for actual strings, TypeError for Symbols. + * Because various internals rely on ToString() coercion of + * internal strings, -allow- (NOP) string coercion for hidden + * symbols. + */ +#if 1 + duk_hstring *h; + h = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h != NULL); + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + DUK_ERROR_TYPE(thr, DUK_STR_CANNOT_STRING_COERCE_SYMBOL); + DUK_WO_NORETURN(goto skip_replace;); + } else { + goto skip_replace; + } +#else + goto skip_replace; +#endif + break; + } + case DUK_TAG_BUFFER: /* Go through Uint8Array.prototype.toString() for coercion. */ + case DUK_TAG_OBJECT: { + /* Plain buffers: go through ArrayBuffer.prototype.toString() + * for coercion. + * + * Symbol objects: duk_to_primitive() results in a plain symbol + * value, and duk_to_string() then causes a TypeError. + */ + duk_to_primitive(thr, idx, DUK_HINT_STRING); + DUK_ASSERT(!duk_is_buffer(thr, idx)); /* ToPrimitive() must guarantee */ + DUK_ASSERT(!duk_is_object(thr, idx)); + return duk_to_string(thr, idx); /* Note: recursive call */ + } + case DUK_TAG_POINTER: { + void *ptr = DUK_TVAL_GET_POINTER(tv); + if (ptr != NULL) { + duk_push_sprintf(thr, DUK_STR_FMT_PTR, (void *) ptr); + } else { + /* Represent a null pointer as 'null' to be consistent with + * the JX format variant. Native '%p' format for a NULL + * pointer may be e.g. '(nil)'. + */ + duk_push_hstring_stridx(thr, DUK_STRIDX_LC_NULL); + } + break; + } + case DUK_TAG_LIGHTFUNC: { + /* Should match Function.prototype.toString() */ + duk_push_lightfunc_tostring(thr, tv); + break; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: { + /* number */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + duk_push_tval(thr, tv); + duk_numconv_stringify(thr, 10 /*radix*/, 0 /*precision:shortest*/, 0 /*force_exponential*/); + break; + } + } + + duk_replace(thr, idx); + +skip_replace: + DUK_ASSERT(duk_is_string(thr, idx)); + return duk_require_string(thr, idx); +} + +DUK_INTERNAL duk_hstring *duk_to_hstring(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *ret; + + DUK_ASSERT_API_ENTRY(thr); + + duk_to_string(thr, idx); + ret = duk_get_hstring(thr, idx); + DUK_ASSERT(ret != NULL); + return ret; +} + +DUK_INTERNAL duk_hstring *duk_to_hstring_m1(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + return duk_to_hstring(thr, -1); +} + +DUK_INTERNAL duk_hstring *duk_to_hstring_acceptsymbol(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *ret; + + DUK_ASSERT_API_ENTRY(thr); + + ret = duk_get_hstring(thr, idx); + if (DUK_UNLIKELY(ret && DUK_HSTRING_HAS_SYMBOL(ret))) { + return ret; + } + return duk_to_hstring(thr, idx); +} + +/* Convert a plain buffer or any buffer object into a string, using the buffer + * bytes 1:1 in the internal string representation. For views the active byte + * slice (not element slice interpreted as an initializer) is used. This is + * necessary in Duktape 2.x because ToString(plainBuffer) no longer creates a + * string with the same bytes as in the buffer but rather (usually) + * '[object ArrayBuffer]'. + */ +DUK_EXTERNAL const char *duk_buffer_to_string(duk_hthread *thr, duk_idx_t idx) { + void *ptr_src; + duk_size_t len; + const char *res; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + + ptr_src = duk_require_buffer_data(thr, idx, &len); + DUK_ASSERT(ptr_src != NULL || len == 0); + + res = duk_push_lstring(thr, (const char *) ptr_src, len); + duk_replace(thr, idx); + return res; +} + +DUK_EXTERNAL void *duk_to_buffer_raw(duk_hthread *thr, duk_idx_t idx, duk_size_t *out_size, duk_uint_t mode) { + duk_hbuffer *h_buf; + const duk_uint8_t *src_data; + duk_size_t src_size; + duk_uint8_t *dst_data; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + + h_buf = duk_get_hbuffer(thr, idx); + if (h_buf != NULL) { + /* Buffer is kept as is, with the fixed/dynamic nature of the + * buffer only changed if requested. An external buffer + * is converted into a non-external dynamic buffer in a + * duk_to_dynamic_buffer() call. + */ + duk_uint_t tmp; + duk_uint8_t *tmp_ptr; + + tmp_ptr = (duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_buf); + src_data = (const duk_uint8_t *) tmp_ptr; + src_size = DUK_HBUFFER_GET_SIZE(h_buf); + + tmp = (DUK_HBUFFER_HAS_DYNAMIC(h_buf) ? DUK_BUF_MODE_DYNAMIC : DUK_BUF_MODE_FIXED); + if ((tmp == mode && !DUK_HBUFFER_HAS_EXTERNAL(h_buf)) || mode == DUK_BUF_MODE_DONTCARE) { + /* Note: src_data may be NULL if input is a zero-size + * dynamic buffer. + */ + dst_data = tmp_ptr; + goto skip_copy; + } + } else { + /* Non-buffer value is first ToString() coerced, then converted + * to a buffer (fixed buffer is used unless a dynamic buffer is + * explicitly requested). Symbols are rejected with a TypeError. + * XXX: C API could maybe allow symbol-to-buffer coercion? + */ + src_data = (const duk_uint8_t *) duk_to_lstring(thr, idx, &src_size); + } + + dst_data = (duk_uint8_t *) duk_push_buffer(thr, src_size, (mode == DUK_BUF_MODE_DYNAMIC) /*dynamic*/); + /* dst_data may be NULL if size is zero. */ + duk_memcpy_unsafe((void *) dst_data, (const void *) src_data, (size_t) src_size); + + duk_replace(thr, idx); +skip_copy: + + if (out_size) { + *out_size = src_size; + } + return dst_data; +} + +DUK_EXTERNAL void *duk_to_pointer(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + void *res; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + tv = DUK_GET_TVAL_POSIDX(thr, idx); + DUK_ASSERT(tv != NULL); + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNDEFINED: + case DUK_TAG_NULL: + case DUK_TAG_BOOLEAN: + res = NULL; + break; + case DUK_TAG_POINTER: + res = DUK_TVAL_GET_POINTER(tv); + break; + case DUK_TAG_STRING: + case DUK_TAG_OBJECT: + case DUK_TAG_BUFFER: + /* Heap allocated: return heap pointer which is NOT useful + * for the caller, except for debugging. + */ + res = (void *) DUK_TVAL_GET_HEAPHDR(tv); + break; + case DUK_TAG_LIGHTFUNC: + /* Function pointers do not always cast correctly to void * + * (depends on memory and segmentation model for instance), + * so they coerce to NULL. + */ + res = NULL; + break; +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: + /* number */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + res = NULL; + break; + } + + duk_push_pointer(thr, res); + duk_replace(thr, idx); + return res; +} + +DUK_LOCAL void duk__push_func_from_lightfunc(duk_hthread *thr, duk_c_function func, duk_small_uint_t lf_flags) { + duk_idx_t nargs; + duk_uint_t flags = 0; /* shared flags for a subset of types */ + duk_small_uint_t lf_len; + duk_hnatfunc *nf; + + nargs = (duk_idx_t) DUK_LFUNC_FLAGS_GET_NARGS(lf_flags); + if (nargs == DUK_LFUNC_NARGS_VARARGS) { + nargs = (duk_idx_t) DUK_VARARGS; + } + + flags = DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_CONSTRUCTABLE | DUK_HOBJECT_FLAG_CALLABLE | + DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_NATFUNC | DUK_HOBJECT_FLAG_NEWENV | DUK_HOBJECT_FLAG_STRICT | + DUK_HOBJECT_FLAG_NOTAIL | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_FUNCTION); + (void) duk__push_c_function_raw(thr, func, nargs, flags, DUK_BIDX_NATIVE_FUNCTION_PROTOTYPE); + + lf_len = DUK_LFUNC_FLAGS_GET_LENGTH(lf_flags); + if ((duk_idx_t) lf_len != nargs) { + /* Explicit length is only needed if it differs from 'nargs'. */ + duk_push_int(thr, (duk_int_t) lf_len); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_NONE); + } + +#if defined(DUK_USE_FUNC_NAME_PROPERTY) + duk_push_lightfunc_name_raw(thr, func, lf_flags); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_NAME, DUK_PROPDESC_FLAGS_C); +#endif + + nf = duk_known_hnatfunc(thr, -1); + nf->magic = (duk_int16_t) DUK_LFUNC_FLAGS_GET_MAGIC(lf_flags); +} + +DUK_EXTERNAL void duk_to_object(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_uint_t flags = 0; /* shared flags for a subset of types */ + duk_small_int_t proto = 0; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); + tv = DUK_GET_TVAL_POSIDX(thr, idx); + DUK_ASSERT(tv != NULL); + + switch (DUK_TVAL_GET_TAG(tv)) { +#if !defined(DUK_USE_BUFFEROBJECT_SUPPORT) + case DUK_TAG_BUFFER: /* With no bufferobject support, don't object coerce. */ +#endif + case DUK_TAG_UNDEFINED: + case DUK_TAG_NULL: { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_OBJECT_COERCIBLE); + DUK_WO_NORETURN(return;); + break; + } + case DUK_TAG_BOOLEAN: { + flags = + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_BOOLEAN); + proto = DUK_BIDX_BOOLEAN_PROTOTYPE; + goto create_object; + } + case DUK_TAG_STRING: { + duk_hstring *h; + h = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h != NULL); + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + flags = DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_SYMBOL); + proto = DUK_BIDX_SYMBOL_PROTOTYPE; + } else { + flags = DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_STRING); + proto = DUK_BIDX_STRING_PROTOTYPE; + } + goto create_object; + } + case DUK_TAG_OBJECT: { + /* nop */ + break; + } +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + case DUK_TAG_BUFFER: { + /* A plain buffer object coerces to a full ArrayBuffer which + * is not fully transparent behavior (ToObject() should be a + * nop for an object). This behavior matches lightfuncs which + * also coerce to an equivalent Function object. There are + * also downsides to defining ToObject(plainBuffer) as a no-op; + * for example duk_to_hobject() could result in a NULL pointer. + */ + duk_hbuffer *h_buf; + + h_buf = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h_buf != NULL); + duk_hbufobj_push_uint8array_from_plain(thr, h_buf); + goto replace_value; + } +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + case DUK_TAG_POINTER: { + flags = + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_POINTER); + proto = DUK_BIDX_POINTER_PROTOTYPE; + goto create_object; + } + case DUK_TAG_LIGHTFUNC: { + /* Lightfunc coerces to a Function instance with concrete + * properties. Since 'length' is virtual for Duktape/C + * functions, don't need to define that. The result is made + * extensible to mimic what happens to strings in object + * coercion: + * + * > Object.isExtensible(Object('foo')) + * true + */ + duk_small_uint_t lf_flags; + duk_c_function func; + + DUK_TVAL_GET_LIGHTFUNC(tv, func, lf_flags); + duk__push_func_from_lightfunc(thr, func, lf_flags); + goto replace_value; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: { + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + flags = + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_NUMBER); + proto = DUK_BIDX_NUMBER_PROTOTYPE; + goto create_object; + } + } + DUK_ASSERT(duk_is_object(thr, idx)); + return; + +create_object: + (void) duk_push_object_helper(thr, flags, proto); + + /* Note: Boolean prototype's internal value property is not writable, + * but duk_xdef_prop_stridx() disregards the write protection. Boolean + * instances are immutable. + * + * String and buffer special behaviors are already enabled which is not + * ideal, but a write to the internal value is not affected by them. + */ + duk_dup(thr, idx); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_VALUE, DUK_PROPDESC_FLAGS_NONE); + +replace_value: + duk_replace(thr, idx); + DUK_ASSERT(duk_is_object(thr, idx)); +} + +DUK_INTERNAL duk_hobject *duk_to_hobject(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *ret; + + DUK_ASSERT_API_ENTRY(thr); + + duk_to_object(thr, idx); + ret = duk_known_hobject(thr, idx); + return ret; +} + +/* + * Type checking + */ + +DUK_LOCAL duk_bool_t duk__tag_check(duk_hthread *thr, duk_idx_t idx, duk_small_uint_t tag) { + duk_tval *tv; + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + return (DUK_TVAL_GET_TAG(tv) == tag); +} + +DUK_LOCAL duk_bool_t duk__obj_flag_any_default_false(duk_hthread *thr, duk_idx_t idx, duk_uint_t flag_mask) { + duk_hobject *obj; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_get_hobject(thr, idx); + if (obj) { + return (DUK_HEAPHDR_CHECK_FLAG_BITS((duk_heaphdr *) obj, flag_mask) ? 1 : 0); + } + return 0; +} + +DUK_INTERNAL duk_int_t duk_get_type_tval(duk_tval *tv) { + DUK_ASSERT(tv != NULL); + +#if defined(DUK_USE_PACKED_TVAL) + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNUSED: + return DUK_TYPE_NONE; + case DUK_TAG_UNDEFINED: + return DUK_TYPE_UNDEFINED; + case DUK_TAG_NULL: + return DUK_TYPE_NULL; + case DUK_TAG_BOOLEAN: + return DUK_TYPE_BOOLEAN; + case DUK_TAG_STRING: + return DUK_TYPE_STRING; + case DUK_TAG_OBJECT: + return DUK_TYPE_OBJECT; + case DUK_TAG_BUFFER: + return DUK_TYPE_BUFFER; + case DUK_TAG_POINTER: + return DUK_TYPE_POINTER; + case DUK_TAG_LIGHTFUNC: + return DUK_TYPE_LIGHTFUNC; +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: + /* Note: number has no explicit tag (in 8-byte representation) */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + return DUK_TYPE_NUMBER; + } +#else /* DUK_USE_PACKED_TVAL */ + DUK_ASSERT(DUK_TVAL_IS_VALID_TAG(tv)); + DUK_ASSERT(sizeof(duk__type_from_tag) / sizeof(duk_uint_t) == DUK_TAG_MAX - DUK_TAG_MIN + 1); + return (duk_int_t) duk__type_from_tag[DUK_TVAL_GET_TAG(tv) - DUK_TAG_MIN]; +#endif /* DUK_USE_PACKED_TVAL */ +} + +DUK_EXTERNAL duk_int_t duk_get_type(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + + return duk_get_type_tval(tv); +} + +#if defined(DUK_USE_VERBOSE_ERRORS) && defined(DUK_USE_PARANOID_ERRORS) +DUK_LOCAL const char * const duk__type_names[] = { "none", "undefined", "null", "boolean", "number", + "string", "object", "buffer", "pointer", "lightfunc" }; + +DUK_INTERNAL const char *duk_get_type_name(duk_hthread *thr, duk_idx_t idx) { + duk_int_t type_tag; + + DUK_ASSERT_API_ENTRY(thr); + + type_tag = duk_get_type(thr, idx); + DUK_ASSERT(type_tag >= DUK_TYPE_MIN && type_tag <= DUK_TYPE_MAX); + DUK_ASSERT(DUK_TYPE_MIN == 0 && sizeof(duk__type_names) / sizeof(const char *) == DUK_TYPE_MAX + 1); + + return duk__type_names[type_tag]; +} +#endif /* DUK_USE_VERBOSE_ERRORS && DUK_USE_PARANOID_ERRORS */ + +DUK_INTERNAL duk_small_uint_t duk_get_class_number(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_hobject *obj; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_OBJECT: + obj = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(obj != NULL); + return DUK_HOBJECT_GET_CLASS_NUMBER(obj); + case DUK_TAG_BUFFER: + /* Buffers behave like Uint8Array objects. */ + return DUK_HOBJECT_CLASS_UINT8ARRAY; + case DUK_TAG_LIGHTFUNC: + /* Lightfuncs behave like Function objects. */ + return DUK_HOBJECT_CLASS_FUNCTION; + default: + /* Primitive or UNUSED, no class number. */ + return DUK_HOBJECT_CLASS_NONE; + } +} + +DUK_EXTERNAL duk_bool_t duk_check_type(duk_hthread *thr, duk_idx_t idx, duk_int_t type) { + DUK_ASSERT_API_ENTRY(thr); + + return (duk_get_type(thr, idx) == type) ? 1 : 0; +} + +DUK_INTERNAL duk_uint_t duk_get_type_mask_tval(duk_tval *tv) { + DUK_ASSERT(tv != NULL); + +#if defined(DUK_USE_PACKED_TVAL) + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNUSED: + return DUK_TYPE_MASK_NONE; + case DUK_TAG_UNDEFINED: + return DUK_TYPE_MASK_UNDEFINED; + case DUK_TAG_NULL: + return DUK_TYPE_MASK_NULL; + case DUK_TAG_BOOLEAN: + return DUK_TYPE_MASK_BOOLEAN; + case DUK_TAG_STRING: + return DUK_TYPE_MASK_STRING; + case DUK_TAG_OBJECT: + return DUK_TYPE_MASK_OBJECT; + case DUK_TAG_BUFFER: + return DUK_TYPE_MASK_BUFFER; + case DUK_TAG_POINTER: + return DUK_TYPE_MASK_POINTER; + case DUK_TAG_LIGHTFUNC: + return DUK_TYPE_MASK_LIGHTFUNC; +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: + /* Note: number has no explicit tag (in 8-byte representation) */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + return DUK_TYPE_MASK_NUMBER; + } +#else /* DUK_USE_PACKED_TVAL */ + DUK_ASSERT(DUK_TVAL_IS_VALID_TAG(tv)); + DUK_ASSERT(sizeof(duk__type_mask_from_tag) / sizeof(duk_uint_t) == DUK_TAG_MAX - DUK_TAG_MIN + 1); + return duk__type_mask_from_tag[DUK_TVAL_GET_TAG(tv) - DUK_TAG_MIN]; +#endif /* DUK_USE_PACKED_TVAL */ +} + +DUK_EXTERNAL duk_uint_t duk_get_type_mask(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + + return duk_get_type_mask_tval(tv); +} + +DUK_EXTERNAL duk_bool_t duk_check_type_mask(duk_hthread *thr, duk_idx_t idx, duk_uint_t mask) { + DUK_ASSERT_API_ENTRY(thr); + + if (DUK_LIKELY((duk_get_type_mask(thr, idx) & mask) != 0U)) { + return 1; + } + if (mask & DUK_TYPE_MASK_THROW) { + DUK_ERROR_TYPE(thr, DUK_STR_UNEXPECTED_TYPE); + DUK_WO_NORETURN(return 0;); + } + return 0; +} + +DUK_EXTERNAL duk_bool_t duk_is_undefined(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__tag_check(thr, idx, DUK_TAG_UNDEFINED); +} + +DUK_EXTERNAL duk_bool_t duk_is_null(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__tag_check(thr, idx, DUK_TAG_NULL); +} + +DUK_EXTERNAL duk_bool_t duk_is_boolean(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__tag_check(thr, idx, DUK_TAG_BOOLEAN); +} + +DUK_EXTERNAL duk_bool_t duk_is_number(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + /* + * Number is special because it doesn't have a specific + * tag in the 8-byte representation. + */ + + /* XXX: shorter version for unpacked representation? */ + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + return DUK_TVAL_IS_NUMBER(tv); +} + +DUK_EXTERNAL duk_bool_t duk_is_nan(duk_hthread *thr, duk_idx_t idx) { + /* XXX: This will now return false for non-numbers, even though they would + * coerce to NaN (as a general rule). In particular, duk_get_number() + * returns a NaN for non-numbers, so should this function also return + * true for non-numbers? + */ + + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + + /* XXX: for packed duk_tval an explicit "is number" check is unnecessary */ + if (!DUK_TVAL_IS_NUMBER(tv)) { + return 0; + } + return (duk_bool_t) DUK_ISNAN(DUK_TVAL_GET_NUMBER(tv)); +} + +DUK_EXTERNAL duk_bool_t duk_is_string(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__tag_check(thr, idx, DUK_TAG_STRING); +} + +DUK_INTERNAL duk_bool_t duk_is_string_notsymbol(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk_get_hstring_notsymbol(thr, idx) != NULL; +} + +DUK_EXTERNAL duk_bool_t duk_is_object(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__tag_check(thr, idx, DUK_TAG_OBJECT); +} + +DUK_EXTERNAL duk_bool_t duk_is_buffer(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__tag_check(thr, idx, DUK_TAG_BUFFER); +} + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_EXTERNAL duk_bool_t duk_is_buffer_data(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_TVAL_IS_BUFFER(tv)) { + return 1; + } else if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + if (DUK_HOBJECT_IS_BUFOBJ(h)) { + return 1; + } + } + return 0; +} +#else /* DUK_USE_BUFFEROBJECT_SUPPORT */ +DUK_EXTERNAL duk_bool_t duk_is_buffer_data(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + + return duk_is_buffer(thr, idx); +} + +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +DUK_EXTERNAL duk_bool_t duk_is_pointer(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__tag_check(thr, idx, DUK_TAG_POINTER); +} + +DUK_EXTERNAL duk_bool_t duk_is_lightfunc(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__tag_check(thr, idx, DUK_TAG_LIGHTFUNC); +} + +DUK_EXTERNAL duk_bool_t duk_is_symbol(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + + DUK_ASSERT_API_ENTRY(thr); + h = duk_get_hstring(thr, idx); + /* Use DUK_LIKELY() here because caller may be more likely to type + * check an expected symbol than not. + */ + if (DUK_LIKELY(h != NULL && DUK_HSTRING_HAS_SYMBOL(h))) { + return 1; + } + return 0; +} + +/* IsArray(), returns true for Array instance or Proxy of Array instance. */ +DUK_EXTERNAL duk_bool_t duk_is_array(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval(thr, idx); + if (tv) { + return duk_js_isarray(tv); + } + return 0; +} + +DUK_EXTERNAL duk_bool_t duk_is_function(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h; + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + return DUK_HOBJECT_HAS_CALLABLE(h) ? 1 : 0; + } + if (DUK_TVAL_IS_LIGHTFUNC(tv)) { + return 1; + } + return 0; +} + +DUK_INTERNAL duk_bool_t duk_is_callable_tval(duk_hthread *thr, duk_tval *tv) { + DUK_ASSERT_API_ENTRY(thr); + + DUK_UNREF(thr); + + if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h; + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + return DUK_HOBJECT_HAS_CALLABLE(h) ? 1 : 0; + } + if (DUK_TVAL_IS_LIGHTFUNC(tv)) { + return 1; + } + return 0; +} + +DUK_EXTERNAL duk_bool_t duk_is_constructable(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h; + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + return DUK_HOBJECT_HAS_CONSTRUCTABLE(h) ? 1 : 0; + } + if (DUK_TVAL_IS_LIGHTFUNC(tv)) { + return 1; + } + return 0; +} + +DUK_EXTERNAL duk_bool_t duk_is_c_function(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__obj_flag_any_default_false(thr, idx, DUK_HOBJECT_FLAG_NATFUNC); +} + +DUK_EXTERNAL duk_bool_t duk_is_ecmascript_function(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__obj_flag_any_default_false(thr, idx, DUK_HOBJECT_FLAG_COMPFUNC); +} + +DUK_EXTERNAL duk_bool_t duk_is_bound_function(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk__obj_flag_any_default_false(thr, idx, DUK_HOBJECT_FLAG_BOUNDFUNC); +} + +DUK_EXTERNAL duk_bool_t duk_is_thread(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *obj; + + DUK_ASSERT_API_ENTRY(thr); + + obj = duk_get_hobject(thr, idx); + if (obj) { + return (DUK_HOBJECT_GET_CLASS_NUMBER(obj) == DUK_HOBJECT_CLASS_THREAD ? 1 : 0); + } + return 0; +} + +DUK_EXTERNAL duk_bool_t duk_is_fixed_buffer(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_TVAL_IS_BUFFER(tv)) { + duk_hbuffer *h = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h != NULL); + return (DUK_HBUFFER_HAS_DYNAMIC(h) ? 0 : 1); + } + return 0; +} + +DUK_EXTERNAL duk_bool_t duk_is_dynamic_buffer(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_TVAL_IS_BUFFER(tv)) { + duk_hbuffer *h = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h != NULL); + return (DUK_HBUFFER_HAS_DYNAMIC(h) && !DUK_HBUFFER_HAS_EXTERNAL(h) ? 1 : 0); + } + return 0; +} + +DUK_EXTERNAL duk_bool_t duk_is_external_buffer(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_get_tval_or_unused(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_TVAL_IS_BUFFER(tv)) { + duk_hbuffer *h = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h != NULL); + return (DUK_HBUFFER_HAS_DYNAMIC(h) && DUK_HBUFFER_HAS_EXTERNAL(h) ? 1 : 0); + } + return 0; +} + +DUK_EXTERNAL duk_errcode_t duk_get_error_code(duk_hthread *thr, duk_idx_t idx) { + duk_hobject *h; + duk_uint_t sanity; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_get_hobject(thr, idx); + + sanity = DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY; + do { + if (!h) { + return DUK_ERR_NONE; + } + + /* XXX: something more convenient? */ + + if (h == thr->builtins[DUK_BIDX_EVAL_ERROR_PROTOTYPE]) { + return DUK_ERR_EVAL_ERROR; + } + if (h == thr->builtins[DUK_BIDX_RANGE_ERROR_PROTOTYPE]) { + return DUK_ERR_RANGE_ERROR; + } + if (h == thr->builtins[DUK_BIDX_REFERENCE_ERROR_PROTOTYPE]) { + return DUK_ERR_REFERENCE_ERROR; + } + if (h == thr->builtins[DUK_BIDX_SYNTAX_ERROR_PROTOTYPE]) { + return DUK_ERR_SYNTAX_ERROR; + } + if (h == thr->builtins[DUK_BIDX_TYPE_ERROR_PROTOTYPE]) { + return DUK_ERR_TYPE_ERROR; + } + if (h == thr->builtins[DUK_BIDX_URI_ERROR_PROTOTYPE]) { + return DUK_ERR_URI_ERROR; + } + if (h == thr->builtins[DUK_BIDX_ERROR_PROTOTYPE]) { + return DUK_ERR_ERROR; + } + + h = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h); + } while (--sanity > 0); + + return DUK_ERR_NONE; +} + +/* + * Pushers + */ + +DUK_INTERNAL void duk_push_tval(duk_hthread *thr, duk_tval *tv) { + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(tv != NULL); + + DUK__CHECK_SPACE(); + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_TVAL(tv_slot, tv); + DUK_TVAL_INCREF(thr, tv); /* no side effects */ +} + +DUK_EXTERNAL void duk_push_undefined(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + DUK__CHECK_SPACE(); + + /* Because value stack init policy is 'undefined above top', + * we don't need to write, just assert. + */ + thr->valstack_top++; + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top - 1)); +} + +DUK_EXTERNAL void duk_push_null(duk_hthread *thr) { + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_NULL(tv_slot); +} + +DUK_EXTERNAL void duk_push_boolean(duk_hthread *thr, duk_bool_t val) { + duk_tval *tv_slot; + duk_small_int_t b; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + b = (val ? 1 : 0); /* ensure value is 1 or 0 (not other non-zero) */ + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_BOOLEAN(tv_slot, b); +} + +DUK_EXTERNAL void duk_push_true(duk_hthread *thr) { + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_BOOLEAN_TRUE(tv_slot); +} + +DUK_EXTERNAL void duk_push_false(duk_hthread *thr) { + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_BOOLEAN_FALSE(tv_slot); +} + +/* normalize NaN which may not match our canonical internal NaN */ +DUK_EXTERNAL void duk_push_number(duk_hthread *thr, duk_double_t val) { + duk_tval *tv_slot; + duk_double_union du; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + du.d = val; + DUK_DBLUNION_NORMALIZE_NAN_CHECK(&du); + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_NUMBER(tv_slot, du.d); +} + +DUK_EXTERNAL void duk_push_int(duk_hthread *thr, duk_int_t val) { +#if defined(DUK_USE_FASTINT) + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + tv_slot = thr->valstack_top++; +#if DUK_INT_MAX <= 0x7fffffffL + DUK_TVAL_SET_I32(tv_slot, (duk_int32_t) val); +#else + if (val >= DUK_FASTINT_MIN && val <= DUK_FASTINT_MAX) { + DUK_TVAL_SET_FASTINT(tv_slot, (duk_int64_t) val); + } else { + duk_double_t = (duk_double_t) val; + DUK_TVAL_SET_NUMBER(tv_slot, d); + } +#endif +#else /* DUK_USE_FASTINT */ + duk_tval *tv_slot; + duk_double_t d; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + d = (duk_double_t) val; + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_NUMBER(tv_slot, d); +#endif /* DUK_USE_FASTINT */ +} + +DUK_EXTERNAL void duk_push_uint(duk_hthread *thr, duk_uint_t val) { +#if defined(DUK_USE_FASTINT) + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + tv_slot = thr->valstack_top++; +#if DUK_UINT_MAX <= 0xffffffffUL + DUK_TVAL_SET_U32(tv_slot, (duk_uint32_t) val); +#else + if (val <= DUK_FASTINT_MAX) { /* val is unsigned so >= 0 */ + /* XXX: take advantage of val being unsigned, no need to mask */ + DUK_TVAL_SET_FASTINT(tv_slot, (duk_int64_t) val); + } else { + duk_double_t = (duk_double_t) val; + DUK_TVAL_SET_NUMBER(tv_slot, d); + } +#endif +#else /* DUK_USE_FASTINT */ + duk_tval *tv_slot; + duk_double_t d; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + d = (duk_double_t) val; + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_NUMBER(tv_slot, d); +#endif /* DUK_USE_FASTINT */ +} + +DUK_EXTERNAL void duk_push_nan(duk_hthread *thr) { + duk_tval *tv_slot; + duk_double_union du; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + DUK_DBLUNION_SET_NAN(&du); + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&du)); + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_NUMBER(tv_slot, du.d); +} + +DUK_EXTERNAL const char *duk_push_lstring(duk_hthread *thr, const char *str, duk_size_t len) { + duk_hstring *h; + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + + /* Check stack before interning (avoid hanging temp). */ + DUK__CHECK_SPACE(); + + /* NULL with zero length represents an empty string; NULL with higher + * length is also now treated like an empty string although it is + * a bit dubious. This is unlike duk_push_string() which pushes a + * 'null' if the input string is a NULL. + */ + if (DUK_UNLIKELY(str == NULL)) { + len = 0U; + } + + /* Check for maximum string length. */ + if (DUK_UNLIKELY(len > DUK_HSTRING_MAX_BYTELEN)) { + DUK_ERROR_RANGE(thr, DUK_STR_STRING_TOO_LONG); + DUK_WO_NORETURN(return NULL;); + } + + h = duk_heap_strtable_intern_checked(thr, (const duk_uint8_t *) str, (duk_uint32_t) len); + DUK_ASSERT(h != NULL); + + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_STRING(tv_slot, h); + DUK_HSTRING_INCREF(thr, h); /* no side effects */ + + return (const char *) DUK_HSTRING_GET_DATA(h); +} + +DUK_EXTERNAL const char *duk_push_string(duk_hthread *thr, const char *str) { + DUK_ASSERT_API_ENTRY(thr); + + if (str) { + return duk_push_lstring(thr, str, DUK_STRLEN(str)); + } else { + duk_push_null(thr); + return NULL; + } +} + +#if !defined(DUK_USE_PREFER_SIZE) +#if defined(DUK_USE_LITCACHE_SIZE) +DUK_EXTERNAL const char *duk_push_literal_raw(duk_hthread *thr, const char *str, duk_size_t len) { + duk_hstring *h; + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(str != NULL); + DUK_ASSERT(str[len] == (char) 0); + + /* Check for maximum string length. */ + if (DUK_UNLIKELY(len > DUK_HSTRING_MAX_BYTELEN)) { + DUK_ERROR_RANGE(thr, DUK_STR_STRING_TOO_LONG); + DUK_WO_NORETURN(return NULL;); + } + + h = duk_heap_strtable_intern_literal_checked(thr, (const duk_uint8_t *) str, (duk_uint32_t) len); + DUK_ASSERT(h != NULL); + + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_STRING(tv_slot, h); + DUK_HSTRING_INCREF(thr, h); /* no side effects */ + + return (const char *) DUK_HSTRING_GET_DATA(h); +} +#else /* DUK_USE_LITCACHE_SIZE */ +DUK_EXTERNAL const char *duk_push_literal_raw(duk_hthread *thr, const char *str, duk_size_t len) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(str != NULL); + DUK_ASSERT(str[len] == (char) 0); + + return duk_push_lstring(thr, str, len); +} +#endif /* DUK_USE_LITCACHE_SIZE */ +#endif /* !DUK_USE_PREFER_SIZE */ + +DUK_EXTERNAL void duk_push_pointer(duk_hthread *thr, void *val) { + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + DUK__CHECK_SPACE(); + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_POINTER(tv_slot, val); +} + +DUK_INTERNAL duk_hstring *duk_push_uint_to_hstring(duk_hthread *thr, duk_uint_t i) { + duk_hstring *h_tmp; + + DUK_ASSERT_API_ENTRY(thr); + + /* XXX: this could be a direct DUK_SPRINTF to a buffer followed by duk_push_string() */ + duk_push_uint(thr, (duk_uint_t) i); + h_tmp = duk_to_hstring_m1(thr); + DUK_ASSERT(h_tmp != NULL); + return h_tmp; +} + +DUK_LOCAL void duk__push_this_helper(duk_hthread *thr, duk_small_uint_t check_object_coercible) { + duk_tval *tv_slot; + + DUK__CHECK_SPACE(); + + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top)); /* because of valstack init policy */ + tv_slot = thr->valstack_top++; + + if (DUK_UNLIKELY(thr->callstack_curr == NULL)) { + if (check_object_coercible) { + goto type_error; + } + /* 'undefined' already on stack top */ + } else { + duk_tval *tv; + + /* 'this' binding is just before current activation's bottom */ + DUK_ASSERT(thr->valstack_bottom > thr->valstack); + tv = thr->valstack_bottom - 1; + if (check_object_coercible && (DUK_TVAL_IS_UNDEFINED(tv) || DUK_TVAL_IS_NULL(tv))) { + /* XXX: better macro for DUK_TVAL_IS_UNDEFINED_OR_NULL(tv) */ + goto type_error; + } + + DUK_TVAL_SET_TVAL(tv_slot, tv); + DUK_TVAL_INCREF(thr, tv); + } + return; + +type_error: + DUK_ERROR_TYPE(thr, DUK_STR_NOT_OBJECT_COERCIBLE); + DUK_WO_NORETURN(return;); +} + +DUK_EXTERNAL void duk_push_this(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + duk__push_this_helper(thr, 0 /*check_object_coercible*/); +} + +DUK_INTERNAL void duk_push_this_check_object_coercible(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + duk__push_this_helper(thr, 1 /*check_object_coercible*/); +} + +DUK_INTERNAL duk_hobject *duk_push_this_coercible_to_object(duk_hthread *thr) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + duk__push_this_helper(thr, 1 /*check_object_coercible*/); + h = duk_to_hobject(thr, -1); + DUK_ASSERT(h != NULL); + return h; +} + +DUK_INTERNAL duk_hstring *duk_push_this_coercible_to_string(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + duk__push_this_helper(thr, 1 /*check_object_coercible*/); + return duk_to_hstring_m1(thr); /* This will reject all Symbol values; accepts Symbol objects. */ +} + +DUK_INTERNAL duk_tval *duk_get_borrowed_this_tval(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + DUK_ASSERT(thr->callstack_top > 0); /* caller required to know */ + DUK_ASSERT(thr->callstack_curr != NULL); /* caller required to know */ + DUK_ASSERT(thr->valstack_bottom > thr->valstack); /* consequence of above */ + DUK_ASSERT(thr->valstack_bottom - 1 >= thr->valstack); /* 'this' binding exists */ + + return thr->valstack_bottom - 1; +} + +DUK_EXTERNAL void duk_push_new_target(duk_hthread *thr) { + duk_activation *act; + + DUK_ASSERT_API_ENTRY(thr); + + /* https://www.ecma-international.org/ecma-262/6.0/#sec-meta-properties-runtime-semantics-evaluation + * https://www.ecma-international.org/ecma-262/6.0/#sec-getnewtarget + * + * No newTarget support now, so as a first approximation + * use the resolved (non-bound) target function. + * + * Check CONSTRUCT flag from current function, or if running + * direct eval, from a non-direct-eval parent (with possibly + * more than one nested direct eval). An alternative to this + * would be to store [[NewTarget]] as a hidden symbol of the + * lexical scope, and then just look up that variable. + * + * Calls from the application will either be for an empty + * call stack, or a Duktape/C function as the top activation. + */ + + act = thr->callstack_curr; + for (;;) { + if (act == NULL) { + break; + } + + if (act->flags & DUK_ACT_FLAG_CONSTRUCT) { + duk_push_tval(thr, &act->tv_func); + return; + } else if (act->flags & DUK_ACT_FLAG_DIRECT_EVAL) { + act = act->parent; + } else { + break; + } + } + + duk_push_undefined(thr); +} + +DUK_EXTERNAL void duk_push_current_function(duk_hthread *thr) { + duk_activation *act; + + DUK_ASSERT_API_ENTRY(thr); + + act = thr->callstack_curr; + if (act != NULL) { + duk_push_tval(thr, &act->tv_func); + } else { + duk_push_undefined(thr); + } +} + +DUK_EXTERNAL void duk_push_current_thread(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + if (thr->heap->curr_thread) { + duk_push_hobject(thr, (duk_hobject *) thr->heap->curr_thread); + } else { + duk_push_undefined(thr); + } +} + +DUK_EXTERNAL void duk_push_global_object(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + duk_push_hobject_bidx(thr, DUK_BIDX_GLOBAL); +} + +/* XXX: size optimize */ +DUK_LOCAL void duk__push_stash(duk_hthread *thr) { + if (!duk_xget_owndataprop_stridx_short(thr, -1, DUK_STRIDX_INT_VALUE)) { + DUK_DDD(DUK_DDDPRINT("creating heap/global/thread stash on first use")); + duk_pop_unsafe(thr); + duk_push_bare_object(thr); + duk_dup_top(thr); + duk_xdef_prop_stridx_short(thr, + -3, + DUK_STRIDX_INT_VALUE, + DUK_PROPDESC_FLAGS_C); /* [ ... parent stash stash ] -> [ ... parent stash ] */ + } + duk_remove_m2(thr); +} + +DUK_EXTERNAL void duk_push_heap_stash(duk_hthread *thr) { + duk_heap *heap; + DUK_ASSERT_API_ENTRY(thr); + heap = thr->heap; + DUK_ASSERT(heap->heap_object != NULL); + duk_push_hobject(thr, heap->heap_object); + duk__push_stash(thr); +} + +DUK_EXTERNAL void duk_push_global_stash(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_push_global_object(thr); + duk__push_stash(thr); +} + +DUK_EXTERNAL void duk_push_thread_stash(duk_hthread *thr, duk_hthread *target_thr) { + DUK_ASSERT_API_ENTRY(thr); + if (DUK_UNLIKELY(target_thr == NULL)) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return;); + } + duk_push_hobject(thr, (duk_hobject *) target_thr); + duk__push_stash(thr); +} + +/* XXX: duk_ssize_t would be useful here */ +DUK_LOCAL duk_int_t duk__try_push_vsprintf(duk_hthread *thr, void *buf, duk_size_t sz, const char *fmt, va_list ap) { + duk_int_t len; + + DUK_CTX_ASSERT_VALID(thr); + DUK_UNREF(thr); + + /* NUL terminator handling doesn't matter here */ + len = DUK_VSNPRINTF((char *) buf, sz, fmt, ap); + if (len < (duk_int_t) sz) { + /* Return value of 'sz' or more indicates output was (potentially) + * truncated. + */ + return (duk_int_t) len; + } + return -1; +} + +DUK_EXTERNAL const char *duk_push_vsprintf(duk_hthread *thr, const char *fmt, va_list ap) { + duk_uint8_t stack_buf[DUK_PUSH_SPRINTF_INITIAL_SIZE]; + duk_size_t sz = DUK_PUSH_SPRINTF_INITIAL_SIZE; + duk_bool_t pushed_buf = 0; + void *buf; + duk_int_t len; /* XXX: duk_ssize_t */ + const char *res; + + DUK_ASSERT_API_ENTRY(thr); + + /* special handling of fmt==NULL */ + if (!fmt) { + duk_hstring *h_str; + duk_push_hstring_empty(thr); + h_str = duk_known_hstring(thr, -1); + return (const char *) DUK_HSTRING_GET_DATA(h_str); + } + + /* initial estimate based on format string */ + sz = DUK_STRLEN(fmt) + 16; /* format plus something to avoid just missing */ + if (sz < DUK_PUSH_SPRINTF_INITIAL_SIZE) { + sz = DUK_PUSH_SPRINTF_INITIAL_SIZE; + } + DUK_ASSERT(sz > 0); + + /* Try to make do with a stack buffer to avoid allocating a temporary buffer. + * This works 99% of the time which is quite nice. + */ + for (;;) { + va_list ap_copy; /* copied so that 'ap' can be reused */ + + if (sz <= sizeof(stack_buf)) { + buf = stack_buf; + } else if (!pushed_buf) { + pushed_buf = 1; + buf = duk_push_dynamic_buffer(thr, sz); + } else { + buf = duk_resize_buffer(thr, -1, sz); + } + DUK_ASSERT(buf != NULL); + + DUK_VA_COPY(ap_copy, ap); + len = duk__try_push_vsprintf(thr, buf, sz, fmt, ap_copy); + va_end(ap_copy); + if (len >= 0) { + break; + } + + /* failed, resize and try again */ + sz = sz * 2; + if (DUK_UNLIKELY(sz >= DUK_PUSH_SPRINTF_SANITY_LIMIT)) { + DUK_ERROR_RANGE(thr, DUK_STR_RESULT_TOO_LONG); + DUK_WO_NORETURN(return NULL;); + } + } + + /* Cannot use duk_buffer_to_string() on the buffer because it is + * usually larger than 'len'; 'buf' is also usually a stack buffer. + */ + res = duk_push_lstring(thr, (const char *) buf, (duk_size_t) len); /* [ buf? res ] */ + if (pushed_buf) { + duk_remove_m2(thr); + } + return res; +} + +DUK_EXTERNAL const char *duk_push_sprintf(duk_hthread *thr, const char *fmt, ...) { + va_list ap; + const char *ret; + + DUK_ASSERT_API_ENTRY(thr); + + /* allow fmt==NULL */ + va_start(ap, fmt); + ret = duk_push_vsprintf(thr, fmt, ap); + va_end(ap); + + return ret; +} + +DUK_INTERNAL duk_hobject *duk_push_object_helper(duk_hthread *thr, + duk_uint_t hobject_flags_and_class, + duk_small_int_t prototype_bidx) { + duk_tval *tv_slot; + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(prototype_bidx == -1 || (prototype_bidx >= 0 && prototype_bidx < DUK_NUM_BUILTINS)); + + DUK__CHECK_SPACE(); + + h = duk_hobject_alloc(thr, hobject_flags_and_class); + DUK_ASSERT(h != NULL); + + DUK_DDD(DUK_DDDPRINT("created object with flags: 0x%08lx", (unsigned long) h->hdr.h_flags)); + + tv_slot = thr->valstack_top; + DUK_TVAL_SET_OBJECT(tv_slot, h); + DUK_HOBJECT_INCREF(thr, h); /* no side effects */ + thr->valstack_top++; + + /* object is now reachable */ + + if (prototype_bidx >= 0) { + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, h, thr->builtins[prototype_bidx]); + } else { + DUK_ASSERT(prototype_bidx == -1); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h) == NULL); + } + + return h; +} + +DUK_INTERNAL duk_hobject *duk_push_object_helper_proto(duk_hthread *thr, duk_uint_t hobject_flags_and_class, duk_hobject *proto) { + duk_hobject *h; + + DUK_ASSERT_API_ENTRY(thr); + + h = duk_push_object_helper(thr, hobject_flags_and_class, -1); + DUK_ASSERT(h != NULL); + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, h, proto); + return h; +} + +DUK_EXTERNAL duk_idx_t duk_push_object(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + (void) duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJECT), + DUK_BIDX_OBJECT_PROTOTYPE); + return duk_get_top_index_unsafe(thr); +} + +DUK_EXTERNAL duk_idx_t duk_push_array(duk_hthread *thr) { + duk_uint_t flags; + duk_harray *obj; + duk_idx_t ret; + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + + flags = DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_ARRAY_PART | + DUK_HOBJECT_FLAG_EXOTIC_ARRAY | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_ARRAY); + + obj = duk_harray_alloc(thr, flags); + DUK_ASSERT(obj != NULL); + + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, (duk_hobject *) obj, thr->builtins[DUK_BIDX_ARRAY_PROTOTYPE]); + + tv_slot = thr->valstack_top; + DUK_TVAL_SET_OBJECT(tv_slot, (duk_hobject *) obj); + DUK_HOBJECT_INCREF(thr, obj); /* XXX: could preallocate with refcount = 1 */ + ret = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom); + thr->valstack_top++; + + DUK_ASSERT(obj->length == 0); /* Array .length starts at zero. */ + return ret; +} + +DUK_EXTERNAL duk_idx_t duk_push_bare_array(duk_hthread *thr) { + duk_uint_t flags; + duk_harray *obj; + duk_idx_t ret; + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + + flags = DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_ARRAY_PART | + DUK_HOBJECT_FLAG_EXOTIC_ARRAY | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_ARRAY); + + obj = duk_harray_alloc(thr, flags); + DUK_ASSERT(obj != NULL); + + tv_slot = thr->valstack_top; + DUK_TVAL_SET_OBJECT(tv_slot, (duk_hobject *) obj); + DUK_HOBJECT_INCREF(thr, obj); /* XXX: could preallocate with refcount = 1 */ + ret = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom); + thr->valstack_top++; + + DUK_ASSERT(obj->length == 0); /* Array .length starts at zero. */ + return ret; +} + +DUK_INTERNAL duk_harray *duk_push_harray(duk_hthread *thr) { + /* XXX: API call could do this directly, cast to void in API macro. */ + duk_harray *a; + + DUK_ASSERT_API_ENTRY(thr); + + (void) duk_push_array(thr); + DUK_ASSERT(DUK_TVAL_IS_OBJECT(thr->valstack_top - 1)); + a = (duk_harray *) DUK_TVAL_GET_OBJECT(thr->valstack_top - 1); + DUK_ASSERT(a != NULL); + return a; +} + +/* Push a duk_harray with preallocated size (.length also set to match size). + * Caller may then populate array part of the duk_harray directly. + */ +DUK_INTERNAL duk_harray *duk_push_harray_with_size(duk_hthread *thr, duk_uint32_t size) { + duk_harray *a; + + DUK_ASSERT_API_ENTRY(thr); + + a = duk_push_harray(thr); + + duk_hobject_realloc_props(thr, (duk_hobject *) a, 0, size, 0, 0); + a->length = size; + return a; +} + +DUK_INTERNAL duk_tval *duk_push_harray_with_size_outptr(duk_hthread *thr, duk_uint32_t size) { + duk_harray *a; + + DUK_ASSERT_API_ENTRY(thr); + + a = duk_push_harray_with_size(thr, size); + DUK_ASSERT(a != NULL); + return DUK_HOBJECT_A_GET_BASE(thr->heap, (duk_hobject *) a); +} + +DUK_EXTERNAL duk_idx_t duk_push_thread_raw(duk_hthread *thr, duk_uint_t flags) { + duk_hthread *obj; + duk_idx_t ret; + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + + DUK__CHECK_SPACE(); + + obj = duk_hthread_alloc(thr, DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_THREAD)); + DUK_ASSERT(obj != NULL); + obj->state = DUK_HTHREAD_STATE_INACTIVE; +#if defined(DUK_USE_ROM_STRINGS) + /* Nothing to initialize, strs[] is in ROM. */ +#else +#if defined(DUK_USE_HEAPPTR16) + obj->strs16 = thr->strs16; +#else + obj->strs = thr->strs; +#endif +#endif + DUK_DDD(DUK_DDDPRINT("created thread object with flags: 0x%08lx", (unsigned long) obj->obj.hdr.h_flags)); + + /* make the new thread reachable */ + tv_slot = thr->valstack_top; + DUK_TVAL_SET_OBJECT(tv_slot, (duk_hobject *) obj); + DUK_HTHREAD_INCREF(thr, obj); + ret = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom); + thr->valstack_top++; + + /* important to do this *after* pushing, to make the thread reachable for gc */ + if (DUK_UNLIKELY(!duk_hthread_init_stacks(thr->heap, obj))) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return 0;); + } + + /* initialize built-ins - either by copying or creating new ones */ + if (flags & DUK_THREAD_NEW_GLOBAL_ENV) { + duk_hthread_create_builtin_objects(obj); + } else { + duk_hthread_copy_builtin_objects(thr, obj); + } + + /* default prototype */ + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, (duk_hobject *) obj, obj->builtins[DUK_BIDX_THREAD_PROTOTYPE]); + + /* Initial stack size satisfies the stack slack constraints so there + * is no need to require stack here. + */ + DUK_ASSERT(DUK_VALSTACK_INITIAL_SIZE >= DUK_VALSTACK_API_ENTRY_MINIMUM + DUK_VALSTACK_INTERNAL_EXTRA); + + return ret; +} + +DUK_INTERNAL duk_hcompfunc *duk_push_hcompfunc(duk_hthread *thr) { + duk_hcompfunc *obj; + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + + DUK__CHECK_SPACE(); + + /* Template functions are not strictly constructable (they don't + * have a "prototype" property for instance), so leave the + * DUK_HOBJECT_FLAG_CONSRUCTABLE flag cleared here. + */ + + obj = duk_hcompfunc_alloc(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_CALLABLE | DUK_HOBJECT_FLAG_COMPFUNC | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_FUNCTION)); + if (DUK_UNLIKELY(obj == NULL)) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return NULL;); + } + + DUK_DDD(DUK_DDDPRINT("created compiled function object with flags: 0x%08lx", (unsigned long) obj->obj.hdr.h_flags)); + + tv_slot = thr->valstack_top; + DUK_TVAL_SET_OBJECT(tv_slot, (duk_hobject *) obj); + DUK_HOBJECT_INCREF(thr, obj); + thr->valstack_top++; + + /* default prototype */ + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) obj) == NULL); + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, (duk_hobject *) obj, thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); + + return obj; +} + +DUK_INTERNAL duk_hboundfunc *duk_push_hboundfunc(duk_hthread *thr) { + duk_hboundfunc *obj; + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + + DUK__CHECK_SPACE(); + obj = duk_hboundfunc_alloc(thr->heap, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_BOUNDFUNC | DUK_HOBJECT_FLAG_CONSTRUCTABLE | + DUK_HOBJECT_FLAG_CALLABLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_FUNCTION)); + if (!obj) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return NULL;); + } + + tv_slot = thr->valstack_top++; + DUK_TVAL_SET_OBJECT(tv_slot, (duk_hobject *) obj); + DUK_HOBJECT_INCREF(thr, obj); + + /* Prototype is left as NULL because the caller always sets it (and + * it depends on the target function). + */ + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) obj) == NULL); + + return obj; +} + +DUK_LOCAL duk_idx_t +duk__push_c_function_raw(duk_hthread *thr, duk_c_function func, duk_idx_t nargs, duk_uint_t flags, duk_small_uint_t proto_bidx) { + duk_hnatfunc *obj; + duk_idx_t ret; + duk_tval *tv_slot; + duk_int16_t func_nargs; + + DUK_CTX_ASSERT_VALID(thr); + + DUK__CHECK_SPACE(); + + if (DUK_UNLIKELY(func == NULL)) { + goto api_error; + } + if (nargs >= 0 && nargs < DUK_HNATFUNC_NARGS_MAX) { + func_nargs = (duk_int16_t) nargs; + } else if (nargs == DUK_VARARGS) { + func_nargs = DUK_HNATFUNC_NARGS_VARARGS; + } else { + goto api_error; + } + + obj = duk_hnatfunc_alloc(thr, flags); + DUK_ASSERT(obj != NULL); + + obj->func = func; + obj->nargs = func_nargs; + + DUK_DDD(DUK_DDDPRINT("created native function object with flags: 0x%08lx, nargs=%ld", + (unsigned long) obj->obj.hdr.h_flags, + (long) obj->nargs)); + + tv_slot = thr->valstack_top; + DUK_TVAL_SET_OBJECT(tv_slot, (duk_hobject *) obj); + DUK_HOBJECT_INCREF(thr, obj); + ret = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom); + thr->valstack_top++; + + DUK_ASSERT_BIDX_VALID(proto_bidx); + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, (duk_hobject *) obj, thr->builtins[proto_bidx]); + return ret; + +api_error: + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return 0;); +} + +DUK_EXTERNAL duk_idx_t duk_push_c_function(duk_hthread *thr, duk_c_function func, duk_int_t nargs) { + duk_uint_t flags; + + DUK_ASSERT_API_ENTRY(thr); + + flags = DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_CONSTRUCTABLE | DUK_HOBJECT_FLAG_CALLABLE | + DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_NATFUNC | DUK_HOBJECT_FLAG_NEWENV | DUK_HOBJECT_FLAG_STRICT | + DUK_HOBJECT_FLAG_NOTAIL | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_FUNCTION); + + /* Default prototype is a Duktape specific %NativeFunctionPrototype% + * which provides .length and .name getters. + */ + return duk__push_c_function_raw(thr, func, nargs, flags, DUK_BIDX_NATIVE_FUNCTION_PROTOTYPE); +} + +DUK_INTERNAL void duk_push_c_function_builtin(duk_hthread *thr, duk_c_function func, duk_int_t nargs) { + duk_uint_t flags; + + DUK_ASSERT_API_ENTRY(thr); + + flags = DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_CONSTRUCTABLE | DUK_HOBJECT_FLAG_CALLABLE | + DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_NATFUNC | DUK_HOBJECT_FLAG_NEWENV | DUK_HOBJECT_FLAG_STRICT | + DUK_HOBJECT_FLAG_NOTAIL | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_FUNCTION); + + /* Must use Function.prototype for standard built-in functions. */ + (void) duk__push_c_function_raw(thr, func, nargs, flags, DUK_BIDX_FUNCTION_PROTOTYPE); +} + +DUK_INTERNAL void duk_push_c_function_builtin_noconstruct(duk_hthread *thr, duk_c_function func, duk_int_t nargs) { + duk_uint_t flags; + + DUK_ASSERT_API_ENTRY(thr); + + flags = DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_CALLABLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_NATFUNC | + DUK_HOBJECT_FLAG_NEWENV | DUK_HOBJECT_FLAG_STRICT | DUK_HOBJECT_FLAG_NOTAIL | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_FUNCTION); + + /* Must use Function.prototype for standard built-in functions. */ + (void) duk__push_c_function_raw(thr, func, nargs, flags, DUK_BIDX_FUNCTION_PROTOTYPE); +} + +DUK_EXTERNAL duk_idx_t +duk_push_c_lightfunc(duk_hthread *thr, duk_c_function func, duk_idx_t nargs, duk_idx_t length, duk_int_t magic) { + duk_small_uint_t lf_flags; + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + + DUK__CHECK_SPACE(); + + if (nargs >= DUK_LFUNC_NARGS_MIN && nargs <= DUK_LFUNC_NARGS_MAX) { + /* as is */ + } else if (nargs == DUK_VARARGS) { + nargs = DUK_LFUNC_NARGS_VARARGS; + } else { + goto api_error; + } + if (DUK_UNLIKELY(!(length >= DUK_LFUNC_LENGTH_MIN && length <= DUK_LFUNC_LENGTH_MAX))) { + goto api_error; + } + if (DUK_UNLIKELY(!(magic >= DUK_LFUNC_MAGIC_MIN && magic <= DUK_LFUNC_MAGIC_MAX))) { + goto api_error; + } + + lf_flags = DUK_LFUNC_FLAGS_PACK((duk_small_int_t) magic, (duk_small_uint_t) length, (duk_small_uint_t) nargs); + tv_slot = thr->valstack_top++; + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(tv_slot)); + DUK_TVAL_SET_LIGHTFUNC(tv_slot, func, lf_flags); + DUK_ASSERT(tv_slot >= thr->valstack_bottom); + return (duk_idx_t) (tv_slot - thr->valstack_bottom); + +api_error: + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return 0;); +} + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_hbufobj *duk_push_bufobj_raw(duk_hthread *thr, + duk_uint_t hobject_flags_and_class, + duk_small_int_t prototype_bidx) { + duk_hbufobj *obj; + duk_tval *tv_slot; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(prototype_bidx >= 0); + + DUK__CHECK_SPACE(); + + obj = duk_hbufobj_alloc(thr, hobject_flags_and_class); + DUK_ASSERT(obj != NULL); + + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, (duk_hobject *) obj, thr->builtins[prototype_bidx]); + DUK_HBUFOBJ_ASSERT_VALID(obj); + + tv_slot = thr->valstack_top; + DUK_TVAL_SET_OBJECT(tv_slot, (duk_hobject *) obj); + DUK_HOBJECT_INCREF(thr, obj); + thr->valstack_top++; + + return obj; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* XXX: There's quite a bit of overlap with buffer creation handling in + * duk_bi_buffer.c. Look for overlap and refactor. + */ +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +#define DUK__PACK_ARGS(classnum, protobidx, elemtype, elemshift, istypedarray) \ + (((classnum) << 24) | ((protobidx) << 16) | ((elemtype) << 8) | ((elemshift) << 4) | (istypedarray)) + +static const duk_uint32_t duk__bufobj_flags_lookup[] = { + /* Node.js Buffers are Uint8Array instances which inherit from Buffer.prototype. */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_ARRAYBUFFER, + DUK_BIDX_ARRAYBUFFER_PROTOTYPE, + DUK_HBUFOBJ_ELEM_UINT8, + 0, + 0), /* DUK_BUFOBJ_ARRAYBUFFER */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_UINT8ARRAY, + DUK_BIDX_NODEJS_BUFFER_PROTOTYPE, + DUK_HBUFOBJ_ELEM_UINT8, + 0, + 1), /* DUK_BUFOBJ_NODEJS_BUFFER */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_DATAVIEW, + DUK_BIDX_DATAVIEW_PROTOTYPE, + DUK_HBUFOBJ_ELEM_UINT8, + 0, + 0), /* DUK_BUFOBJ_DATAVIEW */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_INT8ARRAY, + DUK_BIDX_INT8ARRAY_PROTOTYPE, + DUK_HBUFOBJ_ELEM_INT8, + 0, + 1), /* DUK_BUFOBJ_INT8ARRAY */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_UINT8ARRAY, + DUK_BIDX_UINT8ARRAY_PROTOTYPE, + DUK_HBUFOBJ_ELEM_UINT8, + 0, + 1), /* DUK_BUFOBJ_UINT8ARRAY */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_UINT8CLAMPEDARRAY, + DUK_BIDX_UINT8CLAMPEDARRAY_PROTOTYPE, + DUK_HBUFOBJ_ELEM_UINT8CLAMPED, + 0, + 1), /* DUK_BUFOBJ_UINT8CLAMPEDARRAY */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_INT16ARRAY, + DUK_BIDX_INT16ARRAY_PROTOTYPE, + DUK_HBUFOBJ_ELEM_INT16, + 1, + 1), /* DUK_BUFOBJ_INT16ARRAY */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_UINT16ARRAY, + DUK_BIDX_UINT16ARRAY_PROTOTYPE, + DUK_HBUFOBJ_ELEM_UINT16, + 1, + 1), /* DUK_BUFOBJ_UINT16ARRAY */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_INT32ARRAY, + DUK_BIDX_INT32ARRAY_PROTOTYPE, + DUK_HBUFOBJ_ELEM_INT32, + 2, + 1), /* DUK_BUFOBJ_INT32ARRAY */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_UINT32ARRAY, + DUK_BIDX_UINT32ARRAY_PROTOTYPE, + DUK_HBUFOBJ_ELEM_UINT32, + 2, + 1), /* DUK_BUFOBJ_UINT32ARRAY */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_FLOAT32ARRAY, + DUK_BIDX_FLOAT32ARRAY_PROTOTYPE, + DUK_HBUFOBJ_ELEM_FLOAT32, + 2, + 1), /* DUK_BUFOBJ_FLOAT32ARRAY */ + DUK__PACK_ARGS(DUK_HOBJECT_CLASS_FLOAT64ARRAY, + DUK_BIDX_FLOAT64ARRAY_PROTOTYPE, + DUK_HBUFOBJ_ELEM_FLOAT64, + 3, + 1) /* DUK_BUFOBJ_FLOAT64ARRAY */ +}; +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_EXTERNAL void duk_push_buffer_object(duk_hthread *thr, + duk_idx_t idx_buffer, + duk_size_t byte_offset, + duk_size_t byte_length, + duk_uint_t flags) { + duk_hbufobj *h_bufobj; + duk_hbuffer *h_val; + duk_hobject *h_arraybuf; + duk_uint32_t tmp; + duk_uint_t classnum; + duk_uint_t protobidx; + duk_uint_t lookupidx; + duk_uint_t uint_offset, uint_length, uint_added; + + DUK_ASSERT_API_ENTRY(thr); + + /* The underlying types for offset/length in duk_hbufobj is + * duk_uint_t; make sure argument values fit. + */ + uint_offset = (duk_uint_t) byte_offset; + uint_length = (duk_uint_t) byte_length; + if (sizeof(duk_size_t) != sizeof(duk_uint_t)) { + if (DUK_UNLIKELY((duk_size_t) uint_offset != byte_offset || (duk_size_t) uint_length != byte_length)) { + goto range_error; + } + } + + DUK_ASSERT_DISABLE(flags >= 0); /* flags is unsigned */ + lookupidx = flags; + if (DUK_UNLIKELY(lookupidx >= sizeof(duk__bufobj_flags_lookup) / sizeof(duk_uint32_t))) { + goto arg_error; + } + tmp = duk__bufobj_flags_lookup[lookupidx]; + classnum = tmp >> 24; + protobidx = (tmp >> 16) & 0xff; + + h_arraybuf = duk_get_hobject(thr, idx_buffer); + if (h_arraybuf != NULL && /* argument is an object */ + flags != DUK_BUFOBJ_ARRAYBUFFER && /* creating a view */ + DUK_HOBJECT_GET_CLASS_NUMBER(h_arraybuf) == DUK_HOBJECT_CLASS_ARRAYBUFFER /* argument is ArrayBuffer */) { + duk_uint_t tmp_offset; + + DUK_HBUFOBJ_ASSERT_VALID((duk_hbufobj *) h_arraybuf); + h_val = ((duk_hbufobj *) h_arraybuf)->buf; + if (DUK_UNLIKELY(h_val == NULL)) { + goto arg_error; + } + + tmp_offset = uint_offset + ((duk_hbufobj *) h_arraybuf)->offset; + if (DUK_UNLIKELY(tmp_offset < uint_offset)) { + goto range_error; + } + uint_offset = tmp_offset; + + /* Note intentional difference to new TypedArray(): we allow + * caller to create an uncovered typed array (which is memory + * safe); new TypedArray() rejects it. + */ + } else { + /* Handle unexpected object arguments here too, for nice error + * messages. + */ + h_arraybuf = NULL; + h_val = duk_require_hbuffer(thr, idx_buffer); + } + + /* Wrap check for offset+length. */ + uint_added = uint_offset + uint_length; + if (DUK_UNLIKELY(uint_added < uint_offset)) { + goto range_error; + } + DUK_ASSERT(uint_added >= uint_offset && uint_added >= uint_length); + + DUK_ASSERT(h_val != NULL); + + h_bufobj = duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_BUFOBJ | DUK_HOBJECT_CLASS_AS_FLAGS(classnum), + (duk_small_int_t) protobidx); + DUK_ASSERT(h_bufobj != NULL); + + h_bufobj->buf = h_val; + DUK_HBUFFER_INCREF(thr, h_val); + h_bufobj->buf_prop = h_arraybuf; + DUK_HOBJECT_INCREF_ALLOWNULL(thr, h_arraybuf); + h_bufobj->offset = uint_offset; + h_bufobj->length = uint_length; + h_bufobj->shift = (tmp >> 4) & 0x0f; + h_bufobj->elem_type = (tmp >> 8) & 0xff; + h_bufobj->is_typedarray = tmp & 0x0f; + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + + /* TypedArray views need an automatic ArrayBuffer which must be + * provided as .buffer property of the view. The ArrayBuffer is + * referenced via duk_hbufobj->buf_prop and an inherited .buffer + * accessor returns it. The ArrayBuffer is created lazily on first + * access if necessary so we don't need to do anything more here. + */ + return; + +range_error: + DUK_ERROR_RANGE(thr, DUK_STR_INVALID_ARGS); + DUK_WO_NORETURN(return;); + +arg_error: + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_ARGS); + DUK_WO_NORETURN(return;); +} +#else /* DUK_USE_BUFFEROBJECT_SUPPORT */ +DUK_EXTERNAL void duk_push_buffer_object(duk_hthread *thr, + duk_idx_t idx_buffer, + duk_size_t byte_offset, + duk_size_t byte_length, + duk_uint_t flags) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(idx_buffer); + DUK_UNREF(byte_offset); + DUK_UNREF(byte_length); + DUK_UNREF(flags); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return;); +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +DUK_EXTERNAL duk_idx_t duk_push_error_object_va_raw(duk_hthread *thr, + duk_errcode_t err_code, + const char *filename, + duk_int_t line, + const char *fmt, + va_list ap) { + duk_hobject *proto; +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) + duk_small_uint_t augment_flags; +#endif + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr != NULL); + DUK_UNREF(filename); + DUK_UNREF(line); + + /* Error code also packs a tracedata related flag. */ +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) + augment_flags = 0; + if (err_code & DUK_ERRCODE_FLAG_NOBLAME_FILELINE) { + augment_flags = DUK_AUGMENT_FLAG_NOBLAME_FILELINE; + } +#endif + err_code = err_code & (~DUK_ERRCODE_FLAG_NOBLAME_FILELINE); + + /* error gets its 'name' from the prototype */ + proto = duk_error_prototype_from_code(thr, err_code); + (void) duk_push_object_helper_proto(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_ERROR), + proto); + + /* ... and its 'message' from an instance property */ + if (fmt) { + duk_push_vsprintf(thr, fmt, ap); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_MESSAGE, DUK_PROPDESC_FLAGS_WC); + } else { + /* If no explicit message given, put error code into message field + * (as a number). This is not fully in keeping with the ECMAScript + * error model because messages are supposed to be strings (Error + * constructors use ToString() on their argument). However, it's + * probably more useful than having a separate 'code' property. + */ + duk_push_int(thr, err_code); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_MESSAGE, DUK_PROPDESC_FLAGS_WC); + } + + /* XXX: .code = err_code disabled, not sure if useful */ + + /* Creation time error augmentation */ +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) + /* filename may be NULL in which case file/line is not recorded */ + duk_err_augment_error_create(thr, thr, filename, line, augment_flags); /* may throw an error */ +#endif + + return duk_get_top_index_unsafe(thr); +} + +DUK_EXTERNAL duk_idx_t +duk_push_error_object_raw(duk_hthread *thr, duk_errcode_t err_code, const char *filename, duk_int_t line, const char *fmt, ...) { + va_list ap; + duk_idx_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + va_start(ap, fmt); + ret = duk_push_error_object_va_raw(thr, err_code, filename, line, fmt, ap); + va_end(ap); + return ret; +} + +#if !defined(DUK_USE_VARIADIC_MACROS) +DUK_EXTERNAL duk_idx_t duk_push_error_object_stash(duk_hthread *thr, duk_errcode_t err_code, const char *fmt, ...) { + const char *filename = duk_api_global_filename; + duk_int_t line = duk_api_global_line; + va_list ap; + duk_idx_t ret; + + DUK_ASSERT_API_ENTRY(thr); + + duk_api_global_filename = NULL; + duk_api_global_line = 0; + va_start(ap, fmt); + ret = duk_push_error_object_va_raw(thr, err_code, filename, line, fmt, ap); + va_end(ap); + return ret; +} +#endif /* DUK_USE_VARIADIC_MACROS */ + +DUK_EXTERNAL void *duk_push_buffer_raw(duk_hthread *thr, duk_size_t size, duk_small_uint_t flags) { + duk_tval *tv_slot; + duk_hbuffer *h; + void *buf_data; + + DUK_ASSERT_API_ENTRY(thr); + + DUK__CHECK_SPACE(); + + /* Check for maximum buffer length. */ + if (DUK_UNLIKELY(size > DUK_HBUFFER_MAX_BYTELEN)) { + DUK_ERROR_RANGE(thr, DUK_STR_BUFFER_TOO_LONG); + DUK_WO_NORETURN(return NULL;); + } + + h = duk_hbuffer_alloc(thr->heap, size, flags, &buf_data); + if (DUK_UNLIKELY(h == NULL)) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return NULL;); + } + + tv_slot = thr->valstack_top; + DUK_TVAL_SET_BUFFER(tv_slot, h); + DUK_HBUFFER_INCREF(thr, h); + thr->valstack_top++; + + return (void *) buf_data; +} + +DUK_INTERNAL void *duk_push_fixed_buffer_nozero(duk_hthread *thr, duk_size_t len) { + DUK_ASSERT_API_ENTRY(thr); + return duk_push_buffer_raw(thr, len, DUK_BUF_FLAG_NOZERO); +} + +DUK_INTERNAL void *duk_push_fixed_buffer_zero(duk_hthread *thr, duk_size_t len) { + void *ptr; + + DUK_ASSERT_API_ENTRY(thr); + + ptr = duk_push_buffer_raw(thr, len, 0); + DUK_ASSERT(ptr != NULL); +#if !defined(DUK_USE_ZERO_BUFFER_DATA) + /* ES2015 requires zeroing even when DUK_USE_ZERO_BUFFER_DATA + * is not set. + */ + duk_memzero((void *) ptr, (size_t) len); +#endif + return ptr; +} + +#if defined(DUK_USE_ES6_PROXY) +DUK_EXTERNAL duk_idx_t duk_push_proxy(duk_hthread *thr, duk_uint_t proxy_flags) { + duk_hobject *h_target; + duk_hobject *h_handler; + duk_hproxy *h_proxy; + duk_tval *tv_slot; + duk_uint_t flags; + + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(proxy_flags); + + /* DUK__CHECK_SPACE() unnecessary because the Proxy is written to + * value stack in-place. + */ +#if 0 + DUK__CHECK_SPACE(); +#endif + + /* Reject a proxy object as the target because it would need + * special handling in property lookups. (ES2015 has no such + * restriction.) + */ + h_target = duk_require_hobject_promote_mask(thr, -2, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + DUK_ASSERT(h_target != NULL); + if (DUK_HOBJECT_IS_PROXY(h_target)) { + goto fail_args; + } + + /* Reject a proxy object as the handler because it would cause + * potentially unbounded recursion. (ES2015 has no such + * restriction.) + * + * There's little practical reason to use a lightfunc or a plain + * buffer as the handler table: one could only provide traps via + * their prototype objects (Function.prototype and ArrayBuffer.prototype). + * Even so, as lightfuncs and plain buffers mimic their object + * counterparts, they're promoted and accepted here. + */ + h_handler = duk_require_hobject_promote_mask(thr, -1, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + DUK_ASSERT(h_handler != NULL); + if (DUK_HOBJECT_IS_PROXY(h_handler)) { + goto fail_args; + } + + /* XXX: Proxy object currently has no prototype, so ToPrimitive() + * coercion fails which is a bit confusing. + */ + + /* CALLABLE and CONSTRUCTABLE flags are copied from the (initial) + * target, see ES2015 Sections 9.5.15 and 9.5.13. + */ + flags = DUK_HEAPHDR_GET_FLAGS((duk_heaphdr *) h_target) & (DUK_HOBJECT_FLAG_CALLABLE | DUK_HOBJECT_FLAG_CONSTRUCTABLE); + flags |= DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_EXOTIC_PROXYOBJ; + if (flags & DUK_HOBJECT_FLAG_CALLABLE) { + flags |= DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_FUNCTION) | DUK_HOBJECT_FLAG_SPECIAL_CALL; + } else { + flags |= DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJECT); + } + + h_proxy = duk_hproxy_alloc(thr, flags); + DUK_ASSERT(h_proxy != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) h_proxy) == NULL); + + /* Initialize Proxy target and handler references; avoid INCREF + * by stealing the value stack refcounts via direct value stack + * manipulation. INCREF is needed for the Proxy itself however. + */ + DUK_ASSERT(h_target != NULL); + h_proxy->target = h_target; + DUK_ASSERT(h_handler != NULL); + h_proxy->handler = h_handler; + DUK_HPROXY_ASSERT_VALID(h_proxy); + + DUK_ASSERT(duk_get_hobject(thr, -2) == h_target); + DUK_ASSERT(duk_get_hobject(thr, -1) == h_handler); + tv_slot = thr->valstack_top - 2; + DUK_ASSERT(tv_slot >= thr->valstack_bottom); + DUK_TVAL_SET_OBJECT(tv_slot, (duk_hobject *) h_proxy); + DUK_HOBJECT_INCREF(thr, (duk_hobject *) h_proxy); + tv_slot++; + DUK_TVAL_SET_UNDEFINED(tv_slot); /* [ ... target handler ] -> [ ... proxy undefined ] */ + thr->valstack_top = tv_slot; /* -> [ ... proxy ] */ + + DUK_DD(DUK_DDPRINT("created Proxy: %!iT", duk_get_tval(thr, -1))); + + return (duk_idx_t) (thr->valstack_top - thr->valstack_bottom - 1); + +fail_args: + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return 0;); +} +#else /* DUK_USE_ES6_PROXY */ +DUK_EXTERNAL duk_idx_t duk_push_proxy(duk_hthread *thr, duk_uint_t proxy_flags) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(proxy_flags); + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return 0;); +} +#endif /* DUK_USE_ES6_PROXY */ + +#if defined(DUK_USE_ASSERTIONS) +DUK_LOCAL void duk__validate_push_heapptr(duk_hthread *thr, void *ptr) { + duk_heaphdr *h; + duk_heaphdr *curr; + duk_bool_t found = 0; + + h = (duk_heaphdr *) ptr; + if (h == NULL) { + /* Allowed. */ + return; + } + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(h)); + + /* One particular problem case is where an object has been + * queued for finalization but the finalizer hasn't yet been + * executed. + * + * Corner case: we're running in a finalizer for object X, and + * user code calls duk_push_heapptr() for X itself. In this + * case X will be in finalize_list, and we can detect the case + * by seeing that X's FINALIZED flag is set (which is done before + * the finalizer starts executing). + */ +#if defined(DUK_USE_FINALIZER_SUPPORT) + for (curr = thr->heap->finalize_list; curr != NULL; curr = DUK_HEAPHDR_GET_NEXT(thr->heap, curr)) { + /* FINALIZABLE is set for all objects on finalize_list + * except for an object being finalized right now. So + * can't assert here. + */ +#if 0 + DUK_ASSERT(DUK_HEAPHDR_HAS_FINALIZABLE(curr)); +#endif + + if (curr == h) { + if (DUK_HEAPHDR_HAS_FINALIZED((duk_heaphdr *) h)) { + /* Object is currently being finalized. */ + DUK_ASSERT(found == 0); /* Would indicate corrupted lists. */ + found = 1; + } else { + /* Not being finalized but on finalize_list, + * allowed since Duktape 2.1. + */ + DUK_ASSERT(found == 0); /* Would indicate corrupted lists. */ + found = 1; + } + } + } +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +#if defined(DUK_USE_REFERENCE_COUNTING) + /* Because refzero_list is now processed to completion inline with + * no side effects, it's always empty here. + */ + DUK_ASSERT(thr->heap->refzero_list == NULL); +#endif + + /* If not present in finalize_list (or refzero_list), it + * must be either in heap_allocated or the string table. + */ + if (DUK_HEAPHDR_IS_STRING(h)) { + duk_uint32_t i; + duk_hstring *str; + duk_heap *heap = thr->heap; + + DUK_ASSERT(found == 0); + for (i = 0; i < heap->st_size; i++) { +#if defined(DUK_USE_STRTAB_PTRCOMP) + str = DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, heap->strtable16[i]); +#else + str = heap->strtable[i]; +#endif + while (str != NULL) { + if (str == (duk_hstring *) h) { + DUK_ASSERT(found == 0); /* Would indicate corrupted lists. */ + found = 1; + break; + } + str = str->hdr.h_next; + } + } + DUK_ASSERT(found != 0); + } else { + for (curr = thr->heap->heap_allocated; curr != NULL; curr = DUK_HEAPHDR_GET_NEXT(thr->heap, curr)) { + if (curr == h) { + DUK_ASSERT(found == 0); /* Would indicate corrupted lists. */ + found = 1; + } + } + DUK_ASSERT(found != 0); + } +} +#endif /* DUK_USE_ASSERTIONS */ + +DUK_EXTERNAL duk_idx_t duk_push_heapptr(duk_hthread *thr, void *ptr) { + duk_idx_t ret; + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + /* Reviving an object using a heap pointer is a dangerous API + * operation: if the application doesn't guarantee that the + * pointer target is always reachable, difficult-to-diagnose + * problems may ensue. Try to validate the 'ptr' argument to + * the extent possible. + */ + +#if defined(DUK_USE_ASSERTIONS) + duk__validate_push_heapptr(thr, ptr); +#endif + + DUK__CHECK_SPACE(); + + ret = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom); + tv = thr->valstack_top++; + + if (ptr == NULL) { + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(tv)); + return ret; + } + + DUK_HEAPHDR_ASSERT_VALID((duk_heaphdr *) ptr); + + /* If the argument is on finalize_list it has technically been + * unreachable before duk_push_heapptr() but it's still safe to + * push it. Starting from Duktape 2.1 allow application code to + * do so. There are two main cases: + * + * (1) The object is on the finalize_list and we're called by + * the finalizer for the object being finalized. In this + * case do nothing: finalize_list handling will deal with + * the object queueing. This is detected by the object not + * having a FINALIZABLE flag despite being on the finalize_list; + * the flag is cleared for the object being finalized only. + * + * (2) The object is on the finalize_list but is not currently + * being processed. In this case the object can be queued + * back to heap_allocated with a few flags cleared, in effect + * cancelling the finalizer. + */ + if (DUK_UNLIKELY(DUK_HEAPHDR_HAS_FINALIZABLE((duk_heaphdr *) ptr))) { + duk_heaphdr *curr; + + DUK_D(DUK_DPRINT("duk_push_heapptr() with a pointer on finalize_list, autorescue")); + + curr = (duk_heaphdr *) ptr; + DUK_HEAPHDR_CLEAR_FINALIZABLE(curr); + + /* Because FINALIZED is set prior to finalizer call, it will + * be set for the object being currently finalized, but not + * for other objects on finalize_list. + */ + DUK_HEAPHDR_CLEAR_FINALIZED(curr); + + /* Dequeue object from finalize_list and queue it back to + * heap_allocated. + */ +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(curr) >= 1); /* Preincremented on finalize_list insert. */ + DUK_HEAPHDR_PREDEC_REFCOUNT(curr); +#endif + DUK_HEAP_REMOVE_FROM_FINALIZE_LIST(thr->heap, curr); + DUK_HEAP_INSERT_INTO_HEAP_ALLOCATED(thr->heap, curr); + + /* Continue with the rest. */ + } + + switch (DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) ptr)) { + case DUK_HTYPE_STRING: + DUK_TVAL_SET_STRING(tv, (duk_hstring *) ptr); + break; + case DUK_HTYPE_OBJECT: + DUK_TVAL_SET_OBJECT(tv, (duk_hobject *) ptr); + break; + default: + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) ptr) == DUK_HTYPE_BUFFER); + DUK_TVAL_SET_BUFFER(tv, (duk_hbuffer *) ptr); + break; + } + + DUK_HEAPHDR_INCREF(thr, (duk_heaphdr *) ptr); + + return ret; +} + +/* Push object with no prototype, i.e. a "bare" object. */ +DUK_EXTERNAL duk_idx_t duk_push_bare_object(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + (void) duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJECT), + -1); /* no prototype */ + return duk_get_top_index_unsafe(thr); +} + +DUK_INTERNAL void duk_push_hstring(duk_hthread *thr, duk_hstring *h) { + duk_tval tv; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(h != NULL); + + DUK_TVAL_SET_STRING(&tv, h); + duk_push_tval(thr, &tv); +} + +DUK_INTERNAL void duk_push_hstring_stridx(duk_hthread *thr, duk_small_uint_t stridx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT_STRIDX_VALID(stridx); + duk_push_hstring(thr, DUK_HTHREAD_GET_STRING(thr, stridx)); +} + +DUK_INTERNAL void duk_push_hstring_empty(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_push_hstring(thr, DUK_HTHREAD_GET_STRING(thr, DUK_STRIDX_EMPTY_STRING)); +} + +DUK_INTERNAL void duk_push_hobject(duk_hthread *thr, duk_hobject *h) { + duk_tval tv; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(h != NULL); + + DUK_TVAL_SET_OBJECT(&tv, h); + duk_push_tval(thr, &tv); +} + +DUK_INTERNAL void duk_push_hbuffer(duk_hthread *thr, duk_hbuffer *h) { + duk_tval tv; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(h != NULL); + + DUK_TVAL_SET_BUFFER(&tv, h); + duk_push_tval(thr, &tv); +} + +DUK_INTERNAL void duk_push_hobject_bidx(duk_hthread *thr, duk_small_int_t builtin_idx) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(builtin_idx >= 0 && builtin_idx < DUK_NUM_BUILTINS); + DUK_ASSERT(thr->builtins[builtin_idx] != NULL); + + duk_push_hobject(thr, thr->builtins[builtin_idx]); +} + +/* + * Poppers + */ + +DUK_LOCAL DUK_ALWAYS_INLINE void duk__pop_n_unsafe_raw(duk_hthread *thr, duk_idx_t count) { + duk_tval *tv; +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_tval *tv_end; +#endif + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(count >= 0); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack_bottom) >= (duk_size_t) count); + +#if defined(DUK_USE_REFERENCE_COUNTING) + tv = thr->valstack_top; + tv_end = tv - count; + while (tv != tv_end) { + tv--; + DUK_ASSERT(tv >= thr->valstack_bottom); + DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ(thr, tv); + } + thr->valstack_top = tv; + DUK_REFZERO_CHECK_FAST(thr); +#else + tv = thr->valstack_top; + while (count > 0) { + count--; + tv--; + DUK_ASSERT(tv >= thr->valstack_bottom); + DUK_TVAL_SET_UNDEFINED(tv); + } + thr->valstack_top = tv; +#endif + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); +} + +DUK_EXTERNAL void duk_pop_n(duk_hthread *thr, duk_idx_t count) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + + if (DUK_UNLIKELY((duk_uidx_t) (thr->valstack_top - thr->valstack_bottom) < (duk_uidx_t) count)) { + DUK_ERROR_RANGE_INVALID_COUNT(thr); + DUK_WO_NORETURN(return;); + } + DUK_ASSERT(count >= 0); + + duk__pop_n_unsafe_raw(thr, count); +} + +#if defined(DUK_USE_PREFER_SIZE) +DUK_INTERNAL void duk_pop_n_unsafe(duk_hthread *thr, duk_idx_t count) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n(thr, count); +} +#else /* DUK_USE_PREFER_SIZE */ +DUK_INTERNAL void duk_pop_n_unsafe(duk_hthread *thr, duk_idx_t count) { + DUK_ASSERT_API_ENTRY(thr); + duk__pop_n_unsafe_raw(thr, count); +} +#endif /* DUK_USE_PREFER_SIZE */ + +/* Pop N elements without DECREF (in effect "stealing" any actual refcounts). */ +#if defined(DUK_USE_REFERENCE_COUNTING) +DUK_INTERNAL void duk_pop_n_nodecref_unsafe(duk_hthread *thr, duk_idx_t count) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(count >= 0); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack_bottom) >= (duk_size_t) count); + + tv = thr->valstack_top; + while (count > 0) { + count--; + tv--; + DUK_ASSERT(tv >= thr->valstack_bottom); + DUK_TVAL_SET_UNDEFINED(tv); + } + thr->valstack_top = tv; + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); +} +#else /* DUK_USE_REFERENCE_COUNTING */ +DUK_INTERNAL void duk_pop_n_nodecref_unsafe(duk_hthread *thr, duk_idx_t count) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n_unsafe(thr, count); +} +#endif /* DUK_USE_REFERENCE_COUNTING */ + +/* Popping one element is called so often that when footprint is not an issue, + * compile a specialized function for it. + */ +#if defined(DUK_USE_PREFER_SIZE) +DUK_EXTERNAL void duk_pop(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n(thr, 1); +} +DUK_INTERNAL void duk_pop_unsafe(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n_unsafe(thr, 1); +} +DUK_INTERNAL void duk_pop_nodecref_unsafe(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n_nodecref_unsafe(thr, 1); +} +#else /* DUK_USE_PREFER_SIZE */ +DUK_LOCAL DUK_ALWAYS_INLINE void duk__pop_unsafe_raw(duk_hthread *thr) { + duk_tval *tv; + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(thr->valstack_top != thr->valstack_bottom); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack_bottom) >= (duk_size_t) 1); + + tv = --thr->valstack_top; + DUK_ASSERT(tv >= thr->valstack_bottom); +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, tv); /* side effects */ +#else + DUK_TVAL_SET_UNDEFINED(tv); +#endif + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); +} +DUK_EXTERNAL void duk_pop(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + if (DUK_UNLIKELY(thr->valstack_top == thr->valstack_bottom)) { + DUK_ERROR_RANGE_INVALID_COUNT(thr); + DUK_WO_NORETURN(return;); + } + + duk__pop_unsafe_raw(thr); +} +DUK_INTERNAL void duk_pop_unsafe(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk__pop_unsafe_raw(thr); +} +DUK_INTERNAL void duk_pop_nodecref_unsafe(duk_hthread *thr) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->valstack_top != thr->valstack_bottom); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack_bottom) >= (duk_size_t) 1); + + tv = --thr->valstack_top; + DUK_ASSERT(tv >= thr->valstack_bottom); + DUK_TVAL_SET_UNDEFINED(tv); + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); +} +#endif /* !DUK_USE_PREFER_SIZE */ + +#if defined(DUK_USE_PREFER_SIZE) +DUK_INTERNAL void duk_pop_undefined(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_nodecref_unsafe(thr); +} +#else /* DUK_USE_PREFER_SIZE */ +DUK_INTERNAL void duk_pop_undefined(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->valstack_top != thr->valstack_bottom); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack_bottom) >= (duk_size_t) 1); + + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top - 1)); + thr->valstack_top--; + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); +} +#endif /* !DUK_USE_PREFER_SIZE */ + +#if defined(DUK_USE_PREFER_SIZE) +DUK_EXTERNAL void duk_pop_2(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n(thr, 2); +} +DUK_INTERNAL void duk_pop_2_unsafe(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n_unsafe(thr, 2); +} +DUK_INTERNAL void duk_pop_2_nodecref_unsafe(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n_nodecref_unsafe(thr, 2); +} +#else +DUK_LOCAL DUK_ALWAYS_INLINE void duk__pop_2_unsafe_raw(duk_hthread *thr) { + duk_tval *tv; + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(thr->valstack_top != thr->valstack_bottom); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack_bottom) >= (duk_size_t) 2); + + tv = --thr->valstack_top; + DUK_ASSERT(tv >= thr->valstack_bottom); +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, tv); /* side effects */ +#else + DUK_TVAL_SET_UNDEFINED(tv); +#endif + tv = --thr->valstack_top; + DUK_ASSERT(tv >= thr->valstack_bottom); +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, tv); /* side effects */ +#else + DUK_TVAL_SET_UNDEFINED(tv); +#endif + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); +} +DUK_EXTERNAL void duk_pop_2(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + if (DUK_UNLIKELY(thr->valstack_top - 2 < thr->valstack_bottom)) { + DUK_ERROR_RANGE_INVALID_COUNT(thr); + DUK_WO_NORETURN(return;); + } + + duk__pop_2_unsafe_raw(thr); +} +DUK_INTERNAL void duk_pop_2_unsafe(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk__pop_2_unsafe_raw(thr); +} +DUK_INTERNAL void duk_pop_2_nodecref_unsafe(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->valstack_top != thr->valstack_bottom); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack_bottom) >= (duk_size_t) 2); + + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top - 1)); + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top - 2)); + thr->valstack_top -= 2; + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); +} +#endif /* !DUK_USE_PREFER_SIZE */ + +DUK_EXTERNAL void duk_pop_3(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n(thr, 3); +} + +DUK_INTERNAL void duk_pop_3_unsafe(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n_unsafe(thr, 3); +} + +DUK_INTERNAL void duk_pop_3_nodecref_unsafe(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_pop_n_nodecref_unsafe(thr, 3); +} + +/* + * Pack and unpack (pack value stack entries into an array and vice versa) + */ + +/* XXX: pack index range? array index offset? */ +/* XXX: need ability to pack into a bare array? */ +DUK_INTERNAL void duk_pack(duk_hthread *thr, duk_idx_t count) { + duk_tval *tv_src; + duk_tval *tv_dst; + duk_tval *tv_curr; + duk_tval *tv_limit; + duk_idx_t top; + + DUK_ASSERT_API_ENTRY(thr); + + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + top = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom); + DUK_ASSERT(top >= 0); + if (DUK_UNLIKELY((duk_uidx_t) count > (duk_uidx_t) top)) { + /* Also handles negative count. */ + DUK_ERROR_RANGE_INVALID_COUNT(thr); + DUK_WO_NORETURN(return;); + } + DUK_ASSERT(count >= 0); + + /* Wrapping is controlled by the check above: value stack top can be + * at most DUK_USE_VALSTACK_LIMIT which is low enough so that + * multiplying with sizeof(duk_tval) won't wrap. + */ + DUK_ASSERT(count >= 0 && count <= (duk_idx_t) DUK_USE_VALSTACK_LIMIT); + DUK_ASSERT((duk_size_t) count <= DUK_SIZE_MAX / sizeof(duk_tval)); /* no wrapping */ + + tv_dst = duk_push_harray_with_size_outptr(thr, (duk_uint32_t) count); /* XXX: uninitialized would be OK */ + DUK_ASSERT(count == 0 || tv_dst != NULL); + DUK_ASSERT(!duk_is_bare_object(thr, -1)); + + /* Copy value stack values directly to the array part without + * any refcount updates: net refcount changes are zero. + */ + tv_src = thr->valstack_top - count - 1; + duk_memcpy_unsafe((void *) tv_dst, (const void *) tv_src, (size_t) count * sizeof(duk_tval)); + + /* Overwrite result array to final value stack location and wipe + * the rest; no refcount operations needed. + */ + + tv_dst = tv_src; /* when count == 0, same as tv_src (OK) */ + tv_src = thr->valstack_top - 1; + DUK_TVAL_SET_TVAL(tv_dst, tv_src); + + /* XXX: internal helper to wipe a value stack segment? */ + tv_curr = tv_dst + 1; + tv_limit = thr->valstack_top; + while (tv_curr != tv_limit) { + /* Wipe policy: keep as 'undefined'. */ + DUK_TVAL_SET_UNDEFINED(tv_curr); + tv_curr++; + } + thr->valstack_top = tv_dst + 1; +} + +DUK_INTERNAL duk_idx_t duk_unpack_array_like(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + + tv = duk_require_tval(thr, idx); + if (DUK_LIKELY(DUK_TVAL_IS_OBJECT(tv))) { + duk_hobject *h; + duk_uint32_t len; + duk_uint32_t i; + + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + DUK_UNREF(h); + +#if defined(DUK_USE_ARRAY_FASTPATH) /* close enough */ + if (DUK_LIKELY(DUK_HOBJECT_IS_ARRAY(h) && ((duk_harray *) h)->length <= DUK_HOBJECT_GET_ASIZE(h))) { + duk_harray *h_arr; + duk_tval *tv_src; + duk_tval *tv_dst; + + h_arr = (duk_harray *) h; + len = h_arr->length; + if (DUK_UNLIKELY(len >= 0x80000000UL)) { + goto fail_over_2g; + } + duk_require_stack(thr, (duk_idx_t) len); + + /* The potential allocation in duk_require_stack() may + * run a finalizer which modifies the argArray so that + * e.g. becomes sparse. So, we need to recheck that the + * array didn't change size and that there's still a + * valid backing array part. + * + * XXX: alternatively, could prevent finalizers for the + * duration. + */ + if (DUK_UNLIKELY(len != h_arr->length || h_arr->length > DUK_HOBJECT_GET_ASIZE((duk_hobject *) h_arr))) { + goto skip_fast; + } + + /* Main fast path: arguments array is almost always + * an actual array (though it might also be an arguments + * object). + */ + + DUK_DDD(DUK_DDDPRINT("fast path for %ld elements", (long) h_arr->length)); + tv_src = DUK_HOBJECT_A_GET_BASE(thr->heap, h); + tv_dst = thr->valstack_top; + while (len-- > 0) { + DUK_ASSERT(tv_dst < thr->valstack_end); + if (DUK_UNLIKELY(DUK_TVAL_IS_UNUSED(tv_src))) { + /* Gaps are very unlikely. Skip over them, + * without an ancestor lookup (technically + * not compliant). + */ + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(tv_dst)); /* valstack policy */ + } else { + DUK_TVAL_SET_TVAL(tv_dst, tv_src); + DUK_TVAL_INCREF(thr, tv_dst); + } + tv_src++; + tv_dst++; + } + DUK_ASSERT(tv_dst <= thr->valstack_end); + thr->valstack_top = tv_dst; + return (duk_idx_t) h_arr->length; + } + skip_fast: +#endif /* DUK_USE_ARRAY_FASTPATH */ + + /* Slow path: actual lookups. The initial 'length' lookup + * decides the output length, regardless of side effects that + * may resize or change the argArray while we read the + * indices. + */ + idx = duk_normalize_index(thr, idx); + duk_get_prop_stridx(thr, idx, DUK_STRIDX_LENGTH); + len = duk_to_uint32(thr, -1); /* ToUint32() coercion required */ + if (DUK_UNLIKELY(len >= 0x80000000UL)) { + goto fail_over_2g; + } + duk_pop_unsafe(thr); + DUK_DDD(DUK_DDDPRINT("slow path for %ld elements", (long) len)); + + duk_require_stack(thr, (duk_idx_t) len); + for (i = 0; i < len; i++) { + duk_get_prop_index(thr, idx, (duk_uarridx_t) i); + } + return (duk_idx_t) len; + } else if (DUK_TVAL_IS_UNDEFINED(tv) || DUK_TVAL_IS_NULL(tv)) { + return 0; + } + + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return 0;); + +fail_over_2g: + DUK_ERROR_RANGE_INVALID_LENGTH(thr); + DUK_WO_NORETURN(return 0;); +} + +/* + * Error throwing + */ + +#if defined(DUK_USE_GCC_PRAGMAS) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wsuggest-attribute=noreturn" +#elif defined(DUK_USE_CLANG_PRAGMAS) +#pragma clang diagnostic push +#endif + +DUK_EXTERNAL void duk_throw_raw(duk_hthread *thr) { + duk_tval *tv_val; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr->valstack_bottom >= thr->valstack); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT(thr->valstack_end >= thr->valstack_top); + + if (DUK_UNLIKELY(thr->valstack_top == thr->valstack_bottom)) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return;); + } + + /* Errors are augmented when they are created, not when they are + * thrown or re-thrown. The current error handler, however, runs + * just before an error is thrown. + */ + + /* Sync so that augmentation sees up-to-date activations, NULL + * thr->ptr_curr_pc so that it's not used if side effects occur + * in augmentation or longjmp handling. + */ + duk_hthread_sync_and_null_currpc(thr); + +#if defined(DUK_USE_AUGMENT_ERROR_THROW) + DUK_DDD(DUK_DDDPRINT("THROW ERROR (API): %!dT (before throw augment)", (duk_tval *) duk_get_tval(thr, -1))); + duk_err_augment_error_throw(thr); +#endif + DUK_DDD(DUK_DDDPRINT("THROW ERROR (API): %!dT (after throw augment)", (duk_tval *) duk_get_tval(thr, -1))); + + tv_val = DUK_GET_TVAL_NEGIDX(thr, -1); + duk_err_setup_ljstate1(thr, DUK_LJ_TYPE_THROW, tv_val); +#if defined(DUK_USE_DEBUGGER_SUPPORT) + duk_err_check_debugger_integration(thr); +#endif + + /* thr->heap->lj.jmpbuf_ptr is checked by duk_err_longjmp() so we don't + * need to check that here. If the value is NULL, a fatal error occurs + * because we can't return. + */ + + duk_err_longjmp(thr); + DUK_UNREACHABLE(); +} + +DUK_EXTERNAL void duk_fatal_raw(duk_hthread *thr, const char *err_msg) { + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(thr->heap->fatal_func != NULL); + + DUK_D(DUK_DPRINT("fatal error occurred: %s", err_msg ? err_msg : "NULL")); + + /* fatal_func should be noreturn, but noreturn declarations on function + * pointers has a very spotty support apparently so it's not currently + * done. + */ + thr->heap->fatal_func(thr->heap->heap_udata, err_msg); + + /* If the fatal handler returns, all bets are off. It'd be nice to + * print something here but since we don't want to depend on stdio, + * there's no way to do so portably. + */ + DUK_D(DUK_DPRINT("fatal error handler returned, all bets are off!")); + for (;;) { + /* loop forever, don't return (function marked noreturn) */ + } +} + +DUK_EXTERNAL void duk_error_va_raw(duk_hthread *thr, + duk_errcode_t err_code, + const char *filename, + duk_int_t line, + const char *fmt, + va_list ap) { + DUK_ASSERT_API_ENTRY(thr); + + duk_push_error_object_va_raw(thr, err_code, filename, line, fmt, ap); + (void) duk_throw(thr); + DUK_WO_NORETURN(return;); +} + +DUK_EXTERNAL void duk_error_raw(duk_hthread *thr, + duk_errcode_t err_code, + const char *filename, + duk_int_t line, + const char *fmt, + ...) { + va_list ap; + + DUK_ASSERT_API_ENTRY(thr); + + va_start(ap, fmt); + duk_push_error_object_va_raw(thr, err_code, filename, line, fmt, ap); + va_end(ap); + (void) duk_throw(thr); + DUK_WO_NORETURN(return;); +} + +#if defined(DUK_USE_GCC_PRAGMAS) +#pragma GCC diagnostic pop +#elif defined(DUK_USE_CLANG_PRAGMAS) +#pragma clang diagnostic pop +#endif + +#if !defined(DUK_USE_VARIADIC_MACROS) +DUK_NORETURN( + DUK_LOCAL_DECL void duk__throw_error_from_stash(duk_hthread *thr, duk_errcode_t err_code, const char *fmt, va_list ap)); + +DUK_LOCAL void duk__throw_error_from_stash(duk_hthread *thr, duk_errcode_t err_code, const char *fmt, va_list ap) { + const char *filename; + duk_int_t line; + + DUK_CTX_ASSERT_VALID(thr); + + filename = duk_api_global_filename; + line = duk_api_global_line; + duk_api_global_filename = NULL; + duk_api_global_line = 0; + + duk_push_error_object_va_raw(thr, err_code, filename, line, fmt, ap); + (void) duk_throw(thr); + DUK_WO_NORETURN(return;); +} + +#define DUK__ERROR_STASH_SHARED(code) \ + do { \ + va_list ap; \ + va_start(ap, fmt); \ + duk__throw_error_from_stash(thr, (code), fmt, ap); \ + va_end(ap); \ + DUK_WO_NORETURN(return 0;); \ + } while (0) + +DUK_EXTERNAL duk_ret_t duk_error_stash(duk_hthread *thr, duk_errcode_t err_code, const char *fmt, ...) { + DUK_ASSERT_API_ENTRY(thr); + DUK__ERROR_STASH_SHARED(err_code); +} +DUK_EXTERNAL duk_ret_t duk_generic_error_stash(duk_hthread *thr, const char *fmt, ...) { + DUK_ASSERT_API_ENTRY(thr); + DUK__ERROR_STASH_SHARED(DUK_ERR_ERROR); +} +DUK_EXTERNAL duk_ret_t duk_eval_error_stash(duk_hthread *thr, const char *fmt, ...) { + DUK_ASSERT_API_ENTRY(thr); + DUK__ERROR_STASH_SHARED(DUK_ERR_EVAL_ERROR); +} +DUK_EXTERNAL duk_ret_t duk_range_error_stash(duk_hthread *thr, const char *fmt, ...) { + DUK_ASSERT_API_ENTRY(thr); + DUK__ERROR_STASH_SHARED(DUK_ERR_RANGE_ERROR); +} +DUK_EXTERNAL duk_ret_t duk_reference_error_stash(duk_hthread *thr, const char *fmt, ...) { + DUK_ASSERT_API_ENTRY(thr); + DUK__ERROR_STASH_SHARED(DUK_ERR_REFERENCE_ERROR); +} +DUK_EXTERNAL duk_ret_t duk_syntax_error_stash(duk_hthread *thr, const char *fmt, ...) { + DUK_ASSERT_API_ENTRY(thr); + DUK__ERROR_STASH_SHARED(DUK_ERR_SYNTAX_ERROR); +} +DUK_EXTERNAL duk_ret_t duk_type_error_stash(duk_hthread *thr, const char *fmt, ...) { + DUK_ASSERT_API_ENTRY(thr); + DUK__ERROR_STASH_SHARED(DUK_ERR_TYPE_ERROR); +} +DUK_EXTERNAL duk_ret_t duk_uri_error_stash(duk_hthread *thr, const char *fmt, ...) { + DUK_ASSERT_API_ENTRY(thr); + DUK__ERROR_STASH_SHARED(DUK_ERR_URI_ERROR); +} +#endif /* DUK_USE_VARIADIC_MACROS */ + +/* + * Comparison + */ + +DUK_EXTERNAL duk_bool_t duk_equals(duk_hthread *thr, duk_idx_t idx1, duk_idx_t idx2) { + duk_tval *tv1, *tv2; + + DUK_ASSERT_API_ENTRY(thr); + + tv1 = duk_get_tval(thr, idx1); + tv2 = duk_get_tval(thr, idx2); + if ((tv1 == NULL) || (tv2 == NULL)) { + return 0; + } + + /* Coercion may be needed, the helper handles that by pushing the + * tagged values to the stack. + */ + return duk_js_equals(thr, tv1, tv2); +} + +DUK_EXTERNAL duk_bool_t duk_strict_equals(duk_hthread *thr, duk_idx_t idx1, duk_idx_t idx2) { + duk_tval *tv1, *tv2; + + DUK_ASSERT_API_ENTRY(thr); + + tv1 = duk_get_tval(thr, idx1); + tv2 = duk_get_tval(thr, idx2); + if ((tv1 == NULL) || (tv2 == NULL)) { + return 0; + } + + /* No coercions or other side effects, so safe */ + return duk_js_strict_equals(tv1, tv2); +} + +DUK_EXTERNAL duk_bool_t duk_samevalue(duk_hthread *thr, duk_idx_t idx1, duk_idx_t idx2) { + duk_tval *tv1, *tv2; + + DUK_ASSERT_API_ENTRY(thr); + + tv1 = duk_get_tval(thr, idx1); + tv2 = duk_get_tval(thr, idx2); + if ((tv1 == NULL) || (tv2 == NULL)) { + return 0; + } + + /* No coercions or other side effects, so safe */ + return duk_js_samevalue(tv1, tv2); +} + +/* + * instanceof + */ + +DUK_EXTERNAL duk_bool_t duk_instanceof(duk_hthread *thr, duk_idx_t idx1, duk_idx_t idx2) { + duk_tval *tv1, *tv2; + + DUK_ASSERT_API_ENTRY(thr); + + /* Index validation is strict, which differs from duk_equals(). + * The strict behavior mimics how instanceof itself works, e.g. + * it is a TypeError if rval is not a -callable- object. It would + * be somewhat inconsistent if rval would be allowed to be + * non-existent without a TypeError. + */ + tv1 = duk_require_tval(thr, idx1); + DUK_ASSERT(tv1 != NULL); + tv2 = duk_require_tval(thr, idx2); + DUK_ASSERT(tv2 != NULL); + + return duk_js_instanceof(thr, tv1, tv2); +} + +/* + * Lightfunc + */ + +DUK_INTERNAL void duk_push_lightfunc_name_raw(duk_hthread *thr, duk_c_function func, duk_small_uint_t lf_flags) { + /* Lightfunc name, includes Duktape/C native function pointer, which + * can often be used to locate the function from a symbol table. + * The name also includes the 16-bit duk_tval flags field because it + * includes the magic value. Because a single native function often + * provides different functionality depending on the magic value, it + * seems reasonably to include it in the name. + * + * On the other hand, a complicated name increases string table + * pressure in low memory environments (but only when function name + * is accessed). + */ + + DUK_ASSERT_API_ENTRY(thr); + + duk_push_literal(thr, "light_"); + duk_push_string_funcptr(thr, (duk_uint8_t *) &func, sizeof(func)); + duk_push_sprintf(thr, "_%04x", (unsigned int) lf_flags); + duk_concat(thr, 3); +} + +DUK_INTERNAL void duk_push_lightfunc_name(duk_hthread *thr, duk_tval *tv) { + duk_c_function func; + duk_small_uint_t lf_flags; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(DUK_TVAL_IS_LIGHTFUNC(tv)); + + DUK_TVAL_GET_LIGHTFUNC(tv, func, lf_flags); + duk_push_lightfunc_name_raw(thr, func, lf_flags); +} + +DUK_INTERNAL void duk_push_lightfunc_tostring(duk_hthread *thr, duk_tval *tv) { + duk_c_function func; + duk_small_uint_t lf_flags; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(DUK_TVAL_IS_LIGHTFUNC(tv)); + + DUK_TVAL_GET_LIGHTFUNC(tv, func, lf_flags); /* read before 'tv' potentially invalidated */ + duk_push_literal(thr, "function "); + duk_push_lightfunc_name_raw(thr, func, lf_flags); + duk_push_literal(thr, "() { [lightfunc code] }"); + duk_concat(thr, 3); +} + +/* + * Function pointers + * + * Printing function pointers is non-portable, so we do that by hex printing + * bytes from memory. + */ + +DUK_INTERNAL void duk_push_string_funcptr(duk_hthread *thr, duk_uint8_t *ptr, duk_size_t sz) { + duk_uint8_t buf[32 * 2]; + duk_uint8_t *p, *q; + duk_small_uint_t i; + duk_small_uint_t t; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(sz <= 32); /* sanity limit for function pointer size */ + + p = buf; +#if defined(DUK_USE_INTEGER_LE) + q = ptr + sz; +#else + q = ptr; +#endif + for (i = 0; i < sz; i++) { +#if defined(DUK_USE_INTEGER_LE) + t = *(--q); +#else + t = *(q++); +#endif + *p++ = duk_lc_digits[t >> 4]; + *p++ = duk_lc_digits[t & 0x0f]; + } + + duk_push_lstring(thr, (const char *) buf, sz * 2); +} + +/* + * Push readable string summarizing duk_tval. The operation is side effect + * free and will only throw from internal errors (e.g. out of memory). + * This is used by e.g. property access code to summarize a key/base safely, + * and is not intended to be fast (but small and safe). + */ + +/* String limits for summary strings. */ +#define DUK__READABLE_SUMMARY_MAXCHARS 96 /* maximum supported by helper */ +#define DUK__READABLE_STRING_MAXCHARS 32 /* for strings/symbols */ +#define DUK__READABLE_ERRMSG_MAXCHARS 96 /* for error messages */ + +/* String sanitizer which escapes ASCII control characters and a few other + * ASCII characters, passes Unicode as is, and replaces invalid UTF-8 with + * question marks. No errors are thrown for any input string, except in out + * of memory situations. + */ +DUK_LOCAL void duk__push_hstring_readable_unicode(duk_hthread *thr, duk_hstring *h_input, duk_small_uint_t maxchars) { + const duk_uint8_t *p, *p_start, *p_end; + duk_uint8_t buf[DUK_UNICODE_MAX_XUTF8_LENGTH * DUK__READABLE_SUMMARY_MAXCHARS + 2 /*quotes*/ + 3 /*periods*/]; + duk_uint8_t *q; + duk_ucodepoint_t cp; + duk_small_uint_t nchars; + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(h_input != NULL); + DUK_ASSERT(maxchars <= DUK__READABLE_SUMMARY_MAXCHARS); + + p_start = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_input); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h_input); + p = p_start; + q = buf; + + nchars = 0; + *q++ = (duk_uint8_t) DUK_ASC_SINGLEQUOTE; + for (;;) { + if (p >= p_end) { + break; + } + if (nchars == maxchars) { + *q++ = (duk_uint8_t) DUK_ASC_PERIOD; + *q++ = (duk_uint8_t) DUK_ASC_PERIOD; + *q++ = (duk_uint8_t) DUK_ASC_PERIOD; + break; + } + if (duk_unicode_decode_xutf8(thr, &p, p_start, p_end, &cp)) { + if (cp < 0x20 || cp == 0x7f || cp == DUK_ASC_SINGLEQUOTE || cp == DUK_ASC_BACKSLASH) { + DUK_ASSERT(DUK_UNICODE_MAX_XUTF8_LENGTH >= 4); /* estimate is valid */ + DUK_ASSERT((cp >> 4) <= 0x0f); + *q++ = (duk_uint8_t) DUK_ASC_BACKSLASH; + *q++ = (duk_uint8_t) DUK_ASC_LC_X; + *q++ = (duk_uint8_t) duk_lc_digits[cp >> 4]; + *q++ = (duk_uint8_t) duk_lc_digits[cp & 0x0f]; + } else { + q += duk_unicode_encode_xutf8(cp, q); + } + } else { + p++; /* advance manually */ + *q++ = (duk_uint8_t) DUK_ASC_QUESTION; + } + nchars++; + } + *q++ = (duk_uint8_t) DUK_ASC_SINGLEQUOTE; + + duk_push_lstring(thr, (const char *) buf, (duk_size_t) (q - buf)); +} + +DUK_LOCAL const char *duk__push_string_tval_readable(duk_hthread *thr, duk_tval *tv, duk_bool_t error_aware) { + DUK_CTX_ASSERT_VALID(thr); + /* 'tv' may be NULL */ + + if (tv == NULL) { + duk_push_literal(thr, "none"); + } else { + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_STRING: { + duk_hstring *h = DUK_TVAL_GET_STRING(tv); + if (DUK_HSTRING_HAS_SYMBOL(h)) { + /* XXX: string summary produces question marks + * so this is not very ideal. + */ + duk_push_literal(thr, "[Symbol "); + duk_push_string(thr, duk__get_symbol_type_string(h)); + duk_push_literal(thr, " "); + duk__push_hstring_readable_unicode(thr, h, DUK__READABLE_STRING_MAXCHARS); + duk_push_literal(thr, "]"); + duk_concat(thr, 5); + break; + } + duk__push_hstring_readable_unicode(thr, h, DUK__READABLE_STRING_MAXCHARS); + break; + } + case DUK_TAG_OBJECT: { + duk_hobject *h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + + if (error_aware && duk_hobject_prototype_chain_contains(thr, + h, + thr->builtins[DUK_BIDX_ERROR_PROTOTYPE], + 1 /*ignore_loop*/)) { + /* Get error message in a side effect free way if + * possible; if not, summarize as a generic object. + * Error message currently gets quoted. + */ + /* XXX: better internal getprop call; get without side effects + * but traverse inheritance chain. + */ + duk_tval *tv_msg; + tv_msg = duk_hobject_find_entry_tval_ptr_stridx(thr->heap, h, DUK_STRIDX_MESSAGE); + if (tv_msg != NULL && DUK_TVAL_IS_STRING(tv_msg)) { + /* It's critical to avoid recursion so + * only summarize a string .message. + */ + duk__push_hstring_readable_unicode(thr, + DUK_TVAL_GET_STRING(tv_msg), + DUK__READABLE_ERRMSG_MAXCHARS); + break; + } + } + duk_push_class_string_tval(thr, tv, 1 /*avoid_side_effects*/); + break; + } + case DUK_TAG_BUFFER: { + /* While plain buffers mimic Uint8Arrays, they summarize differently. + * This is useful so that the summarized string accurately reflects the + * internal type which may matter for figuring out bugs etc. + */ + /* XXX: Hex encoded, length limited buffer summary here? */ + duk_hbuffer *h = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h != NULL); + duk_push_sprintf(thr, "[buffer:%ld]", (long) DUK_HBUFFER_GET_SIZE(h)); + break; + } + case DUK_TAG_POINTER: { + /* Surround with parentheses like in JX, ensures NULL pointer + * is distinguishable from null value ("(null)" vs "null"). + */ + duk_push_tval(thr, tv); + duk_push_sprintf(thr, "(%s)", duk_to_string(thr, -1)); + duk_remove_m2(thr); + break; + } + default: { + duk_push_tval(thr, tv); + break; + } + } + } + + return duk_to_string(thr, -1); +} +DUK_INTERNAL const char *duk_push_string_tval_readable(duk_hthread *thr, duk_tval *tv) { + DUK_ASSERT_API_ENTRY(thr); + return duk__push_string_tval_readable(thr, tv, 0 /*error_aware*/); +} + +DUK_INTERNAL const char *duk_push_string_readable(duk_hthread *thr, duk_idx_t idx) { + DUK_ASSERT_API_ENTRY(thr); + return duk_push_string_tval_readable(thr, duk_get_tval(thr, idx)); +} + +DUK_INTERNAL const char *duk_push_string_tval_readable_error(duk_hthread *thr, duk_tval *tv) { + DUK_ASSERT_API_ENTRY(thr); + return duk__push_string_tval_readable(thr, tv, 1 /*error_aware*/); +} + +DUK_INTERNAL void duk_push_symbol_descriptive_string(duk_hthread *thr, duk_hstring *h) { + const duk_uint8_t *p; + const duk_uint8_t *p_end; + const duk_uint8_t *q; + + DUK_ASSERT_API_ENTRY(thr); + + /* .toString() */ + duk_push_literal(thr, "Symbol("); + p = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h); + p_end = p + DUK_HSTRING_GET_BYTELEN(h); + DUK_ASSERT(p[0] == 0xff || (p[0] & 0xc0) == 0x80); + p++; + for (q = p; q < p_end; q++) { + if (*q == 0xffU) { + /* Terminate either at end-of-string (but NUL MUST + * be accepted without terminating description) or + * 0xFF, which is used to mark start of unique trailer + * (and cannot occur in CESU-8 / extended UTF-8). + */ + break; + } + } + duk_push_lstring(thr, (const char *) p, (duk_size_t) (q - p)); + duk_push_literal(thr, ")"); + duk_concat(thr, 3); +} + +/* + * Functions + */ + +#if 0 /* not used yet */ +DUK_INTERNAL void duk_push_hnatfunc_name(duk_hthread *thr, duk_hnatfunc *h) { + duk_c_function func; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_NATFUNC((duk_hobject *) h)); + + duk_push_sprintf(thr, "native_"); + func = h->func; + duk_push_string_funcptr(thr, (duk_uint8_t *) &func, sizeof(func)); + duk_push_sprintf(thr, "_%04x_%04x", + (unsigned int) (duk_uint16_t) h->nargs, + (unsigned int) (duk_uint16_t) h->magic); + duk_concat(thr, 3); +} +#endif + +/* + * duk_tval slice copy + */ + +DUK_INTERNAL void duk_copy_tvals_incref(duk_hthread *thr, duk_tval *tv_dst, duk_tval *tv_src, duk_size_t count) { + duk_tval *tv; + + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(thr); + DUK_ASSERT(count * sizeof(duk_tval) >= count); /* no wrap */ + + duk_memcpy_unsafe((void *) tv_dst, (const void *) tv_src, count * sizeof(duk_tval)); + + tv = tv_dst; + while (count-- > 0) { + DUK_TVAL_INCREF(thr, tv); + tv++; + } +} + +/* automatic undefs */ +#undef DUK__ASSERT_SPACE +#undef DUK__CHECK_SPACE +#undef DUK__ERROR_STASH_SHARED +#undef DUK__PACK_ARGS +#undef DUK__READABLE_ERRMSG_MAXCHARS +#undef DUK__READABLE_STRING_MAXCHARS +#undef DUK__READABLE_SUMMARY_MAXCHARS +#line 1 "duk_api_string.c" +/* + * String manipulation + */ + +/* #include duk_internal.h -> already included */ + +DUK_LOCAL void duk__concat_and_join_helper(duk_hthread *thr, duk_idx_t count_in, duk_bool_t is_join) { + duk_uint_t count; + duk_uint_t i; + duk_size_t idx; + duk_size_t len; + duk_hstring *h; + duk_uint8_t *buf; + + DUK_CTX_ASSERT_VALID(thr); + + if (DUK_UNLIKELY(count_in <= 0)) { + if (count_in < 0) { + DUK_ERROR_RANGE_INVALID_COUNT(thr); + DUK_WO_NORETURN(return;); + } + DUK_ASSERT(count_in == 0); + duk_push_hstring_empty(thr); + return; + } + count = (duk_uint_t) count_in; + + if (is_join) { + duk_size_t t1, t2, limit; + h = duk_to_hstring(thr, -((duk_idx_t) count) - 1); + DUK_ASSERT(h != NULL); + + /* A bit tricky overflow test, see doc/code-issues.rst. */ + t1 = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h); + t2 = (duk_size_t) (count - 1); + limit = (duk_size_t) DUK_HSTRING_MAX_BYTELEN; + if (DUK_UNLIKELY(t2 != 0 && t1 > limit / t2)) { + /* Combined size of separators already overflows. */ + goto error_overflow; + } + len = (duk_size_t) (t1 * t2); + } else { + len = (duk_size_t) 0; + } + + for (i = count; i >= 1; i--) { + duk_size_t new_len; + h = duk_to_hstring(thr, -((duk_idx_t) i)); + new_len = len + (duk_size_t) DUK_HSTRING_GET_BYTELEN(h); + + /* Impose a string maximum length, need to handle overflow + * correctly. + */ + if (new_len < len || /* wrapped */ + new_len > (duk_size_t) DUK_HSTRING_MAX_BYTELEN) { + goto error_overflow; + } + len = new_len; + } + + DUK_DDD(DUK_DDDPRINT("join/concat %lu strings, total length %lu bytes", (unsigned long) count, (unsigned long) len)); + + /* Use stack allocated buffer to ensure reachability in errors + * (e.g. intern error). + */ + buf = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, len); + DUK_ASSERT(buf != NULL); + + /* [ ... (sep) str1 str2 ... strN buf ] */ + + idx = 0; + for (i = count; i >= 1; i--) { + if (is_join && i != count) { + h = duk_require_hstring(thr, -((duk_idx_t) count) - 2); /* extra -1 for buffer */ + duk_memcpy(buf + idx, DUK_HSTRING_GET_DATA(h), DUK_HSTRING_GET_BYTELEN(h)); + idx += DUK_HSTRING_GET_BYTELEN(h); + } + h = duk_require_hstring(thr, -((duk_idx_t) i) - 1); /* extra -1 for buffer */ + duk_memcpy(buf + idx, DUK_HSTRING_GET_DATA(h), DUK_HSTRING_GET_BYTELEN(h)); + idx += DUK_HSTRING_GET_BYTELEN(h); + } + + DUK_ASSERT(idx == len); + + /* [ ... (sep) str1 str2 ... strN buf ] */ + + /* Get rid of the strings early to minimize memory use before intern. */ + + if (is_join) { + duk_replace(thr, -((duk_idx_t) count) - 2); /* overwrite sep */ + duk_pop_n(thr, (duk_idx_t) count); + } else { + duk_replace(thr, -((duk_idx_t) count) - 1); /* overwrite str1 */ + duk_pop_n(thr, (duk_idx_t) (count - 1)); + } + + /* [ ... buf ] */ + + (void) duk_buffer_to_string(thr, -1); /* Safe if inputs are safe. */ + + /* [ ... res ] */ + return; + +error_overflow: + DUK_ERROR_RANGE(thr, DUK_STR_RESULT_TOO_LONG); + DUK_WO_NORETURN(return;); +} + +DUK_EXTERNAL void duk_concat(duk_hthread *thr, duk_idx_t count) { + DUK_ASSERT_API_ENTRY(thr); + + duk__concat_and_join_helper(thr, count, 0 /*is_join*/); +} + +#if defined(DUK_USE_PREFER_SIZE) +DUK_INTERNAL void duk_concat_2(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + duk_concat(thr, 2); +} +#else /* DUK_USE_PREFER_SIZE */ +DUK_INTERNAL void duk_concat_2(duk_hthread *thr) { + duk_hstring *h1; + duk_hstring *h2; + duk_uint8_t *buf; + duk_size_t len1; + duk_size_t len2; + duk_size_t len; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(duk_get_top(thr) >= 2); /* Trusted caller. */ + + h1 = duk_to_hstring(thr, -2); + h2 = duk_to_hstring(thr, -1); + len1 = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h1); + len2 = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h2); + len = len1 + len2; + if (DUK_UNLIKELY(len < len1 || /* wrapped */ + len > (duk_size_t) DUK_HSTRING_MAX_BYTELEN)) { + goto error_overflow; + } + buf = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, len); + DUK_ASSERT(buf != NULL); + + duk_memcpy((void *) buf, (const void *) DUK_HSTRING_GET_DATA(h1), (size_t) len1); + duk_memcpy((void *) (buf + len1), (const void *) DUK_HSTRING_GET_DATA(h2), (size_t) len2); + (void) duk_buffer_to_string(thr, -1); /* Safe if inputs are safe. */ + + /* [ ... str1 str2 buf ] */ + + duk_replace(thr, -3); + duk_pop_unsafe(thr); + return; + +error_overflow: + DUK_ERROR_RANGE(thr, DUK_STR_RESULT_TOO_LONG); + DUK_WO_NORETURN(return;); +} +#endif /* DUK_USE_PREFER_SIZE */ + +DUK_EXTERNAL void duk_join(duk_hthread *thr, duk_idx_t count) { + DUK_ASSERT_API_ENTRY(thr); + + duk__concat_and_join_helper(thr, count, 1 /*is_join*/); +} + +/* XXX: could map/decode be unified with duk_unicode_support.c code? + * Case conversion needs also the character surroundings though. + */ + +DUK_EXTERNAL void duk_decode_string(duk_hthread *thr, duk_idx_t idx, duk_decode_char_function callback, void *udata) { + duk_hstring *h_input; + const duk_uint8_t *p, *p_start, *p_end; + duk_codepoint_t cp; + + DUK_ASSERT_API_ENTRY(thr); + + h_input = duk_require_hstring(thr, idx); /* Accept symbols. */ + DUK_ASSERT(h_input != NULL); + + p_start = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_input); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h_input); + p = p_start; + + for (;;) { + if (p >= p_end) { + break; + } + cp = (duk_codepoint_t) duk_unicode_decode_xutf8_checked(thr, &p, p_start, p_end); + callback(udata, cp); + } +} + +DUK_EXTERNAL void duk_map_string(duk_hthread *thr, duk_idx_t idx, duk_map_char_function callback, void *udata) { + duk_hstring *h_input; + duk_bufwriter_ctx bw_alloc; + duk_bufwriter_ctx *bw; + const duk_uint8_t *p, *p_start, *p_end; + duk_codepoint_t cp; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_normalize_index(thr, idx); + + h_input = duk_require_hstring(thr, idx); /* Accept symbols. */ + DUK_ASSERT(h_input != NULL); + + bw = &bw_alloc; + DUK_BW_INIT_PUSHBUF(thr, bw, DUK_HSTRING_GET_BYTELEN(h_input)); /* Reasonable output estimate. */ + + p_start = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_input); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h_input); + p = p_start; + + for (;;) { + /* XXX: could write output in chunks with fewer ensure calls, + * but relative benefit would be small here. + */ + + if (p >= p_end) { + break; + } + cp = (duk_codepoint_t) duk_unicode_decode_xutf8_checked(thr, &p, p_start, p_end); + cp = callback(udata, cp); + + DUK_BW_WRITE_ENSURE_XUTF8(thr, bw, cp); + } + + DUK_BW_COMPACT(thr, bw); + (void) duk_buffer_to_string(thr, -1); /* Safe, extended UTF-8 encoded. */ + duk_replace(thr, idx); +} + +DUK_EXTERNAL void duk_substring(duk_hthread *thr, duk_idx_t idx, duk_size_t start_offset, duk_size_t end_offset) { + duk_hstring *h; + duk_hstring *res; + duk_size_t start_byte_offset; + duk_size_t end_byte_offset; + duk_size_t charlen; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); /* Accept symbols. */ + h = duk_require_hstring(thr, idx); + DUK_ASSERT(h != NULL); + + charlen = DUK_HSTRING_GET_CHARLEN(h); + if (end_offset >= charlen) { + end_offset = charlen; + } + if (start_offset > end_offset) { + start_offset = end_offset; + } + + DUK_ASSERT_DISABLE(start_offset >= 0); + DUK_ASSERT(start_offset <= end_offset && start_offset <= DUK_HSTRING_GET_CHARLEN(h)); + DUK_ASSERT_DISABLE(end_offset >= 0); + DUK_ASSERT(end_offset >= start_offset && end_offset <= DUK_HSTRING_GET_CHARLEN(h)); + + /* Guaranteed by string limits. */ + DUK_ASSERT(start_offset <= DUK_UINT32_MAX); + DUK_ASSERT(end_offset <= DUK_UINT32_MAX); + + start_byte_offset = (duk_size_t) duk_heap_strcache_offset_char2byte(thr, h, (duk_uint_fast32_t) start_offset); + end_byte_offset = (duk_size_t) duk_heap_strcache_offset_char2byte(thr, h, (duk_uint_fast32_t) end_offset); + + DUK_ASSERT(end_byte_offset >= start_byte_offset); + DUK_ASSERT(end_byte_offset - start_byte_offset <= DUK_UINT32_MAX); /* Guaranteed by string limits. */ + + /* No size check is necessary. */ + res = duk_heap_strtable_intern_checked(thr, + DUK_HSTRING_GET_DATA(h) + start_byte_offset, + (duk_uint32_t) (end_byte_offset - start_byte_offset)); + + duk_push_hstring(thr, res); + duk_replace(thr, idx); +} + +/* XXX: this is quite clunky. Add Unicode helpers to scan backwards and + * forwards with a callback to process codepoints? + */ +DUK_EXTERNAL void duk_trim(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + const duk_uint8_t *p, *p_start, *p_end, *p_tmp1, *p_tmp2; /* pointers for scanning */ + const duk_uint8_t *q_start, *q_end; /* start (incl) and end (excl) of trimmed part */ + duk_codepoint_t cp; + + DUK_ASSERT_API_ENTRY(thr); + + idx = duk_require_normalize_index(thr, idx); /* Accept symbols. */ + h = duk_require_hstring(thr, idx); + DUK_ASSERT(h != NULL); + + p_start = DUK_HSTRING_GET_DATA(h); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h); + + p = p_start; + while (p < p_end) { + p_tmp1 = p; + cp = (duk_codepoint_t) duk_unicode_decode_xutf8_checked(thr, &p_tmp1, p_start, p_end); + if (!(duk_unicode_is_whitespace(cp) || duk_unicode_is_line_terminator(cp))) { + break; + } + p = p_tmp1; + } + q_start = p; + if (p == p_end) { + /* Entire string is whitespace. */ + q_end = p; + goto scan_done; + } + + p = p_end; + while (p > p_start) { + p_tmp1 = p; + while (p > p_start) { + p--; + if (((*p) & 0xc0) != 0x80) { + break; + } + } + p_tmp2 = p; + + cp = (duk_codepoint_t) duk_unicode_decode_xutf8_checked(thr, &p_tmp2, p_start, p_end); + if (!(duk_unicode_is_whitespace(cp) || duk_unicode_is_line_terminator(cp))) { + p = p_tmp1; + break; + } + } + q_end = p; + +scan_done: + /* This may happen when forward and backward scanning disagree + * (possible for non-extended-UTF-8 strings). + */ + if (q_end < q_start) { + q_end = q_start; + } + + DUK_ASSERT(q_start >= p_start && q_start <= p_end); + DUK_ASSERT(q_end >= p_start && q_end <= p_end); + DUK_ASSERT(q_end >= q_start); + + DUK_DDD(DUK_DDDPRINT("trim: p_start=%p, p_end=%p, q_start=%p, q_end=%p", + (const void *) p_start, + (const void *) p_end, + (const void *) q_start, + (const void *) q_end)); + + if (q_start == p_start && q_end == p_end) { + DUK_DDD(DUK_DDDPRINT("nothing was trimmed: avoid interning (hashing etc)")); + return; + } + + duk_push_lstring(thr, (const char *) q_start, (duk_size_t) (q_end - q_start)); + duk_replace(thr, idx); +} + +DUK_EXTERNAL duk_codepoint_t duk_char_code_at(duk_hthread *thr, duk_idx_t idx, duk_size_t char_offset) { + duk_hstring *h; + duk_ucodepoint_t cp; + + DUK_ASSERT_API_ENTRY(thr); + + /* XXX: Share code with String.prototype.charCodeAt? Main difference + * is handling of clamped offsets. + */ + + h = duk_require_hstring(thr, idx); /* Accept symbols. */ + DUK_ASSERT(h != NULL); + + DUK_ASSERT_DISABLE(char_offset >= 0); /* Always true, arg is unsigned. */ + if (char_offset >= DUK_HSTRING_GET_CHARLEN(h)) { + return 0; + } + + DUK_ASSERT(char_offset <= DUK_UINT_MAX); /* Guaranteed by string limits. */ + cp = duk_hstring_char_code_at_raw(thr, h, (duk_uint_t) char_offset, 0 /*surrogate_aware*/); + return (duk_codepoint_t) cp; +} +#line 1 "duk_api_time.c" +/* + * Date/time. + */ + +/* #include duk_internal.h -> already included */ + +DUK_INTERNAL duk_double_t duk_time_get_ecmascript_time(duk_hthread *thr) { + /* ECMAScript time, with millisecond fractions. Exposed via + * duk_get_now() for example. + */ + DUK_UNREF(thr); + return (duk_double_t) DUK_USE_DATE_GET_NOW(thr); +} + +DUK_INTERNAL duk_double_t duk_time_get_ecmascript_time_nofrac(duk_hthread *thr) { + /* ECMAScript time without millisecond fractions. Exposed via + * the Date built-in which doesn't allow fractions. + */ + DUK_UNREF(thr); + return (duk_double_t) DUK_FLOOR(DUK_USE_DATE_GET_NOW(thr)); +} + +DUK_INTERNAL duk_double_t duk_time_get_monotonic_time(duk_hthread *thr) { + DUK_UNREF(thr); +#if defined(DUK_USE_GET_MONOTONIC_TIME) + return (duk_double_t) DUK_USE_GET_MONOTONIC_TIME(thr); +#else + return (duk_double_t) DUK_USE_DATE_GET_NOW(thr); +#endif +} + +DUK_EXTERNAL duk_double_t duk_get_now(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(thr); + + /* This API intentionally allows millisecond fractions. */ + return duk_time_get_ecmascript_time(thr); +} + +#if 0 /* XXX: worth exposing? */ +DUK_EXTERNAL duk_double_t duk_get_monotonic_time(duk_hthread *thr) { + DUK_ASSERT_API_ENTRY(thr); + DUK_UNREF(thr); + + return duk_time_get_monotonic_time(thr); +} +#endif + +DUK_EXTERNAL void duk_time_to_components(duk_hthread *thr, duk_double_t timeval, duk_time_components *comp) { + duk_int_t parts[DUK_DATE_IDX_NUM_PARTS]; + duk_double_t dparts[DUK_DATE_IDX_NUM_PARTS]; + duk_uint_t flags; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(comp != NULL); /* XXX: or check? */ + DUK_UNREF(thr); + + /* Convert as one-based, but change month to zero-based to match the + * ECMAScript Date built-in behavior 1:1. + */ + flags = DUK_DATE_FLAG_ONEBASED | DUK_DATE_FLAG_NAN_TO_ZERO; + + duk_bi_date_timeval_to_parts(timeval, parts, dparts, flags); + + /* XXX: sub-millisecond accuracy for the API */ + + DUK_ASSERT(dparts[DUK_DATE_IDX_MONTH] >= 1.0 && dparts[DUK_DATE_IDX_MONTH] <= 12.0); + comp->year = dparts[DUK_DATE_IDX_YEAR]; + comp->month = dparts[DUK_DATE_IDX_MONTH] - 1.0; + comp->day = dparts[DUK_DATE_IDX_DAY]; + comp->hours = dparts[DUK_DATE_IDX_HOUR]; + comp->minutes = dparts[DUK_DATE_IDX_MINUTE]; + comp->seconds = dparts[DUK_DATE_IDX_SECOND]; + comp->milliseconds = dparts[DUK_DATE_IDX_MILLISECOND]; + comp->weekday = dparts[DUK_DATE_IDX_WEEKDAY]; +} + +DUK_EXTERNAL duk_double_t duk_components_to_time(duk_hthread *thr, duk_time_components *comp) { + duk_double_t d; + duk_double_t dparts[DUK_DATE_IDX_NUM_PARTS]; + duk_uint_t flags; + + DUK_ASSERT_API_ENTRY(thr); + DUK_ASSERT(comp != NULL); /* XXX: or check? */ + DUK_UNREF(thr); + + /* Match Date constructor behavior (with UTC time). Month is given + * as zero-based. Day-of-month is given as one-based so normalize + * it to zero-based as the internal conversion helpers expects all + * components to be zero-based. + */ + flags = 0; + + /* XXX: expensive conversion; use array format in API instead, or unify + * time provider and time API to use same struct? + */ + + dparts[DUK_DATE_IDX_YEAR] = comp->year; + dparts[DUK_DATE_IDX_MONTH] = comp->month; + dparts[DUK_DATE_IDX_DAY] = comp->day - 1.0; + dparts[DUK_DATE_IDX_HOUR] = comp->hours; + dparts[DUK_DATE_IDX_MINUTE] = comp->minutes; + dparts[DUK_DATE_IDX_SECOND] = comp->seconds; + dparts[DUK_DATE_IDX_MILLISECOND] = comp->milliseconds; + dparts[DUK_DATE_IDX_WEEKDAY] = 0; /* ignored */ + + d = duk_bi_date_get_timeval_from_dparts(dparts, flags); + + return d; +} +#line 1 "duk_bi_array.c" +/* + * Array built-ins + * + * Most Array built-ins are intentionally generic in ECMAScript, and are + * intended to work even when the 'this' binding is not an Array instance. + * This ECMAScript feature is also used by much real world code. For this + * reason the implementations here don't assume exotic Array behavior or + * e.g. presence of a .length property. However, some algorithms have a + * fast path for duk_harray backed actual Array instances, enabled when + * footprint is not a concern. + * + * XXX: the "Throw" flag should be set for (almost?) all [[Put]] and + * [[Delete]] operations, but it's currently false throughout. Go through + * all put/delete cases and check throw flag use. Need a new API primitive + * which allows throws flag to be specified. + * + * XXX: array lengths above 2G won't work reliably. There are many places + * where one needs a full signed 32-bit range ([-0xffffffff, 0xffffffff], + * i.e. -33- bits). Although array 'length' cannot be written to be outside + * the unsigned 32-bit range (E5.1 Section 15.4.5.1 throws a RangeError if so) + * some intermediate values may be above 0xffffffff and this may not be always + * correctly handled now (duk_uint32_t is not enough for all algorithms). + * For instance, push() can legitimately write entries beyond length 0xffffffff + * and cause a RangeError only at the end. To do this properly, the current + * push() implementation tracks the array index using a 'double' instead of a + * duk_uint32_t (which is somewhat awkward). See test-bi-array-push-maxlen.js. + * + * On using "put" vs. "def" prop + * ============================= + * + * Code below must be careful to use the appropriate primitive as it matters + * for compliance. When using "put" there may be inherited properties in + * Array.prototype which cause side effects when values are written. When + * using "define" there are no such side effects, and many test262 test cases + * check for this (for real world code, such side effects are very rare). + * Both "put" and "define" are used in the E5.1 specification; as a rule, + * "put" is used when modifying an existing array (or a non-array 'this' + * binding) and "define" for setting values into a fresh result array. + */ + +/* #include duk_internal.h -> already included */ + +/* Perform an intermediate join when this many elements have been pushed + * on the value stack. + */ +#define DUK__ARRAY_MID_JOIN_LIMIT 4096 + +#if defined(DUK_USE_ARRAY_BUILTIN) + +/* + * Shared helpers. + */ + +/* Shared entry code for many Array built-ins: the 'this' binding is pushed + * on the value stack and object coerced, and the current .length is returned. + * Note that length is left on stack (it could be popped, but that's not + * usually necessary because call handling will clean it up automatically). + */ +DUK_LOCAL duk_uint32_t duk__push_this_obj_len_u32(duk_hthread *thr) { + duk_uint32_t len; + + /* XXX: push more directly? */ + (void) duk_push_this_coercible_to_object(thr); + DUK_HOBJECT_ASSERT_VALID(duk_get_hobject(thr, -1)); + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_LENGTH); + len = duk_to_uint32(thr, -1); + + /* -> [ ... ToObject(this) ToUint32(length) ] */ + return len; +} + +DUK_LOCAL duk_uint32_t duk__push_this_obj_len_u32_limited(duk_hthread *thr) { + /* Range limited to [0, 0x7fffffff] range, i.e. range that can be + * represented with duk_int32_t. Use this when the method doesn't + * handle the full 32-bit unsigned range correctly. + */ + duk_uint32_t ret = duk__push_this_obj_len_u32(thr); + if (DUK_UNLIKELY(ret >= 0x80000000UL)) { + DUK_ERROR_RANGE_INVALID_LENGTH(thr); + DUK_WO_NORETURN(return 0U;); + } + return ret; +} + +#if defined(DUK_USE_ARRAY_FASTPATH) +/* Check if 'this' binding is an Array instance (duk_harray) which satisfies + * a few other guarantees for fast path operation. The fast path doesn't + * need to handle all operations, even for duk_harrays, but must handle a + * significant fraction to improve performance. Return a non-NULL duk_harray + * pointer when all fast path criteria are met, NULL otherwise. + */ +DUK_LOCAL duk_harray *duk__arraypart_fastpath_this(duk_hthread *thr) { + duk_tval *tv; + duk_hobject *h; + duk_uint_t flags_mask, flags_bits, flags_value; + + DUK_ASSERT(thr->valstack_bottom > thr->valstack); /* because call in progress */ + tv = DUK_GET_THIS_TVAL_PTR(thr); + + /* Fast path requires that 'this' is a duk_harray. Read only arrays + * (ROM backed) are also rejected for simplicity. + */ + if (!DUK_TVAL_IS_OBJECT(tv)) { + DUK_DD(DUK_DDPRINT("reject array fast path: not an object")); + return NULL; + } + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + flags_mask = DUK_HOBJECT_FLAG_ARRAY_PART | DUK_HOBJECT_FLAG_EXOTIC_ARRAY | DUK_HEAPHDR_FLAG_READONLY; + flags_bits = DUK_HOBJECT_FLAG_ARRAY_PART | DUK_HOBJECT_FLAG_EXOTIC_ARRAY; + flags_value = DUK_HEAPHDR_GET_FLAGS_RAW((duk_heaphdr *) h); + if ((flags_value & flags_mask) != flags_bits) { + DUK_DD(DUK_DDPRINT("reject array fast path: object flag check failed")); + return NULL; + } + + /* In some cases a duk_harray's 'length' may be larger than the + * current array part allocation. Avoid the fast path in these + * cases, so that all fast path code can safely assume that all + * items in the range [0,length[ are backed by the current array + * part allocation. + */ + if (((duk_harray *) h)->length > DUK_HOBJECT_GET_ASIZE(h)) { + DUK_DD(DUK_DDPRINT("reject array fast path: length > array part size")); + return NULL; + } + + /* Guarantees for fast path. */ + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_ASIZE(h) == 0 || DUK_HOBJECT_A_GET_BASE(thr->heap, h) != NULL); + DUK_ASSERT(((duk_harray *) h)->length <= DUK_HOBJECT_GET_ASIZE(h)); + + DUK_DD(DUK_DDPRINT("array fast path allowed for: %!O", (duk_heaphdr *) h)); + return (duk_harray *) h; +} +#endif /* DUK_USE_ARRAY_FASTPATH */ + +/* + * Constructor + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_constructor(duk_hthread *thr) { + duk_idx_t nargs; + duk_harray *a; + duk_double_t d; + duk_uint32_t len; + duk_uint32_t len_prealloc; + + nargs = duk_get_top(thr); + + if (nargs == 1 && duk_is_number(thr, 0)) { + /* XXX: expensive check (also shared elsewhere - so add a shared internal API call?) */ + d = duk_get_number(thr, 0); + len = duk_to_uint32(thr, 0); + if (!duk_double_equals((duk_double_t) len, d)) { + DUK_DCERROR_RANGE_INVALID_LENGTH(thr); + } + + /* For small lengths create a dense preallocated array. + * For large arrays preallocate an initial part. + */ + len_prealloc = len < 64 ? len : 64; + a = duk_push_harray_with_size(thr, len_prealloc); + DUK_ASSERT(a != NULL); + DUK_ASSERT(!duk_is_bare_object(thr, -1)); + a->length = len; + return 1; + } + + duk_pack(thr, nargs); + return 1; +} + +/* + * isArray() + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_constructor_is_array(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 1); + duk_push_boolean(thr, duk_js_isarray(DUK_GET_TVAL_POSIDX(thr, 0))); + return 1; +} + +/* + * toString() + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_to_string(duk_hthread *thr) { + (void) duk_push_this_coercible_to_object(thr); + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_JOIN); + + /* [ ... this func ] */ + if (!duk_is_callable(thr, -1)) { + /* Fall back to the initial (original) Object.toString(). We don't + * currently have pointers to the built-in functions, only the top + * level global objects (like "Array") so this is now done in a bit + * of a hacky manner. It would be cleaner to push the (original) + * function and use duk_call_method(). + */ + + /* XXX: 'this' will be ToObject() coerced twice, which is incorrect + * but should have no visible side effects. + */ + DUK_DDD(DUK_DDDPRINT("this.join is not callable, fall back to (original) Object.toString")); + duk_set_top(thr, 0); + return duk_bi_object_prototype_to_string(thr); /* has access to 'this' binding */ + } + + /* [ ... this func ] */ + + duk_insert(thr, -2); + + /* [ ... func this ] */ + + DUK_DDD( + DUK_DDDPRINT("calling: func=%!iT, this=%!iT", (duk_tval *) duk_get_tval(thr, -2), (duk_tval *) duk_get_tval(thr, -1))); + duk_call_method(thr, 0); + + return 1; +} + +/* + * concat() + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_concat(duk_hthread *thr) { + duk_idx_t i, n; + duk_uint32_t j, idx, len; + duk_hobject *h; + duk_size_t tmp_len; + + /* XXX: In ES2015 Array .length can be up to 2^53-1. The current + * implementation is limited to 2^32-1. + */ + + /* XXX: Fast path for array 'this' and array element. */ + + /* XXX: The insert here is a bit expensive if there are a lot of items. + * It could also be special cased in the outermost for loop quite easily + * (as the element is dup()'d anyway). + */ + + (void) duk_push_this_coercible_to_object(thr); + duk_insert(thr, 0); + n = duk_get_top(thr); + duk_push_array(thr); /* -> [ ToObject(this) item1 ... itemN arr ] */ + + /* NOTE: The Array special behaviors are NOT invoked by duk_xdef_prop_index() + * (which differs from the official algorithm). If no error is thrown, this + * doesn't matter as the length is updated at the end. However, if an error + * is thrown, the length will be unset. That shouldn't matter because the + * caller won't get a reference to the intermediate value. + */ + + idx = 0; + for (i = 0; i < n; i++) { + duk_bool_t spreadable; + duk_bool_t need_has_check; + + DUK_ASSERT_TOP(thr, n + 1); + + /* [ ToObject(this) item1 ... itemN arr ] */ + + h = duk_get_hobject(thr, i); + + if (h == NULL) { + spreadable = 0; + } else { +#if defined(DUK_USE_SYMBOL_BUILTIN) + duk_get_prop_stridx(thr, i, DUK_STRIDX_WELLKNOWN_SYMBOL_IS_CONCAT_SPREADABLE); + if (duk_is_undefined(thr, -1)) { + spreadable = duk_js_isarray_hobject(h); + } else { + spreadable = duk_to_boolean(thr, -1); + } + duk_pop_nodecref_unsafe(thr); +#else + spreadable = duk_js_isarray_hobject(h); +#endif + } + + if (!spreadable) { + duk_dup(thr, i); + duk_xdef_prop_index_wec(thr, -2, idx); + idx++; + if (DUK_UNLIKELY(idx == 0U)) { + /* Index after update is 0, and index written + * was 0xffffffffUL which is no longer a valid + * array index. + */ + goto fail_wrap; + } + continue; + } + + DUK_ASSERT(duk_is_object(thr, i)); + need_has_check = (DUK_HOBJECT_IS_PROXY(h) != 0); /* Always 0 w/o Proxy support. */ + + /* [ ToObject(this) item1 ... itemN arr ] */ + + tmp_len = duk_get_length(thr, i); + len = (duk_uint32_t) tmp_len; + if (DUK_UNLIKELY(tmp_len != (duk_size_t) len)) { + goto fail_wrap; + } + if (DUK_UNLIKELY(idx + len < idx)) { + /* Result length must be at most 0xffffffffUL to be + * a valid 32-bit array index. + */ + goto fail_wrap; + } + for (j = 0; j < len; j++) { + /* For a Proxy element, an explicit 'has' check is + * needed to allow the Proxy to present gaps. + */ + if (need_has_check) { + if (duk_has_prop_index(thr, i, j)) { + duk_get_prop_index(thr, i, j); + duk_xdef_prop_index_wec(thr, -2, idx); + } + } else { + if (duk_get_prop_index(thr, i, j)) { + duk_xdef_prop_index_wec(thr, -2, idx); + } else { + duk_pop_undefined(thr); + } + } + idx++; + DUK_ASSERT(idx != 0U); /* Wrap check above. */ + } + } + + /* ES5.1 has a specification "bug" in that nonexistent trailing + * elements don't affect the result .length. Test262 and other + * engines disagree, and the specification bug was fixed in ES2015 + * (see NOTE 1 in https://www.ecma-international.org/ecma-262/6.0/#sec-array.prototype.concat). + */ + duk_push_uarridx(thr, idx); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_W); + + DUK_ASSERT_TOP(thr, n + 1); + return 1; + +fail_wrap: + DUK_ERROR_RANGE_INVALID_LENGTH(thr); + DUK_WO_NORETURN(return 0;); +} + +/* + * join(), toLocaleString() + * + * Note: checking valstack is necessary, but only in the per-element loop. + * + * Note: the trivial approach of pushing all the elements on the value stack + * and then calling duk_join() fails when the array contains a large number + * of elements. This problem can't be offloaded to duk_join() because the + * elements to join must be handled here and have special handling. Current + * approach is to do intermediate joins with very large number of elements. + * There is no fancy handling; the prefix gets re-joined multiple times. + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_join_shared(duk_hthread *thr) { + duk_uint32_t len, count; + duk_uint32_t idx; + duk_small_int_t to_locale_string = duk_get_current_magic(thr); + duk_idx_t valstack_required; + + /* For join(), nargs is 1. For toLocaleString(), nargs is 0 and + * setting the top essentially pushes an undefined to the stack, + * thus defaulting to a comma separator. + */ + duk_set_top(thr, 1); + if (duk_is_undefined(thr, 0)) { + duk_pop_undefined(thr); + duk_push_hstring_stridx(thr, DUK_STRIDX_COMMA); + } else { + duk_to_string(thr, 0); + } + + len = duk__push_this_obj_len_u32(thr); + + /* [ sep ToObject(this) len ] */ + + DUK_DDD(DUK_DDDPRINT("sep=%!T, this=%!T, len=%lu", + (duk_tval *) duk_get_tval(thr, 0), + (duk_tval *) duk_get_tval(thr, 1), + (unsigned long) len)); + + /* The extra (+4) is tight. */ + valstack_required = (duk_idx_t) ((len >= DUK__ARRAY_MID_JOIN_LIMIT ? DUK__ARRAY_MID_JOIN_LIMIT : len) + 4); + duk_require_stack(thr, valstack_required); + + duk_dup_0(thr); + + /* [ sep ToObject(this) len sep ] */ + + count = 0; + idx = 0; + for (;;) { + DUK_DDD(DUK_DDDPRINT("join idx=%ld", (long) idx)); + if (count >= DUK__ARRAY_MID_JOIN_LIMIT || /* intermediate join to avoid valstack overflow */ + idx >= len) { /* end of loop (careful with len==0) */ + /* [ sep ToObject(this) len sep str0 ... str(count-1) ] */ + DUK_DDD(DUK_DDDPRINT("mid/final join, count=%ld, idx=%ld, len=%ld", (long) count, (long) idx, (long) len)); + duk_join(thr, (duk_idx_t) count); /* -> [ sep ToObject(this) len str ] */ + duk_dup_0(thr); /* -> [ sep ToObject(this) len str sep ] */ + duk_insert(thr, -2); /* -> [ sep ToObject(this) len sep str ] */ + count = 1; + } + if (idx >= len) { + /* if true, the stack already contains the final result */ + break; + } + + duk_get_prop_index(thr, 1, (duk_uarridx_t) idx); + if (duk_is_null_or_undefined(thr, -1)) { + duk_pop_nodecref_unsafe(thr); + duk_push_hstring_empty(thr); + } else { + if (to_locale_string) { + duk_to_object(thr, -1); + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_TO_LOCALE_STRING); + duk_insert(thr, -2); /* -> [ ... toLocaleString ToObject(val) ] */ + duk_call_method(thr, 0); + } + duk_to_string(thr, -1); + } + + count++; + idx++; + } + + /* [ sep ToObject(this) len sep result ] */ + + return 1; +} + +/* + * pop(), push() + */ + +#if defined(DUK_USE_ARRAY_FASTPATH) +DUK_LOCAL duk_ret_t duk__array_pop_fastpath(duk_hthread *thr, duk_harray *h_arr) { + duk_tval *tv_arraypart; + duk_tval *tv_val; + duk_uint32_t len; + + tv_arraypart = DUK_HOBJECT_A_GET_BASE(thr->heap, (duk_hobject *) h_arr); + len = h_arr->length; + if (len <= 0) { + /* nop, return undefined */ + return 0; + } + + len--; + h_arr->length = len; + + /* Fast path doesn't check for an index property inherited from + * Array.prototype. This is quite often acceptable; if not, + * disable fast path. + */ + DUK_ASSERT_VS_SPACE(thr); + tv_val = tv_arraypart + len; + if (DUK_TVAL_IS_UNUSED(tv_val)) { + /* No net refcount change. Value stack already has + * 'undefined' based on value stack init policy. + */ + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top)); + DUK_ASSERT(DUK_TVAL_IS_UNUSED(tv_val)); + } else { + /* No net refcount change. */ + DUK_TVAL_SET_TVAL(thr->valstack_top, tv_val); + DUK_TVAL_SET_UNUSED(tv_val); + } + thr->valstack_top++; + + /* XXX: there's no shrink check in the fast path now */ + + return 1; +} +#endif /* DUK_USE_ARRAY_FASTPATH */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_pop(duk_hthread *thr) { + duk_uint32_t len; + duk_uint32_t idx; +#if defined(DUK_USE_ARRAY_FASTPATH) + duk_harray *h_arr; +#endif + + DUK_ASSERT_TOP(thr, 0); + +#if defined(DUK_USE_ARRAY_FASTPATH) + h_arr = duk__arraypart_fastpath_this(thr); + if (h_arr) { + return duk__array_pop_fastpath(thr, h_arr); + } +#endif + + /* XXX: Merge fastpath check into a related call (push this, coerce length, etc)? */ + + len = duk__push_this_obj_len_u32(thr); + if (len == 0) { + duk_push_int(thr, 0); + duk_put_prop_stridx_short(thr, 0, DUK_STRIDX_LENGTH); + return 0; + } + idx = len - 1; + + duk_get_prop_index(thr, 0, (duk_uarridx_t) idx); + duk_del_prop_index(thr, 0, (duk_uarridx_t) idx); + duk_push_u32(thr, idx); + duk_put_prop_stridx_short(thr, 0, DUK_STRIDX_LENGTH); + return 1; +} + +#if defined(DUK_USE_ARRAY_FASTPATH) +DUK_LOCAL duk_ret_t duk__array_push_fastpath(duk_hthread *thr, duk_harray *h_arr) { + duk_tval *tv_arraypart; + duk_tval *tv_src; + duk_tval *tv_dst; + duk_uint32_t len; + duk_idx_t i, n; + + len = h_arr->length; + tv_arraypart = DUK_HOBJECT_A_GET_BASE(thr->heap, (duk_hobject *) h_arr); + + n = (duk_idx_t) (thr->valstack_top - thr->valstack_bottom); + DUK_ASSERT(n >= 0); + DUK_ASSERT((duk_uint32_t) n <= DUK_UINT32_MAX); + if (DUK_UNLIKELY(len + (duk_uint32_t) n < len)) { + DUK_D(DUK_DPRINT("Array.prototype.push() would go beyond 32-bit length, throw")); + DUK_DCERROR_RANGE_INVALID_LENGTH(thr); /* != 0 return value returned as is by caller */ + } + if (len + (duk_uint32_t) n > DUK_HOBJECT_GET_ASIZE((duk_hobject *) h_arr)) { + /* Array part would need to be extended. Rely on slow path + * for now. + * + * XXX: Rework hobject code a bit and add extend support. + */ + return 0; + } + + tv_src = thr->valstack_bottom; + tv_dst = tv_arraypart + len; + for (i = 0; i < n; i++) { + /* No net refcount change; reset value stack values to + * undefined to satisfy value stack init policy. + */ + DUK_TVAL_SET_TVAL(tv_dst, tv_src); + DUK_TVAL_SET_UNDEFINED(tv_src); + tv_src++; + tv_dst++; + } + thr->valstack_top = thr->valstack_bottom; + len += (duk_uint32_t) n; + h_arr->length = len; + + DUK_ASSERT((duk_uint_t) len == len); + duk_push_uint(thr, (duk_uint_t) len); + return 1; +} +#endif /* DUK_USE_ARRAY_FASTPATH */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_push(duk_hthread *thr) { + /* Note: 'this' is not necessarily an Array object. The push() + * algorithm is supposed to work for other kinds of objects too, + * so the algorithm has e.g. an explicit update for the 'length' + * property which is normally "magical" in arrays. + */ + + duk_uint32_t len; + duk_idx_t i, n; +#if defined(DUK_USE_ARRAY_FASTPATH) + duk_harray *h_arr; +#endif + +#if defined(DUK_USE_ARRAY_FASTPATH) + h_arr = duk__arraypart_fastpath_this(thr); + if (h_arr) { + duk_ret_t rc; + rc = duk__array_push_fastpath(thr, h_arr); + if (rc != 0) { + return rc; + } + DUK_DD(DUK_DDPRINT("array push() fast path exited, resize case")); + } +#endif + + n = duk_get_top(thr); + len = duk__push_this_obj_len_u32(thr); + + /* [ arg1 ... argN obj length ] */ + + /* Technically Array.prototype.push() can create an Array with length + * longer than 2^32-1, i.e. outside the 32-bit range. The final length + * is *not* wrapped to 32 bits in the specification. + * + * This implementation tracks length with a uint32 because it's much + * more practical. + * + * See: test-bi-array-push-maxlen.js. + */ + + if (len + (duk_uint32_t) n < len) { + DUK_D(DUK_DPRINT("Array.prototype.push() would go beyond 32-bit length, throw")); + DUK_DCERROR_RANGE_INVALID_LENGTH(thr); + } + + for (i = 0; i < n; i++) { + duk_dup(thr, i); + duk_put_prop_index(thr, -3, (duk_uarridx_t) (len + (duk_uint32_t) i)); + } + len += (duk_uint32_t) n; + + duk_push_u32(thr, len); + duk_dup_top(thr); + duk_put_prop_stridx_short(thr, -4, DUK_STRIDX_LENGTH); + + /* [ arg1 ... argN obj length new_length ] */ + return 1; +} + +/* + * sort() + * + * Currently qsort with random pivot. This is now really, really slow, + * because there is no fast path for array parts. + * + * Signed indices are used because qsort() leaves and degenerate cases + * may use a negative offset. + */ + +DUK_LOCAL duk_small_int_t duk__array_sort_compare(duk_hthread *thr, duk_int_t idx1, duk_int_t idx2) { + duk_bool_t have1, have2; + duk_bool_t undef1, undef2; + duk_small_int_t ret; + duk_idx_t idx_obj = 1; /* fixed offsets in valstack */ + duk_idx_t idx_fn = 0; + duk_hstring *h1, *h2; + + /* Fast exit if indices are identical. This is valid for a non-existent property, + * for an undefined value, and almost always for ToString() coerced comparison of + * arbitrary values (corner cases where this is not the case include e.g. a an + * object with varying ToString() coercion). + * + * The specification does not prohibit "caching" of values read from the array, so + * assuming equality for comparing an index with itself falls into the category of + * "caching". + * + * Also, compareFn may be inconsistent, so skipping a call to compareFn here may + * have an effect on the final result. The specification does not require any + * specific behavior for inconsistent compare functions, so again, this fast path + * is OK. + */ + + if (idx1 == idx2) { + DUK_DDD(DUK_DDDPRINT("duk__array_sort_compare: idx1=%ld, idx2=%ld -> indices identical, quick exit", + (long) idx1, + (long) idx2)); + return 0; + } + + have1 = duk_get_prop_index(thr, idx_obj, (duk_uarridx_t) idx1); + have2 = duk_get_prop_index(thr, idx_obj, (duk_uarridx_t) idx2); + + DUK_DDD(DUK_DDDPRINT("duk__array_sort_compare: idx1=%ld, idx2=%ld, have1=%ld, have2=%ld, val1=%!T, val2=%!T", + (long) idx1, + (long) idx2, + (long) have1, + (long) have2, + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + + if (have1) { + if (have2) { + ; + } else { + ret = -1; + goto pop_ret; + } + } else { + if (have2) { + ret = 1; + goto pop_ret; + } else { + ret = 0; + goto pop_ret; + } + } + + undef1 = duk_is_undefined(thr, -2); + undef2 = duk_is_undefined(thr, -1); + if (undef1) { + if (undef2) { + ret = 0; + goto pop_ret; + } else { + ret = 1; + goto pop_ret; + } + } else { + if (undef2) { + ret = -1; + goto pop_ret; + } else { + ; + } + } + + if (!duk_is_undefined(thr, idx_fn)) { + duk_double_t d; + + /* No need to check callable; duk_call() will do that. */ + duk_dup(thr, idx_fn); /* -> [ ... x y fn ] */ + duk_insert(thr, -3); /* -> [ ... fn x y ] */ + duk_call(thr, 2); /* -> [ ... res ] */ + + /* ES5 is a bit vague about what to do if the return value is + * not a number. ES2015 provides a concrete description: + * http://www.ecma-international.org/ecma-262/6.0/#sec-sortcompare. + */ + + d = duk_to_number_m1(thr); + if (d < 0.0) { + ret = -1; + } else if (d > 0.0) { + ret = 1; + } else { + /* Because NaN compares to false, NaN is handled here + * without an explicit check above. + */ + ret = 0; + } + + duk_pop_nodecref_unsafe(thr); + DUK_DDD(DUK_DDDPRINT("-> result %ld (from comparefn, after coercion)", (long) ret)); + return ret; + } + + /* string compare is the default (a bit oddly) */ + + /* XXX: any special handling for plain array; causes repeated coercion now? */ + h1 = duk_to_hstring(thr, -2); + h2 = duk_to_hstring_m1(thr); + DUK_ASSERT(h1 != NULL); + DUK_ASSERT(h2 != NULL); + + ret = duk_js_string_compare(h1, h2); /* retval is directly usable */ + goto pop_ret; + +pop_ret: + duk_pop_2_unsafe(thr); + DUK_DDD(DUK_DDDPRINT("-> result %ld", (long) ret)); + return ret; +} + +DUK_LOCAL void duk__array_sort_swap(duk_hthread *thr, duk_int_t l, duk_int_t r) { + duk_bool_t have_l, have_r; + duk_idx_t idx_obj = 1; /* fixed offset in valstack */ + + if (l == r) { + return; + } + + /* swap elements; deal with non-existent elements correctly */ + have_l = duk_get_prop_index(thr, idx_obj, (duk_uarridx_t) l); + have_r = duk_get_prop_index(thr, idx_obj, (duk_uarridx_t) r); + + if (have_r) { + /* right exists, [[Put]] regardless whether or not left exists */ + duk_put_prop_index(thr, idx_obj, (duk_uarridx_t) l); + } else { + duk_del_prop_index(thr, idx_obj, (duk_uarridx_t) l); + duk_pop_undefined(thr); + } + + if (have_l) { + duk_put_prop_index(thr, idx_obj, (duk_uarridx_t) r); + } else { + duk_del_prop_index(thr, idx_obj, (duk_uarridx_t) r); + duk_pop_undefined(thr); + } +} + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) +/* Debug print which visualizes the qsort partitioning process. */ +DUK_LOCAL void duk__debuglog_qsort_state(duk_hthread *thr, duk_int_t lo, duk_int_t hi, duk_int_t pivot) { + char buf[4096]; + char *ptr = buf; + duk_int_t i, n; + n = (duk_int_t) duk_get_length(thr, 1); + if (n > 4000) { + n = 4000; + } + *ptr++ = '['; + for (i = 0; i < n; i++) { + if (i == pivot) { + *ptr++ = '|'; + } else if (i == lo) { + *ptr++ = '<'; + } else if (i == hi) { + *ptr++ = '>'; + } else if (i >= lo && i <= hi) { + *ptr++ = '-'; + } else { + *ptr++ = ' '; + } + } + *ptr++ = ']'; + *ptr++ = '\0'; + + DUK_DDD(DUK_DDDPRINT("%s (lo=%ld, hi=%ld, pivot=%ld)", (const char *) buf, (long) lo, (long) hi, (long) pivot)); +} +#endif + +DUK_LOCAL void duk__array_qsort(duk_hthread *thr, duk_int_t lo, duk_int_t hi) { + duk_int_t p, l, r; + + /* The lo/hi indices may be crossed and hi < 0 is possible at entry. */ + + DUK_DDD(DUK_DDDPRINT("duk__array_qsort: lo=%ld, hi=%ld, obj=%!T", (long) lo, (long) hi, (duk_tval *) duk_get_tval(thr, 1))); + + DUK_ASSERT_TOP(thr, 3); + + /* In some cases it may be that lo > hi, or hi < 0; these + * degenerate cases happen e.g. for empty arrays, and in + * recursion leaves. + */ + + /* trivial cases */ + if (hi - lo < 1) { + DUK_DDD(DUK_DDDPRINT("degenerate case, return immediately")); + return; + } + DUK_ASSERT(hi > lo); + DUK_ASSERT(hi - lo + 1 >= 2); + + /* randomized pivot selection */ + p = lo + (duk_int_t) (duk_util_get_random_double(thr) * (duk_double_t) (hi - lo + 1)); + DUK_ASSERT(p >= lo && p <= hi); + DUK_DDD(DUK_DDDPRINT("lo=%ld, hi=%ld, chose pivot p=%ld", (long) lo, (long) hi, (long) p)); + + /* move pivot out of the way */ + duk__array_sort_swap(thr, p, lo); + p = lo; + DUK_DDD(DUK_DDDPRINT("pivot moved out of the way: %!T", (duk_tval *) duk_get_tval(thr, 1))); + + l = lo + 1; + r = hi; + for (;;) { + /* find elements to swap */ + for (;;) { + DUK_DDD(DUK_DDDPRINT("left scan: l=%ld, r=%ld, p=%ld", (long) l, (long) r, (long) p)); + if (l >= hi) { + break; + } + if (duk__array_sort_compare(thr, l, p) >= 0) { /* !(l < p) */ + break; + } + l++; + } + for (;;) { + DUK_DDD(DUK_DDDPRINT("right scan: l=%ld, r=%ld, p=%ld", (long) l, (long) r, (long) p)); + if (r <= lo) { + break; + } + if (duk__array_sort_compare(thr, p, r) >= 0) { /* !(p < r) */ + break; + } + r--; + } + if (l >= r) { + goto done; + } + DUK_ASSERT(l < r); + + DUK_DDD(DUK_DDDPRINT("swap %ld and %ld", (long) l, (long) r)); + + duk__array_sort_swap(thr, l, r); + + DUK_DDD(DUK_DDDPRINT("after swap: %!T", (duk_tval *) duk_get_tval(thr, 1))); + l++; + r--; + } +done: + /* Note that 'l' and 'r' may cross, i.e. r < l */ + DUK_ASSERT(l >= lo && l <= hi); + DUK_ASSERT(r >= lo && r <= hi); + + /* XXX: there's no explicit recursion bound here now. For the average + * qsort recursion depth O(log n) that's not really necessary: e.g. for + * 2**32 recursion depth would be about 32 which is OK. However, qsort + * worst case recursion depth is O(n) which may be a problem. + */ + + /* move pivot to its final place */ + DUK_DDD(DUK_DDDPRINT("before final pivot swap: %!T", (duk_tval *) duk_get_tval(thr, 1))); + duk__array_sort_swap(thr, lo, r); + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) + duk__debuglog_qsort_state(thr, lo, hi, r); +#endif + + DUK_DDD(DUK_DDDPRINT("recurse: pivot=%ld, obj=%!T", (long) r, (duk_tval *) duk_get_tval(thr, 1))); + duk__array_qsort(thr, lo, r - 1); + duk__array_qsort(thr, r + 1, hi); +} + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_sort(duk_hthread *thr) { + duk_uint32_t len; + + /* XXX: len >= 0x80000000 won't work below because a signed type + * is needed by qsort. + */ + len = duk__push_this_obj_len_u32_limited(thr); + + /* stack[0] = compareFn + * stack[1] = ToObject(this) + * stack[2] = ToUint32(length) + */ + + if (len > 0) { + /* avoid degenerate cases, so that (len - 1) won't underflow */ + duk__array_qsort(thr, (duk_int_t) 0, (duk_int_t) (len - 1)); + } + + DUK_ASSERT_TOP(thr, 3); + duk_pop_nodecref_unsafe(thr); + return 1; /* return ToObject(this) */ +} + +/* + * splice() + */ + +/* XXX: this compiles to over 500 bytes now, even without special handling + * for an array part. Uses signed ints so does not handle full array range correctly. + */ + +/* XXX: can shift() / unshift() use the same helper? + * shift() is (close to?) <--> splice(0, 1) + * unshift is (close to?) <--> splice(0, 0, [items])? + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_splice(duk_hthread *thr) { + duk_idx_t nargs; + duk_uint32_t len_u32; + duk_int_t len; + duk_bool_t have_delcount; + duk_int_t item_count; + duk_int_t act_start; + duk_int_t del_count; + duk_int_t i, n; + + DUK_UNREF(have_delcount); + + nargs = duk_get_top(thr); + if (nargs < 2) { + duk_set_top(thr, 2); + nargs = 2; + have_delcount = 0; + } else { + have_delcount = 1; + } + + /* XXX: len >= 0x80000000 won't work below because we need to be + * able to represent -len. + */ + len_u32 = duk__push_this_obj_len_u32_limited(thr); + len = (duk_int_t) len_u32; + DUK_ASSERT(len >= 0); + + act_start = duk_to_int_clamped(thr, 0, -len, len); + if (act_start < 0) { + act_start = len + act_start; + } + DUK_ASSERT(act_start >= 0 && act_start <= len); + +#if defined(DUK_USE_NONSTD_ARRAY_SPLICE_DELCOUNT) + if (have_delcount) { +#endif + del_count = duk_to_int_clamped(thr, 1, 0, len - act_start); +#if defined(DUK_USE_NONSTD_ARRAY_SPLICE_DELCOUNT) + } else { + /* E5.1 standard behavior when deleteCount is not given would be + * to treat it just like if 'undefined' was given, which coerces + * ultimately to 0. Real world behavior is to splice to the end + * of array, see test-bi-array-proto-splice-no-delcount.js. + */ + del_count = len - act_start; + } +#endif + + DUK_ASSERT(nargs >= 2); + item_count = (duk_int_t) (nargs - 2); + + DUK_ASSERT(del_count >= 0 && del_count <= len - act_start); + DUK_ASSERT(del_count + act_start <= len); + + /* For now, restrict result array into 32-bit length range. */ + if (((duk_double_t) len) - ((duk_double_t) del_count) + ((duk_double_t) item_count) > (duk_double_t) DUK_UINT32_MAX) { + DUK_D(DUK_DPRINT("Array.prototype.splice() would go beyond 32-bit length, throw")); + DUK_DCERROR_RANGE_INVALID_LENGTH(thr); + } + + duk_push_array(thr); + + /* stack[0] = start + * stack[1] = deleteCount + * stack[2...nargs-1] = items + * stack[nargs] = ToObject(this) -3 + * stack[nargs+1] = ToUint32(length) -2 + * stack[nargs+2] = result array -1 + */ + + DUK_ASSERT_TOP(thr, nargs + 3); + + /* Step 9: copy elements-to-be-deleted into the result array */ + + for (i = 0; i < del_count; i++) { + if (duk_get_prop_index(thr, -3, (duk_uarridx_t) (act_start + i))) { + duk_xdef_prop_index_wec(thr, -2, (duk_uarridx_t) i); /* throw flag irrelevant (false in std alg) */ + } else { + duk_pop_undefined(thr); + } + } + duk_push_u32(thr, (duk_uint32_t) del_count); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_W); + + /* Steps 12 and 13: reorganize elements to make room for itemCount elements */ + + if (item_count < del_count) { + /* [ A B C D E F G H ] rel_index = 2, del_count 3, item count 1 + * -> [ A B F G H ] (conceptual intermediate step) + * -> [ A B . F G H ] (placeholder marked) + * [ A B C F G H ] (actual result at this point, C will be replaced) + */ + + DUK_ASSERT_TOP(thr, nargs + 3); + + n = len - del_count; + for (i = act_start; i < n; i++) { + if (duk_get_prop_index(thr, -3, (duk_uarridx_t) (i + del_count))) { + duk_put_prop_index(thr, -4, (duk_uarridx_t) (i + item_count)); + } else { + duk_pop_undefined(thr); + duk_del_prop_index(thr, -3, (duk_uarridx_t) (i + item_count)); + } + } + + DUK_ASSERT_TOP(thr, nargs + 3); + + /* loop iterator init and limit changed from standard algorithm */ + n = len - del_count + item_count; + for (i = len - 1; i >= n; i--) { + duk_del_prop_index(thr, -3, (duk_uarridx_t) i); + } + + DUK_ASSERT_TOP(thr, nargs + 3); + } else if (item_count > del_count) { + /* [ A B C D E F G H ] rel_index = 2, del_count 3, item count 4 + * -> [ A B F G H ] (conceptual intermediate step) + * -> [ A B . . . . F G H ] (placeholder marked) + * [ A B C D E F F G H ] (actual result at this point) + */ + + DUK_ASSERT_TOP(thr, nargs + 3); + + /* loop iterator init and limit changed from standard algorithm */ + for (i = len - del_count - 1; i >= act_start; i--) { + if (duk_get_prop_index(thr, -3, (duk_uarridx_t) (i + del_count))) { + duk_put_prop_index(thr, -4, (duk_uarridx_t) (i + item_count)); + } else { + duk_pop_undefined(thr); + duk_del_prop_index(thr, -3, (duk_uarridx_t) (i + item_count)); + } + } + + DUK_ASSERT_TOP(thr, nargs + 3); + } else { + /* [ A B C D E F G H ] rel_index = 2, del_count 3, item count 3 + * -> [ A B F G H ] (conceptual intermediate step) + * -> [ A B . . . F G H ] (placeholder marked) + * [ A B C D E F G H ] (actual result at this point) + */ + } + DUK_ASSERT_TOP(thr, nargs + 3); + + /* Step 15: insert itemCount elements into the hole made above */ + + for (i = 0; i < item_count; i++) { + duk_dup(thr, i + 2); /* args start at index 2 */ + duk_put_prop_index(thr, -4, (duk_uarridx_t) (act_start + i)); + } + + /* Step 16: update length; note that the final length may be above 32 bit range + * (but we checked above that this isn't the case here) + */ + + duk_push_u32(thr, (duk_uint32_t) (len - del_count + item_count)); + duk_put_prop_stridx_short(thr, -4, DUK_STRIDX_LENGTH); + + /* result array is already at the top of stack */ + DUK_ASSERT_TOP(thr, nargs + 3); + return 1; +} + +/* + * reverse() + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_reverse(duk_hthread *thr) { + duk_uint32_t len; + duk_uint32_t middle; + duk_uint32_t lower, upper; + duk_bool_t have_lower, have_upper; + + len = duk__push_this_obj_len_u32(thr); + middle = len / 2; + + /* If len <= 1, middle will be 0 and for-loop bails out + * immediately (0 < 0 -> false). + */ + + for (lower = 0; lower < middle; lower++) { + DUK_ASSERT(len >= 2); + DUK_ASSERT_TOP(thr, 2); + + DUK_ASSERT(len >= lower + 1); + upper = len - lower - 1; + + have_lower = duk_get_prop_index(thr, -2, (duk_uarridx_t) lower); + have_upper = duk_get_prop_index(thr, -3, (duk_uarridx_t) upper); + + /* [ ToObject(this) ToUint32(length) lowerValue upperValue ] */ + + if (have_upper) { + duk_put_prop_index(thr, -4, (duk_uarridx_t) lower); + } else { + duk_del_prop_index(thr, -4, (duk_uarridx_t) lower); + duk_pop_undefined(thr); + } + + if (have_lower) { + duk_put_prop_index(thr, -3, (duk_uarridx_t) upper); + } else { + duk_del_prop_index(thr, -3, (duk_uarridx_t) upper); + duk_pop_undefined(thr); + } + + DUK_ASSERT_TOP(thr, 2); + } + + DUK_ASSERT_TOP(thr, 2); + duk_pop_unsafe(thr); /* -> [ ToObject(this) ] */ + return 1; +} + +/* + * slice() + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_slice(duk_hthread *thr) { + duk_uint32_t len_u32; + duk_int_t len; + duk_int_t start, end; + duk_int_t i; + duk_uarridx_t idx; + duk_uint32_t res_length = 0; + + /* XXX: len >= 0x80000000 won't work below because we need to be + * able to represent -len. + */ + len_u32 = duk__push_this_obj_len_u32_limited(thr); + len = (duk_int_t) len_u32; + DUK_ASSERT(len >= 0); + + duk_push_array(thr); + + /* stack[0] = start + * stack[1] = end + * stack[2] = ToObject(this) + * stack[3] = ToUint32(length) + * stack[4] = result array + */ + + start = duk_to_int_clamped(thr, 0, -len, len); + if (start < 0) { + start = len + start; + } + /* XXX: could duk_is_undefined() provide defaulting undefined to 'len' + * (the upper limit)? + */ + if (duk_is_undefined(thr, 1)) { + end = len; + } else { + end = duk_to_int_clamped(thr, 1, -len, len); + if (end < 0) { + end = len + end; + } + } + DUK_ASSERT(start >= 0 && start <= len); + DUK_ASSERT(end >= 0 && end <= len); + + idx = 0; + for (i = start; i < end; i++) { + DUK_ASSERT_TOP(thr, 5); + if (duk_get_prop_index(thr, 2, (duk_uarridx_t) i)) { + duk_xdef_prop_index_wec(thr, 4, idx); + res_length = idx + 1; + } else { + duk_pop_undefined(thr); + } + idx++; + DUK_ASSERT_TOP(thr, 5); + } + + duk_push_u32(thr, res_length); + duk_xdef_prop_stridx_short(thr, 4, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_W); + + DUK_ASSERT_TOP(thr, 5); + return 1; +} + +/* + * shift() + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_shift(duk_hthread *thr) { + duk_uint32_t len; + duk_uint32_t i; + + len = duk__push_this_obj_len_u32(thr); + if (len == 0) { + duk_push_int(thr, 0); + duk_put_prop_stridx_short(thr, 0, DUK_STRIDX_LENGTH); + return 0; + } + + duk_get_prop_index(thr, 0, 0); + + /* stack[0] = object (this) + * stack[1] = ToUint32(length) + * stack[2] = elem at index 0 (retval) + */ + + for (i = 1; i < len; i++) { + DUK_ASSERT_TOP(thr, 3); + if (duk_get_prop_index(thr, 0, (duk_uarridx_t) i)) { + /* fromPresent = true */ + duk_put_prop_index(thr, 0, (duk_uarridx_t) (i - 1)); + } else { + /* fromPresent = false */ + duk_del_prop_index(thr, 0, (duk_uarridx_t) (i - 1)); + duk_pop_undefined(thr); + } + } + duk_del_prop_index(thr, 0, (duk_uarridx_t) (len - 1)); + + duk_push_u32(thr, (duk_uint32_t) (len - 1)); + duk_put_prop_stridx_short(thr, 0, DUK_STRIDX_LENGTH); + + DUK_ASSERT_TOP(thr, 3); + return 1; +} + +/* + * unshift() + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_unshift(duk_hthread *thr) { + duk_idx_t nargs; + duk_uint32_t len; + duk_uint32_t i; + + nargs = duk_get_top(thr); + len = duk__push_this_obj_len_u32(thr); + + /* stack[0...nargs-1] = unshift args (vararg) + * stack[nargs] = ToObject(this) + * stack[nargs+1] = ToUint32(length) + */ + + DUK_ASSERT_TOP(thr, nargs + 2); + + /* Note: unshift() may operate on indices above unsigned 32-bit range + * and the final length may be >= 2**32. However, we restrict the + * final result to 32-bit range for practicality. + */ + + if (len + (duk_uint32_t) nargs < len) { + DUK_D(DUK_DPRINT("Array.prototype.unshift() would go beyond 32-bit length, throw")); + DUK_DCERROR_RANGE_INVALID_LENGTH(thr); + } + + i = len; + while (i > 0) { + DUK_ASSERT_TOP(thr, nargs + 2); + i--; + /* k+argCount-1; note that may be above 32-bit range */ + + if (duk_get_prop_index(thr, -2, (duk_uarridx_t) i)) { + /* fromPresent = true */ + /* [ ... ToObject(this) ToUint32(length) val ] */ + duk_put_prop_index( + thr, + -3, + (duk_uarridx_t) (i + (duk_uint32_t) nargs)); /* -> [ ... ToObject(this) ToUint32(length) ] */ + } else { + /* fromPresent = false */ + /* [ ... ToObject(this) ToUint32(length) val ] */ + duk_pop_undefined(thr); + duk_del_prop_index( + thr, + -2, + (duk_uarridx_t) (i + (duk_uint32_t) nargs)); /* -> [ ... ToObject(this) ToUint32(length) ] */ + } + DUK_ASSERT_TOP(thr, nargs + 2); + } + + for (i = 0; i < (duk_uint32_t) nargs; i++) { + DUK_ASSERT_TOP(thr, nargs + 2); + duk_dup(thr, (duk_idx_t) i); /* -> [ ... ToObject(this) ToUint32(length) arg[i] ] */ + duk_put_prop_index(thr, -3, (duk_uarridx_t) i); + DUK_ASSERT_TOP(thr, nargs + 2); + } + + DUK_ASSERT_TOP(thr, nargs + 2); + duk_push_u32(thr, len + (duk_uint32_t) nargs); + duk_dup_top(thr); /* -> [ ... ToObject(this) ToUint32(length) final_len final_len ] */ + duk_put_prop_stridx_short(thr, -4, DUK_STRIDX_LENGTH); + return 1; +} + +/* + * indexOf(), lastIndexOf() + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_indexof_shared(duk_hthread *thr) { + duk_idx_t nargs; + duk_int_t i, len; + duk_int_t from_idx; + duk_small_int_t idx_step = duk_get_current_magic(thr); /* idx_step is +1 for indexOf, -1 for lastIndexOf */ + + /* lastIndexOf() needs to be a vararg function because we must distinguish + * between an undefined fromIndex and a "not given" fromIndex; indexOf() is + * made vararg for symmetry although it doesn't strictly need to be. + */ + + nargs = duk_get_top(thr); + duk_set_top(thr, 2); + + /* XXX: must be able to represent -len */ + len = (duk_int_t) duk__push_this_obj_len_u32_limited(thr); + if (len == 0) { + goto not_found; + } + + /* Index clamping is a bit tricky, we must ensure that we'll only iterate + * through elements that exist and that the specific requirements from E5.1 + * Sections 15.4.4.14 and 15.4.4.15 are fulfilled; especially: + * + * - indexOf: clamp to [-len,len], negative handling -> [0,len], + * if clamped result is len, for-loop bails out immediately + * + * - lastIndexOf: clamp to [-len-1, len-1], negative handling -> [-1, len-1], + * if clamped result is -1, for-loop bails out immediately + * + * If fromIndex is not given, ToInteger(undefined) = 0, which is correct + * for indexOf() but incorrect for lastIndexOf(). Hence special handling, + * and why lastIndexOf() needs to be a vararg function. + */ + + if (nargs >= 2) { + /* indexOf: clamp fromIndex to [-len, len] + * (if fromIndex == len, for-loop terminates directly) + * + * lastIndexOf: clamp fromIndex to [-len - 1, len - 1] + * (if clamped to -len-1 -> fromIndex becomes -1, terminates for-loop directly) + */ + from_idx = duk_to_int_clamped(thr, 1, (idx_step > 0 ? -len : -len - 1), (idx_step > 0 ? len : len - 1)); + if (from_idx < 0) { + /* for lastIndexOf, result may be -1 (mark immediate termination) */ + from_idx = len + from_idx; + } + } else { + /* for indexOf, ToInteger(undefined) would be 0, i.e. correct, but + * handle both indexOf and lastIndexOf specially here. + */ + if (idx_step > 0) { + from_idx = 0; + } else { + from_idx = len - 1; + } + } + + /* stack[0] = searchElement + * stack[1] = fromIndex + * stack[2] = object + * stack[3] = length (not needed, but not popped above) + */ + + for (i = from_idx; i >= 0 && i < len; i += idx_step) { + DUK_ASSERT_TOP(thr, 4); + + if (duk_get_prop_index(thr, 2, (duk_uarridx_t) i)) { + DUK_ASSERT_TOP(thr, 5); + if (duk_strict_equals(thr, 0, 4)) { + duk_push_int(thr, i); + return 1; + } + } + + duk_pop_unsafe(thr); + } + +not_found: + duk_push_int(thr, -1); + return 1; +} + +/* + * every(), some(), forEach(), map(), filter() + */ + +#define DUK__ITER_EVERY 0 +#define DUK__ITER_SOME 1 +#define DUK__ITER_FOREACH 2 +#define DUK__ITER_MAP 3 +#define DUK__ITER_FILTER 4 + +/* XXX: This helper is a bit awkward because the handling for the different iteration + * callers is quite different. This now compiles to a bit less than 500 bytes, so with + * 5 callers the net result is about 100 bytes / caller. + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_iter_shared(duk_hthread *thr) { + duk_uint32_t len; + duk_uint32_t i; + duk_uarridx_t k; + duk_bool_t bval; + duk_small_int_t iter_type = duk_get_current_magic(thr); + duk_uint32_t res_length = 0; + + /* each call this helper serves has nargs==2 */ + DUK_ASSERT_TOP(thr, 2); + + len = duk__push_this_obj_len_u32(thr); + duk_require_callable(thr, 0); + /* if thisArg not supplied, behave as if undefined was supplied */ + + if (iter_type == DUK__ITER_MAP || iter_type == DUK__ITER_FILTER) { + duk_push_array(thr); + } else { + duk_push_undefined(thr); + } + + /* stack[0] = callback + * stack[1] = thisArg + * stack[2] = object + * stack[3] = ToUint32(length) (unused, but avoid unnecessary pop) + * stack[4] = result array (or undefined) + */ + + k = 0; /* result index for filter() */ + for (i = 0; i < len; i++) { + DUK_ASSERT_TOP(thr, 5); + + if (!duk_get_prop_index(thr, 2, (duk_uarridx_t) i)) { + /* For 'map' trailing missing elements don't invoke the + * callback but count towards the result length. + */ + if (iter_type == DUK__ITER_MAP) { + res_length = i + 1; + } + duk_pop_undefined(thr); + continue; + } + + /* The original value needs to be preserved for filter(), hence + * this funny order. We can't re-get the value because of side + * effects. + */ + + duk_dup_0(thr); + duk_dup_1(thr); + duk_dup_m3(thr); + duk_push_u32(thr, i); + duk_dup_2(thr); /* [ ... val callback thisArg val i obj ] */ + duk_call_method(thr, 3); /* -> [ ... val retval ] */ + + switch (iter_type) { + case DUK__ITER_EVERY: + bval = duk_to_boolean(thr, -1); + if (!bval) { + /* stack top contains 'false' */ + return 1; + } + break; + case DUK__ITER_SOME: + bval = duk_to_boolean(thr, -1); + if (bval) { + /* stack top contains 'true' */ + return 1; + } + break; + case DUK__ITER_FOREACH: + /* nop */ + break; + case DUK__ITER_MAP: + duk_dup_top(thr); + duk_xdef_prop_index_wec(thr, 4, (duk_uarridx_t) i); /* retval to result[i] */ + res_length = i + 1; + break; + case DUK__ITER_FILTER: + bval = duk_to_boolean(thr, -1); + if (bval) { + duk_dup_m2(thr); /* orig value */ + duk_xdef_prop_index_wec(thr, 4, (duk_uarridx_t) k); + k++; + res_length = k; + } + break; + default: + DUK_UNREACHABLE(); + break; + } + duk_pop_2_unsafe(thr); + + DUK_ASSERT_TOP(thr, 5); + } + + switch (iter_type) { + case DUK__ITER_EVERY: + duk_push_true(thr); + break; + case DUK__ITER_SOME: + duk_push_false(thr); + break; + case DUK__ITER_FOREACH: + duk_push_undefined(thr); + break; + case DUK__ITER_MAP: + case DUK__ITER_FILTER: + DUK_ASSERT_TOP(thr, 5); + DUK_ASSERT(duk_is_array(thr, -1)); /* topmost element is the result array already */ + duk_push_u32(thr, res_length); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_W); + break; + default: + DUK_UNREACHABLE(); + break; + } + + return 1; +} + +/* + * reduce(), reduceRight() + */ + +DUK_INTERNAL duk_ret_t duk_bi_array_prototype_reduce_shared(duk_hthread *thr) { + duk_idx_t nargs; + duk_bool_t have_acc; + duk_uint32_t i, len; + duk_small_int_t idx_step = duk_get_current_magic(thr); /* idx_step is +1 for reduce, -1 for reduceRight */ + + /* We're a varargs function because we need to detect whether + * initialValue was given or not. + */ + nargs = duk_get_top(thr); + DUK_DDD(DUK_DDDPRINT("nargs=%ld", (long) nargs)); + + duk_set_top(thr, 2); + len = duk__push_this_obj_len_u32(thr); + duk_require_callable(thr, 0); + + /* stack[0] = callback fn + * stack[1] = initialValue + * stack[2] = object (coerced this) + * stack[3] = length (not needed, but not popped above) + * stack[4] = accumulator + */ + + have_acc = 0; + if (nargs >= 2) { + duk_dup_1(thr); + have_acc = 1; + } + DUK_DDD(DUK_DDDPRINT("have_acc=%ld, acc=%!T", (long) have_acc, (duk_tval *) duk_get_tval(thr, 3))); + + /* For len == 0, i is initialized to len - 1 which underflows. + * The condition (i < len) will then exit the for-loop on the + * first round which is correct. Similarly, loop termination + * happens by i underflowing. + */ + + for (i = (idx_step >= 0 ? 0 : len - 1); i < len; /* i >= 0 would always be true */ + i += (duk_uint32_t) idx_step) { + DUK_DDD(DUK_DDDPRINT("i=%ld, len=%ld, have_acc=%ld, top=%ld, acc=%!T", + (long) i, + (long) len, + (long) have_acc, + (long) duk_get_top(thr), + (duk_tval *) duk_get_tval(thr, 4))); + + DUK_ASSERT((have_acc && duk_get_top(thr) == 5) || (!have_acc && duk_get_top(thr) == 4)); + + if (!duk_has_prop_index(thr, 2, (duk_uarridx_t) i)) { + continue; + } + + if (!have_acc) { + DUK_ASSERT_TOP(thr, 4); + duk_get_prop_index(thr, 2, (duk_uarridx_t) i); + have_acc = 1; + DUK_ASSERT_TOP(thr, 5); + } else { + DUK_ASSERT_TOP(thr, 5); + duk_dup_0(thr); + duk_dup(thr, 4); + duk_get_prop_index(thr, 2, (duk_uarridx_t) i); + duk_push_u32(thr, i); + duk_dup_2(thr); + DUK_DDD(DUK_DDDPRINT("calling reduce function: func=%!T, prev=%!T, curr=%!T, idx=%!T, obj=%!T", + (duk_tval *) duk_get_tval(thr, -5), + (duk_tval *) duk_get_tval(thr, -4), + (duk_tval *) duk_get_tval(thr, -3), + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + duk_call(thr, 4); + DUK_DDD(DUK_DDDPRINT("-> result: %!T", (duk_tval *) duk_get_tval(thr, -1))); + duk_replace(thr, 4); + DUK_ASSERT_TOP(thr, 5); + } + } + + if (!have_acc) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + + DUK_ASSERT_TOP(thr, 5); + return 1; +} + +#endif /* DUK_USE_ARRAY_BUILTIN */ + +/* automatic undefs */ +#undef DUK__ARRAY_MID_JOIN_LIMIT +#undef DUK__ITER_EVERY +#undef DUK__ITER_FILTER +#undef DUK__ITER_FOREACH +#undef DUK__ITER_MAP +#undef DUK__ITER_SOME +#line 1 "duk_bi_boolean.c" +/* + * Boolean built-ins + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_BOOLEAN_BUILTIN) + +/* Shared helper to provide toString() and valueOf(). Checks 'this', gets + * the primitive value to stack top, and optionally coerces with ToString(). + */ +DUK_INTERNAL duk_ret_t duk_bi_boolean_prototype_tostring_shared(duk_hthread *thr) { + duk_tval *tv; + duk_hobject *h; + duk_small_int_t coerce_tostring = duk_get_current_magic(thr); + + /* XXX: there is room to use a shared helper here, many built-ins + * check the 'this' type, and if it's an object, check its class, + * then get its internal value, etc. + */ + + duk_push_this(thr); + tv = duk_get_tval(thr, -1); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_IS_BOOLEAN(tv)) { + goto type_ok; + } else if (DUK_TVAL_IS_OBJECT(tv)) { + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + + if (DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_BOOLEAN) { + duk_xget_owndataprop_stridx_short(thr, -1, DUK_STRIDX_INT_VALUE); + DUK_ASSERT(duk_is_boolean(thr, -1)); + goto type_ok; + } + } + + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + /* never here */ + +type_ok: + if (coerce_tostring) { + duk_to_string(thr, -1); + } + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_boolean_constructor(duk_hthread *thr) { + duk_hobject *h_this; + + duk_to_boolean(thr, 0); + + if (duk_is_constructor_call(thr)) { + /* XXX: helper; rely on Boolean.prototype as being non-writable, non-configurable */ + duk_push_this(thr); + h_this = duk_known_hobject(thr, -1); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h_this) == thr->builtins[DUK_BIDX_BOOLEAN_PROTOTYPE]); + + DUK_HOBJECT_SET_CLASS_NUMBER(h_this, DUK_HOBJECT_CLASS_BOOLEAN); + + duk_dup_0(thr); /* -> [ val obj val ] */ + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_VALUE, DUK_PROPDESC_FLAGS_NONE); /* XXX: proper flags? */ + } /* unbalanced stack */ + + return 1; +} + +#endif /* DUK_USE_BOOLEAN_BUILTIN */ +#line 1 "duk_bi_buffer.c" +/* + * ES2015 TypedArray and Node.js Buffer built-ins + */ + +/* #include duk_internal.h -> already included */ + +/* + * Helpers for buffer handling, enabled with DUK_USE_BUFFEROBJECT_SUPPORT. + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +/* Map class number (minus DUK_HOBJECT_CLASS_BUFOBJ_MIN) to a bidx for the + * default internal prototype. + */ +static const duk_uint8_t duk__buffer_proto_from_classnum[] = { + DUK_BIDX_ARRAYBUFFER_PROTOTYPE, DUK_BIDX_DATAVIEW_PROTOTYPE, DUK_BIDX_INT8ARRAY_PROTOTYPE, + DUK_BIDX_UINT8ARRAY_PROTOTYPE, DUK_BIDX_UINT8CLAMPEDARRAY_PROTOTYPE, DUK_BIDX_INT16ARRAY_PROTOTYPE, + DUK_BIDX_UINT16ARRAY_PROTOTYPE, DUK_BIDX_INT32ARRAY_PROTOTYPE, DUK_BIDX_UINT32ARRAY_PROTOTYPE, + DUK_BIDX_FLOAT32ARRAY_PROTOTYPE, DUK_BIDX_FLOAT64ARRAY_PROTOTYPE +}; + +/* Map DUK_HBUFOBJ_ELEM_xxx to duk_hobject class number. + * Sync with duk_hbufobj.h and duk_hobject.h. + */ +static const duk_uint8_t duk__buffer_class_from_elemtype[9] = { DUK_HOBJECT_CLASS_UINT8ARRAY, DUK_HOBJECT_CLASS_UINT8CLAMPEDARRAY, + DUK_HOBJECT_CLASS_INT8ARRAY, DUK_HOBJECT_CLASS_UINT16ARRAY, + DUK_HOBJECT_CLASS_INT16ARRAY, DUK_HOBJECT_CLASS_UINT32ARRAY, + DUK_HOBJECT_CLASS_INT32ARRAY, DUK_HOBJECT_CLASS_FLOAT32ARRAY, + DUK_HOBJECT_CLASS_FLOAT64ARRAY }; + +/* Map DUK_HBUFOBJ_ELEM_xxx to prototype object built-in index. + * Sync with duk_hbufobj.h. + */ +static const duk_uint8_t duk__buffer_proto_from_elemtype[9] = { + DUK_BIDX_UINT8ARRAY_PROTOTYPE, DUK_BIDX_UINT8CLAMPEDARRAY_PROTOTYPE, DUK_BIDX_INT8ARRAY_PROTOTYPE, + DUK_BIDX_UINT16ARRAY_PROTOTYPE, DUK_BIDX_INT16ARRAY_PROTOTYPE, DUK_BIDX_UINT32ARRAY_PROTOTYPE, + DUK_BIDX_INT32ARRAY_PROTOTYPE, DUK_BIDX_FLOAT32ARRAY_PROTOTYPE, DUK_BIDX_FLOAT64ARRAY_PROTOTYPE +}; + +/* Map DUK__FLD_xxx to byte size. */ +static const duk_uint8_t duk__buffer_nbytes_from_fldtype[6] = { + 1, /* DUK__FLD_8BIT */ + 2, /* DUK__FLD_16BIT */ + 4, /* DUK__FLD_32BIT */ + 4, /* DUK__FLD_FLOAT */ + 8, /* DUK__FLD_DOUBLE */ + 0 /* DUK__FLD_VARINT; not relevant here */ +}; + +/* Bitfield for each DUK_HBUFOBJ_ELEM_xxx indicating which element types + * are compatible with a blind byte copy for the TypedArray set() method (also + * used for TypedArray constructor). Array index is target buffer elem type, + * bitfield indicates compatible source types. The types must have same byte + * size and they must be coercion compatible. + */ +#if !defined(DUK_USE_PREFER_SIZE) +static duk_uint16_t duk__buffer_elemtype_copy_compatible[9] = { + /* xxx -> DUK_HBUFOBJ_ELEM_UINT8 */ + (1U << DUK_HBUFOBJ_ELEM_UINT8) | (1U << DUK_HBUFOBJ_ELEM_UINT8CLAMPED) | (1U << DUK_HBUFOBJ_ELEM_INT8), + + /* xxx -> DUK_HBUFOBJ_ELEM_UINT8CLAMPED + * Note: INT8 is -not- copy compatible, e.g. -1 would coerce to 0x00. + */ + (1U << DUK_HBUFOBJ_ELEM_UINT8) | (1U << DUK_HBUFOBJ_ELEM_UINT8CLAMPED), + + /* xxx -> DUK_HBUFOBJ_ELEM_INT8 */ + (1U << DUK_HBUFOBJ_ELEM_UINT8) | (1U << DUK_HBUFOBJ_ELEM_UINT8CLAMPED) | (1U << DUK_HBUFOBJ_ELEM_INT8), + + /* xxx -> DUK_HBUFOBJ_ELEM_UINT16 */ + (1U << DUK_HBUFOBJ_ELEM_UINT16) | (1U << DUK_HBUFOBJ_ELEM_INT16), + + /* xxx -> DUK_HBUFOBJ_ELEM_INT16 */ + (1U << DUK_HBUFOBJ_ELEM_UINT16) | (1U << DUK_HBUFOBJ_ELEM_INT16), + + /* xxx -> DUK_HBUFOBJ_ELEM_UINT32 */ + (1U << DUK_HBUFOBJ_ELEM_UINT32) | (1U << DUK_HBUFOBJ_ELEM_INT32), + + /* xxx -> DUK_HBUFOBJ_ELEM_INT32 */ + (1U << DUK_HBUFOBJ_ELEM_UINT32) | (1U << DUK_HBUFOBJ_ELEM_INT32), + + /* xxx -> DUK_HBUFOBJ_ELEM_FLOAT32 */ + (1U << DUK_HBUFOBJ_ELEM_FLOAT32), + + /* xxx -> DUK_HBUFOBJ_ELEM_FLOAT64 */ + (1U << DUK_HBUFOBJ_ELEM_FLOAT64) +}; +#endif /* !DUK_USE_PREFER_SIZE */ + +DUK_LOCAL duk_hbufobj *duk__hbufobj_promote_this(duk_hthread *thr) { + duk_tval *tv_dst; + duk_hbufobj *res; + + duk_push_this(thr); + DUK_ASSERT(duk_is_buffer(thr, -1)); + res = (duk_hbufobj *) duk_to_hobject(thr, -1); + DUK_HBUFOBJ_ASSERT_VALID(res); + DUK_DD(DUK_DDPRINT("promoted 'this' automatically to an ArrayBuffer: %!iT", duk_get_tval(thr, -1))); + + tv_dst = duk_get_borrowed_this_tval(thr); + DUK_TVAL_SET_OBJECT_UPDREF(thr, tv_dst, (duk_hobject *) res); + duk_pop(thr); + + return res; +} + +#define DUK__BUFOBJ_FLAG_THROW (1 << 0) +#define DUK__BUFOBJ_FLAG_PROMOTE (1 << 1) + +/* Shared helper. When DUK__BUFOBJ_FLAG_PROMOTE is given, the return value is + * always a duk_hbufobj *. Without the flag the return value can also be a + * plain buffer, and the caller must check for it using DUK_HEAPHDR_IS_BUFFER(). + */ +DUK_LOCAL duk_heaphdr *duk__getrequire_bufobj_this(duk_hthread *thr, duk_small_uint_t flags) { + duk_tval *tv; + duk_hbufobj *h_this; + + DUK_ASSERT(thr != NULL); + + tv = duk_get_borrowed_this_tval(thr); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_IS_OBJECT(tv)) { + h_this = (duk_hbufobj *) DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h_this != NULL); + if (DUK_HOBJECT_IS_BUFOBJ((duk_hobject *) h_this)) { + DUK_HBUFOBJ_ASSERT_VALID(h_this); + return (duk_heaphdr *) h_this; + } + } else if (DUK_TVAL_IS_BUFFER(tv)) { + if (flags & DUK__BUFOBJ_FLAG_PROMOTE) { + /* Promote a plain buffer to a Uint8Array. This is very + * inefficient but allows plain buffer to be used wherever an + * Uint8Array is used with very small cost; hot path functions + * like index read/write calls should provide direct buffer + * support to avoid promotion. + */ + /* XXX: make this conditional to a flag if call sites need it? */ + h_this = duk__hbufobj_promote_this(thr); + DUK_ASSERT(h_this != NULL); + DUK_HBUFOBJ_ASSERT_VALID(h_this); + return (duk_heaphdr *) h_this; + } else { + /* XXX: ugly, share return pointer for duk_hbuffer. */ + return (duk_heaphdr *) DUK_TVAL_GET_BUFFER(tv); + } + } + + if (flags & DUK__BUFOBJ_FLAG_THROW) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_BUFFER); + DUK_WO_NORETURN(return NULL;); + } + return NULL; +} + +/* Check that 'this' is a duk_hbufobj and return a pointer to it. */ +DUK_LOCAL duk_hbufobj *duk__get_bufobj_this(duk_hthread *thr) { + return (duk_hbufobj *) duk__getrequire_bufobj_this(thr, DUK__BUFOBJ_FLAG_PROMOTE); +} + +/* Check that 'this' is a duk_hbufobj and return a pointer to it + * (NULL if not). + */ +DUK_LOCAL duk_hbufobj *duk__require_bufobj_this(duk_hthread *thr) { + return (duk_hbufobj *) duk__getrequire_bufobj_this(thr, DUK__BUFOBJ_FLAG_THROW | DUK__BUFOBJ_FLAG_PROMOTE); +} + +/* Check that value is a duk_hbufobj and return a pointer to it. */ +DUK_LOCAL duk_hbufobj *duk__require_bufobj_value(duk_hthread *thr, duk_idx_t idx) { + duk_tval *tv; + duk_hbufobj *h_obj; + + /* Don't accept relative indices now. */ + DUK_ASSERT(idx >= 0); + + tv = duk_require_tval(thr, idx); + DUK_ASSERT(tv != NULL); + if (DUK_TVAL_IS_OBJECT(tv)) { + h_obj = (duk_hbufobj *) DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h_obj != NULL); + if (DUK_HOBJECT_IS_BUFOBJ((duk_hobject *) h_obj)) { + DUK_HBUFOBJ_ASSERT_VALID(h_obj); + return h_obj; + } + } else if (DUK_TVAL_IS_BUFFER(tv)) { + h_obj = (duk_hbufobj *) duk_to_hobject(thr, idx); + DUK_ASSERT(h_obj != NULL); + DUK_HBUFOBJ_ASSERT_VALID(h_obj); + return h_obj; + } + + DUK_ERROR_TYPE(thr, DUK_STR_NOT_BUFFER); + DUK_WO_NORETURN(return NULL;); +} + +DUK_LOCAL void duk__set_bufobj_buffer(duk_hthread *thr, duk_hbufobj *h_bufobj, duk_hbuffer *h_val) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(h_bufobj != NULL); + DUK_ASSERT(h_bufobj->buf == NULL); /* no need to decref */ + DUK_ASSERT(h_val != NULL); + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + DUK_UNREF(thr); + + h_bufobj->buf = h_val; + DUK_HBUFFER_INCREF(thr, h_val); + h_bufobj->length = (duk_uint_t) DUK_HBUFFER_GET_SIZE(h_val); + DUK_ASSERT(h_bufobj->shift == 0); + DUK_ASSERT(h_bufobj->elem_type == DUK_HBUFOBJ_ELEM_UINT8); + DUK_ASSERT(h_bufobj->is_typedarray == 0); + + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); +} + +/* Shared offset/length coercion helper. */ +DUK_LOCAL void duk__resolve_offset_opt_length(duk_hthread *thr, + duk_hbufobj *h_bufarg, + duk_idx_t idx_offset, + duk_idx_t idx_length, + duk_uint_t *out_offset, + duk_uint_t *out_length, + duk_bool_t throw_flag) { + duk_int_t offset_signed; + duk_int_t length_signed; + duk_uint_t offset; + duk_uint_t length; + + offset_signed = duk_to_int(thr, idx_offset); + if (offset_signed < 0) { + goto fail_range; + } + offset = (duk_uint_t) offset_signed; + if (offset > h_bufarg->length) { + goto fail_range; + } + DUK_ASSERT_DISABLE(offset >= 0); /* unsigned */ + DUK_ASSERT(offset <= h_bufarg->length); + + if (duk_is_undefined(thr, idx_length)) { + DUK_ASSERT(h_bufarg->length >= offset); + length = h_bufarg->length - offset; /* >= 0 */ + } else { + length_signed = duk_to_int(thr, idx_length); + if (length_signed < 0) { + goto fail_range; + } + length = (duk_uint_t) length_signed; + DUK_ASSERT(h_bufarg->length >= offset); + if (length > h_bufarg->length - offset) { + /* Unlike for negative arguments, some call sites + * want length to be clamped if it's positive. + */ + if (throw_flag) { + goto fail_range; + } else { + length = h_bufarg->length - offset; + } + } + } + DUK_ASSERT_DISABLE(length >= 0); /* unsigned */ + DUK_ASSERT(offset + length <= h_bufarg->length); + + *out_offset = offset; + *out_length = length; + return; + +fail_range: + DUK_ERROR_RANGE(thr, DUK_STR_INVALID_ARGS); + DUK_WO_NORETURN(return;); +} + +/* Shared lenient buffer length clamping helper. No negative indices, no + * element/byte shifting. + */ +DUK_LOCAL void duk__clamp_startend_nonegidx_noshift(duk_hthread *thr, + duk_int_t buffer_length, + duk_idx_t idx_start, + duk_idx_t idx_end, + duk_int_t *out_start_offset, + duk_int_t *out_end_offset) { + duk_int_t start_offset; + duk_int_t end_offset; + + DUK_ASSERT(out_start_offset != NULL); + DUK_ASSERT(out_end_offset != NULL); + + /* undefined coerces to zero which is correct */ + start_offset = duk_to_int_clamped(thr, idx_start, 0, buffer_length); + if (duk_is_undefined(thr, idx_end)) { + end_offset = buffer_length; + } else { + end_offset = duk_to_int_clamped(thr, idx_end, start_offset, buffer_length); + } + + DUK_ASSERT(start_offset >= 0); + DUK_ASSERT(start_offset <= buffer_length); + DUK_ASSERT(end_offset >= 0); + DUK_ASSERT(end_offset <= buffer_length); + DUK_ASSERT(start_offset <= end_offset); + + *out_start_offset = start_offset; + *out_end_offset = end_offset; +} + +/* Shared lenient buffer length clamping helper. Indices are treated as + * element indices (though output values are byte offsets) which only + * really matters for TypedArray views as other buffer object have a zero + * shift. Negative indices are counted from end of input slice; crossed + * indices are clamped to zero length; and final indices are clamped + * against input slice. Used for e.g. ArrayBuffer slice(). + */ +DUK_LOCAL void duk__clamp_startend_negidx_shifted(duk_hthread *thr, + duk_int_t buffer_length, + duk_uint8_t buffer_shift, + duk_idx_t idx_start, + duk_idx_t idx_end, + duk_int_t *out_start_offset, + duk_int_t *out_end_offset) { + duk_int_t start_offset; + duk_int_t end_offset; + + DUK_ASSERT(out_start_offset != NULL); + DUK_ASSERT(out_end_offset != NULL); + + buffer_length >>= buffer_shift; /* as (full) elements */ + + /* Resolve start/end offset as element indices first; arguments + * at idx_start/idx_end are element offsets. Working with element + * indices first also avoids potential for wrapping. + */ + + start_offset = duk_to_int(thr, idx_start); + if (start_offset < 0) { + start_offset = buffer_length + start_offset; + } + if (duk_is_undefined(thr, idx_end)) { + end_offset = buffer_length; + } else { + end_offset = duk_to_int(thr, idx_end); + if (end_offset < 0) { + end_offset = buffer_length + end_offset; + } + } + /* Note: start_offset/end_offset can still be < 0 here. */ + + if (start_offset < 0) { + start_offset = 0; + } else if (start_offset > buffer_length) { + start_offset = buffer_length; + } + if (end_offset < start_offset) { + end_offset = start_offset; + } else if (end_offset > buffer_length) { + end_offset = buffer_length; + } + DUK_ASSERT(start_offset >= 0); + DUK_ASSERT(start_offset <= buffer_length); + DUK_ASSERT(end_offset >= 0); + DUK_ASSERT(end_offset <= buffer_length); + DUK_ASSERT(start_offset <= end_offset); + + /* Convert indices to byte offsets. */ + start_offset <<= buffer_shift; + end_offset <<= buffer_shift; + + *out_start_offset = start_offset; + *out_end_offset = end_offset; +} + +DUK_INTERNAL void duk_hbufobj_promote_plain(duk_hthread *thr, duk_idx_t idx) { + if (duk_is_buffer(thr, idx)) { + duk_to_object(thr, idx); + } +} + +DUK_INTERNAL void duk_hbufobj_push_uint8array_from_plain(duk_hthread *thr, duk_hbuffer *h_buf) { + /* Push Uint8Array which will share the same underlying buffer as + * the plain buffer argument. Also create an ArrayBuffer with the + * same backing for the result .buffer property. + */ + + duk_push_hbuffer(thr, h_buf); + duk_push_buffer_object(thr, -1, 0, (duk_size_t) DUK_HBUFFER_GET_SIZE(h_buf), DUK_BUFOBJ_UINT8ARRAY); + duk_remove_m2(thr); + +#if 0 + /* More verbose equivalent; maybe useful if e.g. .buffer is omitted. */ + h_bufobj = duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | + DUK_HOBJECT_FLAG_BUFOBJ | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_UINT8ARRAY), + DUK_BIDX_UINT8ARRAY_PROTOTYPE); + DUK_ASSERT(h_bufobj != NULL); + duk__set_bufobj_buffer(thr, h_bufobj, h_buf); + h_bufobj->is_typedarray = 1; + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + + h_arrbuf = duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | + DUK_HOBJECT_FLAG_BUFOBJ | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_ARRAYBUFFER), + DUK_BIDX_ARRAYBUFFER_PROTOTYPE); + DUK_ASSERT(h_arrbuf != NULL); + duk__set_bufobj_buffer(thr, h_arrbuf, h_buf); + DUK_ASSERT(h_arrbuf->is_typedarray == 0); + DUK_HBUFOBJ_ASSERT_VALID(h_arrbuf); + + DUK_ASSERT(h_bufobj->buf_prop == NULL); + h_bufobj->buf_prop = (duk_hobject *) h_arrbuf; + DUK_ASSERT(h_arrbuf != NULL); + DUK_HBUFOBJ_INCREF(thr, h_arrbuf); + duk_pop(thr); +#endif +} + +/* Indexed read helper for buffer objects, also called from outside this file. */ +DUK_INTERNAL void duk_hbufobj_push_validated_read(duk_hthread *thr, + duk_hbufobj *h_bufobj, + duk_uint8_t *p, + duk_small_uint_t elem_size) { + duk_double_union du; + + DUK_ASSERT(elem_size > 0); + duk_memcpy((void *) du.uc, (const void *) p, (size_t) elem_size); + + switch (h_bufobj->elem_type) { + case DUK_HBUFOBJ_ELEM_UINT8: + case DUK_HBUFOBJ_ELEM_UINT8CLAMPED: + duk_push_uint(thr, (duk_uint_t) du.uc[0]); + break; + case DUK_HBUFOBJ_ELEM_INT8: + duk_push_int(thr, (duk_int_t) (duk_int8_t) du.uc[0]); + break; + case DUK_HBUFOBJ_ELEM_UINT16: + duk_push_uint(thr, (duk_uint_t) du.us[0]); + break; + case DUK_HBUFOBJ_ELEM_INT16: + duk_push_int(thr, (duk_int_t) (duk_int16_t) du.us[0]); + break; + case DUK_HBUFOBJ_ELEM_UINT32: + duk_push_uint(thr, (duk_uint_t) du.ui[0]); + break; + case DUK_HBUFOBJ_ELEM_INT32: + duk_push_int(thr, (duk_int_t) (duk_int32_t) du.ui[0]); + break; + case DUK_HBUFOBJ_ELEM_FLOAT32: + duk_push_number(thr, (duk_double_t) du.f[0]); + break; + case DUK_HBUFOBJ_ELEM_FLOAT64: + duk_push_number(thr, (duk_double_t) du.d); + break; + default: + DUK_UNREACHABLE(); + } +} + +/* Indexed write helper for buffer objects, also called from outside this file. */ +DUK_INTERNAL void duk_hbufobj_validated_write(duk_hthread *thr, duk_hbufobj *h_bufobj, duk_uint8_t *p, duk_small_uint_t elem_size) { + duk_double_union du; + + /* NOTE! Caller must ensure that any side effects from the + * coercions below are safe. If that cannot be guaranteed + * (which is normally the case), caller must coerce the + * argument using duk_to_number() before any pointer + * validations; the result of duk_to_number() always coerces + * without side effects here. + */ + + switch (h_bufobj->elem_type) { + case DUK_HBUFOBJ_ELEM_UINT8: + du.uc[0] = (duk_uint8_t) duk_to_uint32(thr, -1); + break; + case DUK_HBUFOBJ_ELEM_UINT8CLAMPED: + du.uc[0] = (duk_uint8_t) duk_to_uint8clamped(thr, -1); + break; + case DUK_HBUFOBJ_ELEM_INT8: + du.uc[0] = (duk_uint8_t) duk_to_int32(thr, -1); + break; + case DUK_HBUFOBJ_ELEM_UINT16: + du.us[0] = (duk_uint16_t) duk_to_uint32(thr, -1); + break; + case DUK_HBUFOBJ_ELEM_INT16: + du.us[0] = (duk_uint16_t) duk_to_int32(thr, -1); + break; + case DUK_HBUFOBJ_ELEM_UINT32: + du.ui[0] = (duk_uint32_t) duk_to_uint32(thr, -1); + break; + case DUK_HBUFOBJ_ELEM_INT32: + du.ui[0] = (duk_uint32_t) duk_to_int32(thr, -1); + break; + case DUK_HBUFOBJ_ELEM_FLOAT32: + /* A double-to-float cast is undefined behavior in C99 if + * the cast is out-of-range, so use a helper. Example: + * runtime error: value -1e+100 is outside the range of representable values of type 'float' + */ + du.f[0] = duk_double_to_float_t(duk_to_number_m1(thr)); + break; + case DUK_HBUFOBJ_ELEM_FLOAT64: + du.d = (duk_double_t) duk_to_number_m1(thr); + break; + default: + DUK_UNREACHABLE(); + } + + DUK_ASSERT(elem_size > 0); + duk_memcpy((void *) p, (const void *) du.uc, (size_t) elem_size); +} + +/* Helper to create a fixed buffer from argument value at index 0. + * Node.js and allocPlain() compatible. + */ +DUK_LOCAL duk_hbuffer *duk__hbufobj_fixed_from_argvalue(duk_hthread *thr) { + duk_int_t len; + duk_int_t i; + duk_size_t buf_size; + duk_uint8_t *buf; + + switch (duk_get_type(thr, 0)) { + case DUK_TYPE_NUMBER: { + len = duk_to_int_clamped(thr, 0, 0, DUK_INT_MAX); + (void) duk_push_fixed_buffer_zero(thr, (duk_size_t) len); + break; + } + case DUK_TYPE_BUFFER: { /* Treat like Uint8Array. */ + goto slow_copy; + } + case DUK_TYPE_OBJECT: { + duk_hobject *h; + duk_hbufobj *h_bufobj; + + /* For Node.js Buffers "Passing an ArrayBuffer returns a Buffer + * that shares allocated memory with the given ArrayBuffer." + * https://nodejs.org/api/buffer.html#buffer_buffer_from_buffer_alloc_and_buffer_allocunsafe + */ + + h = duk_known_hobject(thr, 0); + if (DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_ARRAYBUFFER) { + DUK_ASSERT(DUK_HOBJECT_IS_BUFOBJ(h)); + h_bufobj = (duk_hbufobj *) h; + if (DUK_UNLIKELY(h_bufobj->buf == NULL)) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return NULL;); + } + if (DUK_UNLIKELY(h_bufobj->offset != 0 || h_bufobj->length != DUK_HBUFFER_GET_SIZE(h_bufobj->buf))) { + /* No support for ArrayBuffers with slice + * offset/length. + */ + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return NULL;); + } + duk_push_hbuffer(thr, h_bufobj->buf); + return h_bufobj->buf; + } + goto slow_copy; + } + case DUK_TYPE_STRING: { + /* ignore encoding for now */ + duk_require_hstring_notsymbol(thr, 0); + duk_dup_0(thr); + (void) duk_to_buffer(thr, -1, &buf_size); + break; + } + default: + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return NULL;); + } + +done: + DUK_ASSERT(duk_is_buffer(thr, -1)); + return duk_known_hbuffer(thr, -1); + +slow_copy: + /* XXX: fast path for typed arrays and other buffer objects? */ + + (void) duk_get_prop_stridx_short(thr, 0, DUK_STRIDX_LENGTH); + len = duk_to_int_clamped(thr, -1, 0, DUK_INT_MAX); + duk_pop(thr); + buf = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, (duk_size_t) len); /* no zeroing, all indices get initialized */ + for (i = 0; i < len; i++) { + /* XXX: fast path for array or buffer arguments? */ + duk_get_prop_index(thr, 0, (duk_uarridx_t) i); + buf[i] = (duk_uint8_t) (duk_to_uint32(thr, -1) & 0xffU); + duk_pop(thr); + } + goto done; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer constructor + * + * Node.js Buffers are just Uint8Arrays with internal prototype set to + * Buffer.prototype so they're handled otherwise the same as Uint8Array. + * However, the constructor arguments are very different so a separate + * constructor entry point is used. + */ +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_constructor(duk_hthread *thr) { + duk_hbuffer *h_buf; + + h_buf = duk__hbufobj_fixed_from_argvalue(thr); + DUK_ASSERT(h_buf != NULL); + + duk_push_buffer_object(thr, -1, 0, DUK_HBUFFER_FIXED_GET_SIZE((duk_hbuffer_fixed *) (void *) h_buf), DUK_BUFOBJ_UINT8ARRAY); + duk_push_hobject_bidx(thr, DUK_BIDX_NODEJS_BUFFER_PROTOTYPE); + duk_set_prototype(thr, -2); + + /* XXX: a more direct implementation */ + + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * ArrayBuffer, DataView, and TypedArray constructors + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_arraybuffer_constructor(duk_hthread *thr) { + duk_hbufobj *h_bufobj; + duk_hbuffer *h_val; + duk_int_t len; + + DUK_CTX_ASSERT_VALID(thr); + + duk_require_constructor_call(thr); + + len = duk_to_int(thr, 0); + if (len < 0) { + goto fail_length; + } + (void) duk_push_fixed_buffer_zero(thr, (duk_size_t) len); + h_val = (duk_hbuffer *) duk_known_hbuffer(thr, -1); + + h_bufobj = duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_BUFOBJ | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_ARRAYBUFFER), + DUK_BIDX_ARRAYBUFFER_PROTOTYPE); + DUK_ASSERT(h_bufobj != NULL); + + duk__set_bufobj_buffer(thr, h_bufobj, h_val); + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + + return 1; + +fail_length: + DUK_DCERROR_RANGE_INVALID_LENGTH(thr); +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* Format of magic, bits: + * 0...1: elem size shift (0-3) + * 2...5: elem type (DUK_HBUFOBJ_ELEM_xxx) + * + * XXX: add prototype bidx explicitly to magic instead of using a mapping? + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_typedarray_constructor(duk_hthread *thr) { + duk_tval *tv; + duk_hobject *h_obj; + duk_hbufobj *h_bufobj = NULL; + duk_hbufobj *h_bufarg = NULL; + duk_hbuffer *h_val; + duk_small_uint_t magic; + duk_small_uint_t shift; + duk_small_uint_t elem_type; + duk_small_uint_t elem_size; + duk_small_uint_t class_num; + duk_small_uint_t proto_bidx; + duk_uint_t align_mask; + duk_uint_t elem_length; + duk_int_t elem_length_signed; + duk_uint_t byte_length; + duk_small_uint_t copy_mode; + + /* XXX: The same copy helpers could be shared with at least some + * buffer functions. + */ + + duk_require_constructor_call(thr); + + /* We could fit built-in index into magic but that'd make the magic + * number dependent on built-in numbering (genbuiltins.py doesn't + * handle that yet). So map both class and prototype from the + * element type. + */ + magic = (duk_small_uint_t) duk_get_current_magic(thr); + shift = magic & 0x03U; /* bits 0...1: shift */ + elem_type = (magic >> 2) & 0x0fU; /* bits 2...5: type */ + elem_size = 1U << shift; + align_mask = elem_size - 1; + DUK_ASSERT(elem_type < sizeof(duk__buffer_proto_from_elemtype) / sizeof(duk_uint8_t)); + proto_bidx = duk__buffer_proto_from_elemtype[elem_type]; + DUK_ASSERT(proto_bidx < DUK_NUM_BUILTINS); + DUK_ASSERT(elem_type < sizeof(duk__buffer_class_from_elemtype) / sizeof(duk_uint8_t)); + class_num = duk__buffer_class_from_elemtype[elem_type]; + + DUK_DD(DUK_DDPRINT("typedarray constructor, magic=%d, shift=%d, elem_type=%d, " + "elem_size=%d, proto_bidx=%d, class_num=%d", + (int) magic, + (int) shift, + (int) elem_type, + (int) elem_size, + (int) proto_bidx, + (int) class_num)); + + /* Argument variants. When the argument is an ArrayBuffer a view to + * the same buffer is created; otherwise a new ArrayBuffer is always + * created. + */ + + /* XXX: initial iteration to treat a plain buffer like an ArrayBuffer: + * coerce to an ArrayBuffer object and use that as .buffer. The underlying + * buffer will be the same but result .buffer !== inputPlainBuffer. + */ + duk_hbufobj_promote_plain(thr, 0); + + tv = duk_get_tval(thr, 0); + DUK_ASSERT(tv != NULL); /* arg count */ + if (DUK_TVAL_IS_OBJECT(tv)) { + h_obj = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h_obj != NULL); + + if (DUK_HOBJECT_GET_CLASS_NUMBER(h_obj) == DUK_HOBJECT_CLASS_ARRAYBUFFER) { + /* ArrayBuffer: unlike any other argument variant, create + * a view into the existing buffer. + */ + + duk_int_t byte_offset_signed; + duk_uint_t byte_offset; + + h_bufarg = (duk_hbufobj *) h_obj; + + byte_offset_signed = duk_to_int(thr, 1); + if (byte_offset_signed < 0) { + goto fail_arguments; + } + byte_offset = (duk_uint_t) byte_offset_signed; + if (byte_offset > h_bufarg->length || (byte_offset & align_mask) != 0) { + /* Must be >= 0 and multiple of element size. */ + goto fail_arguments; + } + if (duk_is_undefined(thr, 2)) { + DUK_ASSERT(h_bufarg->length >= byte_offset); + byte_length = h_bufarg->length - byte_offset; + if ((byte_length & align_mask) != 0) { + /* Must be element size multiple from + * start offset to end of buffer. + */ + goto fail_arguments; + } + elem_length = (byte_length >> shift); + } else { + elem_length_signed = duk_to_int(thr, 2); + if (elem_length_signed < 0) { + goto fail_arguments; + } + elem_length = (duk_uint_t) elem_length_signed; + byte_length = elem_length << shift; + if ((byte_length >> shift) != elem_length) { + /* Byte length would overflow. */ + /* XXX: easier check with less code? */ + goto fail_arguments; + } + DUK_ASSERT(h_bufarg->length >= byte_offset); + if (byte_length > h_bufarg->length - byte_offset) { + /* Not enough data. */ + goto fail_arguments; + } + } + DUK_UNREF(elem_length); + DUK_ASSERT_DISABLE(byte_offset >= 0); + DUK_ASSERT(byte_offset <= h_bufarg->length); + DUK_ASSERT_DISABLE(byte_length >= 0); + DUK_ASSERT(byte_offset + byte_length <= h_bufarg->length); + DUK_ASSERT((elem_length << shift) == byte_length); + + h_bufobj = duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_BUFOBJ | + DUK_HOBJECT_CLASS_AS_FLAGS(class_num), + (duk_small_int_t) proto_bidx); + h_val = h_bufarg->buf; + if (h_val == NULL) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + h_bufobj->buf = h_val; + DUK_HBUFFER_INCREF(thr, h_val); + h_bufobj->offset = h_bufarg->offset + byte_offset; + h_bufobj->length = byte_length; + h_bufobj->shift = (duk_uint8_t) shift; + h_bufobj->elem_type = (duk_uint8_t) elem_type; + h_bufobj->is_typedarray = 1; + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + + /* Set .buffer to the argument ArrayBuffer. */ + DUK_ASSERT(h_bufobj->buf_prop == NULL); + h_bufobj->buf_prop = (duk_hobject *) h_bufarg; + DUK_ASSERT(h_bufarg != NULL); + DUK_HBUFOBJ_INCREF(thr, h_bufarg); + return 1; + } else if (DUK_HOBJECT_IS_BUFOBJ(h_obj)) { + /* TypedArray (or other non-ArrayBuffer duk_hbufobj). + * Conceptually same behavior as for an Array-like argument, + * with a few fast paths. + */ + + h_bufarg = (duk_hbufobj *) h_obj; + DUK_HBUFOBJ_ASSERT_VALID(h_bufarg); + elem_length_signed = (duk_int_t) (h_bufarg->length >> h_bufarg->shift); + if (h_bufarg->buf == NULL) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + + /* Select copy mode. Must take into account element + * compatibility and validity of the underlying source + * buffer. + */ + + DUK_DDD(DUK_DDDPRINT("selecting copy mode for bufobj arg, " + "src byte_length=%ld, src shift=%d, " + "src/dst elem_length=%ld; " + "dst shift=%d -> dst byte_length=%ld", + (long) h_bufarg->length, + (int) h_bufarg->shift, + (long) elem_length_signed, + (int) shift, + (long) (elem_length_signed << shift))); + + copy_mode = 2; /* default is explicit index read/write copy */ +#if !defined(DUK_USE_PREFER_SIZE) + /* With a size optimized build copy_mode 2 is enough. + * Modes 0 and 1 are faster but conceptually the same. + */ + DUK_ASSERT(elem_type < sizeof(duk__buffer_elemtype_copy_compatible) / sizeof(duk_uint16_t)); + if (DUK_HBUFOBJ_VALID_SLICE(h_bufarg)) { + if ((duk__buffer_elemtype_copy_compatible[elem_type] & (1 << h_bufarg->elem_type)) != 0) { + DUK_DDD(DUK_DDDPRINT("source/target are copy compatible, memcpy")); + DUK_ASSERT(shift == h_bufarg->shift); /* byte sizes will match */ + copy_mode = 0; + } else { + DUK_DDD(DUK_DDDPRINT("source/target not copy compatible but valid, fast copy")); + copy_mode = 1; + } + } +#endif /* !DUK_USE_PREFER_SIZE */ + } else { + /* Array or Array-like */ + elem_length_signed = (duk_int_t) duk_get_length(thr, 0); + copy_mode = 2; + } + } else { + /* Non-object argument is simply int coerced, matches + * V8 behavior (except for "null", which we coerce to + * 0 but V8 TypeErrors). + */ + elem_length_signed = duk_to_int(thr, 0); + copy_mode = 3; + } + if (elem_length_signed < 0) { + goto fail_arguments; + } + elem_length = (duk_uint_t) elem_length_signed; + byte_length = (duk_uint_t) (elem_length << shift); + if ((byte_length >> shift) != elem_length) { + /* Byte length would overflow. */ + /* XXX: easier check with less code? */ + goto fail_arguments; + } + + DUK_DDD(DUK_DDDPRINT("elem_length=%ld, byte_length=%ld", (long) elem_length, (long) byte_length)); + + /* ArrayBuffer argument is handled specially above; the rest of the + * argument variants are handled by shared code below. + * + * ArrayBuffer in h_bufobj->buf_prop is intentionally left unset. + * It will be automatically created by the .buffer accessor on + * first access. + */ + + /* Push the resulting view object on top of a plain fixed buffer. */ + (void) duk_push_fixed_buffer(thr, byte_length); + h_val = duk_known_hbuffer(thr, -1); + DUK_ASSERT(h_val != NULL); + + h_bufobj = + duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_BUFOBJ | DUK_HOBJECT_CLASS_AS_FLAGS(class_num), + (duk_small_int_t) proto_bidx); + + h_bufobj->buf = h_val; + DUK_HBUFFER_INCREF(thr, h_val); + DUK_ASSERT(h_bufobj->offset == 0); + h_bufobj->length = byte_length; + h_bufobj->shift = (duk_uint8_t) shift; + h_bufobj->elem_type = (duk_uint8_t) elem_type; + h_bufobj->is_typedarray = 1; + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + + /* Copy values, the copy method depends on the arguments. + * + * Copy mode decision may depend on the validity of the underlying + * buffer of the source argument; there must be no harmful side effects + * from there to here for copy_mode to still be valid. + */ + DUK_DDD(DUK_DDDPRINT("copy mode: %d", (int) copy_mode)); + switch (copy_mode) { + /* Copy modes 0 and 1 can be omitted in size optimized build, + * copy mode 2 handles them (but more slowly). + */ +#if !defined(DUK_USE_PREFER_SIZE) + case 0: { + /* Use byte copy. */ + + duk_uint8_t *p_src; + duk_uint8_t *p_dst; + + DUK_ASSERT(h_bufobj != NULL); + DUK_ASSERT(h_bufobj->buf != NULL); + DUK_ASSERT(DUK_HBUFOBJ_VALID_SLICE(h_bufobj)); + DUK_ASSERT(h_bufarg != NULL); + DUK_ASSERT(h_bufarg->buf != NULL); + DUK_ASSERT(DUK_HBUFOBJ_VALID_SLICE(h_bufarg)); + + p_dst = DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_bufobj); + p_src = DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_bufarg); + + DUK_DDD(DUK_DDDPRINT("using memcpy: p_src=%p, p_dst=%p, byte_length=%ld", + (void *) p_src, + (void *) p_dst, + (long) byte_length)); + + duk_memcpy_unsafe((void *) p_dst, (const void *) p_src, (size_t) byte_length); + break; + } + case 1: { + /* Copy values through direct validated reads and writes. */ + + duk_small_uint_t src_elem_size; + duk_small_uint_t dst_elem_size; + duk_uint8_t *p_src; + duk_uint8_t *p_src_end; + duk_uint8_t *p_dst; + + DUK_ASSERT(h_bufobj != NULL); + DUK_ASSERT(h_bufobj->buf != NULL); + DUK_ASSERT(DUK_HBUFOBJ_VALID_SLICE(h_bufobj)); + DUK_ASSERT(h_bufarg != NULL); + DUK_ASSERT(h_bufarg->buf != NULL); + DUK_ASSERT(DUK_HBUFOBJ_VALID_SLICE(h_bufarg)); + + src_elem_size = (duk_small_uint_t) (1U << h_bufarg->shift); + dst_elem_size = elem_size; + + p_src = DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_bufarg); + p_dst = DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_bufobj); + p_src_end = p_src + h_bufarg->length; + + DUK_DDD(DUK_DDDPRINT("using fast copy: p_src=%p, p_src_end=%p, p_dst=%p, " + "src_elem_size=%d, dst_elem_size=%d", + (void *) p_src, + (void *) p_src_end, + (void *) p_dst, + (int) src_elem_size, + (int) dst_elem_size)); + + while (p_src != p_src_end) { + DUK_DDD(DUK_DDDPRINT("fast path per element copy loop: " + "p_src=%p, p_src_end=%p, p_dst=%p", + (void *) p_src, + (void *) p_src_end, + (void *) p_dst)); + /* A validated read() is always a number, so it's write coercion + * is always side effect free an won't invalidate pointers etc. + */ + duk_hbufobj_push_validated_read(thr, h_bufarg, p_src, src_elem_size); + duk_hbufobj_validated_write(thr, h_bufobj, p_dst, dst_elem_size); + duk_pop(thr); + p_src += src_elem_size; + p_dst += dst_elem_size; + } + break; + } +#endif /* !DUK_USE_PREFER_SIZE */ + case 2: { + /* Copy values by index reads and writes. Let virtual + * property handling take care of coercion. + */ + duk_uint_t i; + + DUK_DDD(DUK_DDDPRINT("using slow copy")); + + for (i = 0; i < elem_length; i++) { + duk_get_prop_index(thr, 0, (duk_uarridx_t) i); + duk_put_prop_index(thr, -2, (duk_uarridx_t) i); + } + break; + } + default: + case 3: { + /* No copy, leave zero bytes in the buffer. There's no + * ambiguity with Float32/Float64 because zero bytes also + * represent 0.0. + */ + + DUK_DDD(DUK_DDDPRINT("using no copy")); + break; + } + } + + return 1; + +fail_arguments: + DUK_DCERROR_RANGE_INVALID_ARGS(thr); +} +#else /* DUK_USE_BUFFEROBJECT_SUPPORT */ +/* When bufferobject support is disabled, new Uint8Array() could still be + * supported to create a plain fixed buffer. Disabled for now. + */ +#if 0 +DUK_INTERNAL duk_ret_t duk_bi_typedarray_constructor(duk_hthread *thr) { + duk_int_t elem_length_signed; + duk_uint_t byte_length; + + /* XXX: The same copy helpers could be shared with at least some + * buffer functions. + */ + + duk_require_constructor_call(thr); + + elem_length_signed = duk_require_int(thr, 0); + if (elem_length_signed < 0) { + goto fail_arguments; + } + byte_length = (duk_uint_t) elem_length_signed; + + (void) duk_push_fixed_buffer_zero(thr, (duk_size_t) byte_length); + return 1; + + fail_arguments: + DUK_DCERROR_RANGE_INVALID_ARGS(thr); +} +#endif /* 0 */ +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_dataview_constructor(duk_hthread *thr) { + duk_hbufobj *h_bufarg; + duk_hbufobj *h_bufobj; + duk_hbuffer *h_val; + duk_uint_t offset; + duk_uint_t length; + + duk_require_constructor_call(thr); + + h_bufarg = duk__require_bufobj_value(thr, 0); + DUK_ASSERT(h_bufarg != NULL); + if (DUK_HOBJECT_GET_CLASS_NUMBER((duk_hobject *) h_bufarg) != DUK_HOBJECT_CLASS_ARRAYBUFFER) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + + duk__resolve_offset_opt_length(thr, h_bufarg, 1, 2, &offset, &length, 1 /*throw_flag*/); + DUK_ASSERT(offset <= h_bufarg->length); + DUK_ASSERT(offset + length <= h_bufarg->length); + + h_bufobj = duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_BUFOBJ | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_DATAVIEW), + DUK_BIDX_DATAVIEW_PROTOTYPE); + + h_val = h_bufarg->buf; + if (h_val == NULL) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + h_bufobj->buf = h_val; + DUK_HBUFFER_INCREF(thr, h_val); + h_bufobj->offset = h_bufarg->offset + offset; + h_bufobj->length = length; + DUK_ASSERT(h_bufobj->shift == 0); + DUK_ASSERT(h_bufobj->elem_type == DUK_HBUFOBJ_ELEM_UINT8); + DUK_ASSERT(h_bufobj->is_typedarray == 0); + + DUK_ASSERT(h_bufobj->buf_prop == NULL); + h_bufobj->buf_prop = (duk_hobject *) h_bufarg; + DUK_ASSERT(h_bufarg != NULL); + DUK_HBUFOBJ_INCREF(thr, h_bufarg); + + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * ArrayBuffer.isView() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_arraybuffer_isview(duk_hthread *thr) { + duk_hobject *h_obj; + duk_bool_t ret = 0; + + if (duk_is_buffer(thr, 0)) { + ret = 1; + } else { + h_obj = duk_get_hobject(thr, 0); + if (h_obj != NULL && DUK_HOBJECT_IS_BUFOBJ(h_obj)) { + /* DataView needs special casing: ArrayBuffer.isView() is + * true, but ->is_typedarray is 0. + */ + ret = ((duk_hbufobj *) h_obj)->is_typedarray || + (DUK_HOBJECT_GET_CLASS_NUMBER(h_obj) == DUK_HOBJECT_CLASS_DATAVIEW); + } + } + duk_push_boolean(thr, ret); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Uint8Array.allocPlain() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_uint8array_allocplain(duk_hthread *thr) { + duk__hbufobj_fixed_from_argvalue(thr); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Uint8Array.plainOf() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_uint8array_plainof(duk_hthread *thr) { + duk_hbufobj *h_bufobj; + +#if !defined(DUK_USE_PREFER_SIZE) + /* Avoid churn if argument is already a plain buffer. */ + if (duk_is_buffer(thr, 0)) { + return 1; + } +#endif + + /* Promotes plain buffers to ArrayBuffers, so for a plain buffer + * argument we'll create a pointless temporary (but still work + * correctly). + */ + h_bufobj = duk__require_bufobj_value(thr, 0); + if (h_bufobj->buf == NULL) { + duk_push_undefined(thr); + } else { + duk_push_hbuffer(thr, h_bufobj->buf); + } + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer: toString([encoding], [start], [end]) + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_tostring(duk_hthread *thr) { + duk_hbufobj *h_this; + duk_int_t start_offset, end_offset; + duk_uint8_t *buf_slice; + duk_size_t slice_length; + + h_this = duk__get_bufobj_this(thr); + if (h_this == NULL) { + /* XXX: happens e.g. when evaluating: String(Buffer.prototype). */ + duk_push_literal(thr, "[object Object]"); + return 1; + } + DUK_HBUFOBJ_ASSERT_VALID(h_this); + + /* Ignore encoding for now. */ + + duk__clamp_startend_nonegidx_noshift(thr, + (duk_int_t) h_this->length, + 1 /*idx_start*/, + 2 /*idx_end*/, + &start_offset, + &end_offset); + + slice_length = (duk_size_t) (end_offset - start_offset); + buf_slice = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, slice_length); /* all bytes initialized below */ + DUK_ASSERT(buf_slice != NULL); + + /* Neutered or uncovered, TypeError. */ + if (h_this->buf == NULL || !DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h_this, (duk_size_t) start_offset + slice_length)) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + + /* XXX: ideally we wouldn't make a copy but a view into the buffer for the + * decoding process. Or the decoding helper could be changed to accept + * the slice info (a buffer pointer is NOT a good approach because guaranteeing + * its stability is difficult). + */ + + DUK_ASSERT(DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h_this, (duk_size_t) start_offset + slice_length)); + duk_memcpy_unsafe((void *) buf_slice, + (const void *) (DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_this) + start_offset), + (size_t) slice_length); + + /* Use the equivalent of: new TextEncoder().encode(this) to convert the + * string. Result will be valid UTF-8; non-CESU-8 inputs are currently + * interpreted loosely. Value stack convention is a bit odd for now. + */ + duk_replace(thr, 0); + duk_set_top(thr, 1); + return duk_textdecoder_decode_utf8_nodejs(thr); +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.prototype: toJSON() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_tojson(duk_hthread *thr) { + duk_hbufobj *h_this; + duk_uint8_t *buf; + duk_uint_t i, n; + duk_tval *tv; + + h_this = duk__require_bufobj_this(thr); + DUK_ASSERT(h_this != NULL); + + if (h_this->buf == NULL || !DUK_HBUFOBJ_VALID_SLICE(h_this)) { + /* Serialize uncovered backing buffer as a null; doesn't + * really matter as long we're memory safe. + */ + duk_push_null(thr); + return 1; + } + + duk_push_object(thr); + duk_push_hstring_stridx(thr, DUK_STRIDX_UC_BUFFER); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_TYPE); + + /* XXX: uninitialized would be OK */ + DUK_ASSERT_DISABLE((duk_size_t) h_this->length <= (duk_size_t) DUK_UINT32_MAX); + tv = duk_push_harray_with_size_outptr(thr, (duk_uint32_t) h_this->length); /* XXX: needs revision with >4G buffers */ + DUK_ASSERT(!duk_is_bare_object(thr, -1)); + + DUK_ASSERT(h_this->buf != NULL); + buf = DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_this); + for (i = 0, n = h_this->length; i < n; i++) { + DUK_TVAL_SET_U32(tv + i, (duk_uint32_t) buf[i]); /* no need for decref or incref */ + } + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_DATA); + + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.prototype.equals() + * Node.js Buffer.prototype.compare() + * Node.js Buffer.compare() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_buffer_compare_shared(duk_hthread *thr) { + duk_small_uint_t magic; + duk_hbufobj *h_bufarg1; + duk_hbufobj *h_bufarg2; + duk_small_int_t comp_res; + + /* XXX: keep support for plain buffers and non-Node.js buffers? */ + + magic = (duk_small_uint_t) duk_get_current_magic(thr); + if (magic & 0x02U) { + /* Static call style. */ + h_bufarg1 = duk__require_bufobj_value(thr, 0); + h_bufarg2 = duk__require_bufobj_value(thr, 1); + } else { + h_bufarg1 = duk__require_bufobj_this(thr); + h_bufarg2 = duk__require_bufobj_value(thr, 0); + } + DUK_ASSERT(h_bufarg1 != NULL); + DUK_ASSERT(h_bufarg2 != NULL); + + /* We want to compare the slice/view areas of the arguments. + * If either slice/view is invalid (underlying buffer is shorter) + * ensure equals() is false, but otherwise the only thing that + * matters is to be memory safe. + */ + + if (DUK_HBUFOBJ_VALID_SLICE(h_bufarg1) && DUK_HBUFOBJ_VALID_SLICE(h_bufarg2)) { + comp_res = duk_js_data_compare( + (const duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_bufarg1->buf) + h_bufarg1->offset, + (const duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_bufarg2->buf) + h_bufarg2->offset, + (duk_size_t) h_bufarg1->length, + (duk_size_t) h_bufarg2->length); + } else { + comp_res = -1; /* either nonzero value is ok */ + } + + if (magic & 0x01U) { + /* compare: similar to string comparison but for buffer data. */ + duk_push_int(thr, comp_res); + } else { + /* equals */ + duk_push_boolean(thr, (comp_res == 0)); + } + + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.prototype.fill() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_fill(duk_hthread *thr) { + duk_hbufobj *h_this; + const duk_uint8_t *fill_str_ptr; + duk_size_t fill_str_len; + duk_uint8_t fill_value; + duk_int_t fill_offset; + duk_int_t fill_end; + duk_size_t fill_length; + duk_uint8_t *p; + + h_this = duk__require_bufobj_this(thr); + DUK_ASSERT(h_this != NULL); + if (h_this->buf == NULL) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + + /* [ value offset end ] */ + + if (duk_is_string_notsymbol(thr, 0)) { + fill_str_ptr = (const duk_uint8_t *) duk_get_lstring(thr, 0, &fill_str_len); + DUK_ASSERT(fill_str_ptr != NULL); + } else { + /* Symbols get ToNumber() coerced and cause TypeError. */ + fill_value = (duk_uint8_t) duk_to_uint32(thr, 0); + fill_str_ptr = (const duk_uint8_t *) &fill_value; + fill_str_len = 1; + } + + /* Fill offset handling is more lenient than in Node.js. */ + + duk__clamp_startend_nonegidx_noshift(thr, + (duk_int_t) h_this->length, + 1 /*idx_start*/, + 2 /*idx_end*/, + &fill_offset, + &fill_end); + + DUK_DDD(DUK_DDDPRINT("fill: fill_value=%02x, fill_offset=%ld, fill_end=%ld, view length=%ld", + (unsigned int) fill_value, + (long) fill_offset, + (long) fill_end, + (long) h_this->length)); + + DUK_ASSERT(fill_end - fill_offset >= 0); + DUK_ASSERT(h_this->buf != NULL); + + p = (DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_this) + fill_offset); + fill_length = (duk_size_t) (fill_end - fill_offset); + if (fill_str_len == 1) { + /* Handle single character fills as memset() even when + * the fill data comes from a one-char argument. + */ + duk_memset_unsafe((void *) p, (int) fill_str_ptr[0], (size_t) fill_length); + } else if (fill_str_len > 1) { + duk_size_t i, n, t; + + for (i = 0, n = (duk_size_t) (fill_end - fill_offset), t = 0; i < n; i++) { + p[i] = fill_str_ptr[t++]; + if (t >= fill_str_len) { + t = 0; + } + } + } else { + DUK_DDD(DUK_DDDPRINT("zero size fill pattern, ignore silently")); + } + + /* Return the Buffer to allow chaining: b.fill(0x11).fill(0x22, 3, 5).toString() */ + duk_push_this(thr); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.prototype.write(string, [offset], [length], [encoding]) + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_write(duk_hthread *thr) { + duk_hbufobj *h_this; + duk_uint_t offset; + duk_uint_t length; + const duk_uint8_t *str_data; + duk_size_t str_len; + + /* XXX: very inefficient support for plain buffers */ + h_this = duk__require_bufobj_this(thr); + DUK_ASSERT(h_this != NULL); + + /* Argument must be a string, e.g. a buffer is not allowed. */ + str_data = (const duk_uint8_t *) duk_require_lstring_notsymbol(thr, 0, &str_len); + + duk__resolve_offset_opt_length(thr, h_this, 1, 2, &offset, &length, 0 /*throw_flag*/); + DUK_ASSERT(offset <= h_this->length); + DUK_ASSERT(offset + length <= h_this->length); + + /* XXX: encoding is ignored now. */ + + if (length > str_len) { + length = (duk_uint_t) str_len; + } + + if (DUK_HBUFOBJ_VALID_SLICE(h_this)) { + /* Cannot overlap. */ + duk_memcpy_unsafe((void *) (DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_this) + offset), + (const void *) str_data, + (size_t) length); + } else { + DUK_DDD(DUK_DDDPRINT("write() target buffer is not covered, silent ignore")); + } + + duk_push_uint(thr, length); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.prototype.copy() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_copy(duk_hthread *thr) { + duk_hbufobj *h_this; + duk_hbufobj *h_bufarg; + duk_int_t source_length; + duk_int_t target_length; + duk_int_t target_start, source_start, source_end; + duk_uint_t target_ustart, source_ustart, source_uend; + duk_uint_t copy_size = 0; + + /* [ targetBuffer targetStart sourceStart sourceEnd ] */ + + h_this = duk__require_bufobj_this(thr); + h_bufarg = duk__require_bufobj_value(thr, 0); + DUK_ASSERT(h_this != NULL); + DUK_ASSERT(h_bufarg != NULL); + source_length = (duk_int_t) h_this->length; + target_length = (duk_int_t) h_bufarg->length; + + target_start = duk_to_int(thr, 1); + source_start = duk_to_int(thr, 2); + if (duk_is_undefined(thr, 3)) { + source_end = source_length; + } else { + source_end = duk_to_int(thr, 3); + } + + DUK_DDD(DUK_DDDPRINT("checking copy args: target_start=%ld, target_length=%ld, " + "source_start=%ld, source_end=%ld, source_length=%ld", + (long) target_start, + (long) h_bufarg->length, + (long) source_start, + (long) source_end, + (long) source_length)); + + /* This behavior mostly mimics Node.js now. */ + + if (source_start < 0 || source_end < 0 || target_start < 0) { + /* Negative offsets cause a RangeError. */ + goto fail_bounds; + } + source_ustart = (duk_uint_t) source_start; + source_uend = (duk_uint_t) source_end; + target_ustart = (duk_uint_t) target_start; + if (source_ustart >= source_uend || /* crossed offsets or zero size */ + source_ustart >= (duk_uint_t) source_length || /* source out-of-bounds (but positive) */ + target_ustart >= (duk_uint_t) target_length) { /* target out-of-bounds (but positive) */ + goto silent_ignore; + } + if (source_uend >= (duk_uint_t) source_length) { + /* Source end clamped silently to available length. */ + source_uend = (duk_uint_t) source_length; + } + copy_size = source_uend - source_ustart; + if (target_ustart + copy_size > (duk_uint_t) target_length) { + /* Clamp to target's end if too long. + * + * NOTE: there's no overflow possibility in the comparison; + * both target_ustart and copy_size are >= 0 and based on + * values in duk_int_t range. Adding them as duk_uint_t + * values is then guaranteed not to overflow. + */ + DUK_ASSERT(target_ustart + copy_size >= target_ustart); /* no overflow */ + DUK_ASSERT(target_ustart + copy_size >= copy_size); /* no overflow */ + copy_size = (duk_uint_t) target_length - target_ustart; + } + + DUK_DDD(DUK_DDDPRINT("making copy: target_ustart=%lu source_ustart=%lu copy_size=%lu", + (unsigned long) target_ustart, + (unsigned long) source_ustart, + (unsigned long) copy_size)); + + DUK_ASSERT(copy_size >= 1); + DUK_ASSERT(source_ustart <= (duk_uint_t) source_length); + DUK_ASSERT(source_ustart + copy_size <= (duk_uint_t) source_length); + DUK_ASSERT(target_ustart <= (duk_uint_t) target_length); + DUK_ASSERT(target_ustart + copy_size <= (duk_uint_t) target_length); + + /* Ensure copy is covered by underlying buffers. */ + DUK_ASSERT(h_bufarg->buf != NULL); /* length check */ + DUK_ASSERT(h_this->buf != NULL); /* length check */ + if (DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h_bufarg, target_ustart + copy_size) && + DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h_this, source_ustart + copy_size)) { + /* Must use memmove() because copy area may overlap (source and target + * buffer may be the same, or from different slices. + */ + duk_memmove_unsafe((void *) (DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_bufarg) + target_ustart), + (const void *) (DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_this) + source_ustart), + (size_t) copy_size); + } else { + DUK_DDD(DUK_DDDPRINT("buffer copy not covered by underlying buffer(s), ignoring")); + } + +silent_ignore: + /* Return value is like write(), number of bytes written. + * The return value matters because of code like: + * "off += buf.copy(...)". + */ + duk_push_uint(thr, copy_size); + return 1; + +fail_bounds: + DUK_DCERROR_RANGE_INVALID_ARGS(thr); +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * TypedArray.prototype.set() + * + * TypedArray set() is pretty interesting to implement because: + * + * - The source argument may be a plain array or a typedarray. If the + * source is a TypedArray, values are decoded and re-encoded into the + * target (not as a plain byte copy). This may happen even when the + * element byte size is the same, e.g. integer values may be re-encoded + * into floats. + * + * - Source and target may refer to the same underlying buffer, so that + * the set() operation may overlap. The specification requires that this + * must work as if a copy was made before the operation. Note that this + * is NOT a simple memmove() situation because the source and target + * byte sizes may be different -- e.g. a 4-byte source (Int8Array) may + * expand to a 16-byte target (Uint32Array) so that the target overlaps + * the source both from beginning and the end (unlike in typical memmove). + * + * - Even if 'buf' pointers of the source and target differ, there's no + * guarantee that their memory areas don't overlap. This may be the + * case with external buffers. + * + * Even so, it is nice to optimize for the common case: + * + * - Source and target separate buffers or non-overlapping. + * + * - Source and target have a compatible type so that a plain byte copy + * is possible. Note that while e.g. uint8 and int8 are compatible + * (coercion one way or another doesn't change the byte representation), + * e.g. int8 and uint8clamped are NOT compatible when writing int8 + * values into uint8clamped typedarray (-1 would clamp to 0 for instance). + * + * See test-bi-typedarray-proto-set.js. + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_typedarray_set(duk_hthread *thr) { + duk_hbufobj *h_this; + duk_hobject *h_obj; + duk_uarridx_t i, n; + duk_int_t offset_signed; + duk_uint_t offset_elems; + duk_uint_t offset_bytes; + + h_this = duk__require_bufobj_this(thr); + DUK_ASSERT(h_this != NULL); + DUK_HBUFOBJ_ASSERT_VALID(h_this); + + if (h_this->buf == NULL) { + DUK_DDD(DUK_DDDPRINT("source neutered, skip copy")); + return 0; + } + + duk_hbufobj_promote_plain(thr, 0); + h_obj = duk_require_hobject(thr, 0); + + /* XXX: V8 throws a TypeError for negative values. Would it + * be more useful to interpret negative offsets here from the + * end of the buffer too? + */ + offset_signed = duk_to_int(thr, 1); + if (offset_signed < 0) { + /* For some reason this is a TypeError (at least in V8). */ + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + offset_elems = (duk_uint_t) offset_signed; + offset_bytes = offset_elems << h_this->shift; + if ((offset_bytes >> h_this->shift) != offset_elems) { + /* Byte length would overflow. */ + /* XXX: easier check with less code? */ + goto fail_args; + } + if (offset_bytes > h_this->length) { + /* Equality may be OK but >length not. Checking + * this explicitly avoids some overflow cases + * below. + */ + goto fail_args; + } + DUK_ASSERT(offset_bytes <= h_this->length); + + /* Fast path: source is a TypedArray (or any bufobj). */ + + if (DUK_HOBJECT_IS_BUFOBJ(h_obj)) { + duk_hbufobj *h_bufarg; +#if !defined(DUK_USE_PREFER_SIZE) + duk_uint16_t comp_mask; +#endif + duk_small_int_t no_overlap = 0; + duk_uint_t src_length; + duk_uint_t dst_length; + duk_uint_t dst_length_elems; + duk_uint8_t *p_src_base; + duk_uint8_t *p_src_end; + duk_uint8_t *p_src; + duk_uint8_t *p_dst_base; + duk_uint8_t *p_dst; + duk_small_uint_t src_elem_size; + duk_small_uint_t dst_elem_size; + + h_bufarg = (duk_hbufobj *) h_obj; + DUK_HBUFOBJ_ASSERT_VALID(h_bufarg); + + if (h_bufarg->buf == NULL) { + DUK_DDD(DUK_DDDPRINT("target neutered, skip copy")); + return 0; + } + + /* Nominal size check. */ + src_length = h_bufarg->length; /* bytes in source */ + dst_length_elems = (src_length >> h_bufarg->shift); /* elems in source and dest */ + dst_length = dst_length_elems << h_this->shift; /* bytes in dest */ + if ((dst_length >> h_this->shift) != dst_length_elems) { + /* Byte length would overflow. */ + /* XXX: easier check with less code? */ + goto fail_args; + } + DUK_DDD(DUK_DDDPRINT("nominal size check: src_length=%ld, dst_length=%ld", (long) src_length, (long) dst_length)); + DUK_ASSERT(offset_bytes <= h_this->length); + if (dst_length > h_this->length - offset_bytes) { + /* Overflow not an issue because subtraction is used on the right + * side and guaranteed to be >= 0. + */ + DUK_DDD(DUK_DDDPRINT("copy exceeds target buffer nominal length")); + goto fail_args; + } + if (!DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h_this, offset_bytes + dst_length)) { + DUK_DDD(DUK_DDDPRINT("copy not covered by underlying target buffer, ignore")); + return 0; + } + + p_src_base = DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_bufarg); + p_dst_base = DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_this) + offset_bytes; + + /* Check actual underlying buffers for validity and that they + * cover the copy. No side effects are allowed after the check + * so that the validity status doesn't change. + */ + if (!DUK_HBUFOBJ_VALID_SLICE(h_this) || !DUK_HBUFOBJ_VALID_SLICE(h_bufarg)) { + /* The condition could be more narrow and check for the + * copy area only, but there's no need for fine grained + * behavior when the underlying buffer is misconfigured. + */ + DUK_DDD(DUK_DDDPRINT("source and/or target not covered by underlying buffer, skip copy")); + return 0; + } + + /* We want to do a straight memory copy if possible: this is + * an important operation because .set() is the TypedArray + * way to copy chunks of memory. However, because set() + * conceptually works in terms of elements, not all views are + * compatible with direct byte copying. + * + * If we do manage a direct copy, the "overlap issue" handled + * below can just be solved using memmove() because the source + * and destination element sizes are necessarily equal. + */ + +#if !defined(DUK_USE_PREFER_SIZE) + DUK_ASSERT(h_this->elem_type < sizeof(duk__buffer_elemtype_copy_compatible) / sizeof(duk_uint16_t)); + comp_mask = duk__buffer_elemtype_copy_compatible[h_this->elem_type]; + if (comp_mask & (1 << h_bufarg->elem_type)) { + DUK_ASSERT(src_length == dst_length); + + DUK_DDD(DUK_DDDPRINT("fast path: able to use memmove() because views are compatible")); + duk_memmove_unsafe((void *) p_dst_base, (const void *) p_src_base, (size_t) dst_length); + return 0; + } + DUK_DDD(DUK_DDDPRINT("fast path: views are not compatible with a byte copy, copy by item")); +#endif /* !DUK_USE_PREFER_SIZE */ + + /* We want to avoid making a copy to process set() but that's + * not always possible: the source and the target may overlap + * and because element sizes are different, the overlap cannot + * always be handled with a memmove() or choosing the copy + * direction in a certain way. For example, if source type is + * uint8 and target type is uint32, the target area may exceed + * the source area from both ends! + * + * Note that because external buffers may point to the same + * memory areas, we must ultimately make this check using + * pointers. + * + * NOTE: careful with side effects: any side effect may cause + * a buffer resize (or external buffer pointer/length update)! + */ + + DUK_DDD(DUK_DDDPRINT("overlap check: p_src_base=%p, src_length=%ld, " + "p_dst_base=%p, dst_length=%ld", + (void *) p_src_base, + (long) src_length, + (void *) p_dst_base, + (long) dst_length)); + + if (p_src_base >= p_dst_base + dst_length || /* source starts after dest ends */ + p_src_base + src_length <= p_dst_base) { /* source ends before dest starts */ + no_overlap = 1; + } + + if (!no_overlap) { + /* There's overlap: the desired end result is that + * conceptually a copy is made to avoid "trampling" + * of source data by destination writes. We make + * an actual temporary copy to handle this case. + */ + duk_uint8_t *p_src_copy; + + DUK_DDD(DUK_DDDPRINT("there is overlap, make a copy of the source")); + p_src_copy = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, src_length); + DUK_ASSERT(p_src_copy != NULL); + duk_memcpy_unsafe((void *) p_src_copy, (const void *) p_src_base, (size_t) src_length); + + p_src_base = p_src_copy; /* use p_src_base from now on */ + } + /* Value stack intentionally mixed size here. */ + + DUK_DDD(DUK_DDDPRINT("after overlap check: p_src_base=%p, src_length=%ld, " + "p_dst_base=%p, dst_length=%ld, valstack top=%ld", + (void *) p_src_base, + (long) src_length, + (void *) p_dst_base, + (long) dst_length, + (long) duk_get_top(thr))); + + /* Ready to make the copy. We must proceed element by element + * and must avoid any side effects that might cause the buffer + * validity check above to become invalid. + * + * Although we work through the value stack here, only plain + * numbers are handled which should be side effect safe. + */ + + src_elem_size = (duk_small_uint_t) (1U << h_bufarg->shift); + dst_elem_size = (duk_small_uint_t) (1U << h_this->shift); + p_src = p_src_base; + p_dst = p_dst_base; + p_src_end = p_src_base + src_length; + + while (p_src != p_src_end) { + DUK_DDD(DUK_DDDPRINT("fast path per element copy loop: " + "p_src=%p, p_src_end=%p, p_dst=%p", + (void *) p_src, + (void *) p_src_end, + (void *) p_dst)); + /* A validated read() is always a number, so it's write coercion + * is always side effect free an won't invalidate pointers etc. + */ + duk_hbufobj_push_validated_read(thr, h_bufarg, p_src, src_elem_size); + duk_hbufobj_validated_write(thr, h_this, p_dst, dst_elem_size); + duk_pop(thr); + p_src += src_elem_size; + p_dst += dst_elem_size; + } + + return 0; + } else { + /* Slow path: quite slow, but we save space by using the property code + * to write coerce target values. We don't need to worry about overlap + * here because the source is not a TypedArray. + * + * We could use the bufobj write coercion helper but since the + * property read may have arbitrary side effects, full validity checks + * would be needed for every element anyway. + */ + + n = (duk_uarridx_t) duk_get_length(thr, 0); + DUK_ASSERT(offset_bytes <= h_this->length); + if ((n << h_this->shift) > h_this->length - offset_bytes) { + /* Overflow not an issue because subtraction is used on the right + * side and guaranteed to be >= 0. + */ + DUK_DDD(DUK_DDDPRINT("copy exceeds target buffer nominal length")); + goto fail_args; + } + + /* There's no need to check for buffer validity status for the + * target here: the property access code will do that for each + * element. Moreover, if we did check the validity here, side + * effects from reading the source argument might invalidate + * the results anyway. + */ + + DUK_ASSERT_TOP(thr, 2); + duk_push_this(thr); + + for (i = 0; i < n; i++) { + duk_get_prop_index(thr, 0, i); + duk_put_prop_index(thr, 2, offset_elems + i); + } + } + + return 0; + +fail_args: + DUK_DCERROR_RANGE_INVALID_ARGS(thr); +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.prototype.slice([start], [end]) + * ArrayBuffer.prototype.slice(begin, [end]) + * TypedArray.prototype.subarray(begin, [end]) + * + * The API calls are almost identical; negative indices are counted from end + * of buffer, and final indices are clamped (allowing crossed indices). Main + * differences: + * + * - Copy/view behavior; Node.js .slice() and TypedArray .subarray() create + * views, ArrayBuffer .slice() creates a copy + * + * - Resulting object has a different class and prototype depending on the + * call (or 'this' argument) + * + * - TypedArray .subarray() arguments are element indices, not byte offsets + * + * - Plain buffer argument creates a plain buffer slice + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_LOCAL void duk__arraybuffer_plain_slice(duk_hthread *thr, duk_hbuffer *h_val) { + duk_int_t start_offset, end_offset; + duk_uint_t slice_length; + duk_uint8_t *p_copy; + duk_size_t copy_length; + + duk__clamp_startend_negidx_shifted(thr, + (duk_int_t) DUK_HBUFFER_GET_SIZE(h_val), + 0 /*buffer_shift*/, + 0 /*idx_start*/, + 1 /*idx_end*/, + &start_offset, + &end_offset); + DUK_ASSERT(end_offset <= (duk_int_t) DUK_HBUFFER_GET_SIZE(h_val)); + DUK_ASSERT(start_offset >= 0); + DUK_ASSERT(end_offset >= start_offset); + slice_length = (duk_uint_t) (end_offset - start_offset); + + p_copy = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, (duk_size_t) slice_length); + DUK_ASSERT(p_copy != NULL); + copy_length = slice_length; + + duk_memcpy_unsafe((void *) p_copy, + (const void *) ((duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_val) + start_offset), + copy_length); +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +/* Shared helper for slice/subarray operation. + * Magic: 0x01=isView, 0x02=copy, 0x04=Node.js Buffer special handling. + */ +DUK_INTERNAL duk_ret_t duk_bi_buffer_slice_shared(duk_hthread *thr) { + duk_small_int_t magic; + duk_small_uint_t res_class_num; + duk_small_int_t res_proto_bidx; + duk_hbufobj *h_this; + duk_hbufobj *h_bufobj; + duk_hbuffer *h_val; + duk_int_t start_offset, end_offset; + duk_uint_t slice_length; + duk_tval *tv; + + /* [ start end ] */ + + magic = duk_get_current_magic(thr); + + tv = duk_get_borrowed_this_tval(thr); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_IS_BUFFER(tv)) { + /* For plain buffers return a plain buffer slice. */ + h_val = DUK_TVAL_GET_BUFFER(tv); + DUK_ASSERT(h_val != NULL); + + if (magic & 0x02) { + /* Make copy: ArrayBuffer.prototype.slice() uses this. */ + duk__arraybuffer_plain_slice(thr, h_val); + return 1; + } else { + /* View into existing buffer: cannot be done if the + * result is a plain buffer because there's no slice + * info. So return an ArrayBuffer instance; coerce + * the 'this' binding into an object and behave as if + * the original call was for an Object-coerced plain + * buffer (handled automatically by duk__require_bufobj_this()). + */ + + DUK_DDD(DUK_DDDPRINT("slice() doesn't handle view into plain buffer, coerce 'this' to ArrayBuffer object")); + /* fall through */ + } + } + tv = NULL; /* No longer valid nor needed. */ + + h_this = duk__require_bufobj_this(thr); + + /* Slice offsets are element (not byte) offsets, which only matters + * for TypedArray views, Node.js Buffer and ArrayBuffer have shift + * zero so byte and element offsets are the same. Negative indices + * are counted from end of slice, crossed indices are allowed (and + * result in zero length result), and final values are clamped + * against the current slice. There's intentionally no check + * against the underlying buffer here. + */ + + duk__clamp_startend_negidx_shifted(thr, + (duk_int_t) h_this->length, + (duk_uint8_t) h_this->shift, + 0 /*idx_start*/, + 1 /*idx_end*/, + &start_offset, + &end_offset); + DUK_ASSERT(end_offset >= start_offset); + DUK_ASSERT(start_offset >= 0); + DUK_ASSERT(end_offset >= 0); + slice_length = (duk_uint_t) (end_offset - start_offset); + + /* The resulting buffer object gets the same class and prototype as + * the buffer in 'this', e.g. if the input is a Uint8Array the + * result is a Uint8Array; if the input is a Float32Array, the + * result is a Float32Array. The result internal prototype should + * be the default prototype for the class (e.g. initial value of + * Uint8Array.prototype), not copied from the argument (Duktape 1.x + * did that). + * + * Node.js Buffers have special handling: they're Uint8Arrays as far + * as the internal class is concerned, so the new Buffer should also + * be an Uint8Array but inherit from Buffer.prototype. + */ + res_class_num = DUK_HOBJECT_GET_CLASS_NUMBER((duk_hobject *) h_this); + DUK_ASSERT(res_class_num >= DUK_HOBJECT_CLASS_BUFOBJ_MIN); /* type check guarantees */ + DUK_ASSERT(res_class_num <= DUK_HOBJECT_CLASS_BUFOBJ_MAX); + res_proto_bidx = duk__buffer_proto_from_classnum[res_class_num - DUK_HOBJECT_CLASS_BUFOBJ_MIN]; + if (magic & 0x04) { + res_proto_bidx = DUK_BIDX_NODEJS_BUFFER_PROTOTYPE; + } + h_bufobj = + duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_BUFOBJ | DUK_HOBJECT_CLASS_AS_FLAGS(res_class_num), + res_proto_bidx); + DUK_ASSERT(h_bufobj != NULL); + + DUK_ASSERT(h_bufobj->length == 0); + h_bufobj->shift = h_this->shift; /* inherit */ + h_bufobj->elem_type = h_this->elem_type; /* inherit */ + h_bufobj->is_typedarray = magic & 0x01; + DUK_ASSERT(h_bufobj->is_typedarray == 0 || h_bufobj->is_typedarray == 1); + + h_val = h_this->buf; + if (h_val == NULL) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + + if (magic & 0x02) { + /* non-zero: make copy */ + duk_uint8_t *p_copy; + duk_size_t copy_length; + + p_copy = (duk_uint8_t *) duk_push_fixed_buffer_zero( + thr, + (duk_size_t) slice_length); /* must be zeroed, not all bytes always copied */ + DUK_ASSERT(p_copy != NULL); + + /* Copy slice, respecting underlying buffer limits; remainder + * is left as zero. + */ + copy_length = DUK_HBUFOBJ_CLAMP_BYTELENGTH(h_this, slice_length); + duk_memcpy_unsafe((void *) p_copy, + (const void *) (DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_this) + start_offset), + copy_length); + + h_val = duk_known_hbuffer(thr, -1); + + h_bufobj->buf = h_val; + DUK_HBUFFER_INCREF(thr, h_val); + h_bufobj->length = slice_length; + DUK_ASSERT(h_bufobj->offset == 0); + + duk_pop(thr); /* reachable so pop OK */ + } else { + h_bufobj->buf = h_val; + DUK_HBUFFER_INCREF(thr, h_val); + h_bufobj->length = slice_length; + h_bufobj->offset = h_this->offset + (duk_uint_t) start_offset; + + /* Copy the .buffer property, needed for TypedArray.prototype.subarray(). + * + * XXX: limit copy only for TypedArray classes specifically? + */ + + DUK_ASSERT(h_bufobj->buf_prop == NULL); + h_bufobj->buf_prop = h_this->buf_prop; /* may be NULL */ + DUK_HOBJECT_INCREF_ALLOWNULL(thr, (duk_hobject *) h_bufobj->buf_prop); + } + /* unbalanced stack on purpose */ + + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.isEncoding() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_is_encoding(duk_hthread *thr) { + const char *encoding; + + /* only accept lowercase 'utf8' now. */ + + encoding = duk_to_string(thr, 0); + DUK_ASSERT(duk_is_string(thr, 0)); /* guaranteed by duk_to_string() */ + duk_push_boolean(thr, DUK_STRCMP(encoding, "utf8") == 0); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.isBuffer() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_is_buffer(duk_hthread *thr) { + duk_hobject *h; + duk_hobject *h_proto; + duk_bool_t ret = 0; + + DUK_ASSERT(duk_get_top(thr) >= 1); /* nargs */ + h = duk_get_hobject(thr, 0); + if (h != NULL) { + h_proto = thr->builtins[DUK_BIDX_NODEJS_BUFFER_PROTOTYPE]; + DUK_ASSERT(h_proto != NULL); + + h = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h); + if (h != NULL) { + ret = duk_hobject_prototype_chain_contains(thr, h, h_proto, 0 /*ignore_loop*/); + } + } + + duk_push_boolean(thr, ret); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.byteLength() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_byte_length(duk_hthread *thr) { + const char *str; + duk_size_t len; + + /* At the moment Buffer() will just use the string bytes as + * is (ignoring encoding), so we return the string length here + * unconditionally. + */ + + /* XXX: to be revised; Old Node.js behavior just coerces any buffer + * values to string: + * $ node + * > Buffer.byteLength(new Uint32Array(10)) + * 20 + * > Buffer.byteLength(new Uint32Array(100)) + * 20 + * (The 20 comes from '[object Uint32Array]'.length + */ + + str = duk_to_lstring(thr, 0, &len); + DUK_UNREF(str); + duk_push_size_t(thr, len); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Node.js Buffer.concat() + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_nodejs_buffer_concat(duk_hthread *thr) { + duk_hobject *h_arg; + duk_uint_t total_length; + duk_hbufobj *h_bufobj; + duk_hbufobj *h_bufres; + duk_hbuffer *h_val; + duk_uint_t i, n; + duk_uint8_t *p; + duk_size_t space_left; + duk_size_t copy_size; + + /* Node.js accepts only actual Arrays. */ + h_arg = duk_require_hobject(thr, 0); + if (DUK_HOBJECT_GET_CLASS_NUMBER(h_arg) != DUK_HOBJECT_CLASS_ARRAY) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + + /* Compute result length and validate argument buffers. */ + n = (duk_uint_t) duk_get_length(thr, 0); + total_length = 0; + for (i = 0; i < n; i++) { + /* Neutered checks not necessary here: neutered buffers have + * zero 'length' so we'll effectively skip them. + */ + DUK_ASSERT_TOP(thr, 2); /* [ array totalLength ] */ + duk_get_prop_index(thr, 0, (duk_uarridx_t) i); /* -> [ array totalLength buf ] */ + h_bufobj = duk__require_bufobj_value(thr, 2); + DUK_ASSERT(h_bufobj != NULL); + total_length += h_bufobj->length; + if (DUK_UNLIKELY(total_length < h_bufobj->length)) { + DUK_DCERROR_RANGE_INVALID_ARGS(thr); /* Wrapped. */ + } + duk_pop(thr); + } + /* In Node.js v0.12.1 a 1-element array is special and won't create a + * copy, this was fixed later so an explicit check no longer needed. + */ + + /* User totalLength overrides a computed length, but we'll check + * every copy in the copy loop. Note that duk_to_int() can + * technically have arbitrary side effects so we need to recheck + * the buffers in the copy loop. + */ + if (!duk_is_undefined(thr, 1) && n > 0) { + /* For n == 0, Node.js ignores totalLength argument and + * returns a zero length buffer. + */ + duk_int_t total_length_signed; + total_length_signed = duk_to_int(thr, 1); + if (total_length_signed < 0) { + DUK_DCERROR_RANGE_INVALID_ARGS(thr); + } + total_length = (duk_uint_t) total_length_signed; + } + + h_bufres = duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_BUFOBJ | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_UINT8ARRAY), + DUK_BIDX_NODEJS_BUFFER_PROTOTYPE); + DUK_ASSERT(h_bufres != NULL); + + p = (duk_uint8_t *) duk_push_fixed_buffer_zero(thr, + total_length); /* must be zeroed, all bytes not necessarily written over */ + DUK_ASSERT(p != NULL); + space_left = (duk_size_t) total_length; + + for (i = 0; i < n; i++) { + DUK_ASSERT_TOP(thr, 4); /* [ array totalLength bufres buf ] */ + + duk_get_prop_index(thr, 0, (duk_uarridx_t) i); + h_bufobj = duk__require_bufobj_value(thr, 4); + DUK_ASSERT(h_bufobj != NULL); + + copy_size = h_bufobj->length; + if (copy_size > space_left) { + copy_size = space_left; + } + + if (h_bufobj->buf != NULL && DUK_HBUFOBJ_VALID_SLICE(h_bufobj)) { + duk_memcpy_unsafe((void *) p, (const void *) DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_bufobj), copy_size); + } else { + /* Just skip, leaving zeroes in the result. */ + ; + } + p += copy_size; + space_left -= copy_size; + + duk_pop(thr); + } + + h_val = duk_known_hbuffer(thr, -1); + + duk__set_bufobj_buffer(thr, h_bufres, h_val); + h_bufres->is_typedarray = 1; + DUK_HBUFOBJ_ASSERT_VALID(h_bufres); + + duk_pop(thr); /* pop plain buffer, now reachable through h_bufres */ + + return 1; /* return h_bufres */ +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Shared readfield and writefield methods + * + * The readfield/writefield methods need support for endianness and field + * types. All offsets are byte based so no offset shifting is needed. + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +/* Format of magic, bits: + * 0...1: field type; 0=uint8, 1=uint16, 2=uint32, 3=float, 4=double, 5=unused, 6=unused, 7=unused + * 3: endianness: 0=little, 1=big + * 4: signed: 1=yes, 0=no + * 5: typedarray: 1=yes, 0=no + */ +#define DUK__FLD_8BIT 0 +#define DUK__FLD_16BIT 1 +#define DUK__FLD_32BIT 2 +#define DUK__FLD_FLOAT 3 +#define DUK__FLD_DOUBLE 4 +#define DUK__FLD_VARINT 5 +#define DUK__FLD_BIGENDIAN (1 << 3) +#define DUK__FLD_SIGNED (1 << 4) +#define DUK__FLD_TYPEDARRAY (1 << 5) + +/* XXX: split into separate functions for each field type? */ +DUK_INTERNAL duk_ret_t duk_bi_buffer_readfield(duk_hthread *thr) { + duk_small_uint_t magic = (duk_small_uint_t) duk_get_current_magic(thr); + duk_small_uint_t magic_ftype; + duk_small_uint_t magic_bigendian; + duk_small_uint_t magic_signed; + duk_small_uint_t magic_typedarray; + duk_small_uint_t endswap; + duk_hbufobj *h_this; + duk_bool_t no_assert; + duk_int_t offset_signed; + duk_uint_t offset; + duk_uint_t buffer_length; + duk_uint_t check_length; + duk_uint8_t *buf; + duk_double_union du; + + magic_ftype = magic & 0x0007U; + magic_bigendian = magic & 0x0008U; + magic_signed = magic & 0x0010U; + magic_typedarray = magic & 0x0020U; + + h_this = duk__require_bufobj_this(thr); /* XXX: very inefficient for plain buffers */ + DUK_ASSERT(h_this != NULL); + buffer_length = h_this->length; + + /* [ offset noAssert ], when ftype != DUK__FLD_VARINT */ + /* [ offset fieldByteLength noAssert ], when ftype == DUK__FLD_VARINT */ + /* [ offset littleEndian ], when DUK__FLD_TYPEDARRAY (regardless of ftype) */ + + /* Handle TypedArray vs. Node.js Buffer arg differences */ + if (magic_typedarray) { + no_assert = 0; +#if defined(DUK_USE_INTEGER_LE) + endswap = !duk_to_boolean(thr, 1); /* 1=little endian */ +#else + endswap = duk_to_boolean(thr, 1); /* 1=little endian */ +#endif + } else { + no_assert = duk_to_boolean(thr, (magic_ftype == DUK__FLD_VARINT) ? 2 : 1); +#if defined(DUK_USE_INTEGER_LE) + endswap = magic_bigendian; +#else + endswap = !magic_bigendian; +#endif + } + + /* Offset is coerced first to signed integer range and then to unsigned. + * This ensures we can add a small byte length (1-8) to the offset in + * bound checks and not wrap. + */ + offset_signed = duk_to_int(thr, 0); + offset = (duk_uint_t) offset_signed; + if (offset_signed < 0) { + goto fail_bounds; + } + + DUK_DDD(DUK_DDDPRINT("readfield, buffer_length=%ld, offset=%ld, no_assert=%d, " + "magic=%04x, magic_fieldtype=%d, magic_bigendian=%d, magic_signed=%d, " + "endswap=%u", + (long) buffer_length, + (long) offset, + (int) no_assert, + (unsigned int) magic, + (int) magic_ftype, + (int) (magic_bigendian >> 3), + (int) (magic_signed >> 4), + (int) endswap)); + + /* Update 'buffer_length' to be the effective, safe limit which + * takes into account the underlying buffer. This value will be + * potentially invalidated by any side effect. + */ + check_length = DUK_HBUFOBJ_CLAMP_BYTELENGTH(h_this, buffer_length); + DUK_DDD(DUK_DDDPRINT("buffer_length=%ld, check_length=%ld", (long) buffer_length, (long) check_length)); + + if (h_this->buf) { + buf = DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_this); + } else { + /* Neutered. We could go into the switch-case safely with + * buf == NULL because check_length == 0. To avoid scanbuild + * warnings, fail directly instead. + */ + DUK_ASSERT(check_length == 0); + goto fail_neutered; + } + DUK_ASSERT(buf != NULL); + + switch (magic_ftype) { + case DUK__FLD_8BIT: { + duk_uint8_t tmp; + if (offset + 1U > check_length) { + goto fail_bounds; + } + tmp = buf[offset]; + if (magic_signed) { + duk_push_int(thr, (duk_int_t) ((duk_int8_t) tmp)); + } else { + duk_push_uint(thr, (duk_uint_t) tmp); + } + break; + } + case DUK__FLD_16BIT: { + duk_uint16_t tmp; + if (offset + 2U > check_length) { + goto fail_bounds; + } + duk_memcpy((void *) du.uc, (const void *) (buf + offset), 2); + tmp = du.us[0]; + if (endswap) { + tmp = DUK_BSWAP16(tmp); + } + if (magic_signed) { + duk_push_int(thr, (duk_int_t) ((duk_int16_t) tmp)); + } else { + duk_push_uint(thr, (duk_uint_t) tmp); + } + break; + } + case DUK__FLD_32BIT: { + duk_uint32_t tmp; + if (offset + 4U > check_length) { + goto fail_bounds; + } + duk_memcpy((void *) du.uc, (const void *) (buf + offset), 4); + tmp = du.ui[0]; + if (endswap) { + tmp = DUK_BSWAP32(tmp); + } + if (magic_signed) { + duk_push_int(thr, (duk_int_t) ((duk_int32_t) tmp)); + } else { + duk_push_uint(thr, (duk_uint_t) tmp); + } + break; + } + case DUK__FLD_FLOAT: { + duk_uint32_t tmp; + if (offset + 4U > check_length) { + goto fail_bounds; + } + duk_memcpy((void *) du.uc, (const void *) (buf + offset), 4); + if (endswap) { + tmp = du.ui[0]; + tmp = DUK_BSWAP32(tmp); + du.ui[0] = tmp; + } + duk_push_number(thr, (duk_double_t) du.f[0]); + break; + } + case DUK__FLD_DOUBLE: { + if (offset + 8U > check_length) { + goto fail_bounds; + } + duk_memcpy((void *) du.uc, (const void *) (buf + offset), 8); + if (endswap) { + DUK_DBLUNION_BSWAP64(&du); + } + duk_push_number(thr, (duk_double_t) du.d); + break; + } + case DUK__FLD_VARINT: { + /* Node.js Buffer variable width integer field. We don't really + * care about speed here, so aim for shortest algorithm. + */ + duk_int_t field_bytelen; + duk_int_t i, i_step, i_end; +#if defined(DUK_USE_64BIT_OPS) + duk_int64_t tmp; + duk_small_uint_t shift_tmp; +#else + duk_double_t tmp; + duk_small_int_t highbyte; +#endif + const duk_uint8_t *p; + + field_bytelen = duk_get_int(thr, 1); /* avoid side effects! */ + if (field_bytelen < 1 || field_bytelen > 6) { + goto fail_field_length; + } + if (offset + (duk_uint_t) field_bytelen > check_length) { + goto fail_bounds; + } + p = (const duk_uint8_t *) (buf + offset); + + /* Slow gathering of value using either 64-bit arithmetic + * or IEEE doubles if 64-bit types not available. Handling + * of negative numbers is a bit non-obvious in both cases. + */ + + if (magic_bigendian) { + /* Gather in big endian */ + i = 0; + i_step = 1; + i_end = field_bytelen; /* one i_step over */ + } else { + /* Gather in little endian */ + i = field_bytelen - 1; + i_step = -1; + i_end = -1; /* one i_step over */ + } + +#if defined(DUK_USE_64BIT_OPS) + tmp = 0; + do { + DUK_ASSERT(i >= 0 && i < field_bytelen); + tmp = (tmp << 8) + (duk_int64_t) p[i]; + i += i_step; + } while (i != i_end); + + if (magic_signed) { + /* Shift to sign extend. Left shift must be unsigned + * to avoid undefined behavior; right shift must be + * signed to sign extend properly. + */ + shift_tmp = (duk_small_uint_t) (64U - (duk_small_uint_t) field_bytelen * 8U); + tmp = (duk_int64_t) ((duk_uint64_t) tmp << shift_tmp) >> shift_tmp; + } + + duk_push_i64(thr, tmp); +#else + highbyte = p[i]; + if (magic_signed && (highbyte & 0x80) != 0) { + /* 0xff => 255 - 256 = -1; 0x80 => 128 - 256 = -128 */ + tmp = (duk_double_t) (highbyte - 256); + } else { + tmp = (duk_double_t) highbyte; + } + for (;;) { + i += i_step; + if (i == i_end) { + break; + } + DUK_ASSERT(i >= 0 && i < field_bytelen); + tmp = (tmp * 256.0) + (duk_double_t) p[i]; + } + + duk_push_number(thr, tmp); +#endif + break; + } + default: { /* should never happen but default here */ + goto fail_bounds; + } + } + + return 1; + +fail_neutered: +fail_field_length: +fail_bounds: + if (no_assert) { + /* Node.js return value for noAssert out-of-bounds reads is + * usually (but not always) NaN. Return NaN consistently. + */ + duk_push_nan(thr); + return 1; + } + DUK_DCERROR_RANGE_INVALID_ARGS(thr); +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +/* XXX: split into separate functions for each field type? */ +DUK_INTERNAL duk_ret_t duk_bi_buffer_writefield(duk_hthread *thr) { + duk_small_uint_t magic = (duk_small_uint_t) duk_get_current_magic(thr); + duk_small_uint_t magic_ftype; + duk_small_uint_t magic_bigendian; + duk_small_uint_t magic_signed; + duk_small_uint_t magic_typedarray; + duk_small_uint_t endswap; + duk_hbufobj *h_this; + duk_bool_t no_assert; + duk_int_t offset_signed; + duk_uint_t offset; + duk_uint_t buffer_length; + duk_uint_t check_length; + duk_uint8_t *buf; + duk_double_union du; + duk_int_t nbytes = 0; + + magic_ftype = magic & 0x0007U; + magic_bigendian = magic & 0x0008U; + magic_signed = magic & 0x0010U; + magic_typedarray = magic & 0x0020U; + DUK_UNREF(magic_signed); + + h_this = duk__require_bufobj_this(thr); /* XXX: very inefficient for plain buffers */ + DUK_ASSERT(h_this != NULL); + buffer_length = h_this->length; + + /* [ value offset noAssert ], when ftype != DUK__FLD_VARINT */ + /* [ value offset fieldByteLength noAssert ], when ftype == DUK__FLD_VARINT */ + /* [ offset value littleEndian ], when DUK__FLD_TYPEDARRAY (regardless of ftype) */ + + /* Handle TypedArray vs. Node.js Buffer arg differences */ + if (magic_typedarray) { + no_assert = 0; +#if defined(DUK_USE_INTEGER_LE) + endswap = !duk_to_boolean(thr, 2); /* 1=little endian */ +#else + endswap = duk_to_boolean(thr, 2); /* 1=little endian */ +#endif + duk_swap(thr, 0, 1); /* offset/value order different from Node.js */ + } else { + no_assert = duk_to_boolean(thr, (magic_ftype == DUK__FLD_VARINT) ? 3 : 2); +#if defined(DUK_USE_INTEGER_LE) + endswap = magic_bigendian; +#else + endswap = !magic_bigendian; +#endif + } + + /* Offset is coerced first to signed integer range and then to unsigned. + * This ensures we can add a small byte length (1-8) to the offset in + * bound checks and not wrap. + */ + offset_signed = duk_to_int(thr, 1); + offset = (duk_uint_t) offset_signed; + + /* We need 'nbytes' even for a failed offset; return value must be + * (offset + nbytes) even when write fails due to invalid offset. + */ + if (magic_ftype != DUK__FLD_VARINT) { + DUK_ASSERT(magic_ftype < (duk_small_uint_t) (sizeof(duk__buffer_nbytes_from_fldtype) / sizeof(duk_uint8_t))); + nbytes = duk__buffer_nbytes_from_fldtype[magic_ftype]; + } else { + nbytes = duk_get_int(thr, 2); + if (nbytes < 1 || nbytes > 6) { + goto fail_field_length; + } + } + DUK_ASSERT(nbytes >= 1 && nbytes <= 8); + + /* Now we can check offset validity. */ + if (offset_signed < 0) { + goto fail_bounds; + } + + DUK_DDD(DUK_DDDPRINT("writefield, value=%!T, buffer_length=%ld, offset=%ld, no_assert=%d, " + "magic=%04x, magic_fieldtype=%d, magic_bigendian=%d, magic_signed=%d, " + "endswap=%u", + duk_get_tval(thr, 0), + (long) buffer_length, + (long) offset, + (int) no_assert, + (unsigned int) magic, + (int) magic_ftype, + (int) (magic_bigendian >> 3), + (int) (magic_signed >> 4), + (int) endswap)); + + /* Coerce value to a number before computing check_length, so that + * the field type specific coercion below can't have side effects + * that would invalidate check_length. + */ + duk_to_number(thr, 0); + + /* Update 'buffer_length' to be the effective, safe limit which + * takes into account the underlying buffer. This value will be + * potentially invalidated by any side effect. + */ + check_length = DUK_HBUFOBJ_CLAMP_BYTELENGTH(h_this, buffer_length); + DUK_DDD(DUK_DDDPRINT("buffer_length=%ld, check_length=%ld", (long) buffer_length, (long) check_length)); + + if (h_this->buf) { + buf = DUK_HBUFOBJ_GET_SLICE_BASE(thr->heap, h_this); + } else { + /* Neutered. We could go into the switch-case safely with + * buf == NULL because check_length == 0. To avoid scanbuild + * warnings, fail directly instead. + */ + DUK_ASSERT(check_length == 0); + goto fail_neutered; + } + DUK_ASSERT(buf != NULL); + + switch (magic_ftype) { + case DUK__FLD_8BIT: { + if (offset + 1U > check_length) { + goto fail_bounds; + } + /* sign doesn't matter when writing */ + buf[offset] = (duk_uint8_t) duk_to_uint32(thr, 0); + break; + } + case DUK__FLD_16BIT: { + duk_uint16_t tmp; + if (offset + 2U > check_length) { + goto fail_bounds; + } + tmp = (duk_uint16_t) duk_to_uint32(thr, 0); + if (endswap) { + tmp = DUK_BSWAP16(tmp); + } + du.us[0] = tmp; + /* sign doesn't matter when writing */ + duk_memcpy((void *) (buf + offset), (const void *) du.uc, 2); + break; + } + case DUK__FLD_32BIT: { + duk_uint32_t tmp; + if (offset + 4U > check_length) { + goto fail_bounds; + } + tmp = (duk_uint32_t) duk_to_uint32(thr, 0); + if (endswap) { + tmp = DUK_BSWAP32(tmp); + } + du.ui[0] = tmp; + /* sign doesn't matter when writing */ + duk_memcpy((void *) (buf + offset), (const void *) du.uc, 4); + break; + } + case DUK__FLD_FLOAT: { + duk_uint32_t tmp; + if (offset + 4U > check_length) { + goto fail_bounds; + } + du.f[0] = (duk_float_t) duk_to_number(thr, 0); + if (endswap) { + tmp = du.ui[0]; + tmp = DUK_BSWAP32(tmp); + du.ui[0] = tmp; + } + /* sign doesn't matter when writing */ + duk_memcpy((void *) (buf + offset), (const void *) du.uc, 4); + break; + } + case DUK__FLD_DOUBLE: { + if (offset + 8U > check_length) { + goto fail_bounds; + } + du.d = (duk_double_t) duk_to_number(thr, 0); + if (endswap) { + DUK_DBLUNION_BSWAP64(&du); + } + /* sign doesn't matter when writing */ + duk_memcpy((void *) (buf + offset), (const void *) du.uc, 8); + break; + } + case DUK__FLD_VARINT: { + /* Node.js Buffer variable width integer field. We don't really + * care about speed here, so aim for shortest algorithm. + */ + duk_int_t field_bytelen; + duk_int_t i, i_step, i_end; +#if defined(DUK_USE_64BIT_OPS) + duk_int64_t tmp; +#else + duk_double_t tmp; +#endif + duk_uint8_t *p; + + field_bytelen = (duk_int_t) nbytes; + if (offset + (duk_uint_t) field_bytelen > check_length) { + goto fail_bounds; + } + + /* Slow writing of value using either 64-bit arithmetic + * or IEEE doubles if 64-bit types not available. There's + * no special sign handling when writing varints. + */ + + if (magic_bigendian) { + /* Write in big endian */ + i = field_bytelen; /* one i_step added at top of loop */ + i_step = -1; + i_end = 0; + } else { + /* Write in little endian */ + i = -1; /* one i_step added at top of loop */ + i_step = 1; + i_end = field_bytelen - 1; + } + + /* XXX: The duk_to_number() cast followed by integer coercion + * is platform specific so NaN, +/- Infinity, and out-of-bounds + * values result in platform specific output now. + * See: test-bi-nodejs-buffer-proto-varint-special.js + */ + +#if defined(DUK_USE_64BIT_OPS) + tmp = (duk_int64_t) duk_to_number(thr, 0); + p = (duk_uint8_t *) (buf + offset); + do { + i += i_step; + DUK_ASSERT(i >= 0 && i < field_bytelen); + p[i] = (duk_uint8_t) (tmp & 0xff); + tmp = tmp >> 8; /* unnecessary shift for last byte */ + } while (i != i_end); +#else + tmp = duk_to_number(thr, 0); + p = (duk_uint8_t *) (buf + offset); + do { + i += i_step; + tmp = DUK_FLOOR(tmp); + DUK_ASSERT(i >= 0 && i < field_bytelen); + p[i] = (duk_uint8_t) (DUK_FMOD(tmp, 256.0)); + tmp = tmp / 256.0; /* unnecessary div for last byte */ + } while (i != i_end); +#endif + break; + } + default: { /* should never happen but default here */ + goto fail_bounds; + } + } + + /* Node.js Buffer: return offset + #bytes written (i.e. next + * write offset). + */ + if (magic_typedarray) { + /* For TypedArrays 'undefined' return value is specified + * by ES2015 (matches V8). + */ + return 0; + } + duk_push_uint(thr, offset + (duk_uint_t) nbytes); + return 1; + +fail_neutered: +fail_field_length: +fail_bounds: + if (no_assert) { + /* Node.js return value for failed writes is offset + #bytes + * that would have been written. + */ + /* XXX: for negative input offsets, 'offset' will be a large + * positive value so the result here is confusing. + */ + if (magic_typedarray) { + return 0; + } + duk_push_uint(thr, offset + (duk_uint_t) nbytes); + return 1; + } + DUK_DCERROR_RANGE_INVALID_ARGS(thr); +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * Accessors for .buffer, .byteLength, .byteOffset + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_LOCAL duk_hbufobj *duk__autospawn_arraybuffer(duk_hthread *thr, duk_hbuffer *h_buf) { + duk_hbufobj *h_res; + + h_res = duk_push_bufobj_raw(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_BUFOBJ | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_ARRAYBUFFER), + DUK_BIDX_ARRAYBUFFER_PROTOTYPE); + DUK_ASSERT(h_res != NULL); + DUK_UNREF(h_res); + + duk__set_bufobj_buffer(thr, h_res, h_buf); + DUK_HBUFOBJ_ASSERT_VALID(h_res); + DUK_ASSERT(h_res->buf_prop == NULL); + return h_res; +} + +DUK_INTERNAL duk_ret_t duk_bi_typedarray_buffer_getter(duk_hthread *thr) { + duk_hbufobj *h_bufobj; + + h_bufobj = (duk_hbufobj *) duk__getrequire_bufobj_this(thr, DUK__BUFOBJ_FLAG_THROW /*flags*/); + DUK_ASSERT(h_bufobj != NULL); + if (DUK_HEAPHDR_IS_BUFFER((duk_heaphdr *) h_bufobj)) { + DUK_DD(DUK_DDPRINT("autospawn ArrayBuffer for plain buffer")); + (void) duk__autospawn_arraybuffer(thr, (duk_hbuffer *) h_bufobj); + return 1; + } else { + if (h_bufobj->buf_prop == NULL && + DUK_HOBJECT_GET_CLASS_NUMBER((duk_hobject *) h_bufobj) != DUK_HOBJECT_CLASS_ARRAYBUFFER && + h_bufobj->buf != NULL) { + duk_hbufobj *h_arrbuf; + + DUK_DD(DUK_DDPRINT("autospawn ArrayBuffer for typed array or DataView")); + h_arrbuf = duk__autospawn_arraybuffer(thr, h_bufobj->buf); + + if (h_bufobj->buf_prop == NULL) { + /* Must recheck buf_prop, in case ArrayBuffer + * alloc had a side effect which already filled + * it! + */ + + /* Set ArrayBuffer's .byteOffset and .byteLength based + * on the view so that Arraybuffer[view.byteOffset] + * matches view[0]. + */ + h_arrbuf->offset = 0; + DUK_ASSERT(h_bufobj->offset + h_bufobj->length >= h_bufobj->offset); /* Wrap check on creation. */ + h_arrbuf->length = h_bufobj->offset + h_bufobj->length; + DUK_ASSERT(h_arrbuf->buf_prop == NULL); + + DUK_ASSERT(h_bufobj->buf_prop == NULL); + h_bufobj->buf_prop = (duk_hobject *) h_arrbuf; + DUK_HBUFOBJ_INCREF(thr, h_arrbuf); /* Now reachable and accounted for. */ + } + + /* Left on stack; pushed for the second time below (OK). */ + } + if (h_bufobj->buf_prop) { + duk_push_hobject(thr, h_bufobj->buf_prop); + return 1; + } + } + return 0; +} + +DUK_INTERNAL duk_ret_t duk_bi_typedarray_byteoffset_getter(duk_hthread *thr) { + duk_hbufobj *h_bufobj; + + h_bufobj = (duk_hbufobj *) duk__getrequire_bufobj_this(thr, DUK__BUFOBJ_FLAG_THROW /*flags*/); + DUK_ASSERT(h_bufobj != NULL); + if (DUK_HEAPHDR_IS_BUFFER((duk_heaphdr *) h_bufobj)) { + duk_push_uint(thr, 0); + } else { + /* If neutered must return 0; offset is zeroed during + * neutering. + */ + duk_push_uint(thr, h_bufobj->offset); + } + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_typedarray_bytelength_getter(duk_hthread *thr) { + duk_hbufobj *h_bufobj; + + h_bufobj = (duk_hbufobj *) duk__getrequire_bufobj_this(thr, DUK__BUFOBJ_FLAG_THROW /*flags*/); + DUK_ASSERT(h_bufobj != NULL); + if (DUK_HEAPHDR_IS_BUFFER((duk_heaphdr *) h_bufobj)) { + duk_hbuffer *h_buf; + + h_buf = (duk_hbuffer *) h_bufobj; + DUK_ASSERT(DUK_HBUFFER_GET_SIZE(h_buf) <= DUK_UINT_MAX); /* Buffer limits. */ + duk_push_uint(thr, (duk_uint_t) DUK_HBUFFER_GET_SIZE(h_buf)); + } else { + /* If neutered must return 0; length is zeroed during + * neutering. + */ + duk_push_uint(thr, h_bufobj->length); + } + return 1; +} +#else /* DUK_USE_BUFFEROBJECT_SUPPORT */ +/* No .buffer getter without ArrayBuffer support. */ +#if 0 +DUK_INTERNAL duk_ret_t duk_bi_typedarray_buffer_getter(duk_hthread *thr) { + return 0; +} +#endif + +DUK_INTERNAL duk_ret_t duk_bi_typedarray_byteoffset_getter(duk_hthread *thr) { + duk_push_uint(thr, 0); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_typedarray_bytelength_getter(duk_hthread *thr) { + duk_hbuffer *h_buf; + + /* XXX: helper? */ + duk_push_this(thr); + h_buf = duk_require_hbuffer(thr, -1); + duk_push_uint(thr, DUK_HBUFFER_GET_SIZE(h_buf)); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* automatic undefs */ +#undef DUK__BUFOBJ_FLAG_PROMOTE +#undef DUK__BUFOBJ_FLAG_THROW +#undef DUK__FLD_16BIT +#undef DUK__FLD_32BIT +#undef DUK__FLD_8BIT +#undef DUK__FLD_BIGENDIAN +#undef DUK__FLD_DOUBLE +#undef DUK__FLD_FLOAT +#undef DUK__FLD_SIGNED +#undef DUK__FLD_TYPEDARRAY +#undef DUK__FLD_VARINT +#line 1 "duk_bi_cbor.c" +/* + * CBOR bindings. + * + * http://cbor.io/ + * https://tools.ietf.org/html/rfc7049 + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_CBOR_SUPPORT) + +/* #define DUK_CBOR_STRESS */ + +/* Default behavior for encoding strings: use CBOR text string if string + * is UTF-8 compatible, otherwise use CBOR byte string. These defines + * can be used to force either type for all strings. Using text strings + * for non-UTF-8 data is technically invalid CBOR. + */ +/* #define DUK_CBOR_TEXT_STRINGS */ +/* #define DUK_CBOR_BYTE_STRINGS */ + +/* Misc. defines. */ +/* #define DUK_CBOR_PREFER_SIZE */ +/* #define DUK_CBOR_DOUBLE_AS_IS */ +/* #define DUK_CBOR_DECODE_FASTPATH */ + +typedef struct { + duk_hthread *thr; + duk_uint8_t *ptr; + duk_uint8_t *buf; + duk_uint8_t *buf_end; + duk_size_t len; + duk_idx_t idx_buf; + duk_uint_t recursion_depth; + duk_uint_t recursion_limit; +} duk_cbor_encode_context; + +typedef struct { + duk_hthread *thr; + const duk_uint8_t *buf; + duk_size_t off; + duk_size_t len; + duk_uint_t recursion_depth; + duk_uint_t recursion_limit; +} duk_cbor_decode_context; + +DUK_LOCAL void duk__cbor_encode_value(duk_cbor_encode_context *enc_ctx); +DUK_LOCAL void duk__cbor_decode_value(duk_cbor_decode_context *dec_ctx); + +/* + * Misc + */ + +DUK_LOCAL duk_uint32_t duk__cbor_double_to_uint32(double d) { + /* Out of range casts are undefined behavior, so caller must avoid. */ + DUK_ASSERT(d >= 0.0 && d <= 4294967295.0); + return (duk_uint32_t) d; +} + +/* + * Encoding + */ + +DUK_LOCAL void duk__cbor_encode_error(duk_cbor_encode_context *enc_ctx) { + (void) duk_type_error(enc_ctx->thr, "cbor encode error"); +} + +DUK_LOCAL void duk__cbor_encode_req_stack(duk_cbor_encode_context *enc_ctx) { + duk_require_stack(enc_ctx->thr, 4); +} + +DUK_LOCAL void duk__cbor_encode_objarr_entry(duk_cbor_encode_context *enc_ctx) { + duk_hthread *thr = enc_ctx->thr; + + /* Native stack check in object/array recursion. */ + duk_native_stack_check(thr); + + /* When working with deeply recursive structures, this is important + * to ensure there's no effective depth limit. + */ + duk__cbor_encode_req_stack(enc_ctx); + + DUK_ASSERT(enc_ctx->recursion_depth <= enc_ctx->recursion_limit); + if (enc_ctx->recursion_depth >= enc_ctx->recursion_limit) { + DUK_ERROR_RANGE(thr, DUK_STR_ENC_RECLIMIT); + DUK_WO_NORETURN(return;); + } + enc_ctx->recursion_depth++; +} + +DUK_LOCAL void duk__cbor_encode_objarr_exit(duk_cbor_encode_context *enc_ctx) { + DUK_ASSERT(enc_ctx->recursion_depth > 0); + enc_ctx->recursion_depth--; +} + +/* Check that a size_t is in uint32 range to avoid out-of-range casts. */ +DUK_LOCAL void duk__cbor_encode_sizet_uint32_check(duk_cbor_encode_context *enc_ctx, duk_size_t len) { + if (DUK_UNLIKELY(sizeof(duk_size_t) > sizeof(duk_uint32_t) && len > (duk_size_t) DUK_UINT32_MAX)) { + duk__cbor_encode_error(enc_ctx); + } +} + +DUK_LOCAL DUK_NOINLINE void duk__cbor_encode_ensure_slowpath(duk_cbor_encode_context *enc_ctx, duk_size_t len) { + duk_size_t oldlen; + duk_size_t minlen; + duk_size_t newlen; + duk_uint8_t *p_new; + duk_size_t old_data_len; + + DUK_ASSERT(enc_ctx->ptr >= enc_ctx->buf); + DUK_ASSERT(enc_ctx->buf_end >= enc_ctx->ptr); + DUK_ASSERT(enc_ctx->buf_end >= enc_ctx->buf); + + /* Overflow check. + * + * Limit example: 0xffffffffUL / 2U = 0x7fffffffUL, we reject >= 0x80000000UL. + */ + oldlen = enc_ctx->len; + minlen = oldlen + len; + if (DUK_UNLIKELY(oldlen > DUK_SIZE_MAX / 2U || minlen < oldlen)) { + duk__cbor_encode_error(enc_ctx); + } + +#if defined(DUK_CBOR_STRESS) + newlen = oldlen + 1U; +#else + newlen = oldlen * 2U; +#endif + DUK_ASSERT(newlen >= oldlen); + + if (minlen > newlen) { + newlen = minlen; + } + DUK_ASSERT(newlen >= oldlen); + DUK_ASSERT(newlen >= minlen); + DUK_ASSERT(newlen > 0U); + + DUK_DD(DUK_DDPRINT("cbor encode buffer resized to %ld", (long) newlen)); + + p_new = (duk_uint8_t *) duk_resize_buffer(enc_ctx->thr, enc_ctx->idx_buf, newlen); + DUK_ASSERT(p_new != NULL); + old_data_len = (duk_size_t) (enc_ctx->ptr - enc_ctx->buf); + enc_ctx->buf = p_new; + enc_ctx->buf_end = p_new + newlen; + enc_ctx->ptr = p_new + old_data_len; + enc_ctx->len = newlen; +} + +DUK_LOCAL DUK_INLINE void duk__cbor_encode_ensure(duk_cbor_encode_context *enc_ctx, duk_size_t len) { + if (DUK_LIKELY((duk_size_t) (enc_ctx->buf_end - enc_ctx->ptr) >= len)) { + return; + } + duk__cbor_encode_ensure_slowpath(enc_ctx, len); +} + +DUK_LOCAL duk_size_t duk__cbor_get_reserve(duk_cbor_encode_context *enc_ctx) { + DUK_ASSERT(enc_ctx->ptr >= enc_ctx->buf); + DUK_ASSERT(enc_ctx->ptr <= enc_ctx->buf_end); + return (duk_size_t) (enc_ctx->buf_end - enc_ctx->ptr); +} + +DUK_LOCAL void duk__cbor_encode_uint32(duk_cbor_encode_context *enc_ctx, duk_uint32_t u, duk_uint8_t base) { + duk_uint8_t *p; + + /* Caller must ensure space. */ + DUK_ASSERT(duk__cbor_get_reserve(enc_ctx) >= 1 + 4); + + p = enc_ctx->ptr; + if (DUK_LIKELY(u <= 23U)) { + *p++ = (duk_uint8_t) (base + (duk_uint8_t) u); + } else if (u <= 0xffUL) { + *p++ = base + 0x18U; + *p++ = (duk_uint8_t) u; + } else if (u <= 0xffffUL) { + *p++ = base + 0x19U; + DUK_RAW_WRITEINC_U16_BE(p, (duk_uint16_t) u); + } else { + *p++ = base + 0x1aU; + DUK_RAW_WRITEINC_U32_BE(p, u); + } + enc_ctx->ptr = p; +} + +#if defined(DUK_CBOR_DOUBLE_AS_IS) +DUK_LOCAL void duk__cbor_encode_double(duk_cbor_encode_context *enc_ctx, double d) { + duk_uint8_t *p; + + /* Caller must ensure space. */ + DUK_ASSERT(duk__cbor_get_reserve(enc_ctx) >= 1 + 8); + + p = enc_ctx->ptr; + *p++ = 0xfbU; + DUK_RAW_WRITEINC_DOUBLE_BE(p, d); + p += 8; + enc_ctx->ptr = p; +} +#else /* DUK_CBOR_DOUBLE_AS_IS */ +DUK_LOCAL void duk__cbor_encode_double_fp(duk_cbor_encode_context *enc_ctx, double d) { + duk_double_union u; + duk_uint16_t u16; + duk_int16_t expt; + duk_uint8_t *p; + + DUK_ASSERT(DUK_FPCLASSIFY(d) != DUK_FP_ZERO); + + /* Caller must ensure space. */ + DUK_ASSERT(duk__cbor_get_reserve(enc_ctx) >= 1 + 8); + + /* Organize into little endian (no-op if platform is little endian). */ + u.d = d; + duk_dblunion_host_to_little(&u); + + /* Check if 'd' can represented as a normal half-float. + * Denormal half-floats could also be used, but that check + * isn't done now (denormal half-floats are decoded of course). + * So just check exponent range and that at most 10 significant + * bits (excluding implicit leading 1) are used in 'd'. + */ + u16 = (((duk_uint16_t) u.uc[7]) << 8) | ((duk_uint16_t) u.uc[6]); + expt = (duk_int16_t) ((u16 & 0x7ff0U) >> 4) - 1023; + + if (expt >= -14 && expt <= 15) { + /* Half-float normal exponents (excl. denormals). + * + * 7 6 5 4 3 2 1 0 (LE index) + * double: seeeeeee eeeemmmm mmmmmmmm mmmmmmmm mmmmmmmm mmmmmmmm mmmmmmmm mmmmmmmm + * half: seeeee mmmm mmmmmm00 00000000 00000000 00000000 00000000 00000000 + */ + duk_bool_t use_half_float; + + use_half_float = + (u.uc[0] == 0 && u.uc[1] == 0 && u.uc[2] == 0 && u.uc[3] == 0 && u.uc[4] == 0 && (u.uc[5] & 0x03U) == 0); + + if (use_half_float) { + duk_uint32_t t; + + expt += 15; + t = (duk_uint32_t) (u.uc[7] & 0x80U) << 8; + t += (duk_uint32_t) expt << 10; + t += ((duk_uint32_t) u.uc[6] & 0x0fU) << 6; + t += ((duk_uint32_t) u.uc[5]) >> 2; + + /* seeeeemm mmmmmmmm */ + p = enc_ctx->ptr; + *p++ = 0xf9U; + DUK_RAW_WRITEINC_U16_BE(p, (duk_uint16_t) t); + enc_ctx->ptr = p; + return; + } + } + + /* Same check for plain float. Also no denormal support here. */ + if (expt >= -126 && expt <= 127) { + /* Float normal exponents (excl. denormals). + * + * double: seeeeeee eeeemmmm mmmmmmmm mmmmmmmm mmmmmmmm mmmmmmmm mmmmmmmm mmmmmmmm + * float: seeee eeeemmmm mmmmmmmm mmmmmmmm mmm00000 00000000 00000000 00000000 + */ + duk_bool_t use_float; + duk_float_t d_float; + + /* We could do this explicit mantissa check, but doing + * a double-float-double cast is fine because we've + * already verified that the exponent is in range so + * that the narrower cast is not undefined behavior. + */ +#if 0 + use_float = + (u.uc[0] == 0 && u.uc[1] == 0 && u.uc[2] == 0 && (u.uc[3] & 0xe0U) == 0); +#endif + d_float = (duk_float_t) d; + use_float = duk_double_equals((duk_double_t) d_float, d); + if (use_float) { + p = enc_ctx->ptr; + *p++ = 0xfaU; + DUK_RAW_WRITEINC_FLOAT_BE(p, d_float); + enc_ctx->ptr = p; + return; + } + } + + /* Special handling for NaN and Inf which we want to encode as + * half-floats. They share the same (maximum) exponent. + */ + if (expt == 1024) { + DUK_ASSERT(DUK_ISNAN(d) || DUK_ISINF(d)); + p = enc_ctx->ptr; + *p++ = 0xf9U; + if (DUK_ISNAN(d)) { + /* Shortest NaN encoding is using a half-float. Lose the + * exact NaN bits in the process. IEEE double would be + * 7ff8 0000 0000 0000, i.e. a quiet NaN in most architectures + * (https://en.wikipedia.org/wiki/NaN#Encoding). The + * equivalent half float is 7e00. + */ + *p++ = 0x7eU; + } else { + /* Shortest +/- Infinity encoding is using a half-float. */ + if (DUK_SIGNBIT(d)) { + *p++ = 0xfcU; + } else { + *p++ = 0x7cU; + } + } + *p++ = 0x00U; + enc_ctx->ptr = p; + return; + } + + /* Cannot use half-float or float, encode as full IEEE double. */ + p = enc_ctx->ptr; + *p++ = 0xfbU; + DUK_RAW_WRITEINC_DOUBLE_BE(p, d); + enc_ctx->ptr = p; +} + +DUK_LOCAL void duk__cbor_encode_double(duk_cbor_encode_context *enc_ctx, double d) { + duk_uint8_t *p; + double d_floor; + + /* Integers and floating point values of all types are conceptually + * equivalent in CBOR. Try to always choose the shortest encoding + * which is not always immediately obvious. For example, NaN and Inf + * can be most compactly represented as a half-float (assuming NaN + * bits are not preserved), and 0x1'0000'0000 as a single precision + * float. Shortest forms in preference order (prefer integer over + * float when equal length): + * + * uint 1 byte [0,23] (not -0) + * sint 1 byte [-24,-1] + * uint+1 2 bytes [24,255] + * sint+1 2 bytes [-256,-25] + * uint+2 3 bytes [256,65535] + * sint+2 3 bytes [-65536,-257] + * half-float 3 bytes -0, NaN, +/- Infinity, range [-65504,65504] + * uint+4 5 bytes [65536,4294967295] + * sint+4 5 bytes [-4294967296,-258] + * float 5 bytes range [-(1 - 2^(-24)) * 2^128, (1 - 2^(-24)) * 2^128] + * uint+8 9 bytes [4294967296,18446744073709551615] + * sint+8 9 bytes [-18446744073709551616,-4294967297] + * double 9 bytes + * + * For whole numbers (compatible with integers): + * - 1-byte or 2-byte uint/sint representation is preferred for + * [-256,255]. + * - 3-byte uint/sint is preferred for [-65536,65535]. Half floats + * are never preferred because they have the same length. + * - 5-byte uint/sint is preferred for [-4294967296,4294967295]. + * Single precision floats are never preferred, and half-floats + * don't reach above the 3-byte uint/sint range so they're never + * preferred. + * - So, for all integers up to signed/unsigned 32-bit range the + * preferred encoding is always an integer uint/sint. + * - For integers above 32 bits the situation is more complicated. + * Half-floats are never useful for them because of their limited + * range, but IEEE single precision floats (5 bytes encoded) can + * represent some integers between the 32-bit and 64-bit ranges + * which require 9 bytes as a uint/sint. + * + * For floating point values not compatible with integers, the + * preferred encoding is quite clear: + * - For +Inf/-Inf use half-float. + * - For NaN use a half-float, assuming NaN bits ("payload") is + * not worth preserving. Duktape doesn't in general guarantee + * preservation of the NaN payload so using a half-float seems + * consistent with that. + * - For remaining values, prefer the shortest form which doesn't + * lose any precision. For normal half-floats and single precision + * floats this is simple: just check exponent and mantissa bits + * using a fixed mask. For denormal half-floats and single + * precision floats the check is a bit more complicated: a normal + * IEEE double can sometimes be represented as a denormal + * half-float or single precision float. + * + * https://en.wikipedia.org/wiki/Half-precision_floating-point_format#IEEE_754_half-precision_binary_floating-point_format:_binary16 + */ + + /* Caller must ensure space. */ + DUK_ASSERT(duk__cbor_get_reserve(enc_ctx) >= 1 + 8); + + /* Most important path is integers. The floor() test will be true + * for Inf too (but not NaN). + */ + d_floor = DUK_FLOOR(d); /* identity if d is +/- 0.0, NaN, or +/- Infinity */ + if (DUK_LIKELY(duk_double_equals(d_floor, d) != 0)) { + DUK_ASSERT(!DUK_ISNAN(d)); /* NaN == NaN compares false. */ + if (DUK_SIGNBIT(d)) { + if (d >= -4294967296.0) { + d = -1.0 - d; + if (d >= 0.0) { + DUK_ASSERT(d >= 0.0); + duk__cbor_encode_uint32(enc_ctx, duk__cbor_double_to_uint32(d), 0x20U); + return; + } + + /* Input was negative zero, d == -1.0 < 0.0. + * Shortest -0 is using half-float. + */ + p = enc_ctx->ptr; + *p++ = 0xf9U; + *p++ = 0x80U; + *p++ = 0x00U; + enc_ctx->ptr = p; + return; + } + } else { + if (d <= 4294967295.0) { + /* Positive zero needs no special handling. */ + DUK_ASSERT(d >= 0.0); + duk__cbor_encode_uint32(enc_ctx, duk__cbor_double_to_uint32(d), 0x00U); + return; + } + } + } + + /* 64-bit integers are not supported at present. So + * we also don't need to deal with choosing between a + * 64-bit uint/sint representation vs. IEEE double or + * float. + */ + + DUK_ASSERT(DUK_FPCLASSIFY(d) != DUK_FP_ZERO); + duk__cbor_encode_double_fp(enc_ctx, d); +} +#endif /* DUK_CBOR_DOUBLE_AS_IS */ + +DUK_LOCAL void duk__cbor_encode_string_top(duk_cbor_encode_context *enc_ctx) { + const duk_uint8_t *str; + duk_size_t len; + duk_uint8_t *p; + + /* CBOR differentiates between UTF-8 text strings and byte strings. + * Text strings MUST be valid UTF-8, so not all Duktape strings can + * be encoded as valid CBOR text strings. Possible behaviors: + * + * 1. Use text string when input is valid UTF-8, otherwise use + * byte string (maybe tagged to indicate it was an extended + * UTF-8 string). + * 2. Always use text strings, but sanitize input string so that + * invalid UTF-8 is replaced with U+FFFD for example. Combine + * surrogates whenever possible. + * 3. Always use byte strings. This is simple and produces valid + * CBOR, but isn't ideal for interoperability. + * 4. Always use text strings, even for invalid UTF-8 such as + * codepoints in the surrogate pair range. This is simple but + * produces technically invalid CBOR for non-UTF-8 strings which + * may affect interoperability. + * + * Current default is 1; can be changed with defines. + */ + + /* Caller must ensure space. */ + DUK_ASSERT(duk__cbor_get_reserve(enc_ctx) >= 1 + 8); + + str = (const duk_uint8_t *) duk_require_lstring(enc_ctx->thr, -1, &len); + if (duk_is_symbol(enc_ctx->thr, -1)) { + /* Symbols, encode as an empty table for now. This matches + * the behavior of cbor-js. + * + * XXX: Maybe encode String() coercion with a tag? + * XXX: Option to keep enough information to recover + * Symbols when decoding (this is not always desirable). + */ + p = enc_ctx->ptr; + *p++ = 0xa0U; + enc_ctx->ptr = p; + return; + } + + duk__cbor_encode_sizet_uint32_check(enc_ctx, len); +#if defined(DUK_CBOR_TEXT_STRINGS) + duk__cbor_encode_uint32(enc_ctx, (duk_uint32_t) len, 0x60U); +#elif defined(DUK_CBOR_BYTE_STRINGS) + duk__cbor_encode_uint32(enc_ctx, (duk_uint32_t) len, 0x40U); +#else + duk__cbor_encode_uint32(enc_ctx, + (duk_uint32_t) len, + (DUK_LIKELY(duk_unicode_is_utf8_compatible(str, len) != 0) ? 0x60U : 0x40U)); +#endif + duk__cbor_encode_ensure(enc_ctx, len); + p = enc_ctx->ptr; + duk_memcpy((void *) p, (const void *) str, len); + p += len; + enc_ctx->ptr = p; +} + +DUK_LOCAL void duk__cbor_encode_object(duk_cbor_encode_context *enc_ctx) { + duk_uint8_t *buf; + duk_size_t len; + duk_uint8_t *p; + duk_size_t i; + duk_size_t off_ib; + duk_uint32_t count; + + /* Caller must ensure space. */ + DUK_ASSERT(duk__cbor_get_reserve(enc_ctx) >= 1 + 8); + + duk__cbor_encode_objarr_entry(enc_ctx); + + /* XXX: Support for specific built-ins like Date and RegExp. */ + if (duk_is_array(enc_ctx->thr, -1)) { + /* Shortest encoding for arrays >= 256 in length is actually + * the indefinite length one (3 or more bytes vs. 2 bytes). + * We still use the definite length version because it is + * more decoding friendly. + */ + len = duk_get_length(enc_ctx->thr, -1); + duk__cbor_encode_sizet_uint32_check(enc_ctx, len); + duk__cbor_encode_uint32(enc_ctx, (duk_uint32_t) len, 0x80U); + for (i = 0; i < len; i++) { + duk_get_prop_index(enc_ctx->thr, -1, (duk_uarridx_t) i); + duk__cbor_encode_value(enc_ctx); + } + } else if (duk_is_buffer_data(enc_ctx->thr, -1)) { + /* XXX: Tag buffer data? + * XXX: Encode typed arrays as integer arrays rather + * than buffer data as is? + */ + buf = (duk_uint8_t *) duk_require_buffer_data(enc_ctx->thr, -1, &len); + duk__cbor_encode_sizet_uint32_check(enc_ctx, len); + duk__cbor_encode_uint32(enc_ctx, (duk_uint32_t) len, 0x40U); + duk__cbor_encode_ensure(enc_ctx, len); + p = enc_ctx->ptr; + duk_memcpy_unsafe((void *) p, (const void *) buf, len); + p += len; + enc_ctx->ptr = p; + } else { + /* We don't know the number of properties in advance + * but would still like to encode at least small + * objects without indefinite length. Emit an + * indefinite length byte initially, and if the final + * property count is small enough to also fit in one + * byte, backpatch it later. Otherwise keep the + * indefinite length. This works well up to 23 + * properties which is practical and good enough. + */ + off_ib = (duk_size_t) (enc_ctx->ptr - enc_ctx->buf); /* XXX: get_offset? */ + count = 0U; + p = enc_ctx->ptr; + *p++ = 0xa0U + 0x1fU; /* indefinite length */ + enc_ctx->ptr = p; + duk_enum(enc_ctx->thr, -1, DUK_ENUM_OWN_PROPERTIES_ONLY); + while (duk_next(enc_ctx->thr, -1, 1 /*get_value*/)) { + duk_insert(enc_ctx->thr, -2); /* [ ... key value ] -> [ ... value key ] */ + duk__cbor_encode_value(enc_ctx); + duk__cbor_encode_value(enc_ctx); + count++; + if (count == 0U) { + duk__cbor_encode_error(enc_ctx); + } + } + duk_pop(enc_ctx->thr); + if (count <= 0x17U) { + DUK_ASSERT(off_ib < enc_ctx->len); + enc_ctx->buf[off_ib] = 0xa0U + (duk_uint8_t) count; + } else { + duk__cbor_encode_ensure(enc_ctx, 1); + p = enc_ctx->ptr; + *p++ = 0xffU; /* break */ + enc_ctx->ptr = p; + } + } + + duk__cbor_encode_objarr_exit(enc_ctx); +} + +DUK_LOCAL void duk__cbor_encode_buffer(duk_cbor_encode_context *enc_ctx) { + duk_uint8_t *buf; + duk_size_t len; + duk_uint8_t *p; + + /* Caller must ensure space. */ + DUK_ASSERT(duk__cbor_get_reserve(enc_ctx) >= 1 + 8); + + /* Tag buffer data? */ + buf = (duk_uint8_t *) duk_require_buffer(enc_ctx->thr, -1, &len); + duk__cbor_encode_sizet_uint32_check(enc_ctx, len); + duk__cbor_encode_uint32(enc_ctx, (duk_uint32_t) len, 0x40U); + duk__cbor_encode_ensure(enc_ctx, len); + p = enc_ctx->ptr; + duk_memcpy_unsafe((void *) p, (const void *) buf, len); + p += len; + enc_ctx->ptr = p; +} + +DUK_LOCAL void duk__cbor_encode_pointer(duk_cbor_encode_context *enc_ctx) { + /* Pointers (void *) are challenging to encode. They can't + * be relied to be even 64-bit integer compatible (there are + * pointer models larger than that), nor can floats encode + * them. They could be encoded as strings (%p format) but + * that's not portable. They could be encoded as direct memory + * representations. Recovering pointers is non-portable in any + * case but it would be nice to be able to detect and recover + * compatible pointers. + * + * For now, encode as "(%p)" string, matching JX. There doesn't + * seem to be an appropriate tag, so pointers don't currently + * survive a CBOR encode/decode roundtrip intact. + */ + const char *ptr; + + ptr = duk_to_string(enc_ctx->thr, -1); + DUK_ASSERT(ptr != NULL); + duk_push_sprintf(enc_ctx->thr, "(%s)", ptr); + duk_remove(enc_ctx->thr, -2); + duk__cbor_encode_string_top(enc_ctx); +} + +DUK_LOCAL void duk__cbor_encode_lightfunc(duk_cbor_encode_context *enc_ctx) { + duk_uint8_t *p; + + /* Caller must ensure space. */ + DUK_ASSERT(duk__cbor_get_reserve(enc_ctx) >= 1 + 8); + + /* For now encode as an empty object. */ + p = enc_ctx->ptr; + *p++ = 0xa0U; + enc_ctx->ptr = p; +} + +DUK_LOCAL void duk__cbor_encode_value(duk_cbor_encode_context *enc_ctx) { + duk_uint8_t *p; + + /* Encode/decode cycle currently loses some type information. + * This can be improved by registering custom tags with IANA. + */ + + /* Reserve space for up to 64-bit types (1 initial byte + 8 + * followup bytes). This allows encoding of integers, floats, + * string/buffer length fields, etc without separate checks + * in each code path. + */ + duk__cbor_encode_ensure(enc_ctx, 1 + 8); + + switch (duk_get_type(enc_ctx->thr, -1)) { + case DUK_TYPE_UNDEFINED: { + p = enc_ctx->ptr; + *p++ = 0xf7; + enc_ctx->ptr = p; + break; + } + case DUK_TYPE_NULL: { + p = enc_ctx->ptr; + *p++ = 0xf6; + enc_ctx->ptr = p; + break; + } + case DUK_TYPE_BOOLEAN: { + duk_uint8_t u8 = duk_get_boolean(enc_ctx->thr, -1) ? 0xf5U : 0xf4U; + p = enc_ctx->ptr; + *p++ = u8; + enc_ctx->ptr = p; + break; + } + case DUK_TYPE_NUMBER: { + duk__cbor_encode_double(enc_ctx, duk_get_number(enc_ctx->thr, -1)); + break; + } + case DUK_TYPE_STRING: { + duk__cbor_encode_string_top(enc_ctx); + break; + } + case DUK_TYPE_OBJECT: { + duk__cbor_encode_object(enc_ctx); + break; + } + case DUK_TYPE_BUFFER: { + duk__cbor_encode_buffer(enc_ctx); + break; + } + case DUK_TYPE_POINTER: { + duk__cbor_encode_pointer(enc_ctx); + break; + } + case DUK_TYPE_LIGHTFUNC: { + duk__cbor_encode_lightfunc(enc_ctx); + break; + } + case DUK_TYPE_NONE: + default: + goto fail; + } + + duk_pop(enc_ctx->thr); + return; + +fail: + duk__cbor_encode_error(enc_ctx); +} + +/* + * Decoding + */ + +DUK_LOCAL void duk__cbor_decode_error(duk_cbor_decode_context *dec_ctx) { + (void) duk_type_error(dec_ctx->thr, "cbor decode error"); +} + +DUK_LOCAL void duk__cbor_decode_req_stack(duk_cbor_decode_context *dec_ctx) { + duk_require_stack(dec_ctx->thr, 4); +} + +DUK_LOCAL void duk__cbor_decode_objarr_entry(duk_cbor_decode_context *dec_ctx) { + duk_hthread *thr = dec_ctx->thr; + + /* Native stack check in object/array recursion. */ + duk_native_stack_check(thr); + + duk__cbor_decode_req_stack(dec_ctx); + + DUK_ASSERT(dec_ctx->recursion_depth <= dec_ctx->recursion_limit); + if (dec_ctx->recursion_depth >= dec_ctx->recursion_limit) { + DUK_ERROR_RANGE(thr, DUK_STR_DEC_RECLIMIT); + DUK_WO_NORETURN(return;); + } + dec_ctx->recursion_depth++; +} + +DUK_LOCAL void duk__cbor_decode_objarr_exit(duk_cbor_decode_context *dec_ctx) { + DUK_ASSERT(dec_ctx->recursion_depth > 0); + dec_ctx->recursion_depth--; +} + +DUK_LOCAL duk_uint8_t duk__cbor_decode_readbyte(duk_cbor_decode_context *dec_ctx) { + DUK_ASSERT(dec_ctx->off <= dec_ctx->len); + if (DUK_UNLIKELY(dec_ctx->len - dec_ctx->off < 1U)) { + duk__cbor_decode_error(dec_ctx); + } + return dec_ctx->buf[dec_ctx->off++]; +} + +DUK_LOCAL duk_uint16_t duk__cbor_decode_read_u16(duk_cbor_decode_context *dec_ctx) { + duk_uint16_t res; + + DUK_ASSERT(dec_ctx->off <= dec_ctx->len); + if (DUK_UNLIKELY(dec_ctx->len - dec_ctx->off < 2U)) { + duk__cbor_decode_error(dec_ctx); + } + res = DUK_RAW_READ_U16_BE(dec_ctx->buf + dec_ctx->off); + dec_ctx->off += 2; + return res; +} + +DUK_LOCAL duk_uint32_t duk__cbor_decode_read_u32(duk_cbor_decode_context *dec_ctx) { + duk_uint32_t res; + + DUK_ASSERT(dec_ctx->off <= dec_ctx->len); + if (DUK_UNLIKELY(dec_ctx->len - dec_ctx->off < 4U)) { + duk__cbor_decode_error(dec_ctx); + } + res = DUK_RAW_READ_U32_BE(dec_ctx->buf + dec_ctx->off); + dec_ctx->off += 4; + return res; +} + +DUK_LOCAL duk_uint8_t duk__cbor_decode_peekbyte(duk_cbor_decode_context *dec_ctx) { + if (DUK_UNLIKELY(dec_ctx->off >= dec_ctx->len)) { + duk__cbor_decode_error(dec_ctx); + } + return dec_ctx->buf[dec_ctx->off]; +} + +DUK_LOCAL void duk__cbor_decode_rewind(duk_cbor_decode_context *dec_ctx, duk_size_t len) { + DUK_ASSERT(len <= dec_ctx->off); /* Caller must ensure. */ + dec_ctx->off -= len; +} + +#if 0 +DUK_LOCAL void duk__cbor_decode_ensure(duk_cbor_decode_context *dec_ctx, duk_size_t len) { + if (dec_ctx->off + len > dec_ctx->len) { + duk__cbor_decode_error(dec_ctx); + } +} +#endif + +DUK_LOCAL const duk_uint8_t *duk__cbor_decode_consume(duk_cbor_decode_context *dec_ctx, duk_size_t len) { + DUK_ASSERT(dec_ctx->off <= dec_ctx->len); + if (DUK_LIKELY(dec_ctx->len - dec_ctx->off >= len)) { + const duk_uint8_t *res = dec_ctx->buf + dec_ctx->off; + dec_ctx->off += len; + return res; + } + + duk__cbor_decode_error(dec_ctx); /* Not enough input. */ + return NULL; +} + +DUK_LOCAL int duk__cbor_decode_checkbreak(duk_cbor_decode_context *dec_ctx) { + if (duk__cbor_decode_peekbyte(dec_ctx) == 0xffU) { + DUK_ASSERT(dec_ctx->off < dec_ctx->len); + dec_ctx->off++; +#if 0 + (void) duk__cbor_decode_readbyte(dec_ctx); +#endif + return 1; + } + return 0; +} + +DUK_LOCAL void duk__cbor_decode_push_aival_int(duk_cbor_decode_context *dec_ctx, duk_uint8_t ib, duk_bool_t negative) { + duk_uint8_t ai; + duk_uint32_t t, t1, t2; +#if 0 + duk_uint64_t t3; +#endif + duk_double_t d1, d2; + duk_double_t d; + + ai = ib & 0x1fU; + if (ai <= 0x17U) { + t = ai; + goto shared_exit; + } + + switch (ai) { + case 0x18U: /* 1 byte */ + t = (duk_uint32_t) duk__cbor_decode_readbyte(dec_ctx); + goto shared_exit; + case 0x19U: /* 2 byte */ + t = (duk_uint32_t) duk__cbor_decode_read_u16(dec_ctx); + goto shared_exit; + case 0x1aU: /* 4 byte */ + t = (duk_uint32_t) duk__cbor_decode_read_u32(dec_ctx); + goto shared_exit; + case 0x1bU: /* 8 byte */ + /* For uint64 it's important to handle the -1.0 part before + * casting to double: otherwise the adjustment might be lost + * in the cast. Uses: -1.0 - d <=> -(d + 1.0). + */ + t = (duk_uint32_t) duk__cbor_decode_read_u32(dec_ctx); + t2 = t; + t = (duk_uint32_t) duk__cbor_decode_read_u32(dec_ctx); + t1 = t; +#if 0 + t3 = (duk_uint64_t) t2 * DUK_U64_CONSTANT(0x100000000) + (duk_uint64_t) t1; + if (negative) { + if (t3 == DUK_UINT64_MAX) { + /* -(0xffff'ffff'ffff'ffffULL + 1) = + * -0x1'0000'0000'0000'0000 + * + * >>> -0x10000000000000000 + * -18446744073709551616L + */ + return -18446744073709551616.0; + } else { + return -((duk_double_t) (t3 + DUK_U64_CONSTANT(1))); + } + } else { + return (duk_double_t) t3; /* XXX: cast helper */ + } +#endif +#if 0 + t3 = (duk_uint64_t) t2 * DUK_U64_CONSTANT(0x100000000) + (duk_uint64_t) t1; + if (negative) { + /* Simpler version: take advantage of the fact that + * 0xffff'ffff'ffff'ffff and 0x1'0000'0000'0000'0000 + * both round to 0x1'0000'0000'0000'0000: + * > (0xffffffffffffffff).toString(16) + * '10000000000000000' + * > (0x10000000000000000).toString(16) + * '10000000000000000' + * + * For the DUK_UINT64_MAX case we just skip the +1 + * increment to avoid wrapping; the result still + * comes out right for an IEEE double cast. + */ + if (t3 != DUK_UINT64_MAX) { + t3++; + } + return -((duk_double_t) t3); + } else { + return (duk_double_t) t3; /* XXX: cast helper */ + } +#endif +#if 1 + /* Use two double parts, avoids dependency on 64-bit type. + * Avoid precision loss carefully, especially when dealing + * with the required +1 for negative values. + * + * No fastint check for this path at present. + */ + d1 = (duk_double_t) t1; /* XXX: cast helpers */ + d2 = (duk_double_t) t2 * 4294967296.0; + if (negative) { + d1 += 1.0; + } + d = d2 + d1; + if (negative) { + d = -d; + } +#endif + /* XXX: a push and check for fastint API would be nice */ + duk_push_number(dec_ctx->thr, d); + return; + } + + duk__cbor_decode_error(dec_ctx); + return; + +shared_exit: + if (negative) { + /* XXX: a push and check for fastint API would be nice */ + if ((duk_uint_t) t <= (duk_uint_t) - (DUK_INT_MIN + 1)) { + duk_push_int(dec_ctx->thr, -1 - ((duk_int_t) t)); + } else { + duk_push_number(dec_ctx->thr, -1.0 - (duk_double_t) t); + } + } else { + duk_push_uint(dec_ctx->thr, (duk_uint_t) t); + } +} + +DUK_LOCAL void duk__cbor_decode_skip_aival_int(duk_cbor_decode_context *dec_ctx, duk_uint8_t ib) { + const duk_int8_t skips[32] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 2, 4, 8, -1, -1, -1, -1 }; + duk_uint8_t ai; + duk_int8_t skip; + + ai = ib & 0x1fU; + skip = skips[ai]; + if (DUK_UNLIKELY(skip < 0)) { + duk__cbor_decode_error(dec_ctx); + } + duk__cbor_decode_consume(dec_ctx, (duk_size_t) skip); + return; +} + +DUK_LOCAL duk_uint32_t duk__cbor_decode_aival_uint32(duk_cbor_decode_context *dec_ctx, duk_uint8_t ib) { + duk_uint8_t ai; + duk_uint32_t t; + + ai = ib & 0x1fU; + if (ai <= 0x17U) { + return (duk_uint32_t) ai; + } + + switch (ai) { + case 0x18U: /* 1 byte */ + t = (duk_uint32_t) duk__cbor_decode_readbyte(dec_ctx); + return t; + case 0x19U: /* 2 byte */ + t = (duk_uint32_t) duk__cbor_decode_read_u16(dec_ctx); + return t; + case 0x1aU: /* 4 byte */ + t = (duk_uint32_t) duk__cbor_decode_read_u32(dec_ctx); + return t; + case 0x1bU: /* 8 byte */ + t = (duk_uint32_t) duk__cbor_decode_read_u32(dec_ctx); + if (t != 0U) { + break; + } + t = (duk_uint32_t) duk__cbor_decode_read_u32(dec_ctx); + return t; + } + + duk__cbor_decode_error(dec_ctx); + return 0U; +} + +DUK_LOCAL void duk__cbor_decode_buffer(duk_cbor_decode_context *dec_ctx, duk_uint8_t expected_base) { + duk_uint32_t len; + duk_uint8_t *buf; + const duk_uint8_t *inp; + duk_uint8_t ib; + + ib = duk__cbor_decode_readbyte(dec_ctx); + if ((ib & 0xe0U) != expected_base) { + duk__cbor_decode_error(dec_ctx); + } + /* Indefinite format is rejected by the following on purpose. */ + len = duk__cbor_decode_aival_uint32(dec_ctx, ib); + inp = duk__cbor_decode_consume(dec_ctx, len); + /* XXX: duk_push_fixed_buffer_with_data() would be a nice API addition. */ + buf = (duk_uint8_t *) duk_push_fixed_buffer(dec_ctx->thr, (duk_size_t) len); + duk_memcpy((void *) buf, (const void *) inp, (size_t) len); +} + +DUK_LOCAL void duk__cbor_decode_join_buffers(duk_cbor_decode_context *dec_ctx, duk_idx_t count) { + duk_size_t total_size = 0; + duk_idx_t top = duk_get_top(dec_ctx->thr); + duk_idx_t base = top - count; /* count is >= 1 */ + duk_idx_t idx; + duk_uint8_t *p = NULL; + + DUK_ASSERT(count >= 1); + DUK_ASSERT(top >= count); + + for (;;) { + /* First round: compute total size. + * Second round: copy into place. + */ + for (idx = base; idx < top; idx++) { + duk_uint8_t *buf_data; + duk_size_t buf_size; + + buf_data = (duk_uint8_t *) duk_require_buffer(dec_ctx->thr, idx, &buf_size); + if (p != NULL) { + duk_memcpy_unsafe((void *) p, (const void *) buf_data, buf_size); + p += buf_size; + } else { + total_size += buf_size; + if (DUK_UNLIKELY(total_size < buf_size)) { /* Wrap check. */ + duk__cbor_decode_error(dec_ctx); + } + } + } + + if (p != NULL) { + break; + } else { + p = (duk_uint8_t *) duk_push_fixed_buffer(dec_ctx->thr, total_size); + DUK_ASSERT(p != NULL); + } + } + + duk_replace(dec_ctx->thr, base); + duk_pop_n(dec_ctx->thr, count - 1); +} + +DUK_LOCAL void duk__cbor_decode_and_join_strbuf(duk_cbor_decode_context *dec_ctx, duk_uint8_t expected_base) { + duk_idx_t count = 0; + for (;;) { + if (duk__cbor_decode_checkbreak(dec_ctx)) { + break; + } + duk_require_stack(dec_ctx->thr, 1); + duk__cbor_decode_buffer(dec_ctx, expected_base); + count++; + if (DUK_UNLIKELY(count <= 0)) { /* Wrap check. */ + duk__cbor_decode_error(dec_ctx); + } + } + if (count == 0) { + (void) duk_push_fixed_buffer(dec_ctx->thr, 0); + } else if (count > 1) { + duk__cbor_decode_join_buffers(dec_ctx, count); + } +} + +DUK_LOCAL duk_double_t duk__cbor_decode_half_float(duk_cbor_decode_context *dec_ctx) { + duk_double_union u; + const duk_uint8_t *inp; + duk_int_t expt; + duk_uint_t u16; + duk_uint_t tmp; + duk_double_t res; + + inp = duk__cbor_decode_consume(dec_ctx, 2); + u16 = ((duk_uint_t) inp[0] << 8) + (duk_uint_t) inp[1]; + expt = (duk_int_t) ((u16 >> 10) & 0x1fU) - 15; + + /* Reconstruct IEEE double into little endian order first, then convert + * to host order. + */ + + duk_memzero((void *) &u, sizeof(u)); + + if (expt == -15) { + /* Zero or denormal; but note that half float + * denormals become double normals. + */ + if ((u16 & 0x03ffU) == 0) { + u.uc[7] = inp[0] & 0x80U; + } else { + /* Create denormal by first creating a double that + * contains the denormal bits and a leading implicit + * 1-bit. Then subtract away the implicit 1-bit. + * + * 0.mmmmmmmmmm * 2^-14 + * 1.mmmmmmmmmm 0.... * 2^-14 + * -1.0000000000 0.... * 2^-14 + * + * Double exponent: -14 + 1023 = 0x3f1 + */ + u.uc[7] = 0x3fU; + u.uc[6] = 0x10U + (duk_uint8_t) ((u16 >> 6) & 0x0fU); + u.uc[5] = (duk_uint8_t) ((u16 << 2) & 0xffU); /* Mask is really 0xfcU */ + + duk_dblunion_little_to_host(&u); + res = u.d - 0.00006103515625; /* 2^(-14) */ + if (u16 & 0x8000U) { + res = -res; + } + return res; + } + } else if (expt == 16) { + /* +/- Inf or NaN. */ + if ((u16 & 0x03ffU) == 0) { + u.uc[7] = (inp[0] & 0x80U) + 0x7fU; + u.uc[6] = 0xf0U; + } else { + /* Create a 'quiet NaN' with highest + * bit set (there are some platforms + * where the NaN payload convention is + * the opposite). Keep sign. + */ + u.uc[7] = (inp[0] & 0x80U) + 0x7fU; + u.uc[6] = 0xf8U; + } + } else { + /* Normal. */ + tmp = (inp[0] & 0x80U) ? 0x80000000UL : 0UL; + tmp += (duk_uint_t) (expt + 1023) << 20; + tmp += (duk_uint_t) (inp[0] & 0x03U) << 18; + tmp += (duk_uint_t) (inp[1] & 0xffU) << 10; + u.uc[7] = (tmp >> 24) & 0xffU; + u.uc[6] = (tmp >> 16) & 0xffU; + u.uc[5] = (tmp >> 8) & 0xffU; + u.uc[4] = (tmp >> 0) & 0xffU; + } + + duk_dblunion_little_to_host(&u); + return u.d; +} + +DUK_LOCAL void duk__cbor_decode_string(duk_cbor_decode_context *dec_ctx, duk_uint8_t ib, duk_uint8_t ai) { + /* If the CBOR string data is not valid UTF-8 it is technically + * invalid CBOR. Possible behaviors at least: + * + * 1. Reject the input, i.e. throw TypeError. + * + * 2. Accept the input, but sanitize non-UTF-8 data into UTF-8 + * using U+FFFD replacements. Also it might make sense to + * decode non-BMP codepoints into surrogates for better + * ECMAScript compatibility. + * + * 3. Accept the input as a Duktape string (which are not always + * valid UTF-8), but reject any input that would create a + * Symbol representation. + * + * Current behavior is 3. + */ + + if (ai == 0x1fU) { + duk_uint8_t *buf_data; + duk_size_t buf_size; + + duk__cbor_decode_and_join_strbuf(dec_ctx, 0x60U); + buf_data = (duk_uint8_t *) duk_require_buffer(dec_ctx->thr, -1, &buf_size); + (void) duk_push_lstring(dec_ctx->thr, (const char *) buf_data, buf_size); + duk_remove(dec_ctx->thr, -2); + } else { + duk_uint32_t len; + const duk_uint8_t *inp; + + len = duk__cbor_decode_aival_uint32(dec_ctx, ib); + inp = duk__cbor_decode_consume(dec_ctx, len); + (void) duk_push_lstring(dec_ctx->thr, (const char *) inp, (duk_size_t) len); + } + if (duk_is_symbol(dec_ctx->thr, -1)) { + /* Refuse to create Symbols when decoding. */ + duk__cbor_decode_error(dec_ctx); + } + + /* XXX: Here a Duktape API call to convert input -> utf-8 with + * replacements would be nice. + */ +} + +DUK_LOCAL duk_bool_t duk__cbor_decode_array(duk_cbor_decode_context *dec_ctx, duk_uint8_t ib, duk_uint8_t ai) { + duk_uint32_t idx, len; + + duk__cbor_decode_objarr_entry(dec_ctx); + + /* Support arrays up to 0xfffffffeU in length. 0xffffffff is + * used as an indefinite length marker. + */ + if (ai == 0x1fU) { + len = 0xffffffffUL; + } else { + len = duk__cbor_decode_aival_uint32(dec_ctx, ib); + if (len == 0xffffffffUL) { + goto failure; + } + } + + /* XXX: use bare array? */ + duk_push_array(dec_ctx->thr); + for (idx = 0U;;) { + if (len == 0xffffffffUL && duk__cbor_decode_checkbreak(dec_ctx)) { + break; + } + if (idx == len) { + if (ai == 0x1fU) { + goto failure; + } + break; + } + duk__cbor_decode_value(dec_ctx); + duk_put_prop_index(dec_ctx->thr, -2, (duk_uarridx_t) idx); + idx++; + if (idx == 0U) { + goto failure; /* wrapped */ + } + } + +#if 0 + success: +#endif + duk__cbor_decode_objarr_exit(dec_ctx); + return 1; + +failure: + /* No need to unwind recursion checks, caller will throw. */ + return 0; +} + +DUK_LOCAL duk_bool_t duk__cbor_decode_map(duk_cbor_decode_context *dec_ctx, duk_uint8_t ib, duk_uint8_t ai) { + duk_uint32_t count; + + duk__cbor_decode_objarr_entry(dec_ctx); + + if (ai == 0x1fU) { + count = 0xffffffffUL; + } else { + count = duk__cbor_decode_aival_uint32(dec_ctx, ib); + if (count == 0xffffffffUL) { + goto failure; + } + } + + /* XXX: use bare object? */ + duk_push_object(dec_ctx->thr); + for (;;) { + if (count == 0xffffffffUL) { + if (duk__cbor_decode_checkbreak(dec_ctx)) { + break; + } + } else { + if (count == 0UL) { + break; + } + count--; + } + + /* Non-string keys are coerced to strings, + * possibly leading to overwriting previous + * keys. Last key of a certain coerced name + * wins. If key is an object, it will coerce + * to '[object Object]' which is consistent + * but potentially misleading. One alternative + * would be to skip non-string keys. + */ + duk__cbor_decode_value(dec_ctx); + duk__cbor_decode_value(dec_ctx); + duk_put_prop(dec_ctx->thr, -3); + } + +#if 0 + success: +#endif + duk__cbor_decode_objarr_exit(dec_ctx); + return 1; + +failure: + /* No need to unwind recursion checks, caller will throw. */ + return 0; +} + +DUK_LOCAL duk_double_t duk__cbor_decode_float(duk_cbor_decode_context *dec_ctx) { + duk_float_union u; + const duk_uint8_t *inp; + inp = duk__cbor_decode_consume(dec_ctx, 4); + duk_memcpy((void *) u.uc, (const void *) inp, 4); + duk_fltunion_big_to_host(&u); + return (duk_double_t) u.f; +} + +DUK_LOCAL duk_double_t duk__cbor_decode_double(duk_cbor_decode_context *dec_ctx) { + duk_double_union u; + const duk_uint8_t *inp; + inp = duk__cbor_decode_consume(dec_ctx, 8); + duk_memcpy((void *) u.uc, (const void *) inp, 8); + duk_dblunion_big_to_host(&u); + return u.d; +} + +#if defined(DUK_CBOR_DECODE_FASTPATH) +#define DUK__CBOR_AI (ib & 0x1fU) + +DUK_LOCAL void duk__cbor_decode_value(duk_cbor_decode_context *dec_ctx) { + duk_uint8_t ib; + + /* Any paths potentially recursing back to duk__cbor_decode_value() + * must perform a Duktape value stack growth check. Avoid the check + * here for simple paths like primitive values. + */ + +reread_initial_byte: + DUK_DDD(DUK_DDDPRINT("cbor decode off=%ld len=%ld", (long) dec_ctx->off, (long) dec_ctx->len)); + + ib = duk__cbor_decode_readbyte(dec_ctx); + + /* Full initial byte switch, footprint cost over baseline is ~+1kB. */ + /* XXX: Force full switch with no range check. */ + + switch (ib) { + case 0x00U: + case 0x01U: + case 0x02U: + case 0x03U: + case 0x04U: + case 0x05U: + case 0x06U: + case 0x07U: + case 0x08U: + case 0x09U: + case 0x0aU: + case 0x0bU: + case 0x0cU: + case 0x0dU: + case 0x0eU: + case 0x0fU: + case 0x10U: + case 0x11U: + case 0x12U: + case 0x13U: + case 0x14U: + case 0x15U: + case 0x16U: + case 0x17U: + duk_push_uint(dec_ctx->thr, ib); + break; + case 0x18U: + case 0x19U: + case 0x1aU: + case 0x1bU: + duk__cbor_decode_push_aival_int(dec_ctx, ib, 0 /*negative*/); + break; + case 0x1cU: + case 0x1dU: + case 0x1eU: + case 0x1fU: + goto format_error; + case 0x20U: + case 0x21U: + case 0x22U: + case 0x23U: + case 0x24U: + case 0x25U: + case 0x26U: + case 0x27U: + case 0x28U: + case 0x29U: + case 0x2aU: + case 0x2bU: + case 0x2cU: + case 0x2dU: + case 0x2eU: + case 0x2fU: + case 0x30U: + case 0x31U: + case 0x32U: + case 0x33U: + case 0x34U: + case 0x35U: + case 0x36U: + case 0x37U: + duk_push_int(dec_ctx->thr, -((duk_int_t) ((ib - 0x20U) + 1U))); + break; + case 0x38U: + case 0x39U: + case 0x3aU: + case 0x3bU: + duk__cbor_decode_push_aival_int(dec_ctx, ib, 1 /*negative*/); + break; + case 0x3cU: + case 0x3dU: + case 0x3eU: + case 0x3fU: + goto format_error; + case 0x40U: + case 0x41U: + case 0x42U: + case 0x43U: + case 0x44U: + case 0x45U: + case 0x46U: + case 0x47U: + case 0x48U: + case 0x49U: + case 0x4aU: + case 0x4bU: + case 0x4cU: + case 0x4dU: + case 0x4eU: + case 0x4fU: + case 0x50U: + case 0x51U: + case 0x52U: + case 0x53U: + case 0x54U: + case 0x55U: + case 0x56U: + case 0x57U: + /* XXX: Avoid rewind, we know the length already. */ + DUK_ASSERT(dec_ctx->off > 0U); + dec_ctx->off--; + duk__cbor_decode_buffer(dec_ctx, 0x40U); + break; + case 0x58U: + case 0x59U: + case 0x5aU: + case 0x5bU: + /* XXX: Avoid rewind, decode length inline. */ + DUK_ASSERT(dec_ctx->off > 0U); + dec_ctx->off--; + duk__cbor_decode_buffer(dec_ctx, 0x40U); + break; + case 0x5cU: + case 0x5dU: + case 0x5eU: + goto format_error; + case 0x5fU: + duk__cbor_decode_and_join_strbuf(dec_ctx, 0x40U); + break; + case 0x60U: + case 0x61U: + case 0x62U: + case 0x63U: + case 0x64U: + case 0x65U: + case 0x66U: + case 0x67U: + case 0x68U: + case 0x69U: + case 0x6aU: + case 0x6bU: + case 0x6cU: + case 0x6dU: + case 0x6eU: + case 0x6fU: + case 0x70U: + case 0x71U: + case 0x72U: + case 0x73U: + case 0x74U: + case 0x75U: + case 0x76U: + case 0x77U: + /* XXX: Avoid double decode of length. */ + duk__cbor_decode_string(dec_ctx, ib, DUK__CBOR_AI); + break; + case 0x78U: + case 0x79U: + case 0x7aU: + case 0x7bU: + /* XXX: Avoid double decode of length. */ + duk__cbor_decode_string(dec_ctx, ib, DUK__CBOR_AI); + break; + case 0x7cU: + case 0x7dU: + case 0x7eU: + goto format_error; + case 0x7fU: + duk__cbor_decode_string(dec_ctx, ib, DUK__CBOR_AI); + break; + case 0x80U: + case 0x81U: + case 0x82U: + case 0x83U: + case 0x84U: + case 0x85U: + case 0x86U: + case 0x87U: + case 0x88U: + case 0x89U: + case 0x8aU: + case 0x8bU: + case 0x8cU: + case 0x8dU: + case 0x8eU: + case 0x8fU: + case 0x90U: + case 0x91U: + case 0x92U: + case 0x93U: + case 0x94U: + case 0x95U: + case 0x96U: + case 0x97U: + if (DUK_UNLIKELY(duk__cbor_decode_array(dec_ctx, ib, DUK__CBOR_AI) == 0)) { + goto format_error; + } + break; + case 0x98U: + case 0x99U: + case 0x9aU: + case 0x9bU: + if (DUK_UNLIKELY(duk__cbor_decode_array(dec_ctx, ib, DUK__CBOR_AI) == 0)) { + goto format_error; + } + break; + case 0x9cU: + case 0x9dU: + case 0x9eU: + goto format_error; + case 0x9fU: + if (DUK_UNLIKELY(duk__cbor_decode_array(dec_ctx, ib, DUK__CBOR_AI) == 0)) { + goto format_error; + } + break; + case 0xa0U: + case 0xa1U: + case 0xa2U: + case 0xa3U: + case 0xa4U: + case 0xa5U: + case 0xa6U: + case 0xa7U: + case 0xa8U: + case 0xa9U: + case 0xaaU: + case 0xabU: + case 0xacU: + case 0xadU: + case 0xaeU: + case 0xafU: + case 0xb0U: + case 0xb1U: + case 0xb2U: + case 0xb3U: + case 0xb4U: + case 0xb5U: + case 0xb6U: + case 0xb7U: + if (DUK_UNLIKELY(duk__cbor_decode_map(dec_ctx, ib, DUK__CBOR_AI) == 0)) { + goto format_error; + } + break; + case 0xb8U: + case 0xb9U: + case 0xbaU: + case 0xbbU: + if (DUK_UNLIKELY(duk__cbor_decode_map(dec_ctx, ib, DUK__CBOR_AI) == 0)) { + goto format_error; + } + break; + case 0xbcU: + case 0xbdU: + case 0xbeU: + goto format_error; + case 0xbfU: + if (DUK_UNLIKELY(duk__cbor_decode_map(dec_ctx, ib, DUK__CBOR_AI) == 0)) { + goto format_error; + } + break; + case 0xc0U: + case 0xc1U: + case 0xc2U: + case 0xc3U: + case 0xc4U: + case 0xc5U: + case 0xc6U: + case 0xc7U: + case 0xc8U: + case 0xc9U: + case 0xcaU: + case 0xcbU: + case 0xccU: + case 0xcdU: + case 0xceU: + case 0xcfU: + case 0xd0U: + case 0xd1U: + case 0xd2U: + case 0xd3U: + case 0xd4U: + case 0xd5U: + case 0xd6U: + case 0xd7U: + /* Tag 0-23: drop. */ + goto reread_initial_byte; + case 0xd8U: + case 0xd9U: + case 0xdaU: + case 0xdbU: + duk__cbor_decode_skip_aival_int(dec_ctx, ib); + goto reread_initial_byte; + case 0xdcU: + case 0xddU: + case 0xdeU: + case 0xdfU: + goto format_error; + case 0xe0U: + goto format_error; + case 0xe1U: + goto format_error; + case 0xe2U: + goto format_error; + case 0xe3U: + goto format_error; + case 0xe4U: + goto format_error; + case 0xe5U: + goto format_error; + case 0xe6U: + goto format_error; + case 0xe7U: + goto format_error; + case 0xe8U: + goto format_error; + case 0xe9U: + goto format_error; + case 0xeaU: + goto format_error; + case 0xebU: + goto format_error; + case 0xecU: + goto format_error; + case 0xedU: + goto format_error; + case 0xeeU: + goto format_error; + case 0xefU: + goto format_error; + case 0xf0U: + goto format_error; + case 0xf1U: + goto format_error; + case 0xf2U: + goto format_error; + case 0xf3U: + goto format_error; + case 0xf4U: + duk_push_false(dec_ctx->thr); + break; + case 0xf5U: + duk_push_true(dec_ctx->thr); + break; + case 0xf6U: + duk_push_null(dec_ctx->thr); + break; + case 0xf7U: + duk_push_undefined(dec_ctx->thr); + break; + case 0xf8U: + /* Simple value 32-255, nothing defined yet, so reject. */ + goto format_error; + case 0xf9U: { + duk_double_t d; + d = duk__cbor_decode_half_float(dec_ctx); + duk_push_number(dec_ctx->thr, d); + break; + } + case 0xfaU: { + duk_double_t d; + d = duk__cbor_decode_float(dec_ctx); + duk_push_number(dec_ctx->thr, d); + break; + } + case 0xfbU: { + duk_double_t d; + d = duk__cbor_decode_double(dec_ctx); + duk_push_number(dec_ctx->thr, d); + break; + } + case 0xfcU: + case 0xfdU: + case 0xfeU: + case 0xffU: + goto format_error; + } /* end switch */ + + return; + +format_error: + duk__cbor_decode_error(dec_ctx); +} +#else /* DUK_CBOR_DECODE_FASTPATH */ +DUK_LOCAL void duk__cbor_decode_value(duk_cbor_decode_context *dec_ctx) { + duk_uint8_t ib, mt, ai; + + /* Any paths potentially recursing back to duk__cbor_decode_value() + * must perform a Duktape value stack growth check. Avoid the check + * here for simple paths like primitive values. + */ + +reread_initial_byte: + DUK_DDD(DUK_DDDPRINT("cbor decode off=%ld len=%ld", (long) dec_ctx->off, (long) dec_ctx->len)); + + ib = duk__cbor_decode_readbyte(dec_ctx); + mt = ib >> 5U; + ai = ib & 0x1fU; + + /* Additional information in [24,27] = [0x18,0x1b] has relatively + * uniform handling for all major types: read 1/2/4/8 additional + * bytes. For major type 7 the 1-byte value is a 'simple type', and + * 2/4/8-byte values are floats. For other major types the 1/2/4/8 + * byte values are integers. The lengths are uniform, but the typing + * is not. + */ + + switch (mt) { + case 0U: { /* unsigned integer */ + duk__cbor_decode_push_aival_int(dec_ctx, ib, 0 /*negative*/); + break; + } + case 1U: { /* negative integer */ + duk__cbor_decode_push_aival_int(dec_ctx, ib, 1 /*negative*/); + break; + } + case 2U: { /* byte string */ + if (ai == 0x1fU) { + duk__cbor_decode_and_join_strbuf(dec_ctx, 0x40U); + } else { + duk__cbor_decode_rewind(dec_ctx, 1U); + duk__cbor_decode_buffer(dec_ctx, 0x40U); + } + break; + } + case 3U: { /* text string */ + duk__cbor_decode_string(dec_ctx, ib, ai); + break; + } + case 4U: { /* array of data items */ + if (DUK_UNLIKELY(duk__cbor_decode_array(dec_ctx, ib, ai) == 0)) { + goto format_error; + } + break; + } + case 5U: { /* map of pairs of data items */ + if (DUK_UNLIKELY(duk__cbor_decode_map(dec_ctx, ib, ai) == 0)) { + goto format_error; + } + break; + } + case 6U: { /* semantic tagging */ + /* Tags are ignored now, re-read initial byte. A tagged + * value may itself be tagged (an unlimited number of times) + * so keep on peeling away tags. + */ + duk__cbor_decode_skip_aival_int(dec_ctx, ib); + goto reread_initial_byte; + } + case 7U: { /* floating point numbers, simple data types, break; other */ + switch (ai) { + case 0x14U: { + duk_push_false(dec_ctx->thr); + break; + } + case 0x15U: { + duk_push_true(dec_ctx->thr); + break; + } + case 0x16U: { + duk_push_null(dec_ctx->thr); + break; + } + case 0x17U: { + duk_push_undefined(dec_ctx->thr); + break; + } + case 0x18U: { /* more simple values (1 byte) */ + /* Simple value encoded in additional byte (none + * are defined so far). RFC 7049 states that the + * follow-up byte must be 32-255 to minimize + * confusion. So, a non-shortest encoding like + * f815 (= true, shortest encoding f5) must be + * rejected. cbor.me tester rejects f815, but + * e.g. Python CBOR binding decodes it as true. + */ + goto format_error; + } + case 0x19U: { /* half-float (2 bytes) */ + duk_double_t d; + d = duk__cbor_decode_half_float(dec_ctx); + duk_push_number(dec_ctx->thr, d); + break; + } + case 0x1aU: { /* float (4 bytes) */ + duk_double_t d; + d = duk__cbor_decode_float(dec_ctx); + duk_push_number(dec_ctx->thr, d); + break; + } + case 0x1bU: { /* double (8 bytes) */ + duk_double_t d; + d = duk__cbor_decode_double(dec_ctx); + duk_push_number(dec_ctx->thr, d); + break; + } + case 0xffU: /* unexpected break */ + default: { + goto format_error; + } + } /* end switch */ + break; + } + default: { + goto format_error; /* will never actually occur */ + } + } /* end switch */ + + return; + +format_error: + duk__cbor_decode_error(dec_ctx); +} +#endif /* DUK_CBOR_DECODE_FASTPATH */ + +DUK_LOCAL void duk__cbor_encode(duk_hthread *thr, duk_idx_t idx, duk_uint_t encode_flags) { + duk_cbor_encode_context enc_ctx; + duk_uint8_t *buf; + + DUK_UNREF(encode_flags); + + idx = duk_require_normalize_index(thr, idx); + + enc_ctx.thr = thr; + enc_ctx.idx_buf = duk_get_top(thr); + + enc_ctx.len = 64; + buf = (duk_uint8_t *) duk_push_dynamic_buffer(thr, enc_ctx.len); + enc_ctx.ptr = buf; + enc_ctx.buf = buf; + enc_ctx.buf_end = buf + enc_ctx.len; + + enc_ctx.recursion_depth = 0; + enc_ctx.recursion_limit = DUK_USE_CBOR_ENC_RECLIMIT; + + duk_dup(thr, idx); + duk__cbor_encode_req_stack(&enc_ctx); + duk__cbor_encode_value(&enc_ctx); + DUK_ASSERT(enc_ctx.recursion_depth == 0); + duk_resize_buffer(enc_ctx.thr, enc_ctx.idx_buf, (duk_size_t) (enc_ctx.ptr - enc_ctx.buf)); + duk_replace(thr, idx); +} + +DUK_LOCAL void duk__cbor_decode(duk_hthread *thr, duk_idx_t idx, duk_uint_t decode_flags) { + duk_cbor_decode_context dec_ctx; + + DUK_UNREF(decode_flags); + + /* Suppress compile warnings for functions only needed with e.g. + * asserts enabled. + */ + DUK_UNREF(duk__cbor_get_reserve); + + idx = duk_require_normalize_index(thr, idx); + + dec_ctx.thr = thr; + dec_ctx.buf = (const duk_uint8_t *) duk_require_buffer_data(thr, idx, &dec_ctx.len); + dec_ctx.off = 0; + /* dec_ctx.len: set above */ + + dec_ctx.recursion_depth = 0; + dec_ctx.recursion_limit = DUK_USE_CBOR_DEC_RECLIMIT; + + duk__cbor_decode_req_stack(&dec_ctx); + duk__cbor_decode_value(&dec_ctx); + DUK_ASSERT(dec_ctx.recursion_depth == 0); + if (dec_ctx.off != dec_ctx.len) { + (void) duk_type_error(thr, "trailing garbage"); + } + + duk_replace(thr, idx); +} + +#else /* DUK_USE_CBOR_SUPPORT */ + +DUK_LOCAL void duk__cbor_encode(duk_hthread *thr, duk_idx_t idx, duk_uint_t encode_flags) { + DUK_UNREF(idx); + DUK_UNREF(encode_flags); + DUK_ERROR_UNSUPPORTED(thr); +} + +DUK_LOCAL void duk__cbor_decode(duk_hthread *thr, duk_idx_t idx, duk_uint_t decode_flags) { + DUK_UNREF(idx); + DUK_UNREF(decode_flags); + DUK_ERROR_UNSUPPORTED(thr); +} + +#endif /* DUK_USE_CBOR_SUPPORT */ + +/* + * Public APIs + */ + +DUK_EXTERNAL void duk_cbor_encode(duk_hthread *thr, duk_idx_t idx, duk_uint_t encode_flags) { + DUK_ASSERT_API_ENTRY(thr); + duk__cbor_encode(thr, idx, encode_flags); +} +DUK_EXTERNAL void duk_cbor_decode(duk_hthread *thr, duk_idx_t idx, duk_uint_t decode_flags) { + DUK_ASSERT_API_ENTRY(thr); + duk__cbor_decode(thr, idx, decode_flags); +} + +#if defined(DUK_USE_CBOR_BUILTIN) +#if defined(DUK_USE_CBOR_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_cbor_encode(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 1); + + duk__cbor_encode(thr, -1, 0 /*flags*/); + + /* Produce an ArrayBuffer by first decoding into a plain buffer which + * mimics a Uint8Array and gettings its .buffer property. + */ + /* XXX: shortcut */ + (void) duk_get_prop_stridx(thr, -1, DUK_STRIDX_LC_BUFFER); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_cbor_decode(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 1); + + duk__cbor_decode(thr, -1, 0 /*flags*/); + return 1; +} +#else /* DUK_USE_CBOR_SUPPORT */ +DUK_INTERNAL duk_ret_t duk_bi_cbor_encode(duk_hthread *thr) { + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return 0;); +} +DUK_INTERNAL duk_ret_t duk_bi_cbor_decode(duk_hthread *thr) { + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return 0;); +} +#endif /* DUK_USE_CBOR_SUPPORT */ +#endif /* DUK_USE_CBOR_BUILTIN */ + +/* automatic undefs */ +#undef DUK__CBOR_AI +#line 1 "duk_bi_date.c" +/* + * Date built-ins + * + * Unlike most built-ins, Date has some platform dependencies for getting + * UTC time, converting between UTC and local time, and parsing and + * formatting time values. These are all abstracted behind DUK_USE_xxx + * config options. There are built-in platform specific providers for + * POSIX and Windows, but external providers can also be used. + * + * See doc/datetime.rst. + * + */ + +/* #include duk_internal.h -> already included */ + +/* XXX: currently defines unnecessary symbols when DUK_USE_DATE_BUILTIN is disabled. */ + +/* + * Forward declarations + */ + +DUK_LOCAL_DECL duk_double_t duk__push_this_get_timeval_tzoffset(duk_hthread *thr, duk_small_uint_t flags, duk_int_t *out_tzoffset); +DUK_LOCAL_DECL duk_double_t duk__push_this_get_timeval(duk_hthread *thr, duk_small_uint_t flags); +DUK_LOCAL_DECL void duk__twodigit_year_fixup(duk_hthread *thr, duk_idx_t idx_val); +DUK_LOCAL_DECL duk_ret_t duk__set_this_timeval_from_dparts(duk_hthread *thr, duk_double_t *dparts, duk_small_uint_t flags); + +/* + * Other file level defines + */ + +/* Debug macro to print all parts and dparts (used manually because of debug level). */ +#define DUK__DPRINT_PARTS_AND_DPARTS(parts, dparts) \ + do { \ + DUK_D(DUK_DPRINT("parts: %ld %ld %ld %ld %ld %ld %ld %ld, dparts: %lf %lf %lf %lf %lf %lf %lf %lf", \ + (long) (parts)[0], \ + (long) (parts)[1], \ + (long) (parts)[2], \ + (long) (parts)[3], \ + (long) (parts)[4], \ + (long) (parts)[5], \ + (long) (parts)[6], \ + (long) (parts)[7], \ + (double) (dparts)[0], \ + (double) (dparts)[1], \ + (double) (dparts)[2], \ + (double) (dparts)[3], \ + (double) (dparts)[4], \ + (double) (dparts)[5], \ + (double) (dparts)[6], \ + (double) (dparts)[7])); \ + } while (0) +#define DUK__DPRINT_PARTS(parts) \ + do { \ + DUK_D(DUK_DPRINT("parts: %ld %ld %ld %ld %ld %ld %ld %ld", \ + (long) (parts)[0], \ + (long) (parts)[1], \ + (long) (parts)[2], \ + (long) (parts)[3], \ + (long) (parts)[4], \ + (long) (parts)[5], \ + (long) (parts)[6], \ + (long) (parts)[7])); \ + } while (0) +#define DUK__DPRINT_DPARTS(dparts) \ + do { \ + DUK_D(DUK_DPRINT("dparts: %lf %lf %lf %lf %lf %lf %lf %lf", \ + (double) (dparts)[0], \ + (double) (dparts)[1], \ + (double) (dparts)[2], \ + (double) (dparts)[3], \ + (double) (dparts)[4], \ + (double) (dparts)[5], \ + (double) (dparts)[6], \ + (double) (dparts)[7])); \ + } while (0) + +/* Equivalent year for DST calculations outside [1970,2038[ range, see + * E5 Section 15.9.1.8. Equivalent year has the same leap-year-ness and + * starts with the same weekday on Jan 1. + * https://bugzilla.mozilla.org/show_bug.cgi?id=351066 + */ +#define DUK__YEAR(x) ((duk_uint8_t) ((x) -1970)) +DUK_LOCAL duk_uint8_t duk__date_equivyear[14] = { +#if 1 + /* This is based on V8 EquivalentYear() algorithm (see util/genequivyear.py): + * http://code.google.com/p/v8/source/browse/trunk/src/date.h#146 + */ + + /* non-leap year: sunday, monday, ... */ + DUK__YEAR(2023), + DUK__YEAR(2035), + DUK__YEAR(2019), + DUK__YEAR(2031), + DUK__YEAR(2015), + DUK__YEAR(2027), + DUK__YEAR(2011), + + /* leap year: sunday, monday, ... */ + DUK__YEAR(2012), + DUK__YEAR(2024), + DUK__YEAR(2008), + DUK__YEAR(2020), + DUK__YEAR(2032), + DUK__YEAR(2016), + DUK__YEAR(2028) +#endif + +#if 0 + /* This is based on Rhino EquivalentYear() algorithm: + * https://github.com/mozilla/rhino/blob/f99cc11d616f0cdda2c42bde72b3484df6182947/src/org/mozilla/javascript/NativeDate.java + */ + + /* non-leap year: sunday, monday, ... */ + DUK__YEAR(1978), DUK__YEAR(1973), DUK__YEAR(1985), DUK__YEAR(1986), + DUK__YEAR(1981), DUK__YEAR(1971), DUK__YEAR(1977), + + /* leap year: sunday, monday, ... */ + DUK__YEAR(1984), DUK__YEAR(1996), DUK__YEAR(1980), DUK__YEAR(1992), + DUK__YEAR(1976), DUK__YEAR(1988), DUK__YEAR(1972) +#endif +}; + +/* + * ISO 8601 subset parser. + */ + +/* Parser part count. */ +#define DUK__NUM_ISO8601_PARSER_PARTS 9 + +/* Parser part indices. */ +#define DUK__PI_YEAR 0 +#define DUK__PI_MONTH 1 +#define DUK__PI_DAY 2 +#define DUK__PI_HOUR 3 +#define DUK__PI_MINUTE 4 +#define DUK__PI_SECOND 5 +#define DUK__PI_MILLISECOND 6 +#define DUK__PI_TZHOUR 7 +#define DUK__PI_TZMINUTE 8 + +/* Parser part masks. */ +#define DUK__PM_YEAR (1 << DUK__PI_YEAR) +#define DUK__PM_MONTH (1 << DUK__PI_MONTH) +#define DUK__PM_DAY (1 << DUK__PI_DAY) +#define DUK__PM_HOUR (1 << DUK__PI_HOUR) +#define DUK__PM_MINUTE (1 << DUK__PI_MINUTE) +#define DUK__PM_SECOND (1 << DUK__PI_SECOND) +#define DUK__PM_MILLISECOND (1 << DUK__PI_MILLISECOND) +#define DUK__PM_TZHOUR (1 << DUK__PI_TZHOUR) +#define DUK__PM_TZMINUTE (1 << DUK__PI_TZMINUTE) + +/* Parser separator indices. */ +#define DUK__SI_PLUS 0 +#define DUK__SI_MINUS 1 +#define DUK__SI_T 2 +#define DUK__SI_SPACE 3 +#define DUK__SI_COLON 4 +#define DUK__SI_PERIOD 5 +#define DUK__SI_Z 6 +#define DUK__SI_NUL 7 + +/* Parser separator masks. */ +#define DUK__SM_PLUS (1 << DUK__SI_PLUS) +#define DUK__SM_MINUS (1 << DUK__SI_MINUS) +#define DUK__SM_T (1 << DUK__SI_T) +#define DUK__SM_SPACE (1 << DUK__SI_SPACE) +#define DUK__SM_COLON (1 << DUK__SI_COLON) +#define DUK__SM_PERIOD (1 << DUK__SI_PERIOD) +#define DUK__SM_Z (1 << DUK__SI_Z) +#define DUK__SM_NUL (1 << DUK__SI_NUL) + +/* Rule control flags. */ +#define DUK__CF_NEG (1 << 0) /* continue matching, set neg_tzoffset flag */ +#define DUK__CF_ACCEPT (1 << 1) /* accept string */ +#define DUK__CF_ACCEPT_NUL (1 << 2) /* accept string if next char is NUL (otherwise reject) */ + +#define DUK__PACK_RULE(partmask, sepmask, nextpart, flags) \ + ((duk_uint32_t) (partmask) + (((duk_uint32_t) (sepmask)) << 9) + (((duk_uint32_t) (nextpart)) << 17) + \ + (((duk_uint32_t) (flags)) << 21)) + +#define DUK__UNPACK_RULE(rule, var_nextidx, var_flags) \ + do { \ + (var_nextidx) = (duk_small_uint_t) (((rule) >> 17) & 0x0f); \ + (var_flags) = (duk_small_uint_t) ((rule) >> 21); \ + } while (0) + +#define DUK__RULE_MASK_PART_SEP 0x1ffffUL + +/* Matching separator index is used in the control table */ +DUK_LOCAL const duk_uint8_t duk__parse_iso8601_seps[] = { + DUK_ASC_PLUS /*0*/, DUK_ASC_MINUS /*1*/, DUK_ASC_UC_T /*2*/, DUK_ASC_SPACE /*3*/, + DUK_ASC_COLON /*4*/, DUK_ASC_PERIOD /*5*/, DUK_ASC_UC_Z /*6*/, DUK_ASC_NUL /*7*/ +}; + +/* Rule table: first matching rule is used to determine what to do next. */ +DUK_LOCAL const duk_uint32_t duk__parse_iso8601_control[] = { + DUK__PACK_RULE(DUK__PM_YEAR, DUK__SM_MINUS, DUK__PI_MONTH, 0), + DUK__PACK_RULE(DUK__PM_MONTH, DUK__SM_MINUS, DUK__PI_DAY, 0), + DUK__PACK_RULE(DUK__PM_YEAR | DUK__PM_MONTH | DUK__PM_DAY, DUK__SM_T | DUK__SM_SPACE, DUK__PI_HOUR, 0), + DUK__PACK_RULE(DUK__PM_HOUR, DUK__SM_COLON, DUK__PI_MINUTE, 0), + DUK__PACK_RULE(DUK__PM_MINUTE, DUK__SM_COLON, DUK__PI_SECOND, 0), + DUK__PACK_RULE(DUK__PM_SECOND, DUK__SM_PERIOD, DUK__PI_MILLISECOND, 0), + DUK__PACK_RULE(DUK__PM_TZHOUR, DUK__SM_COLON, DUK__PI_TZMINUTE, 0), + DUK__PACK_RULE(DUK__PM_YEAR | DUK__PM_MONTH | DUK__PM_DAY | DUK__PM_HOUR /*Note1*/ | DUK__PM_MINUTE | DUK__PM_SECOND | + DUK__PM_MILLISECOND, + DUK__SM_PLUS, + DUK__PI_TZHOUR, + 0), + DUK__PACK_RULE(DUK__PM_YEAR | DUK__PM_MONTH | DUK__PM_DAY | DUK__PM_HOUR /*Note1*/ | DUK__PM_MINUTE | DUK__PM_SECOND | + DUK__PM_MILLISECOND, + DUK__SM_MINUS, + DUK__PI_TZHOUR, + DUK__CF_NEG), + DUK__PACK_RULE(DUK__PM_YEAR | DUK__PM_MONTH | DUK__PM_DAY | DUK__PM_HOUR /*Note1*/ | DUK__PM_MINUTE | DUK__PM_SECOND | + DUK__PM_MILLISECOND, + DUK__SM_Z, + 0, + DUK__CF_ACCEPT_NUL), + DUK__PACK_RULE(DUK__PM_YEAR | DUK__PM_MONTH | DUK__PM_DAY | DUK__PM_HOUR /*Note1*/ | DUK__PM_MINUTE | DUK__PM_SECOND | + DUK__PM_MILLISECOND | DUK__PM_TZHOUR /*Note2*/ | DUK__PM_TZMINUTE, + DUK__SM_NUL, + 0, + DUK__CF_ACCEPT) + + /* Note1: the specification doesn't require matching a time form with + * just hours ("HH"), but we accept it here, e.g. "2012-01-02T12Z". + * + * Note2: the specification doesn't require matching a timezone offset + * with just hours ("HH"), but accept it here, e.g. "2012-01-02T03:04:05+02" + */ +}; + +DUK_LOCAL duk_bool_t duk__parse_string_iso8601_subset(duk_hthread *thr, const char *str) { + duk_int_t parts[DUK__NUM_ISO8601_PARSER_PARTS]; + duk_double_t dparts[DUK_DATE_IDX_NUM_PARTS]; + duk_double_t d; + const duk_uint8_t *p; + duk_small_uint_t part_idx = 0; + duk_int_t accum = 0; + duk_small_uint_t ndigits = 0; + duk_bool_t neg_year = 0; + duk_bool_t neg_tzoffset = 0; + duk_uint_fast8_t ch; + duk_small_uint_t i; + + /* During parsing, month and day are one-based; set defaults here. */ + duk_memzero(parts, sizeof(parts)); + DUK_ASSERT(parts[DUK_DATE_IDX_YEAR] == 0); /* don't care value, year is mandatory */ + parts[DUK_DATE_IDX_MONTH] = 1; + parts[DUK_DATE_IDX_DAY] = 1; + + /* Special handling for year sign. */ + p = (const duk_uint8_t *) str; + ch = p[0]; + if (ch == DUK_ASC_PLUS) { + p++; + } else if (ch == DUK_ASC_MINUS) { + neg_year = 1; + p++; + } + + for (;;) { + ch = *p++; + DUK_DDD(DUK_DDDPRINT("parsing, part_idx=%ld, char=%ld ('%c')", + (long) part_idx, + (long) ch, + (int) ((ch >= 0x20 && ch <= 0x7e) ? ch : DUK_ASC_QUESTION))); + + if (ch >= DUK_ASC_0 && ch <= DUK_ASC_9) { + if (ndigits >= 9) { + DUK_DDD(DUK_DDDPRINT("too many digits -> reject")); + goto reject; + } + if (part_idx == DUK__PI_MILLISECOND && ndigits >= 3) { + /* ignore millisecond fractions after 3 */ + } else { + accum = accum * 10 + ((duk_int_t) ch) - ((duk_int_t) DUK_ASC_0) + 0x00; + ndigits++; + } + } else { + duk_uint_fast32_t match_val; + duk_small_uint_t sep_idx; + + if (ndigits <= 0) { + goto reject; + } + if (part_idx == DUK__PI_MILLISECOND) { + /* complete the millisecond field */ + while (ndigits < 3) { + accum *= 10; + ndigits++; + } + } + parts[part_idx] = accum; + DUK_DDD(DUK_DDDPRINT("wrote part %ld -> value %ld", (long) part_idx, (long) accum)); + + accum = 0; + ndigits = 0; + + for (i = 0; i < (duk_small_uint_t) (sizeof(duk__parse_iso8601_seps) / sizeof(duk_uint8_t)); i++) { + if (duk__parse_iso8601_seps[i] == ch) { + break; + } + } + if (i == (duk_small_uint_t) (sizeof(duk__parse_iso8601_seps) / sizeof(duk_uint8_t))) { + DUK_DDD(DUK_DDDPRINT("separator character doesn't match -> reject")); + goto reject; + } + + sep_idx = i; + match_val = (1UL << part_idx) + (1UL << (sep_idx + 9)); /* match against rule part/sep bits */ + + for (i = 0; i < (duk_small_uint_t) (sizeof(duk__parse_iso8601_control) / sizeof(duk_uint32_t)); i++) { + duk_uint_fast32_t rule = duk__parse_iso8601_control[i]; + duk_small_uint_t nextpart; + duk_small_uint_t cflags; + + DUK_DDD(DUK_DDDPRINT("part_idx=%ld, sep_idx=%ld, match_val=0x%08lx, considering rule=0x%08lx", + (long) part_idx, + (long) sep_idx, + (unsigned long) match_val, + (unsigned long) rule)); + + if ((rule & match_val) != match_val) { + continue; + } + + DUK__UNPACK_RULE(rule, nextpart, cflags); + + DUK_DDD(DUK_DDDPRINT("rule match -> part_idx=%ld, sep_idx=%ld, match_val=0x%08lx, " + "rule=0x%08lx -> nextpart=%ld, cflags=0x%02lx", + (long) part_idx, + (long) sep_idx, + (unsigned long) match_val, + (unsigned long) rule, + (long) nextpart, + (unsigned long) cflags)); + + if (cflags & DUK__CF_NEG) { + neg_tzoffset = 1; + } + + if (cflags & DUK__CF_ACCEPT) { + goto accept; + } + + if (cflags & DUK__CF_ACCEPT_NUL) { + DUK_ASSERT(*(p - 1) != (char) 0); + if (*p == DUK_ASC_NUL) { + goto accept; + } + goto reject; + } + + part_idx = nextpart; + break; + } /* rule match */ + + if (i == (duk_small_uint_t) (sizeof(duk__parse_iso8601_control) / sizeof(duk_uint32_t))) { + DUK_DDD(DUK_DDDPRINT("no rule matches -> reject")); + goto reject; + } + + if (ch == 0) { + /* This shouldn't be necessary, but check just in case + * to avoid any chance of overruns. + */ + DUK_DDD(DUK_DDDPRINT("NUL after rule matching (should not happen) -> reject")); + goto reject; + } + } /* if-digit-else-ctrl */ + } /* char loop */ + + /* We should never exit the loop above. */ + DUK_UNREACHABLE(); + +reject: + DUK_DDD(DUK_DDDPRINT("reject")); + return 0; + +accept: + DUK_DDD(DUK_DDDPRINT("accept")); + + /* Apply timezone offset to get the main parts in UTC */ + if (neg_year) { + parts[DUK__PI_YEAR] = -parts[DUK__PI_YEAR]; + } + if (neg_tzoffset) { + parts[DUK__PI_HOUR] += parts[DUK__PI_TZHOUR]; + parts[DUK__PI_MINUTE] += parts[DUK__PI_TZMINUTE]; + } else { + parts[DUK__PI_HOUR] -= parts[DUK__PI_TZHOUR]; + parts[DUK__PI_MINUTE] -= parts[DUK__PI_TZMINUTE]; + } + parts[DUK__PI_MONTH] -= 1; /* zero-based month */ + parts[DUK__PI_DAY] -= 1; /* zero-based day */ + + /* Use double parts, they tolerate unnormalized time. + * + * Note: DUK_DATE_IDX_WEEKDAY is initialized with a bogus value (DUK__PI_TZHOUR) + * on purpose. It won't be actually used by duk_bi_date_get_timeval_from_dparts(), + * but will make the value initialized just in case, and avoid any + * potential for Valgrind issues. + */ + for (i = 0; i < DUK_DATE_IDX_NUM_PARTS; i++) { + DUK_DDD(DUK_DDDPRINT("part[%ld] = %ld", (long) i, (long) parts[i])); + dparts[i] = parts[i]; + } + + d = duk_bi_date_get_timeval_from_dparts(dparts, 0 /*flags*/); + duk_push_number(thr, d); + return 1; +} + +/* + * Date/time parsing helper. + * + * Parse a datetime string into a time value. We must first try to parse + * the input according to the standard format in E5.1 Section 15.9.1.15. + * If that fails, we can try to parse using custom parsing, which can + * either be platform neutral (custom code) or platform specific (using + * existing platform API calls). + * + * Note in particular that we must parse whatever toString(), toUTCString(), + * and toISOString() can produce; see E5.1 Section 15.9.4.2. + * + * Returns 1 to allow tail calling. + * + * There is much room for improvement here with respect to supporting + * alternative datetime formats. For instance, V8 parses '2012-01-01' as + * UTC and '2012/01/01' as local time. + */ + +DUK_LOCAL duk_ret_t duk__parse_string(duk_hthread *thr, const char *str) { + /* XXX: there is a small risk here: because the ISO 8601 parser is + * very loose, it may end up parsing some datetime values which + * would be better parsed with a platform specific parser. + */ + + DUK_ASSERT(str != NULL); + DUK_DDD(DUK_DDDPRINT("parse datetime from string '%s'", (const char *) str)); + + if (duk__parse_string_iso8601_subset(thr, str) != 0) { + return 1; + } + +#if defined(DUK_USE_DATE_PARSE_STRING) + /* Contract, either: + * - Push value on stack and return 1 + * - Don't push anything on stack and return 0 + */ + + if (DUK_USE_DATE_PARSE_STRING(thr, str) != 0) { + return 1; + } +#else + /* No platform-specific parsing, this is not an error. */ +#endif + + duk_push_nan(thr); + return 1; +} + +/* + * Calendar helpers + * + * Some helpers are used for getters and can operate on normalized values + * which can be represented with 32-bit signed integers. Other helpers are + * needed by setters and operate on un-normalized double values, must watch + * out for non-finite numbers etc. + */ + +DUK_LOCAL duk_uint8_t duk__days_in_month[12] = { (duk_uint8_t) 31, (duk_uint8_t) 28, (duk_uint8_t) 31, (duk_uint8_t) 30, + (duk_uint8_t) 31, (duk_uint8_t) 30, (duk_uint8_t) 31, (duk_uint8_t) 31, + (duk_uint8_t) 30, (duk_uint8_t) 31, (duk_uint8_t) 30, (duk_uint8_t) 31 }; + +/* Maximum iteration count for computing UTC-to-local time offset when + * creating an ECMAScript time value from local parts. + */ +#define DUK__LOCAL_TZOFFSET_MAXITER 4 + +/* Because 'day since epoch' can be negative and is used to compute weekday + * using a modulo operation, add this multiple of 7 to avoid negative values + * when year is below 1970 epoch. ECMAScript time values are restricted to + * +/- 100 million days from epoch, so this adder fits nicely into 32 bits. + * Round to a multiple of 7 (= floor(100000000 / 7) * 7) and add margin. + */ +#define DUK__WEEKDAY_MOD_ADDER (20000000 * 7) /* 0x08583b00 */ + +DUK_INTERNAL duk_bool_t duk_bi_date_is_leap_year(duk_int_t year) { + if ((year % 4) != 0) { + return 0; + } + if ((year % 100) != 0) { + return 1; + } + if ((year % 400) != 0) { + return 0; + } + return 1; +} + +DUK_INTERNAL duk_bool_t duk_bi_date_timeval_in_valid_range(duk_double_t x) { + return (x >= -DUK_DATE_MSEC_100M_DAYS && x <= DUK_DATE_MSEC_100M_DAYS); +} + +DUK_INTERNAL duk_bool_t duk_bi_date_timeval_in_leeway_range(duk_double_t x) { + return (x >= -DUK_DATE_MSEC_100M_DAYS_LEEWAY && x <= DUK_DATE_MSEC_100M_DAYS_LEEWAY); +} + +DUK_INTERNAL duk_bool_t duk_bi_date_year_in_valid_range(duk_double_t x) { + return (x >= DUK_DATE_MIN_ECMA_YEAR && x <= DUK_DATE_MAX_ECMA_YEAR); +} + +DUK_LOCAL duk_double_t duk__timeclip(duk_double_t x) { + if (!DUK_ISFINITE(x)) { + return DUK_DOUBLE_NAN; + } + + if (!duk_bi_date_timeval_in_valid_range(x)) { + return DUK_DOUBLE_NAN; + } + + x = duk_js_tointeger_number(x); + + /* Here we'd have the option to normalize -0 to +0. */ + return x; +} + +/* Integer division which floors also negative values correctly. */ +DUK_LOCAL duk_int_t duk__div_floor(duk_int_t a, duk_int_t b) { + DUK_ASSERT(b > 0); + if (a >= 0) { + return a / b; + } else { + /* e.g. a = -4, b = 5 --> -4 - 5 + 1 / 5 --> -8 / 5 --> -1 + * a = -5, b = 5 --> -5 - 5 + 1 / 5 --> -9 / 5 --> -1 + * a = -6, b = 5 --> -6 - 5 + 1 / 5 --> -10 / 5 --> -2 + */ + return (a - b + 1) / b; + } +} + +/* Compute day number of the first day of a given year. */ +DUK_LOCAL duk_int_t duk__day_from_year(duk_int_t year) { + /* Note: in integer arithmetic, (x / 4) is same as floor(x / 4) for non-negative + * values, but is incorrect for negative ones. + */ + return 365 * (year - 1970) + duk__div_floor(year - 1969, 4) - duk__div_floor(year - 1901, 100) + + duk__div_floor(year - 1601, 400); +} + +/* Given a day number, determine year and day-within-year. */ +DUK_LOCAL duk_int_t duk__year_from_day(duk_int_t day, duk_small_int_t *out_day_within_year) { + duk_int_t year; + duk_int_t diff_days; + + /* estimate year upwards (towards positive infinity), then back down; + * two iterations should be enough + */ + + if (day >= 0) { + year = 1970 + day / 365; + } else { + year = 1970 + day / 366; + } + + for (;;) { + diff_days = duk__day_from_year(year) - day; + DUK_DDD(DUK_DDDPRINT("year=%ld day=%ld, diff_days=%ld", (long) year, (long) day, (long) diff_days)); + if (diff_days <= 0) { + DUK_ASSERT(-diff_days < 366); /* fits into duk_small_int_t */ + *out_day_within_year = -diff_days; + DUK_DDD(DUK_DDDPRINT("--> year=%ld, day-within-year=%ld", (long) year, (long) *out_day_within_year)); + DUK_ASSERT(*out_day_within_year >= 0); + DUK_ASSERT(*out_day_within_year < (duk_bi_date_is_leap_year(year) ? 366 : 365)); + return year; + } + + /* Note: this is very tricky; we must never 'overshoot' the + * correction downwards. + */ + year -= 1 + (diff_days - 1) / 366; /* conservative */ + } +} + +/* Given a (year, month, day-within-month) triple, compute day number. + * The input triple is un-normalized and may contain non-finite values. + */ +DUK_LOCAL duk_double_t duk__make_day(duk_double_t year, duk_double_t month, duk_double_t day) { + duk_int_t day_num; + duk_bool_t is_leap; + duk_small_int_t i, n; + + /* Assume that year, month, day are all coerced to whole numbers. + * They may also be NaN or infinity, in which case this function + * must return NaN or infinity to ensure time value becomes NaN. + * If 'day' is NaN, the final return will end up returning a NaN, + * so it doesn't need to be checked here. + */ + + if (!DUK_ISFINITE(year) || !DUK_ISFINITE(month)) { + return DUK_DOUBLE_NAN; + } + + year += DUK_FLOOR(month / 12.0); + + month = DUK_FMOD(month, 12.0); + if (month < 0.0) { + /* handle negative values */ + month += 12.0; + } + + /* The algorithm in E5.1 Section 15.9.1.12 normalizes month, but + * does not normalize the day-of-month (nor check whether or not + * it is finite) because it's not necessary for finding the day + * number which matches the (year,month) pair. + * + * We assume that duk__day_from_year() is exact here. + * + * Without an explicit infinity / NaN check in the beginning, + * day_num would be a bogus integer here. + * + * It's possible for 'year' to be out of integer range here. + * If so, we need to return NaN without integer overflow. + * This fixes test-bug-setyear-overflow.js. + */ + + if (!duk_bi_date_year_in_valid_range(year)) { + DUK_DD(DUK_DDPRINT("year not in ecmascript valid range, avoid integer overflow: %lf", (double) year)); + return DUK_DOUBLE_NAN; + } + day_num = duk__day_from_year((duk_int_t) year); + is_leap = duk_bi_date_is_leap_year((duk_int_t) year); + + n = (duk_small_int_t) month; + for (i = 0; i < n; i++) { + day_num += duk__days_in_month[i]; + if (i == 1 && is_leap) { + day_num++; + } + } + + /* If 'day' is NaN, returns NaN. */ + return (duk_double_t) day_num + day; +} + +/* Split time value into parts. The time value may contain fractions (it may + * come from duk_time_to_components() API call) which are truncated. Possible + * local time adjustment has already been applied when reading the time value. + */ +DUK_INTERNAL void duk_bi_date_timeval_to_parts(duk_double_t d, duk_int_t *parts, duk_double_t *dparts, duk_small_uint_t flags) { + duk_double_t d1, d2; + duk_int_t t1, t2; + duk_int_t day_since_epoch; + duk_int_t year; /* does not fit into 16 bits */ + duk_small_int_t day_in_year; + duk_small_int_t month; + duk_small_int_t day; + duk_small_int_t dim; + duk_int_t jan1_since_epoch; + duk_small_int_t jan1_weekday; + duk_int_t equiv_year; + duk_small_uint_t i; + duk_bool_t is_leap; + duk_small_int_t arridx; + + DUK_ASSERT(DUK_ISFINITE(d)); /* caller checks */ + d = DUK_FLOOR(d); /* remove fractions if present */ + DUK_ASSERT(duk_double_equals(DUK_FLOOR(d), d)); + + /* The timevalue must be in valid ECMAScript range, but since a local + * time offset can be applied, we need to allow a +/- 24h leeway to + * the value. In other words, although the UTC time is within the + * ECMAScript range, the local part values can be just outside of it. + */ + DUK_UNREF(duk_bi_date_timeval_in_leeway_range); + DUK_ASSERT(duk_bi_date_timeval_in_leeway_range(d)); + + /* These computations are guaranteed to be exact for the valid + * E5 time value range, assuming milliseconds without fractions. + */ + d1 = (duk_double_t) DUK_FMOD(d, (double) DUK_DATE_MSEC_DAY); + if (d1 < 0.0) { + /* deal with negative values */ + d1 += (duk_double_t) DUK_DATE_MSEC_DAY; + } + d2 = DUK_FLOOR((double) (d / (duk_double_t) DUK_DATE_MSEC_DAY)); + DUK_ASSERT(duk_double_equals(d2 * ((duk_double_t) DUK_DATE_MSEC_DAY) + d1, d)); + /* now expected to fit into a 32-bit integer */ + t1 = (duk_int_t) d1; + t2 = (duk_int_t) d2; + day_since_epoch = t2; + DUK_ASSERT(duk_double_equals((duk_double_t) t1, d1)); + DUK_ASSERT(duk_double_equals((duk_double_t) t2, d2)); + + /* t1 = milliseconds within day (fits 32 bit) + * t2 = day number from epoch (fits 32 bit, may be negative) + */ + + parts[DUK_DATE_IDX_MILLISECOND] = t1 % 1000; + t1 /= 1000; + parts[DUK_DATE_IDX_SECOND] = t1 % 60; + t1 /= 60; + parts[DUK_DATE_IDX_MINUTE] = t1 % 60; + t1 /= 60; + parts[DUK_DATE_IDX_HOUR] = t1; + DUK_ASSERT(parts[DUK_DATE_IDX_MILLISECOND] >= 0 && parts[DUK_DATE_IDX_MILLISECOND] <= 999); + DUK_ASSERT(parts[DUK_DATE_IDX_SECOND] >= 0 && parts[DUK_DATE_IDX_SECOND] <= 59); + DUK_ASSERT(parts[DUK_DATE_IDX_MINUTE] >= 0 && parts[DUK_DATE_IDX_MINUTE] <= 59); + DUK_ASSERT(parts[DUK_DATE_IDX_HOUR] >= 0 && parts[DUK_DATE_IDX_HOUR] <= 23); + + DUK_DDD(DUK_DDDPRINT("d=%lf, d1=%lf, d2=%lf, t1=%ld, t2=%ld, parts: hour=%ld min=%ld sec=%ld msec=%ld", + (double) d, + (double) d1, + (double) d2, + (long) t1, + (long) t2, + (long) parts[DUK_DATE_IDX_HOUR], + (long) parts[DUK_DATE_IDX_MINUTE], + (long) parts[DUK_DATE_IDX_SECOND], + (long) parts[DUK_DATE_IDX_MILLISECOND])); + + /* This assert depends on the input parts representing time inside + * the ECMAScript range. + */ + DUK_ASSERT(t2 + DUK__WEEKDAY_MOD_ADDER >= 0); + parts[DUK_DATE_IDX_WEEKDAY] = (t2 + 4 + DUK__WEEKDAY_MOD_ADDER) % 7; /* E5.1 Section 15.9.1.6 */ + DUK_ASSERT(parts[DUK_DATE_IDX_WEEKDAY] >= 0 && parts[DUK_DATE_IDX_WEEKDAY] <= 6); + + year = duk__year_from_day(t2, &day_in_year); + day = day_in_year; + is_leap = duk_bi_date_is_leap_year(year); + for (month = 0; month < 12; month++) { + dim = duk__days_in_month[month]; + if (month == 1 && is_leap) { + dim++; + } + DUK_DDD(DUK_DDDPRINT("month=%ld, dim=%ld, day=%ld", (long) month, (long) dim, (long) day)); + if (day < dim) { + break; + } + day -= dim; + } + DUK_DDD(DUK_DDDPRINT("final month=%ld", (long) month)); + DUK_ASSERT(month >= 0 && month <= 11); + DUK_ASSERT(day >= 0 && day <= 31); + + /* Equivalent year mapping, used to avoid DST trouble when platform + * may fail to provide reasonable DST answers for dates outside the + * ordinary range (e.g. 1970-2038). An equivalent year has the same + * leap-year-ness as the original year and begins on the same weekday + * (Jan 1). + * + * The year 2038 is avoided because there seem to be problems with it + * on some platforms. The year 1970 is also avoided as there were + * practical problems with it; an equivalent year is used for it too, + * which breaks some DST computations for 1970 right now, see e.g. + * test-bi-date-tzoffset-brute-fi.js. + */ + if ((flags & DUK_DATE_FLAG_EQUIVYEAR) && (year < 1971 || year > 2037)) { + DUK_ASSERT(is_leap == 0 || is_leap == 1); + + jan1_since_epoch = day_since_epoch - day_in_year; /* day number for Jan 1 since epoch */ + DUK_ASSERT(jan1_since_epoch + DUK__WEEKDAY_MOD_ADDER >= 0); + jan1_weekday = (jan1_since_epoch + 4 + DUK__WEEKDAY_MOD_ADDER) % 7; /* E5.1 Section 15.9.1.6 */ + DUK_ASSERT(jan1_weekday >= 0 && jan1_weekday <= 6); + arridx = jan1_weekday; + if (is_leap) { + arridx += 7; + } + DUK_ASSERT(arridx >= 0 && arridx < (duk_small_int_t) (sizeof(duk__date_equivyear) / sizeof(duk_uint8_t))); + + equiv_year = (duk_int_t) duk__date_equivyear[arridx] + 1970; + year = equiv_year; + DUK_DDD(DUK_DDDPRINT("equiv year mapping, year=%ld, day_in_year=%ld, day_since_epoch=%ld, " + "jan1_since_epoch=%ld, jan1_weekday=%ld -> equiv year %ld", + (long) year, + (long) day_in_year, + (long) day_since_epoch, + (long) jan1_since_epoch, + (long) jan1_weekday, + (long) equiv_year)); + } + + parts[DUK_DATE_IDX_YEAR] = year; + parts[DUK_DATE_IDX_MONTH] = month; + parts[DUK_DATE_IDX_DAY] = day; + + if (flags & DUK_DATE_FLAG_ONEBASED) { + parts[DUK_DATE_IDX_MONTH]++; /* zero-based -> one-based */ + parts[DUK_DATE_IDX_DAY]++; /* -""- */ + } + + if (dparts != NULL) { + for (i = 0; i < DUK_DATE_IDX_NUM_PARTS; i++) { + dparts[i] = (duk_double_t) parts[i]; + } + } +} + +/* Compute time value from (double) parts. The parts can be either UTC + * or local time; if local, they need to be (conceptually) converted into + * UTC time. The parts may represent valid or invalid time, and may be + * wildly out of range (but may cancel each other and still come out in + * the valid Date range). + */ +DUK_INTERNAL duk_double_t duk_bi_date_get_timeval_from_dparts(duk_double_t *dparts, duk_small_uint_t flags) { +#if defined(DUK_USE_PARANOID_DATE_COMPUTATION) + /* See comments below on MakeTime why these are volatile. */ + volatile duk_double_t tmp_time; + volatile duk_double_t tmp_day; + volatile duk_double_t d; +#else + duk_double_t tmp_time; + duk_double_t tmp_day; + duk_double_t d; +#endif + duk_small_uint_t i; + duk_int_t tzoff, tzoffprev1, tzoffprev2; + + /* Expects 'this' at top of stack on entry. */ + + /* Coerce all finite parts with ToInteger(). ToInteger() must not + * be called for NaN/Infinity because it will convert e.g. NaN to + * zero. If ToInteger() has already been called, this has no side + * effects and is idempotent. + * + * Don't read dparts[DUK_DATE_IDX_WEEKDAY]; it will cause Valgrind + * issues if the value is uninitialized. + */ + for (i = 0; i <= DUK_DATE_IDX_MILLISECOND; i++) { + /* SCANBUILD: scan-build complains here about assigned value + * being garbage or undefined. This is correct but operating + * on undefined values has no ill effect and is ignored by the + * caller in the case where this happens. + */ + d = dparts[i]; + if (DUK_ISFINITE(d)) { + dparts[i] = duk_js_tointeger_number(d); + } + } + + /* Use explicit steps in computation to try to ensure that + * computation happens with intermediate results coerced to + * double values (instead of using something more accurate). + * E.g. E5.1 Section 15.9.1.11 requires use of IEEE 754 + * rules (= ECMAScript '+' and '*' operators). + * + * Without 'volatile' even this approach fails on some platform + * and compiler combinations. For instance, gcc 4.8.1 on Ubuntu + * 64-bit, with -m32 and without -std=c99, test-bi-date-canceling.js + * would fail because of some optimizations when computing tmp_time + * (MakeTime below). Adding 'volatile' to tmp_time solved this + * particular problem (annoyingly, also adding debug prints or + * running the executable under valgrind hides it). + */ + + /* MakeTime */ + tmp_time = 0.0; + tmp_time += dparts[DUK_DATE_IDX_HOUR] * ((duk_double_t) DUK_DATE_MSEC_HOUR); + tmp_time += dparts[DUK_DATE_IDX_MINUTE] * ((duk_double_t) DUK_DATE_MSEC_MINUTE); + tmp_time += dparts[DUK_DATE_IDX_SECOND] * ((duk_double_t) DUK_DATE_MSEC_SECOND); + tmp_time += dparts[DUK_DATE_IDX_MILLISECOND]; + + /* MakeDay */ + tmp_day = duk__make_day(dparts[DUK_DATE_IDX_YEAR], dparts[DUK_DATE_IDX_MONTH], dparts[DUK_DATE_IDX_DAY]); + + /* MakeDate */ + d = tmp_day * ((duk_double_t) DUK_DATE_MSEC_DAY) + tmp_time; + + DUK_DDD(DUK_DDDPRINT("time=%lf day=%lf --> timeval=%lf", (double) tmp_time, (double) tmp_day, (double) d)); + + /* Optional UTC conversion. */ + if (flags & DUK_DATE_FLAG_LOCALTIME) { + /* DUK_USE_DATE_GET_LOCAL_TZOFFSET() needs to be called with a + * time value computed from UTC parts. At this point we only + * have 'd' which is a time value computed from local parts, so + * it is off by the UTC-to-local time offset which we don't know + * yet. The current solution for computing the UTC-to-local + * time offset is to iterate a few times and detect a fixed + * point or a two-cycle loop (or a sanity iteration limit), + * see test-bi-date-local-parts.js and test-bi-date-tzoffset-basic-fi.js. + * + * E5.1 Section 15.9.1.9: + * UTC(t) = t - LocalTZA - DaylightSavingTA(t - LocalTZA) + * + * For NaN/inf, DUK_USE_DATE_GET_LOCAL_TZOFFSET() returns 0. + */ + +#if 0 + /* Old solution: don't iterate, incorrect */ + tzoff = DUK_USE_DATE_GET_LOCAL_TZOFFSET(d); + DUK_DDD(DUK_DDDPRINT("tzoffset w/o iteration, tzoff=%ld", (long) tzoff)); + d -= tzoff * 1000L; + DUK_UNREF(tzoffprev1); + DUK_UNREF(tzoffprev2); +#endif + + /* Iteration solution */ + tzoff = 0; + tzoffprev1 = 999999999L; /* invalid value which never matches */ + for (i = 0; i < DUK__LOCAL_TZOFFSET_MAXITER; i++) { + tzoffprev2 = tzoffprev1; + tzoffprev1 = tzoff; + tzoff = DUK_USE_DATE_GET_LOCAL_TZOFFSET(d - tzoff * 1000L); + DUK_DDD(DUK_DDDPRINT("tzoffset iteration, i=%d, tzoff=%ld, tzoffprev1=%ld tzoffprev2=%ld", + (int) i, + (long) tzoff, + (long) tzoffprev1, + (long) tzoffprev2)); + if (tzoff == tzoffprev1) { + DUK_DDD(DUK_DDDPRINT("tzoffset iteration finished, i=%d, tzoff=%ld, tzoffprev1=%ld, tzoffprev2=%ld", + (int) i, + (long) tzoff, + (long) tzoffprev1, + (long) tzoffprev2)); + break; + } else if (tzoff == tzoffprev2) { + /* Two value cycle, see e.g. test-bi-date-tzoffset-basic-fi.js. + * In these cases, favor a higher tzoffset to get a consistent + * result which is independent of iteration count. Not sure if + * this is a generically correct solution. + */ + DUK_DDD(DUK_DDDPRINT( + "tzoffset iteration two-value cycle, i=%d, tzoff=%ld, tzoffprev1=%ld, tzoffprev2=%ld", + (int) i, + (long) tzoff, + (long) tzoffprev1, + (long) tzoffprev2)); + if (tzoffprev1 > tzoff) { + tzoff = tzoffprev1; + } + break; + } + } + DUK_DDD(DUK_DDDPRINT("tzoffset iteration, tzoff=%ld", (long) tzoff)); + d -= tzoff * 1000L; + } + + /* TimeClip(), which also handles Infinity -> NaN conversion */ + d = duk__timeclip(d); + + return d; +} + +/* + * API oriented helpers + */ + +/* Push 'this' binding, check that it is a Date object; then push the + * internal time value. At the end, stack is: [ ... this timeval ]. + * Returns the time value. Local time adjustment is done if requested. + */ +DUK_LOCAL duk_double_t duk__push_this_get_timeval_tzoffset(duk_hthread *thr, duk_small_uint_t flags, duk_int_t *out_tzoffset) { + duk_hobject *h; + duk_double_t d; + duk_int_t tzoffset = 0; + + duk_push_this(thr); + h = duk_get_hobject(thr, -1); /* XXX: getter with class check, useful in built-ins */ + if (h == NULL || DUK_HOBJECT_GET_CLASS_NUMBER(h) != DUK_HOBJECT_CLASS_DATE) { + DUK_ERROR_TYPE(thr, "expected Date"); + DUK_WO_NORETURN(return 0.0;); + } + + duk_xget_owndataprop_stridx_short(thr, -1, DUK_STRIDX_INT_VALUE); + d = duk_to_number_m1(thr); + duk_pop(thr); + + if (DUK_ISNAN(d)) { + if (flags & DUK_DATE_FLAG_NAN_TO_ZERO) { + d = 0.0; + } + if (flags & DUK_DATE_FLAG_NAN_TO_RANGE_ERROR) { + DUK_ERROR_RANGE(thr, "Invalid Date"); + DUK_WO_NORETURN(return 0.0;); + } + } + /* if no NaN handling flag, may still be NaN here, but not Inf */ + DUK_ASSERT(!DUK_ISINF(d)); + + if (flags & DUK_DATE_FLAG_LOCALTIME) { + /* Note: DST adjustment is determined using UTC time. + * If 'd' is NaN, tzoffset will be 0. + */ + tzoffset = DUK_USE_DATE_GET_LOCAL_TZOFFSET(d); /* seconds */ + d += tzoffset * 1000L; + } + if (out_tzoffset) { + *out_tzoffset = tzoffset; + } + + /* [ ... this ] */ + return d; +} + +DUK_LOCAL duk_double_t duk__push_this_get_timeval(duk_hthread *thr, duk_small_uint_t flags) { + return duk__push_this_get_timeval_tzoffset(thr, flags, NULL); +} + +/* Set timeval to 'this' from dparts, push the new time value onto the + * value stack and return 1 (caller can then tail call us). Expects + * the value stack to contain 'this' on the stack top. + */ +DUK_LOCAL duk_ret_t duk__set_this_timeval_from_dparts(duk_hthread *thr, duk_double_t *dparts, duk_small_uint_t flags) { + duk_double_t d; + + /* [ ... this ] */ + + d = duk_bi_date_get_timeval_from_dparts(dparts, flags); + duk_push_number(thr, d); /* -> [ ... this timeval_new ] */ + duk_dup_top(thr); /* -> [ ... this timeval_new timeval_new ] */ + + /* Must force write because e.g. .setYear() must work even when + * the Date instance is frozen. + */ + duk_xdef_prop_stridx_short(thr, -3, DUK_STRIDX_INT_VALUE, DUK_PROPDESC_FLAGS_W); + + /* Stack top: new time value, return 1 to allow tail calls. */ + return 1; +} + +/* 'out_buf' must be at least DUK_BI_DATE_ISO8601_BUFSIZE long. */ +DUK_LOCAL void duk__format_parts_iso8601(duk_int_t *parts, duk_int_t tzoffset, duk_small_uint_t flags, duk_uint8_t *out_buf) { + char yearstr[8]; /* "-123456\0" */ + char tzstr[8]; /* "+11:22\0" */ + char sep = (flags & DUK_DATE_FLAG_SEP_T) ? DUK_ASC_UC_T : DUK_ASC_SPACE; + + DUK_ASSERT(parts[DUK_DATE_IDX_MONTH] >= 1 && parts[DUK_DATE_IDX_MONTH] <= 12); + DUK_ASSERT(parts[DUK_DATE_IDX_DAY] >= 1 && parts[DUK_DATE_IDX_DAY] <= 31); + DUK_ASSERT(parts[DUK_DATE_IDX_YEAR] >= -999999 && parts[DUK_DATE_IDX_YEAR] <= 999999); + + /* Note: %06d for positive value, %07d for negative value to include + * sign and 6 digits. + */ + DUK_SNPRINTF(yearstr, + sizeof(yearstr), + (parts[DUK_DATE_IDX_YEAR] >= 0 && parts[DUK_DATE_IDX_YEAR] <= 9999) ? + "%04ld" : + ((parts[DUK_DATE_IDX_YEAR] >= 0) ? "+%06ld" : "%07ld"), + (long) parts[DUK_DATE_IDX_YEAR]); + yearstr[sizeof(yearstr) - 1] = (char) 0; + + if (flags & DUK_DATE_FLAG_LOCALTIME) { + /* tzoffset seconds are dropped; 16 bits suffice for + * time offset in minutes + */ + const char *fmt; + duk_small_int_t tmp, arg_hours, arg_minutes; + + if (tzoffset >= 0) { + tmp = tzoffset; + fmt = "+%02d:%02d"; + } else { + tmp = -tzoffset; + fmt = "-%02d:%02d"; + } + tmp = tmp / 60; + arg_hours = tmp / 60; + arg_minutes = tmp % 60; + DUK_ASSERT(arg_hours <= 24); /* Even less is actually guaranteed for a valid tzoffset. */ + arg_hours = arg_hours & 0x3f; /* For [0,24] this is a no-op, but fixes GCC 7 warning, see + https://github.com/svaarala/duktape/issues/1602. */ + + DUK_SNPRINTF(tzstr, sizeof(tzstr), fmt, (int) arg_hours, (int) arg_minutes); + tzstr[sizeof(tzstr) - 1] = (char) 0; + } else { + tzstr[0] = DUK_ASC_UC_Z; + tzstr[1] = (char) 0; + } + + /* Unlike year, the other parts fit into 16 bits so %d format + * is portable. + */ + if ((flags & DUK_DATE_FLAG_TOSTRING_DATE) && (flags & DUK_DATE_FLAG_TOSTRING_TIME)) { + DUK_SPRINTF((char *) out_buf, + "%s-%02d-%02d%c%02d:%02d:%02d.%03d%s", + (const char *) yearstr, + (int) parts[DUK_DATE_IDX_MONTH], + (int) parts[DUK_DATE_IDX_DAY], + (int) sep, + (int) parts[DUK_DATE_IDX_HOUR], + (int) parts[DUK_DATE_IDX_MINUTE], + (int) parts[DUK_DATE_IDX_SECOND], + (int) parts[DUK_DATE_IDX_MILLISECOND], + (const char *) tzstr); + } else if (flags & DUK_DATE_FLAG_TOSTRING_DATE) { + DUK_SPRINTF((char *) out_buf, + "%s-%02d-%02d", + (const char *) yearstr, + (int) parts[DUK_DATE_IDX_MONTH], + (int) parts[DUK_DATE_IDX_DAY]); + } else { + DUK_ASSERT(flags & DUK_DATE_FLAG_TOSTRING_TIME); + DUK_SPRINTF((char *) out_buf, + "%02d:%02d:%02d.%03d%s", + (int) parts[DUK_DATE_IDX_HOUR], + (int) parts[DUK_DATE_IDX_MINUTE], + (int) parts[DUK_DATE_IDX_SECOND], + (int) parts[DUK_DATE_IDX_MILLISECOND], + (const char *) tzstr); + } +} + +/* Helper for string conversion calls: check 'this' binding, get the + * internal time value, and format date and/or time in a few formats. + * Return value allows tail calls. + */ +DUK_LOCAL duk_ret_t duk__to_string_helper(duk_hthread *thr, duk_small_uint_t flags) { + duk_double_t d; + duk_int_t parts[DUK_DATE_IDX_NUM_PARTS]; + duk_int_t tzoffset; /* seconds, doesn't fit into 16 bits */ + duk_bool_t rc; + duk_uint8_t buf[DUK_BI_DATE_ISO8601_BUFSIZE]; + + DUK_UNREF(rc); /* unreferenced with some options */ + + d = duk__push_this_get_timeval_tzoffset(thr, flags, &tzoffset); + if (DUK_ISNAN(d)) { + duk_push_hstring_stridx(thr, DUK_STRIDX_INVALID_DATE); + return 1; + } + DUK_ASSERT(DUK_ISFINITE(d)); + + /* formatters always get one-based month/day-of-month */ + duk_bi_date_timeval_to_parts(d, parts, NULL, DUK_DATE_FLAG_ONEBASED); + DUK_ASSERT(parts[DUK_DATE_IDX_MONTH] >= 1 && parts[DUK_DATE_IDX_MONTH] <= 12); + DUK_ASSERT(parts[DUK_DATE_IDX_DAY] >= 1 && parts[DUK_DATE_IDX_DAY] <= 31); + + if (flags & DUK_DATE_FLAG_TOSTRING_LOCALE) { + /* try locale specific formatter; if it refuses to format the + * string, fall back to an ISO 8601 formatted value in local + * time. + */ +#if defined(DUK_USE_DATE_FORMAT_STRING) + /* Contract, either: + * - Push string to value stack and return 1 + * - Don't push anything and return 0 + */ + + rc = DUK_USE_DATE_FORMAT_STRING(thr, parts, tzoffset, flags); + if (rc != 0) { + return 1; + } +#else + /* No locale specific formatter; this is OK, we fall back + * to ISO 8601. + */ +#endif + } + + /* Different calling convention than above used because the helper + * is shared. + */ + duk__format_parts_iso8601(parts, tzoffset, flags, buf); + duk_push_string(thr, (const char *) buf); + return 1; +} + +/* Helper for component getter calls: check 'this' binding, get the + * internal time value, split it into parts (either as UTC time or + * local time), push a specified component as a return value to the + * value stack and return 1 (caller can then tail call us). + */ +DUK_LOCAL duk_ret_t duk__get_part_helper(duk_hthread *thr, duk_small_uint_t flags_and_idx) { + duk_double_t d; + duk_int_t parts[DUK_DATE_IDX_NUM_PARTS]; + duk_small_uint_t idx_part = (duk_small_uint_t) (flags_and_idx >> DUK_DATE_FLAG_VALUE_SHIFT); /* unpack args */ + + DUK_ASSERT_DISABLE(idx_part >= 0); /* unsigned */ + DUK_ASSERT(idx_part < DUK_DATE_IDX_NUM_PARTS); + + d = duk__push_this_get_timeval(thr, flags_and_idx); + if (DUK_ISNAN(d)) { + duk_push_nan(thr); + return 1; + } + DUK_ASSERT(DUK_ISFINITE(d)); + + duk_bi_date_timeval_to_parts(d, parts, NULL, flags_and_idx); /* no need to mask idx portion */ + + /* Setter APIs detect special year numbers (0...99) and apply a +1900 + * only in certain cases. The legacy getYear() getter applies -1900 + * unconditionally. + */ + duk_push_int(thr, (flags_and_idx & DUK_DATE_FLAG_SUB1900) ? parts[idx_part] - 1900 : parts[idx_part]); + return 1; +} + +/* Helper for component setter calls: check 'this' binding, get the + * internal time value, split it into parts (either as UTC time or + * local time), modify one or more components as specified, recompute + * the time value, set it as the internal value. Finally, push the + * new time value as a return value to the value stack and return 1 + * (caller can then tail call us). + */ +DUK_LOCAL duk_ret_t duk__set_part_helper(duk_hthread *thr, duk_small_uint_t flags_and_maxnargs) { + duk_double_t d; + duk_int_t parts[DUK_DATE_IDX_NUM_PARTS]; + duk_double_t dparts[DUK_DATE_IDX_NUM_PARTS]; + duk_idx_t nargs; + duk_small_uint_t maxnargs = (duk_small_uint_t) (flags_and_maxnargs >> DUK_DATE_FLAG_VALUE_SHIFT); /* unpack args */ + duk_small_uint_t idx_first, idx; + duk_small_uint_t i; + + nargs = duk_get_top(thr); + d = duk__push_this_get_timeval(thr, flags_and_maxnargs); + DUK_ASSERT(DUK_ISFINITE(d) || DUK_ISNAN(d)); + + if (DUK_ISFINITE(d)) { + duk_bi_date_timeval_to_parts(d, parts, dparts, flags_and_maxnargs); + } else { + /* NaN timevalue: we need to coerce the arguments, but + * the resulting internal timestamp needs to remain NaN. + * This works but is not pretty: parts and dparts will + * be partially uninitialized, but we only write to them. + */ + } + + /* + * Determining which datetime components to overwrite based on + * stack arguments is a bit complicated, but important to factor + * out from setters themselves for compactness. + * + * If DUK_DATE_FLAG_TIMESETTER, maxnargs indicates setter type: + * + * 1 -> millisecond + * 2 -> second, [millisecond] + * 3 -> minute, [second], [millisecond] + * 4 -> hour, [minute], [second], [millisecond] + * + * Else: + * + * 1 -> date + * 2 -> month, [date] + * 3 -> year, [month], [date] + * + * By comparing nargs and maxnargs (and flags) we know which + * components to override. We rely on part index ordering. + */ + + if (flags_and_maxnargs & DUK_DATE_FLAG_TIMESETTER) { + DUK_ASSERT(maxnargs >= 1 && maxnargs <= 4); + idx_first = DUK_DATE_IDX_MILLISECOND - (maxnargs - 1); + } else { + DUK_ASSERT(maxnargs >= 1 && maxnargs <= 3); + idx_first = DUK_DATE_IDX_DAY - (maxnargs - 1); + } + DUK_ASSERT_DISABLE(idx_first >= 0); /* unsigned */ + DUK_ASSERT(idx_first < DUK_DATE_IDX_NUM_PARTS); + + for (i = 0; i < maxnargs; i++) { + if ((duk_idx_t) i >= nargs) { + /* no argument given -> leave components untouched */ + break; + } + idx = idx_first + i; + DUK_ASSERT_DISABLE(idx >= 0); /* unsigned */ + DUK_ASSERT(idx < DUK_DATE_IDX_NUM_PARTS); + + if (idx == DUK_DATE_IDX_YEAR && (flags_and_maxnargs & DUK_DATE_FLAG_YEAR_FIXUP)) { + duk__twodigit_year_fixup(thr, (duk_idx_t) i); + } + + dparts[idx] = duk_to_number(thr, (duk_idx_t) i); + + if (idx == DUK_DATE_IDX_DAY) { + /* Day-of-month is one-based in the API, but zero-based + * internally, so fix here. Note that month is zero-based + * both in the API and internally. + */ + /* SCANBUILD: complains about use of uninitialized values. + * The complaint is correct, but operating in undefined + * values here is intentional in some cases and the caller + * ignores the results. + */ + dparts[idx] -= 1.0; + } + } + + /* Leaves new timevalue on stack top and returns 1, which is correct + * for part setters. + */ + if (DUK_ISFINITE(d)) { + return duk__set_this_timeval_from_dparts(thr, dparts, flags_and_maxnargs); + } else { + /* Internal timevalue is already NaN, so don't touch it. */ + duk_push_nan(thr); + return 1; + } +} + +/* Apply ToNumber() to specified index; if ToInteger(val) in [0,99], add + * 1900 and replace value at idx_val. + */ +DUK_LOCAL void duk__twodigit_year_fixup(duk_hthread *thr, duk_idx_t idx_val) { + duk_double_t d; + + /* XXX: idx_val would fit into 16 bits, but using duk_small_uint_t + * might not generate better code due to casting. + */ + + /* E5 Sections 15.9.3.1, B.2.4, B.2.5 */ + duk_to_number(thr, idx_val); + if (duk_is_nan(thr, idx_val)) { + return; + } + duk_dup(thr, idx_val); + duk_to_int(thr, -1); + d = duk_get_number(thr, -1); /* get as double to handle huge numbers correctly */ + if (d >= 0.0 && d <= 99.0) { + d += 1900.0; + duk_push_number(thr, d); + duk_replace(thr, idx_val); + } + duk_pop(thr); +} + +/* Set datetime parts from stack arguments, defaulting any missing values. + * Day-of-week is not set; it is not required when setting the time value. + */ +DUK_LOCAL void duk__set_parts_from_args(duk_hthread *thr, duk_double_t *dparts, duk_idx_t nargs) { + duk_double_t d; + duk_small_uint_t i; + duk_small_uint_t idx; + + /* Causes a ToNumber() coercion, but doesn't break coercion order since + * year is coerced first anyway. + */ + duk__twodigit_year_fixup(thr, 0); + + /* There are at most 7 args, but we use 8 here so that also + * DUK_DATE_IDX_WEEKDAY gets initialized (to zero) to avoid the potential + * for any Valgrind gripes later. + */ + for (i = 0; i < 8; i++) { + /* Note: rely on index ordering */ + idx = DUK_DATE_IDX_YEAR + i; + if ((duk_idx_t) i < nargs) { + d = duk_to_number(thr, (duk_idx_t) i); + if (idx == DUK_DATE_IDX_DAY) { + /* Convert day from one-based to zero-based (internal). This may + * cause the day part to be negative, which is OK. + */ + d -= 1.0; + } + } else { + /* All components default to 0 except day-of-month which defaults + * to 1. However, because our internal day-of-month is zero-based, + * it also defaults to zero here. + */ + d = 0.0; + } + dparts[idx] = d; + } + + DUK_DDD(DUK_DDDPRINT("parts from args -> %lf %lf %lf %lf %lf %lf %lf %lf", + (double) dparts[0], + (double) dparts[1], + (double) dparts[2], + (double) dparts[3], + (double) dparts[4], + (double) dparts[5], + (double) dparts[6], + (double) dparts[7])); +} + +/* + * Indirect magic value lookup for Date methods. + * + * Date methods don't put their control flags into the function magic value + * because they wouldn't fit into a LIGHTFUNC's magic field. Instead, the + * magic value is set to an index pointing to the array of control flags + * below. + * + * This must be kept in strict sync with genbuiltins.py! + */ + +static duk_uint16_t duk__date_magics[] = { + /* 0: toString */ + DUK_DATE_FLAG_TOSTRING_DATE + DUK_DATE_FLAG_TOSTRING_TIME + DUK_DATE_FLAG_LOCALTIME, + + /* 1: toDateString */ + DUK_DATE_FLAG_TOSTRING_DATE + DUK_DATE_FLAG_LOCALTIME, + + /* 2: toTimeString */ + DUK_DATE_FLAG_TOSTRING_TIME + DUK_DATE_FLAG_LOCALTIME, + + /* 3: toLocaleString */ + DUK_DATE_FLAG_TOSTRING_DATE + DUK_DATE_FLAG_TOSTRING_TIME + DUK_DATE_FLAG_TOSTRING_LOCALE + DUK_DATE_FLAG_LOCALTIME, + + /* 4: toLocaleDateString */ + DUK_DATE_FLAG_TOSTRING_DATE + DUK_DATE_FLAG_TOSTRING_LOCALE + DUK_DATE_FLAG_LOCALTIME, + + /* 5: toLocaleTimeString */ + DUK_DATE_FLAG_TOSTRING_TIME + DUK_DATE_FLAG_TOSTRING_LOCALE + DUK_DATE_FLAG_LOCALTIME, + + /* 6: toUTCString */ + DUK_DATE_FLAG_TOSTRING_DATE + DUK_DATE_FLAG_TOSTRING_TIME, + + /* 7: toISOString */ + DUK_DATE_FLAG_TOSTRING_DATE + DUK_DATE_FLAG_TOSTRING_TIME + DUK_DATE_FLAG_NAN_TO_RANGE_ERROR + DUK_DATE_FLAG_SEP_T, + + /* 8: getFullYear */ + DUK_DATE_FLAG_LOCALTIME + (DUK_DATE_IDX_YEAR << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 9: getUTCFullYear */ + 0 + (DUK_DATE_IDX_YEAR << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 10: getMonth */ + DUK_DATE_FLAG_LOCALTIME + (DUK_DATE_IDX_MONTH << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 11: getUTCMonth */ + 0 + (DUK_DATE_IDX_MONTH << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 12: getDate */ + DUK_DATE_FLAG_ONEBASED + DUK_DATE_FLAG_LOCALTIME + (DUK_DATE_IDX_DAY << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 13: getUTCDate */ + DUK_DATE_FLAG_ONEBASED + (DUK_DATE_IDX_DAY << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 14: getDay */ + DUK_DATE_FLAG_LOCALTIME + (DUK_DATE_IDX_WEEKDAY << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 15: getUTCDay */ + 0 + (DUK_DATE_IDX_WEEKDAY << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 16: getHours */ + DUK_DATE_FLAG_LOCALTIME + (DUK_DATE_IDX_HOUR << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 17: getUTCHours */ + 0 + (DUK_DATE_IDX_HOUR << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 18: getMinutes */ + DUK_DATE_FLAG_LOCALTIME + (DUK_DATE_IDX_MINUTE << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 19: getUTCMinutes */ + 0 + (DUK_DATE_IDX_MINUTE << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 20: getSeconds */ + DUK_DATE_FLAG_LOCALTIME + (DUK_DATE_IDX_SECOND << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 21: getUTCSeconds */ + 0 + (DUK_DATE_IDX_SECOND << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 22: getMilliseconds */ + DUK_DATE_FLAG_LOCALTIME + (DUK_DATE_IDX_MILLISECOND << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 23: getUTCMilliseconds */ + 0 + (DUK_DATE_IDX_MILLISECOND << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 24: setMilliseconds */ + DUK_DATE_FLAG_TIMESETTER + DUK_DATE_FLAG_LOCALTIME + (1 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 25: setUTCMilliseconds */ + DUK_DATE_FLAG_TIMESETTER + (1 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 26: setSeconds */ + DUK_DATE_FLAG_TIMESETTER + DUK_DATE_FLAG_LOCALTIME + (2 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 27: setUTCSeconds */ + DUK_DATE_FLAG_TIMESETTER + (2 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 28: setMinutes */ + DUK_DATE_FLAG_TIMESETTER + DUK_DATE_FLAG_LOCALTIME + (3 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 29: setUTCMinutes */ + DUK_DATE_FLAG_TIMESETTER + (3 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 30: setHours */ + DUK_DATE_FLAG_TIMESETTER + DUK_DATE_FLAG_LOCALTIME + (4 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 31: setUTCHours */ + DUK_DATE_FLAG_TIMESETTER + (4 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 32: setDate */ + DUK_DATE_FLAG_LOCALTIME + (1 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 33: setUTCDate */ + 0 + (1 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 34: setMonth */ + DUK_DATE_FLAG_LOCALTIME + (2 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 35: setUTCMonth */ + 0 + (2 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 36: setFullYear */ + DUK_DATE_FLAG_NAN_TO_ZERO + DUK_DATE_FLAG_LOCALTIME + (3 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 37: setUTCFullYear */ + DUK_DATE_FLAG_NAN_TO_ZERO + (3 << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 38: getYear */ + DUK_DATE_FLAG_LOCALTIME + DUK_DATE_FLAG_SUB1900 + (DUK_DATE_IDX_YEAR << DUK_DATE_FLAG_VALUE_SHIFT), + + /* 39: setYear */ + DUK_DATE_FLAG_NAN_TO_ZERO + DUK_DATE_FLAG_YEAR_FIXUP + (3 << DUK_DATE_FLAG_VALUE_SHIFT), +}; + +DUK_LOCAL duk_small_uint_t duk__date_get_indirect_magic(duk_hthread *thr) { + duk_small_uint_t magicidx = (duk_small_uint_t) duk_get_current_magic(thr); + DUK_ASSERT(magicidx < (duk_small_int_t) (sizeof(duk__date_magics) / sizeof(duk_uint16_t))); + return (duk_small_uint_t) duk__date_magics[magicidx]; +} + +#if defined(DUK_USE_DATE_BUILTIN) +/* + * Constructor calls + */ + +DUK_INTERNAL duk_ret_t duk_bi_date_constructor(duk_hthread *thr) { + duk_idx_t nargs = duk_get_top(thr); + duk_bool_t is_cons = duk_is_constructor_call(thr); + duk_double_t dparts[DUK_DATE_IDX_NUM_PARTS]; + duk_double_t d; + + DUK_DDD(DUK_DDDPRINT("Date constructor, nargs=%ld, is_cons=%ld", (long) nargs, (long) is_cons)); + + (void) duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_DATE), + DUK_BIDX_DATE_PROTOTYPE); + + /* Unlike most built-ins, the internal [[PrimitiveValue]] of a Date + * is mutable. + */ + + if (nargs == 0 || !is_cons) { + d = duk__timeclip(duk_time_get_ecmascript_time_nofrac(thr)); + duk_push_number(thr, d); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_VALUE, DUK_PROPDESC_FLAGS_W); + if (!is_cons) { + /* called as a normal function: return new Date().toString() */ + duk_to_string(thr, -1); + } + return 1; + } else if (nargs == 1) { + const char *str; + duk_to_primitive(thr, 0, DUK_HINT_NONE); + str = duk_get_string_notsymbol(thr, 0); + if (str) { + duk__parse_string(thr, str); + duk_replace(thr, 0); /* may be NaN */ + } + d = duk__timeclip(duk_to_number(thr, 0)); /* symbols fail here */ + duk_push_number(thr, d); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_VALUE, DUK_PROPDESC_FLAGS_W); + return 1; + } + + duk__set_parts_from_args(thr, dparts, nargs); + + /* Parts are in local time, convert when setting. */ + + (void) duk__set_this_timeval_from_dparts(thr, dparts, DUK_DATE_FLAG_LOCALTIME /*flags*/); /* -> [ ... this timeval ] */ + duk_pop(thr); /* -> [ ... this ] */ + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_date_constructor_parse(duk_hthread *thr) { + return duk__parse_string(thr, duk_to_string(thr, 0)); +} + +DUK_INTERNAL duk_ret_t duk_bi_date_constructor_utc(duk_hthread *thr) { + duk_idx_t nargs = duk_get_top(thr); + duk_double_t dparts[DUK_DATE_IDX_NUM_PARTS]; + duk_double_t d; + + /* Behavior for nargs < 2 is implementation dependent: currently we'll + * set a NaN time value (matching V8 behavior) in this case. + */ + + if (nargs < 2) { + duk_push_nan(thr); + } else { + duk__set_parts_from_args(thr, dparts, nargs); + d = duk_bi_date_get_timeval_from_dparts(dparts, 0 /*flags*/); + duk_push_number(thr, d); + } + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_date_constructor_now(duk_hthread *thr) { + duk_double_t d; + + d = duk_time_get_ecmascript_time_nofrac(thr); + DUK_ASSERT(duk_double_equals(duk__timeclip(d), d)); /* TimeClip() should never be necessary */ + duk_push_number(thr, d); + return 1; +} + +/* + * String/JSON conversions + * + * Human readable conversions are now basically ISO 8601 with a space + * (instead of 'T') as the date/time separator. This is a good baseline + * and is platform independent. + * + * A shared native helper to provide many conversions. Magic value contains + * a set of flags. The helper provides: + * + * toString() + * toDateString() + * toTimeString() + * toLocaleString() + * toLocaleDateString() + * toLocaleTimeString() + * toUTCString() + * toISOString() + * + * Notes: + * + * - Date.prototype.toGMTString() and Date.prototype.toUTCString() are + * required to be the same ECMAScript function object (!), so it is + * omitted from here. + * + * - Date.prototype.toUTCString(): E5.1 specification does not require a + * specific format, but result should be human readable. The + * specification suggests using ISO 8601 format with a space (instead + * of 'T') separator if a more human readable format is not available. + * + * - Date.prototype.toISOString(): unlike other conversion functions, + * toISOString() requires a RangeError for invalid date values. + */ + +DUK_INTERNAL duk_ret_t duk_bi_date_prototype_tostring_shared(duk_hthread *thr) { + duk_small_uint_t flags = duk__date_get_indirect_magic(thr); + return duk__to_string_helper(thr, flags); +} + +DUK_INTERNAL duk_ret_t duk_bi_date_prototype_value_of(duk_hthread *thr) { + /* This native function is also used for Date.prototype.getTime() + * as their behavior is identical. + */ + + duk_double_t d = duk__push_this_get_timeval(thr, 0 /*flags*/); /* -> [ this ] */ + DUK_ASSERT(DUK_ISFINITE(d) || DUK_ISNAN(d)); + duk_push_number(thr, d); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_date_prototype_to_json(duk_hthread *thr) { + /* Note: toJSON() is a generic function which works even if 'this' + * is not a Date. The sole argument is ignored. + */ + + duk_push_this(thr); + duk_to_object(thr, -1); + + duk_dup_top(thr); + duk_to_primitive(thr, -1, DUK_HINT_NUMBER); + if (duk_is_number(thr, -1)) { + duk_double_t d = duk_get_number(thr, -1); + if (!DUK_ISFINITE(d)) { + duk_push_null(thr); + return 1; + } + } + duk_pop(thr); + + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_TO_ISO_STRING); + duk_dup_m2(thr); /* -> [ O toIsoString O ] */ + duk_call_method(thr, 0); + return 1; +} + +/* + * Getters. + * + * Implementing getters is quite easy. The internal time value is either + * NaN, or represents milliseconds (without fractions) from Jan 1, 1970. + * The internal time value can be converted to integer parts, and each + * part will be normalized and will fit into a 32-bit signed integer. + * + * A shared native helper to provide all getters. Magic value contains + * a set of flags and also packs the date component index argument. The + * helper provides: + * + * getFullYear() + * getUTCFullYear() + * getMonth() + * getUTCMonth() + * getDate() + * getUTCDate() + * getDay() + * getUTCDay() + * getHours() + * getUTCHours() + * getMinutes() + * getUTCMinutes() + * getSeconds() + * getUTCSeconds() + * getMilliseconds() + * getUTCMilliseconds() + * getYear() + * + * Notes: + * + * - Date.prototype.getDate(): 'date' means day-of-month, and is + * zero-based in internal calculations but public API expects it to + * be one-based. + * + * - Date.prototype.getTime() and Date.prototype.valueOf() have identical + * behavior. They have separate function objects, but share the same C + * function (duk_bi_date_prototype_value_of). + */ + +DUK_INTERNAL duk_ret_t duk_bi_date_prototype_get_shared(duk_hthread *thr) { + duk_small_uint_t flags_and_idx = duk__date_get_indirect_magic(thr); + return duk__get_part_helper(thr, flags_and_idx); +} + +DUK_INTERNAL duk_ret_t duk_bi_date_prototype_get_timezone_offset(duk_hthread *thr) { + /* + * Return (t - LocalTime(t)) in minutes: + * + * t - LocalTime(t) = t - (t + LocalTZA + DaylightSavingTA(t)) + * = -(LocalTZA + DaylightSavingTA(t)) + * + * where DaylightSavingTA() is checked for time 't'. + * + * Note that the sign of the result is opposite to common usage, + * e.g. for EE(S)T which normally is +2h or +3h from UTC, this + * function returns -120 or -180. + * + */ + + duk_double_t d; + duk_int_t tzoffset; + + /* Note: DST adjustment is determined using UTC time. */ + d = duk__push_this_get_timeval(thr, 0 /*flags*/); + DUK_ASSERT(DUK_ISFINITE(d) || DUK_ISNAN(d)); + if (DUK_ISNAN(d)) { + duk_push_nan(thr); + } else { + DUK_ASSERT(DUK_ISFINITE(d)); + tzoffset = DUK_USE_DATE_GET_LOCAL_TZOFFSET(d); + duk_push_int(thr, -tzoffset / 60); + } + return 1; +} + +/* + * Setters. + * + * Setters are a bit more complicated than getters. Component setters + * break down the current time value into its (normalized) component + * parts, replace one or more components with -unnormalized- new values, + * and the components are then converted back into a time value. As an + * example of using unnormalized values: + * + * var d = new Date(1234567890); + * + * is equivalent to: + * + * var d = new Date(0); + * d.setUTCMilliseconds(1234567890); + * + * A shared native helper to provide almost all setters. Magic value + * contains a set of flags and also packs the "maxnargs" argument. The + * helper provides: + * + * setMilliseconds() + * setUTCMilliseconds() + * setSeconds() + * setUTCSeconds() + * setMinutes() + * setUTCMinutes() + * setHours() + * setUTCHours() + * setDate() + * setUTCDate() + * setMonth() + * setUTCMonth() + * setFullYear() + * setUTCFullYear() + * setYear() + * + * Notes: + * + * - Date.prototype.setYear() (Section B addition): special year check + * is omitted. NaN / Infinity will just flow through and ultimately + * result in a NaN internal time value. + * + * - Date.prototype.setYear() does not have optional arguments for + * setting month and day-in-month (like setFullYear()), but we indicate + * 'maxnargs' to be 3 to get the year written to the correct component + * index in duk__set_part_helper(). The function has nargs == 1, so only + * the year will be set regardless of actual argument count. + */ + +DUK_INTERNAL duk_ret_t duk_bi_date_prototype_set_shared(duk_hthread *thr) { + duk_small_uint_t flags_and_maxnargs = duk__date_get_indirect_magic(thr); + return duk__set_part_helper(thr, flags_and_maxnargs); +} + +DUK_INTERNAL duk_ret_t duk_bi_date_prototype_set_time(duk_hthread *thr) { + duk_double_t d; + + (void) duk__push_this_get_timeval(thr, 0 /*flags*/); /* -> [ timeval this ] */ + d = duk__timeclip(duk_to_number(thr, 0)); + duk_push_number(thr, d); + duk_dup_top(thr); + /* Must force write because .setTime() must work even when + * the Date instance is frozen. + */ + duk_xdef_prop_stridx_short(thr, -3, DUK_STRIDX_INT_VALUE, DUK_PROPDESC_FLAGS_W); + /* -> [ timeval this timeval ] */ + + return 1; +} + +/* + * Misc. + */ + +#if defined(DUK_USE_SYMBOL_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_date_prototype_toprimitive(duk_hthread *thr) { + duk_size_t hintlen; + const char *hintstr; + duk_int_t hint; + + /* Invokes OrdinaryToPrimitive() with suitable hint. Note that the + * method is generic, and works on non-Date arguments too. + * + * https://www.ecma-international.org/ecma-262/6.0/#sec-date.prototype-@@toprimitive + */ + + duk_push_this(thr); + duk_require_object(thr, -1); + DUK_ASSERT_TOP(thr, 2); + + hintstr = duk_require_lstring(thr, 0, &hintlen); + if ((hintlen == 6 && DUK_STRCMP(hintstr, "string") == 0) || (hintlen == 7 && DUK_STRCMP(hintstr, "default") == 0)) { + hint = DUK_HINT_STRING; + } else if (hintlen == 6 && DUK_STRCMP(hintstr, "number") == 0) { + hint = DUK_HINT_NUMBER; + } else { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + + duk_to_primitive_ordinary(thr, -1, hint); + return 1; +} +#endif /* DUK_USE_SYMBOL_BUILTIN */ + +#endif /* DUK_USE_DATE_BUILTIN */ + +/* automatic undefs */ +#undef DUK__CF_ACCEPT +#undef DUK__CF_ACCEPT_NUL +#undef DUK__CF_NEG +#undef DUK__DPRINT_DPARTS +#undef DUK__DPRINT_PARTS +#undef DUK__DPRINT_PARTS_AND_DPARTS +#undef DUK__LOCAL_TZOFFSET_MAXITER +#undef DUK__NUM_ISO8601_PARSER_PARTS +#undef DUK__PACK_RULE +#undef DUK__PI_DAY +#undef DUK__PI_HOUR +#undef DUK__PI_MILLISECOND +#undef DUK__PI_MINUTE +#undef DUK__PI_MONTH +#undef DUK__PI_SECOND +#undef DUK__PI_TZHOUR +#undef DUK__PI_TZMINUTE +#undef DUK__PI_YEAR +#undef DUK__PM_DAY +#undef DUK__PM_HOUR +#undef DUK__PM_MILLISECOND +#undef DUK__PM_MINUTE +#undef DUK__PM_MONTH +#undef DUK__PM_SECOND +#undef DUK__PM_TZHOUR +#undef DUK__PM_TZMINUTE +#undef DUK__PM_YEAR +#undef DUK__RULE_MASK_PART_SEP +#undef DUK__SI_COLON +#undef DUK__SI_MINUS +#undef DUK__SI_NUL +#undef DUK__SI_PERIOD +#undef DUK__SI_PLUS +#undef DUK__SI_SPACE +#undef DUK__SI_T +#undef DUK__SI_Z +#undef DUK__SM_COLON +#undef DUK__SM_MINUS +#undef DUK__SM_NUL +#undef DUK__SM_PERIOD +#undef DUK__SM_PLUS +#undef DUK__SM_SPACE +#undef DUK__SM_T +#undef DUK__SM_Z +#undef DUK__UNPACK_RULE +#undef DUK__WEEKDAY_MOD_ADDER +#undef DUK__YEAR +#line 1 "duk_bi_date_unix.c" +/* + * Unix-like Date providers + * + * Generally useful Unix / POSIX / ANSI Date providers. + */ + +/* #include duk_internal.h -> already included */ + +/* The necessary #includes are in place in duk_config.h. */ + +/* Buffer sizes for some UNIX calls. Larger than strictly necessary + * to avoid Valgrind errors. + */ +#define DUK__STRPTIME_BUF_SIZE 64 +#define DUK__STRFTIME_BUF_SIZE 64 + +#if defined(DUK_USE_DATE_NOW_GETTIMEOFDAY) +/* Get current ECMAScript time (= UNIX/Posix time, but in milliseconds). */ +DUK_INTERNAL duk_double_t duk_bi_date_get_now_gettimeofday(void) { + struct timeval tv; + duk_double_t d; + + if (gettimeofday(&tv, NULL) != 0) { + DUK_D(DUK_DPRINT("gettimeofday() failed")); + return 0.0; + } + + /* As of Duktape 2.2.0 allow fractions. */ + d = ((duk_double_t) tv.tv_sec) * 1000.0 + ((duk_double_t) tv.tv_usec) / 1000.0; + + return d; +} +#endif /* DUK_USE_DATE_NOW_GETTIMEOFDAY */ + +#if defined(DUK_USE_DATE_NOW_TIME) +/* Not a very good provider: only full seconds are available. */ +DUK_INTERNAL duk_double_t duk_bi_date_get_now_time(void) { + time_t t; + + t = time(NULL); + if (t == (time_t) -1) { + DUK_D(DUK_DPRINT("time() failed")); + return 0.0; + } + return ((duk_double_t) t) * 1000.0; +} +#endif /* DUK_USE_DATE_NOW_TIME */ + +#if defined(DUK_USE_DATE_TZO_GMTIME) || defined(DUK_USE_DATE_TZO_GMTIME_R) || defined(DUK_USE_DATE_TZO_GMTIME_S) +/* Get local time offset (in seconds) for a certain (UTC) instant 'd'. */ +DUK_INTERNAL duk_int_t duk_bi_date_get_local_tzoffset_gmtime(duk_double_t d) { + time_t t, t1, t2; + duk_int_t parts[DUK_DATE_IDX_NUM_PARTS]; + duk_double_t dparts[DUK_DATE_IDX_NUM_PARTS]; + struct tm tms[2]; +#if defined(DUK_USE_DATE_TZO_GMTIME) + struct tm *tm_ptr; +#endif + + /* For NaN/inf, the return value doesn't matter. */ + if (!DUK_ISFINITE(d)) { + return 0; + } + + /* If not within ECMAScript range, some integer time calculations + * won't work correctly (and some asserts will fail), so bail out + * if so. This fixes test-bug-date-insane-setyear.js. There is + * a +/- 24h leeway in this range check to avoid a test262 corner + * case documented in test-bug-date-timeval-edges.js. + */ + if (!duk_bi_date_timeval_in_leeway_range(d)) { + DUK_DD(DUK_DDPRINT("timeval not within valid range, skip tzoffset computation to avoid integer overflows")); + return 0; + } + + /* + * This is a bit tricky to implement portably. The result depends + * on the timestamp (specifically, DST depends on the timestamp). + * If e.g. UNIX APIs are used, they'll have portability issues with + * very small and very large years. + * + * Current approach: + * + * - Stay within portable UNIX limits by using equivalent year mapping. + * Avoid year 1970 and 2038 as some conversions start to fail, at + * least on some platforms. Avoiding 1970 means that there are + * currently DST discrepancies for 1970. + * + * - Create a UTC and local time breakdowns from 't'. Then create + * a time_t using gmtime() and localtime() and compute the time + * difference between the two. + * + * Equivalent year mapping (E5 Section 15.9.1.8): + * + * If the host environment provides functionality for determining + * daylight saving time, the implementation of ECMAScript is free + * to map the year in question to an equivalent year (same + * leap-year-ness and same starting week day for the year) for which + * the host environment provides daylight saving time information. + * The only restriction is that all equivalent years should produce + * the same result. + * + * This approach is quite reasonable but not entirely correct, e.g. + * the specification also states (E5 Section 15.9.1.8): + * + * The implementation of ECMAScript should not try to determine + * whether the exact time was subject to daylight saving time, but + * just whether daylight saving time would have been in effect if + * the _current daylight saving time algorithm_ had been used at the + * time. This avoids complications such as taking into account the + * years that the locale observed daylight saving time year round. + * + * Since we rely on the platform APIs for conversions between local + * time and UTC, we can't guarantee the above. Rather, if the platform + * has historical DST rules they will be applied. This seems to be the + * general preferred direction in ECMAScript standardization (or at least + * implementations) anyway, and even the equivalent year mapping should + * be disabled if the platform is known to handle DST properly for the + * full ECMAScript range. + * + * The following has useful discussion and links: + * + * https://bugzilla.mozilla.org/show_bug.cgi?id=351066 + */ + + duk_bi_date_timeval_to_parts(d, parts, dparts, DUK_DATE_FLAG_EQUIVYEAR /*flags*/); + DUK_ASSERT(parts[DUK_DATE_IDX_YEAR] >= 1970 && parts[DUK_DATE_IDX_YEAR] <= 2038); + + d = duk_bi_date_get_timeval_from_dparts(dparts, 0 /*flags*/); + DUK_ASSERT(d >= 0 && d < 2147483648.0 * 1000.0); /* unsigned 31-bit range */ + t = (time_t) (d / 1000.0); + DUK_DDD(DUK_DDDPRINT("timeval: %lf -> time_t %ld", (double) d, (long) t)); + + duk_memzero((void *) tms, sizeof(struct tm) * 2); + +#if defined(DUK_USE_DATE_TZO_GMTIME_R) + (void) gmtime_r(&t, &tms[0]); + (void) localtime_r(&t, &tms[1]); +#elif defined(DUK_USE_DATE_TZO_GMTIME_S) + (void) gmtime_s(&t, &tms[0]); + (void) localtime_s(&t, &tms[1]); +#elif defined(DUK_USE_DATE_TZO_GMTIME) + tm_ptr = gmtime(&t); + duk_memcpy((void *) &tms[0], tm_ptr, sizeof(struct tm)); + tm_ptr = localtime(&t); + duk_memcpy((void *) &tms[1], tm_ptr, sizeof(struct tm)); +#else +#error internal error +#endif + DUK_DDD(DUK_DDDPRINT("gmtime result: tm={sec:%ld,min:%ld,hour:%ld,mday:%ld,mon:%ld,year:%ld," + "wday:%ld,yday:%ld,isdst:%ld}", + (long) tms[0].tm_sec, + (long) tms[0].tm_min, + (long) tms[0].tm_hour, + (long) tms[0].tm_mday, + (long) tms[0].tm_mon, + (long) tms[0].tm_year, + (long) tms[0].tm_wday, + (long) tms[0].tm_yday, + (long) tms[0].tm_isdst)); + DUK_DDD(DUK_DDDPRINT("localtime result: tm={sec:%ld,min:%ld,hour:%ld,mday:%ld,mon:%ld,year:%ld," + "wday:%ld,yday:%ld,isdst:%ld}", + (long) tms[1].tm_sec, + (long) tms[1].tm_min, + (long) tms[1].tm_hour, + (long) tms[1].tm_mday, + (long) tms[1].tm_mon, + (long) tms[1].tm_year, + (long) tms[1].tm_wday, + (long) tms[1].tm_yday, + (long) tms[1].tm_isdst)); + + /* tm_isdst is both an input and an output to mktime(), use 0 to + * avoid DST handling in mktime(): + * - https://github.com/svaarala/duktape/issues/406 + * - http://stackoverflow.com/questions/8558919/mktime-and-tm-isdst + */ + tms[0].tm_isdst = 0; + tms[1].tm_isdst = 0; + t1 = mktime(&tms[0]); /* UTC */ + t2 = mktime(&tms[1]); /* local */ + if (t1 == (time_t) -1 || t2 == (time_t) -1) { + /* This check used to be for (t < 0) but on some platforms + * time_t is unsigned and apparently the proper way to detect + * an mktime() error return is the cast above. See e.g.: + * http://pubs.opengroup.org/onlinepubs/009695299/functions/mktime.html + */ + goto mktime_error; + } + DUK_DDD(DUK_DDDPRINT("t1=%ld (utc), t2=%ld (local)", (long) t1, (long) t2)); + + /* Compute final offset in seconds, positive if local time ahead of + * UTC (returned value is UTC-to-local offset). + * + * difftime() returns a double, so coercion to int generates quite + * a lot of code. Direct subtraction is not portable, however. + * XXX: allow direct subtraction on known platforms. + */ +#if 0 + return (duk_int_t) (t2 - t1); +#endif + return (duk_int_t) difftime(t2, t1); + +mktime_error: + /* XXX: return something more useful, so that caller can throw? */ + DUK_D(DUK_DPRINT("mktime() failed, d=%lf", (double) d)); + return 0; +} +#endif /* DUK_USE_DATE_TZO_GMTIME */ + +#if defined(DUK_USE_DATE_PRS_STRPTIME) +DUK_INTERNAL duk_bool_t duk_bi_date_parse_string_strptime(duk_hthread *thr, const char *str) { + struct tm tm; + time_t t; + char buf[DUK__STRPTIME_BUF_SIZE]; + + /* Copy to buffer with slack to avoid Valgrind gripes from strptime. */ + DUK_ASSERT(str != NULL); + duk_memzero(buf, sizeof(buf)); /* valgrind whine without this */ + DUK_SNPRINTF(buf, sizeof(buf), "%s", (const char *) str); + buf[sizeof(buf) - 1] = (char) 0; + + DUK_DDD(DUK_DDDPRINT("parsing: '%s'", (const char *) buf)); + + duk_memzero(&tm, sizeof(tm)); + if (strptime((const char *) buf, "%c", &tm) != NULL) { + DUK_DDD(DUK_DDDPRINT("before mktime: tm={sec:%ld,min:%ld,hour:%ld,mday:%ld,mon:%ld,year:%ld," + "wday:%ld,yday:%ld,isdst:%ld}", + (long) tm.tm_sec, + (long) tm.tm_min, + (long) tm.tm_hour, + (long) tm.tm_mday, + (long) tm.tm_mon, + (long) tm.tm_year, + (long) tm.tm_wday, + (long) tm.tm_yday, + (long) tm.tm_isdst)); + tm.tm_isdst = -1; /* negative: dst info not available */ + + t = mktime(&tm); + DUK_DDD(DUK_DDDPRINT("mktime() -> %ld", (long) t)); + if (t >= 0) { + duk_push_number(thr, ((duk_double_t) t) * 1000.0); + return 1; + } + } + + return 0; +} +#endif /* DUK_USE_DATE_PRS_STRPTIME */ + +#if defined(DUK_USE_DATE_PRS_GETDATE) +DUK_INTERNAL duk_bool_t duk_bi_date_parse_string_getdate(duk_hthread *thr, const char *str) { + struct tm tm; + duk_small_int_t rc; + time_t t; + + /* For this to work, DATEMSK must be set, so this is not very + * convenient for an embeddable interpreter. + */ + + duk_memzero(&tm, sizeof(struct tm)); + rc = (duk_small_int_t) getdate_r(str, &tm); + DUK_DDD(DUK_DDDPRINT("getdate_r() -> %ld", (long) rc)); + + if (rc == 0) { + t = mktime(&tm); + DUK_DDD(DUK_DDDPRINT("mktime() -> %ld", (long) t)); + if (t >= 0) { + duk_push_number(thr, (duk_double_t) t); + return 1; + } + } + + return 0; +} +#endif /* DUK_USE_DATE_PRS_GETDATE */ + +#if defined(DUK_USE_DATE_FMT_STRFTIME) +DUK_INTERNAL duk_bool_t duk_bi_date_format_parts_strftime(duk_hthread *thr, + duk_int_t *parts, + duk_int_t tzoffset, + duk_small_uint_t flags) { + char buf[DUK__STRFTIME_BUF_SIZE]; + struct tm tm; + const char *fmt; + + DUK_UNREF(tzoffset); + + /* If the platform doesn't support the entire ECMAScript range, we need + * to return 0 so that the caller can fall back to the default formatter. + * + * For now, assume that if time_t is 8 bytes or more, the whole ECMAScript + * range is supported. For smaller time_t values (4 bytes in practice), + * assumes that the signed 32-bit range is supported. + * + * XXX: detect this more correctly per platform. The size of time_t is + * probably not an accurate guarantee of strftime() supporting or not + * supporting a large time range (the full ECMAScript range). + */ + if (sizeof(time_t) < 8 && (parts[DUK_DATE_IDX_YEAR] < 1970 || parts[DUK_DATE_IDX_YEAR] > 2037)) { + /* be paranoid for 32-bit time values (even avoiding negative ones) */ + return 0; + } + + duk_memzero(&tm, sizeof(tm)); + tm.tm_sec = parts[DUK_DATE_IDX_SECOND]; + tm.tm_min = parts[DUK_DATE_IDX_MINUTE]; + tm.tm_hour = parts[DUK_DATE_IDX_HOUR]; + tm.tm_mday = parts[DUK_DATE_IDX_DAY]; /* already one-based */ + tm.tm_mon = parts[DUK_DATE_IDX_MONTH] - 1; /* one-based -> zero-based */ + tm.tm_year = parts[DUK_DATE_IDX_YEAR] - 1900; + tm.tm_wday = parts[DUK_DATE_IDX_WEEKDAY]; + tm.tm_isdst = 0; + + duk_memzero(buf, sizeof(buf)); + if ((flags & DUK_DATE_FLAG_TOSTRING_DATE) && (flags & DUK_DATE_FLAG_TOSTRING_TIME)) { + fmt = "%c"; + } else if (flags & DUK_DATE_FLAG_TOSTRING_DATE) { + fmt = "%x"; + } else { + DUK_ASSERT(flags & DUK_DATE_FLAG_TOSTRING_TIME); + fmt = "%X"; + } + (void) strftime(buf, sizeof(buf) - 1, fmt, &tm); + DUK_ASSERT(buf[sizeof(buf) - 1] == 0); + + duk_push_string(thr, buf); + return 1; +} +#endif /* DUK_USE_DATE_FMT_STRFTIME */ + +#if defined(DUK_USE_GET_MONOTONIC_TIME_CLOCK_GETTIME) +DUK_INTERNAL duk_double_t duk_bi_date_get_monotonic_time_clock_gettime(void) { + struct timespec ts; + + if (clock_gettime(CLOCK_MONOTONIC, &ts) == 0) { + return (duk_double_t) ts.tv_sec * 1000.0 + (duk_double_t) ts.tv_nsec / 1000000.0; + } else { + DUK_D(DUK_DPRINT("clock_gettime(CLOCK_MONOTONIC) failed")); + return 0.0; + } +} +#endif + +/* automatic undefs */ +#undef DUK__STRFTIME_BUF_SIZE +#undef DUK__STRPTIME_BUF_SIZE +#line 1 "duk_bi_date_windows.c" +/* + * Windows Date providers + * + * Platform specific links: + * + * - http://msdn.microsoft.com/en-us/library/windows/desktop/ms725473(v=vs.85).aspx + */ + +/* #include duk_internal.h -> already included */ + +/* The necessary #includes are in place in duk_config.h. */ + +#if defined(DUK_USE_DATE_NOW_WINDOWS) || defined(DUK_USE_DATE_TZO_WINDOWS) +/* Shared Windows helpers. */ +DUK_LOCAL void duk__convert_systime_to_ularge(const SYSTEMTIME *st, ULARGE_INTEGER *res) { + FILETIME ft; + if (SystemTimeToFileTime(st, &ft) == 0) { + DUK_D(DUK_DPRINT("SystemTimeToFileTime() failed, returning 0")); + res->QuadPart = 0; + } else { + res->LowPart = ft.dwLowDateTime; + res->HighPart = ft.dwHighDateTime; + } +} + +#if defined(DUK_USE_DATE_NOW_WINDOWS_SUBMS) +DUK_LOCAL void duk__convert_filetime_to_ularge(const FILETIME *ft, ULARGE_INTEGER *res) { + res->LowPart = ft->dwLowDateTime; + res->HighPart = ft->dwHighDateTime; +} +#endif /* DUK_USE_DATE_NOW_WINDOWS_SUBMS */ + +DUK_LOCAL void duk__set_systime_jan1970(SYSTEMTIME *st) { + duk_memzero((void *) st, sizeof(*st)); + st->wYear = 1970; + st->wMonth = 1; + st->wDayOfWeek = 4; /* not sure whether or not needed; Thursday */ + st->wDay = 1; + DUK_ASSERT(st->wHour == 0); + DUK_ASSERT(st->wMinute == 0); + DUK_ASSERT(st->wSecond == 0); + DUK_ASSERT(st->wMilliseconds == 0); +} +#endif /* defined(DUK_USE_DATE_NOW_WINDOWS) || defined(DUK_USE_DATE_TZO_WINDOWS) */ + +#if defined(DUK_USE_DATE_NOW_WINDOWS) +DUK_INTERNAL duk_double_t duk_bi_date_get_now_windows(void) { + /* Suggested step-by-step method from documentation of RtlTimeToSecondsSince1970: + * http://msdn.microsoft.com/en-us/library/windows/desktop/ms724928(v=vs.85).aspx + */ + SYSTEMTIME st1, st2; + ULARGE_INTEGER tmp1, tmp2; + + GetSystemTime(&st1); + duk__convert_systime_to_ularge((const SYSTEMTIME *) &st1, &tmp1); + + duk__set_systime_jan1970(&st2); + duk__convert_systime_to_ularge((const SYSTEMTIME *) &st2, &tmp2); + + /* Difference is in 100ns units, convert to milliseconds, keeping + * fractions since Duktape 2.2.0. This is only theoretical because + * SYSTEMTIME is limited to milliseconds. + */ + return (duk_double_t) ((LONGLONG) tmp1.QuadPart - (LONGLONG) tmp2.QuadPart) / 10000.0; +} +#endif /* DUK_USE_DATE_NOW_WINDOWS */ + +#if defined(DUK_USE_DATE_NOW_WINDOWS_SUBMS) +DUK_INTERNAL duk_double_t duk_bi_date_get_now_windows_subms(void) { + /* Variant of the basic algorithm using GetSystemTimePreciseAsFileTime() + * for more accuracy. + */ + FILETIME ft1; + SYSTEMTIME st2; + ULARGE_INTEGER tmp1, tmp2; + + GetSystemTimePreciseAsFileTime(&ft1); + duk__convert_filetime_to_ularge((const FILETIME *) &ft1, &tmp1); + + duk__set_systime_jan1970(&st2); + duk__convert_systime_to_ularge((const SYSTEMTIME *) &st2, &tmp2); + + /* Difference is in 100ns units, convert to milliseconds, keeping + * fractions since Duktape 2.2.0. + */ + return (duk_double_t) ((LONGLONG) tmp1.QuadPart - (LONGLONG) tmp2.QuadPart) / 10000.0; +} +#endif /* DUK_USE_DATE_NOW_WINDOWS */ + +#if defined(DUK_USE_DATE_TZO_WINDOWS) +DUK_INTERNAL duk_int_t duk_bi_date_get_local_tzoffset_windows(duk_double_t d) { + SYSTEMTIME st1; + SYSTEMTIME st2; + SYSTEMTIME st3; + ULARGE_INTEGER tmp1; + ULARGE_INTEGER tmp2; + ULARGE_INTEGER tmp3; + FILETIME ft1; + + /* XXX: handling of timestamps outside Windows supported range. + * How does Windows deal with dates before 1600? Does windows + * support all ECMAScript years (like -200000 and +200000)? + * Should equivalent year mapping be used here too? If so, use + * a shared helper (currently integrated into timeval-to-parts). + */ + + /* Use the approach described in "Remarks" of FileTimeToLocalFileTime: + * http://msdn.microsoft.com/en-us/library/windows/desktop/ms724277(v=vs.85).aspx + */ + + duk__set_systime_jan1970(&st1); + duk__convert_systime_to_ularge((const SYSTEMTIME *) &st1, &tmp1); + tmp2.QuadPart = (ULONGLONG) (d * 10000.0); /* millisec -> 100ns units since jan 1, 1970 */ + tmp2.QuadPart += tmp1.QuadPart; /* input 'd' in Windows UTC, 100ns units */ + + ft1.dwLowDateTime = tmp2.LowPart; + ft1.dwHighDateTime = tmp2.HighPart; + if (FileTimeToSystemTime((const FILETIME *) &ft1, &st2) == 0) { + DUK_D(DUK_DPRINT("FileTimeToSystemTime() failed, return tzoffset 0")); + return 0; + } + if (SystemTimeToTzSpecificLocalTime((LPTIME_ZONE_INFORMATION) NULL, &st2, &st3) == 0) { + DUK_D(DUK_DPRINT("SystemTimeToTzSpecificLocalTime() failed, return tzoffset 0")); + return 0; + } + duk__convert_systime_to_ularge((const SYSTEMTIME *) &st3, &tmp3); + + /* Positive if local time ahead of UTC. */ + return (duk_int_t) (((LONGLONG) tmp3.QuadPart - (LONGLONG) tmp2.QuadPart) / DUK_I64_CONSTANT(10000000)); /* seconds */ +} +#endif /* DUK_USE_DATE_TZO_WINDOWS */ + +#if defined(DUK_USE_DATE_TZO_WINDOWS_NO_DST) +DUK_INTERNAL duk_int_t duk_bi_date_get_local_tzoffset_windows_no_dst(duk_double_t d) { + SYSTEMTIME st1; + SYSTEMTIME st2; + FILETIME ft1; + FILETIME ft2; + ULARGE_INTEGER tmp1; + ULARGE_INTEGER tmp2; + + /* Do a similar computation to duk_bi_date_get_local_tzoffset_windows + * but without accounting for daylight savings time. Use this on + * Windows platforms (like Durango) that don't support the + * SystemTimeToTzSpecificLocalTime() call. + */ + + /* current time not needed for this computation */ + DUK_UNREF(d); + + duk__set_systime_jan1970(&st1); + duk__convert_systime_to_ularge((const SYSTEMTIME *) &st1, &tmp1); + + ft1.dwLowDateTime = tmp1.LowPart; + ft1.dwHighDateTime = tmp1.HighPart; + if (FileTimeToLocalFileTime((const FILETIME *) &ft1, &ft2) == 0) { + DUK_D(DUK_DPRINT("FileTimeToLocalFileTime() failed, return tzoffset 0")); + return 0; + } + if (FileTimeToSystemTime((const FILETIME *) &ft2, &st2) == 0) { + DUK_D(DUK_DPRINT("FileTimeToSystemTime() failed, return tzoffset 0")); + return 0; + } + duk__convert_systime_to_ularge((const SYSTEMTIME *) &st2, &tmp2); + + return (duk_int_t) (((LONGLONG) tmp2.QuadPart - (LONGLONG) tmp1.QuadPart) / DUK_I64_CONSTANT(10000000)); /* seconds */ +} +#endif /* DUK_USE_DATE_TZO_WINDOWS_NO_DST */ + +#if defined(DUK_USE_GET_MONOTONIC_TIME_WINDOWS_QPC) +DUK_INTERNAL duk_double_t duk_bi_date_get_monotonic_time_windows_qpc(void) { + LARGE_INTEGER count, freq; + + /* There are legacy issues with QueryPerformanceCounter(): + * - Potential jumps: + * https://support.microsoft.com/en-us/help/274323/performance-counter-value-may-unexpectedly-leap-forward + * - Differences between cores (XP): + * https://msdn.microsoft.com/en-us/library/windows/desktop/dn553408(v=vs.85).aspx#qpc_support_in_windows_versions + * + * We avoid these by enabling QPC by default only for Vista or later. + */ + + if (QueryPerformanceCounter(&count) && QueryPerformanceFrequency(&freq)) { + /* XXX: QueryPerformanceFrequency() can be cached */ + return (duk_double_t) count.QuadPart / (duk_double_t) freq.QuadPart * 1000.0; + } else { + /* MSDN: "On systems that run Windows XP or later, the function + * will always succeed and will thus never return zero." + * Provide minimal error path just in case user enables this + * feature in pre-XP Windows. + */ + return 0.0; + } +} +#endif /* DUK_USE_GET_MONOTONIC_TIME_WINDOWS_QPC */ +#line 1 "duk_bi_duktape.c" +/* + * Duktape built-ins + * + * Size optimization note: it might seem that vararg multipurpose functions + * like fin(), enc(), and dec() are not very size optimal, but using a single + * user-visible ECMAScript function saves a lot of run-time footprint; each + * Function instance takes >100 bytes. Using a shared native helper and a + * 'magic' value won't save much if there are multiple Function instances + * anyway. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_DUKTAPE_BUILTIN) + +DUK_INTERNAL duk_ret_t duk_bi_duktape_object_info(duk_hthread *thr) { + duk_inspect_value(thr, -1); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_duktape_object_act(duk_hthread *thr) { + duk_int_t level; + + level = duk_to_int(thr, 0); + duk_inspect_callstack_entry(thr, level); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_duktape_object_gc(duk_hthread *thr) { + duk_small_uint_t flags; + + flags = (duk_small_uint_t) duk_get_uint(thr, 0); + duk_heap_mark_and_sweep(thr->heap, flags); + + /* XXX: Not sure what the best return value would be in the API. + * Return true for now. + */ + duk_push_true(thr); + return 1; +} + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_duktape_object_fin(duk_hthread *thr) { + (void) duk_require_hobject(thr, 0); + if (duk_get_top(thr) >= 2) { + /* Set: currently a finalizer is disabled by setting it to + * undefined; this does not remove the property at the moment. + * The value could be type checked to be either a function + * or something else; if something else, the property could + * be deleted. Must use duk_set_finalizer() to keep + * DUK_HOBJECT_FLAG_HAVE_FINALIZER in sync. + */ + duk_set_top(thr, 2); + duk_set_finalizer(thr, 0); + return 0; + } else { + /* Get. */ + DUK_ASSERT(duk_get_top(thr) == 1); + duk_get_finalizer(thr, 0); + return 1; + } +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +DUK_INTERNAL duk_ret_t duk_bi_duktape_object_enc(duk_hthread *thr) { + duk_hstring *h_str; + + /* Vararg function: must be careful to check/require arguments. + * The JSON helpers accept invalid indices and treat them like + * non-existent optional parameters. + */ + + h_str = duk_require_hstring(thr, 0); /* Could reject symbols, but no point: won't match comparisons. */ + duk_require_valid_index(thr, 1); + + if (h_str == DUK_HTHREAD_STRING_HEX(thr)) { + duk_set_top(thr, 2); + duk_hex_encode(thr, 1); + DUK_ASSERT_TOP(thr, 2); + } else if (h_str == DUK_HTHREAD_STRING_BASE64(thr)) { + duk_set_top(thr, 2); + duk_base64_encode(thr, 1); + DUK_ASSERT_TOP(thr, 2); +#if defined(DUK_USE_JSON_SUPPORT) && defined(DUK_USE_JX) + } else if (h_str == DUK_HTHREAD_STRING_JX(thr)) { + duk_bi_json_stringify_helper(thr, + 1 /*idx_value*/, + 2 /*idx_replacer*/, + 3 /*idx_space*/, + DUK_JSON_FLAG_EXT_CUSTOM | DUK_JSON_FLAG_ASCII_ONLY | + DUK_JSON_FLAG_AVOID_KEY_QUOTES /*flags*/); +#endif +#if defined(DUK_USE_JSON_SUPPORT) && defined(DUK_USE_JC) + } else if (h_str == DUK_HTHREAD_STRING_JC(thr)) { + duk_bi_json_stringify_helper(thr, + 1 /*idx_value*/, + 2 /*idx_replacer*/, + 3 /*idx_space*/, + DUK_JSON_FLAG_EXT_COMPATIBLE | DUK_JSON_FLAG_ASCII_ONLY /*flags*/); +#endif + } else { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_duktape_object_dec(duk_hthread *thr) { + duk_hstring *h_str; + + /* Vararg function: must be careful to check/require arguments. + * The JSON helpers accept invalid indices and treat them like + * non-existent optional parameters. + */ + + h_str = duk_require_hstring(thr, 0); /* Could reject symbols, but no point: won't match comparisons */ + duk_require_valid_index(thr, 1); + + if (h_str == DUK_HTHREAD_STRING_HEX(thr)) { + duk_set_top(thr, 2); + duk_hex_decode(thr, 1); + DUK_ASSERT_TOP(thr, 2); + } else if (h_str == DUK_HTHREAD_STRING_BASE64(thr)) { + duk_set_top(thr, 2); + duk_base64_decode(thr, 1); + DUK_ASSERT_TOP(thr, 2); +#if defined(DUK_USE_JSON_SUPPORT) && defined(DUK_USE_JX) + } else if (h_str == DUK_HTHREAD_STRING_JX(thr)) { + duk_bi_json_parse_helper(thr, 1 /*idx_value*/, 2 /*idx_replacer*/, DUK_JSON_FLAG_EXT_CUSTOM /*flags*/); +#endif +#if defined(DUK_USE_JSON_SUPPORT) && defined(DUK_USE_JC) + } else if (h_str == DUK_HTHREAD_STRING_JC(thr)) { + duk_bi_json_parse_helper(thr, 1 /*idx_value*/, 2 /*idx_replacer*/, DUK_JSON_FLAG_EXT_COMPATIBLE /*flags*/); +#endif + } else { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + return 1; +} + +/* + * Compact an object + */ + +DUK_INTERNAL duk_ret_t duk_bi_duktape_object_compact(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 1); + duk_compact(thr, 0); + return 1; /* return the argument object */ +} + +#endif /* DUK_USE_DUKTAPE_BUILTIN */ +#line 1 "duk_bi_encoding.c" +/* + * WHATWG Encoding API built-ins + * + * API specification: https://encoding.spec.whatwg.org/#api + * Web IDL: https://www.w3.org/TR/WebIDL/ + */ + +/* #include duk_internal.h -> already included */ + +/* + * Data structures for encoding/decoding + */ + +typedef struct { + duk_uint8_t *out; /* where to write next byte(s) */ + duk_codepoint_t lead; /* lead surrogate */ +} duk__encode_context; + +typedef struct { + /* UTF-8 decoding state */ + duk_codepoint_t codepoint; /* built up incrementally */ + duk_uint8_t upper; /* max value of next byte (decode error otherwise) */ + duk_uint8_t lower; /* min value of next byte (ditto) */ + duk_uint8_t needed; /* how many more bytes we need */ + duk_uint8_t bom_handled; /* BOM seen or no longer expected */ + + /* Decoder configuration */ + duk_uint8_t fatal; + duk_uint8_t ignore_bom; +} duk__decode_context; + +/* The signed duk_codepoint_t type is used to signal a decoded codepoint + * (>= 0) or various other states using negative values. + */ +#define DUK__CP_CONTINUE (-1) /* continue to next byte, no completed codepoint */ +#define DUK__CP_ERROR (-2) /* decoding error */ +#define DUK__CP_RETRY (-3) /* decoding error; retry last byte */ + +/* + * Raw helpers for encoding/decoding + */ + +/* Emit UTF-8 (= CESU-8) encoded U+FFFD (replacement char), i.e. ef bf bd. */ +DUK_LOCAL duk_uint8_t *duk__utf8_emit_repl(duk_uint8_t *ptr) { + *ptr++ = 0xef; + *ptr++ = 0xbf; + *ptr++ = 0xbd; + return ptr; +} + +DUK_LOCAL void duk__utf8_decode_init(duk__decode_context *dec_ctx) { + /* (Re)init the decoding state of 'dec_ctx' but leave decoder + * configuration fields untouched. + */ + dec_ctx->codepoint = 0x0000L; + dec_ctx->upper = 0xbf; + dec_ctx->lower = 0x80; + dec_ctx->needed = 0; + dec_ctx->bom_handled = 0; +} + +DUK_LOCAL duk_codepoint_t duk__utf8_decode_next(duk__decode_context *dec_ctx, duk_uint8_t x) { + /* + * UTF-8 algorithm based on the Encoding specification: + * https://encoding.spec.whatwg.org/#utf-8-decoder + * + * Two main states: decoding initial byte vs. decoding continuation + * bytes. Shortest length encoding is validated by restricting the + * allowed range of first continuation byte using 'lower' and 'upper'. + */ + + if (dec_ctx->needed == 0) { + /* process initial byte */ + if (x <= 0x7f) { + /* U+0000-U+007F, 1 byte (ASCII) */ + return (duk_codepoint_t) x; + } else if (x >= 0xc2 && x <= 0xdf) { + /* U+0080-U+07FF, 2 bytes */ + dec_ctx->needed = 1; + dec_ctx->codepoint = x & 0x1f; + DUK_ASSERT(dec_ctx->lower == 0x80); + DUK_ASSERT(dec_ctx->upper == 0xbf); + return DUK__CP_CONTINUE; + } else if (x >= 0xe0 && x <= 0xef) { + /* U+0800-U+FFFF, 3 bytes */ + if (x == 0xe0) { + dec_ctx->lower = 0xa0; + DUK_ASSERT(dec_ctx->upper == 0xbf); + } else if (x == 0xed) { + DUK_ASSERT(dec_ctx->lower == 0x80); + dec_ctx->upper = 0x9f; + } + dec_ctx->needed = 2; + dec_ctx->codepoint = x & 0x0f; + return DUK__CP_CONTINUE; + } else if (x >= 0xf0 && x <= 0xf4) { + /* U+010000-U+10FFFF, 4 bytes */ + if (x == 0xf0) { + dec_ctx->lower = 0x90; + DUK_ASSERT(dec_ctx->upper == 0xbf); + } else if (x == 0xf4) { + DUK_ASSERT(dec_ctx->lower == 0x80); + dec_ctx->upper = 0x8f; + } + dec_ctx->needed = 3; + dec_ctx->codepoint = x & 0x07; + return DUK__CP_CONTINUE; + } else { + /* not a legal initial byte */ + return DUK__CP_ERROR; + } + } else { + /* process continuation byte */ + if (x >= dec_ctx->lower && x <= dec_ctx->upper) { + dec_ctx->lower = 0x80; + dec_ctx->upper = 0xbf; + dec_ctx->codepoint = (dec_ctx->codepoint << 6) | (x & 0x3f); + if (--dec_ctx->needed > 0) { + /* need more bytes */ + return DUK__CP_CONTINUE; + } else { + /* got a codepoint */ + duk_codepoint_t ret; + DUK_ASSERT(dec_ctx->codepoint <= 0x10ffffL); /* Decoding rules guarantee. */ + ret = dec_ctx->codepoint; + dec_ctx->codepoint = 0x0000L; + dec_ctx->needed = 0; + return ret; + } + } else { + /* We just encountered an illegal UTF-8 continuation byte. This might + * be the initial byte of the next character; if we return a plain + * error status and the decoder is in replacement mode, the character + * will be masked. We still need to alert the caller to the error + * though. + */ + dec_ctx->codepoint = 0x0000L; + dec_ctx->needed = 0; + dec_ctx->lower = 0x80; + dec_ctx->upper = 0xbf; + return DUK__CP_RETRY; + } + } +} + +#if defined(DUK_USE_ENCODING_BUILTINS) +DUK_LOCAL void duk__utf8_encode_char(void *udata, duk_codepoint_t codepoint) { + duk__encode_context *enc_ctx; + + DUK_ASSERT(codepoint >= 0); + enc_ctx = (duk__encode_context *) udata; + DUK_ASSERT(enc_ctx != NULL); + +#if !defined(DUK_USE_PREFER_SIZE) + if (codepoint <= 0x7f && enc_ctx->lead == 0x0000L) { + /* Fast path for ASCII. */ + *enc_ctx->out++ = (duk_uint8_t) codepoint; + return; + } +#endif + + if (DUK_UNLIKELY(codepoint > 0x10ffffL)) { + /* cannot legally encode in UTF-8 */ + codepoint = DUK_UNICODE_CP_REPLACEMENT_CHARACTER; + } else if (codepoint >= 0xd800L && codepoint <= 0xdfffL) { + if (codepoint <= 0xdbffL) { + /* high surrogate */ + duk_codepoint_t prev_lead = enc_ctx->lead; + enc_ctx->lead = codepoint; + if (prev_lead == 0x0000L) { + /* high surrogate, no output */ + return; + } else { + /* consecutive high surrogates, consider first one unpaired */ + codepoint = DUK_UNICODE_CP_REPLACEMENT_CHARACTER; + } + } else { + /* low surrogate */ + if (enc_ctx->lead != 0x0000L) { + codepoint = + (duk_codepoint_t) (0x010000L + ((enc_ctx->lead - 0xd800L) << 10) + (codepoint - 0xdc00L)); + enc_ctx->lead = 0x0000L; + } else { + /* unpaired low surrogate */ + DUK_ASSERT(enc_ctx->lead == 0x0000L); + codepoint = DUK_UNICODE_CP_REPLACEMENT_CHARACTER; + } + } + } else { + if (enc_ctx->lead != 0x0000L) { + /* unpaired high surrogate: emit replacement character and the input codepoint */ + enc_ctx->lead = 0x0000L; + enc_ctx->out = duk__utf8_emit_repl(enc_ctx->out); + } + } + + /* Codepoint may be original input, a decoded surrogate pair, or may + * have been replaced with U+FFFD. + */ + enc_ctx->out += duk_unicode_encode_xutf8((duk_ucodepoint_t) codepoint, enc_ctx->out); +} +#endif /* DUK_USE_ENCODING_BUILTINS */ + +/* Shared helper for buffer-to-string using a TextDecoder() compatible UTF-8 + * decoder. + */ +DUK_LOCAL duk_ret_t duk__decode_helper(duk_hthread *thr, duk__decode_context *dec_ctx) { + const duk_uint8_t *input; + duk_size_t len = 0; + duk_size_t len_tmp; + duk_bool_t stream = 0; + duk_codepoint_t codepoint; + duk_uint8_t *output; + const duk_uint8_t *in; + duk_uint8_t *out; + + DUK_ASSERT(dec_ctx != NULL); + + /* Careful with input buffer pointer: any side effects involving + * code execution (e.g. getters, coercion calls, and finalizers) + * may cause a resize and invalidate a pointer we've read. This + * is why the pointer is actually looked up at the last minute. + * Argument validation must still happen first to match WHATWG + * required side effect order. + */ + + if (duk_is_undefined(thr, 0)) { + duk_push_fixed_buffer_nozero(thr, 0); + duk_replace(thr, 0); + } + (void) duk_require_buffer_data(thr, 0, &len); /* Need 'len', avoid pointer. */ + + if (duk_check_type_mask(thr, 1, DUK_TYPE_MASK_UNDEFINED | DUK_TYPE_MASK_NULL | DUK_TYPE_MASK_NONE)) { + /* Use defaults, treat missing value like undefined. */ + } else { + duk_require_type_mask(thr, + 1, + DUK_TYPE_MASK_UNDEFINED | DUK_TYPE_MASK_NULL | DUK_TYPE_MASK_LIGHTFUNC | + DUK_TYPE_MASK_BUFFER | DUK_TYPE_MASK_OBJECT); + if (duk_get_prop_literal(thr, 1, "stream")) { + stream = duk_to_boolean(thr, -1); + } + } + + /* Allowance is 3*len in the general case because all bytes may potentially + * become U+FFFD. If the first byte completes a non-BMP codepoint it will + * decode to a CESU-8 surrogate pair (6 bytes) so we allow 3 extra bytes to + * compensate: (1*3)+3 = 6. Non-BMP codepoints are safe otherwise because + * the 4->6 expansion is well under the 3x allowance. + * + * XXX: As with TextEncoder, need a better buffer allocation strategy here. + */ + if (len >= (DUK_HBUFFER_MAX_BYTELEN / 3) - 3) { + DUK_ERROR_TYPE(thr, DUK_STR_RESULT_TOO_LONG); + DUK_WO_NORETURN(return 0;); + } + output = + (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, 3 + (3 * len)); /* used parts will be always manually written over */ + + input = (const duk_uint8_t *) duk_get_buffer_data(thr, 0, &len_tmp); + DUK_ASSERT(input != NULL || len == 0); + if (DUK_UNLIKELY(len != len_tmp)) { + /* Very unlikely but possible: source buffer was resized by + * a side effect when fixed buffer was pushed. Output buffer + * may not be large enough to hold output, so just fail if + * length has changed. + */ + DUK_D(DUK_DPRINT("input buffer resized by side effect, fail")); + goto fail_type; + } + + /* From this point onwards it's critical that no side effect occur + * which may disturb 'input': finalizer execution, property accesses, + * active coercions, etc. Even an allocation related mark-and-sweep + * may affect the pointer because it may trigger a pending finalizer. + */ + + in = input; + out = output; + while (in < input + len) { + codepoint = duk__utf8_decode_next(dec_ctx, *in++); + if (codepoint < 0) { + if (codepoint == DUK__CP_CONTINUE) { + continue; + } + + /* Decoding error with or without retry. */ + DUK_ASSERT(codepoint == DUK__CP_ERROR || codepoint == DUK__CP_RETRY); + if (codepoint == DUK__CP_RETRY) { + --in; /* retry last byte */ + } + /* replacement mode: replace with U+FFFD */ + codepoint = DUK_UNICODE_CP_REPLACEMENT_CHARACTER; + if (dec_ctx->fatal) { + /* fatal mode: throw a TypeError */ + goto fail_type; + } + /* Continue with 'codepoint', Unicode replacement. */ + } + DUK_ASSERT(codepoint >= 0x0000L && codepoint <= 0x10ffffL); + + if (!dec_ctx->bom_handled) { + dec_ctx->bom_handled = 1; + if (codepoint == 0xfeffL && !dec_ctx->ignore_bom) { + continue; + } + } + + out += duk_unicode_encode_cesu8((duk_ucodepoint_t) codepoint, out); + DUK_ASSERT(out <= output + (3 + (3 * len))); + } + + if (!stream) { + if (dec_ctx->needed != 0) { + /* truncated sequence at end of buffer */ + if (dec_ctx->fatal) { + goto fail_type; + } else { + out += duk_unicode_encode_cesu8(DUK_UNICODE_CP_REPLACEMENT_CHARACTER, out); + DUK_ASSERT(out <= output + (3 + (3 * len))); + } + } + duk__utf8_decode_init(dec_ctx); /* Initialize decoding state for potential reuse. */ + } + + /* Output buffer is fixed and thus stable even if there had been + * side effects (which there shouldn't be). + */ + duk_push_lstring(thr, (const char *) output, (duk_size_t) (out - output)); + return 1; + +fail_type: + DUK_ERROR_TYPE(thr, DUK_STR_UTF8_DECODE_FAILED); + DUK_WO_NORETURN(return 0;); +} + +/* + * Built-in bindings + */ + +#if defined(DUK_USE_ENCODING_BUILTINS) +DUK_INTERNAL duk_ret_t duk_bi_textencoder_constructor(duk_hthread *thr) { + /* TextEncoder currently requires no persistent state, so the constructor + * does nothing on purpose. + */ + + duk_require_constructor_call(thr); + return 0; +} + +DUK_INTERNAL duk_ret_t duk_bi_textencoder_prototype_encoding_getter(duk_hthread *thr) { + duk_push_literal(thr, "utf-8"); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_textencoder_prototype_encode(duk_hthread *thr) { + duk__encode_context enc_ctx; + duk_size_t len; + duk_size_t final_len; + duk_uint8_t *output; + + DUK_ASSERT_TOP(thr, 1); + if (duk_is_undefined(thr, 0)) { + len = 0; + } else { + duk_hstring *h_input; + + h_input = duk_to_hstring(thr, 0); + DUK_ASSERT(h_input != NULL); + + len = (duk_size_t) DUK_HSTRING_GET_CHARLEN(h_input); + if (len >= DUK_HBUFFER_MAX_BYTELEN / 3) { + DUK_ERROR_TYPE(thr, DUK_STR_RESULT_TOO_LONG); + DUK_WO_NORETURN(return 0;); + } + } + + /* Allowance is 3*len because all bytes can potentially be replaced with + * U+FFFD -- which rather inconveniently encodes to 3 bytes in UTF-8. + * Rely on dynamic buffer data pointer stability: no other code has + * access to the data pointer. + * + * XXX: The buffer allocation strategy used here is rather inefficient. + * Maybe switch to a chunk-based strategy, or preprocess the string to + * figure out the space needed ahead of time? + */ + DUK_ASSERT(3 * len >= len); + output = (duk_uint8_t *) duk_push_dynamic_buffer(thr, 3 * len); + + if (len > 0) { + DUK_ASSERT(duk_is_string(thr, 0)); /* True if len > 0. */ + + /* XXX: duk_decode_string() is used to process the input + * string. For standard ECMAScript strings, represented + * internally as CESU-8, this is fine. However, behavior + * beyond CESU-8 is not very strict: codepoints using an + * extended form of UTF-8 are also accepted, and invalid + * codepoint sequences (which are allowed in Duktape strings) + * are not handled as well as they could (e.g. invalid + * continuation bytes may mask following codepoints). + * This is how ECMAScript code would also see such strings. + * Maybe replace duk_decode_string() with an explicit strict + * CESU-8 decoder here? + */ + enc_ctx.lead = 0x0000L; + enc_ctx.out = output; + duk_decode_string(thr, 0, duk__utf8_encode_char, (void *) &enc_ctx); + if (enc_ctx.lead != 0x0000L) { + /* unpaired high surrogate at end of string */ + enc_ctx.out = duk__utf8_emit_repl(enc_ctx.out); + DUK_ASSERT(enc_ctx.out <= output + (3 * len)); + } + + /* The output buffer is usually very much oversized, so shrink it to + * actually needed size. Pointer stability assumed up to this point. + */ + DUK_ASSERT_TOP(thr, 2); + DUK_ASSERT(output == (duk_uint8_t *) duk_get_buffer_data(thr, -1, NULL)); + + final_len = (duk_size_t) (enc_ctx.out - output); + duk_resize_buffer(thr, -1, final_len); + /* 'output' and 'enc_ctx.out' are potentially invalidated by the resize. */ + } else { + final_len = 0; + } + + /* Standard WHATWG output is a Uint8Array. Here the Uint8Array will + * be backed by a dynamic buffer which differs from e.g. Uint8Arrays + * created as 'new Uint8Array(N)'. ECMAScript code won't see the + * difference but C code will. When bufferobjects are not supported, + * returns a plain dynamic buffer. + */ +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + duk_push_buffer_object(thr, -1, 0, final_len, DUK_BUFOBJ_UINT8ARRAY); +#endif + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_textdecoder_constructor(duk_hthread *thr) { + duk__decode_context *dec_ctx; + duk_bool_t fatal = 0; + duk_bool_t ignore_bom = 0; + + DUK_ASSERT_TOP(thr, 2); + duk_require_constructor_call(thr); + if (!duk_is_undefined(thr, 0)) { + /* XXX: For now ignore 'label' (encoding identifier). */ + duk_to_string(thr, 0); + } + if (!duk_is_null_or_undefined(thr, 1)) { + if (duk_get_prop_literal(thr, 1, "fatal")) { + fatal = duk_to_boolean(thr, -1); + } + if (duk_get_prop_literal(thr, 1, "ignoreBOM")) { + ignore_bom = duk_to_boolean(thr, -1); + } + } + + duk_push_this(thr); + + /* The decode context is not assumed to be zeroed; all fields are + * initialized explicitly. + */ + dec_ctx = (duk__decode_context *) duk_push_fixed_buffer(thr, sizeof(duk__decode_context)); + dec_ctx->fatal = (duk_uint8_t) fatal; + dec_ctx->ignore_bom = (duk_uint8_t) ignore_bom; + duk__utf8_decode_init(dec_ctx); /* Initializes remaining fields. */ + + duk_put_prop_literal(thr, -2, DUK_INTERNAL_SYMBOL("Context")); + return 0; +} + +/* Get TextDecoder context from 'this'; leaves garbage on stack. */ +DUK_LOCAL duk__decode_context *duk__get_textdecoder_context(duk_hthread *thr) { + duk__decode_context *dec_ctx; + duk_push_this(thr); + duk_get_prop_literal(thr, -1, DUK_INTERNAL_SYMBOL("Context")); + dec_ctx = (duk__decode_context *) duk_require_buffer(thr, -1, NULL); + DUK_ASSERT(dec_ctx != NULL); + return dec_ctx; +} + +DUK_INTERNAL duk_ret_t duk_bi_textdecoder_prototype_shared_getter(duk_hthread *thr) { + duk__decode_context *dec_ctx; + duk_int_t magic; + + dec_ctx = duk__get_textdecoder_context(thr); + magic = duk_get_current_magic(thr); + switch (magic) { + case 0: + /* Encoding is now fixed, so _Context lookup is only needed to + * validate the 'this' binding (TypeError if not TextDecoder-like). + */ + duk_push_literal(thr, "utf-8"); + break; + case 1: + duk_push_boolean(thr, dec_ctx->fatal); + break; + default: + duk_push_boolean(thr, dec_ctx->ignore_bom); + break; + } + + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_textdecoder_prototype_decode(duk_hthread *thr) { + duk__decode_context *dec_ctx; + + dec_ctx = duk__get_textdecoder_context(thr); + return duk__decode_helper(thr, dec_ctx); +} +#endif /* DUK_USE_ENCODING_BUILTINS */ + +/* + * Internal helper for Node.js Buffer + */ + +/* Internal helper used for Node.js Buffer .toString(). Value stack convention + * is currently odd: it mimics TextDecoder .decode() so that argument must be at + * index 0, and decode options (not present for Buffer) at index 1. Return value + * is a Duktape/C function return value. + */ +DUK_INTERNAL duk_ret_t duk_textdecoder_decode_utf8_nodejs(duk_hthread *thr) { + duk__decode_context dec_ctx; + + dec_ctx.fatal = 0; /* use replacement chars */ + dec_ctx.ignore_bom = 1; /* ignore BOMs (matches Node.js Buffer .toString()) */ + duk__utf8_decode_init(&dec_ctx); + + return duk__decode_helper(thr, &dec_ctx); +} + +/* automatic undefs */ +#undef DUK__CP_CONTINUE +#undef DUK__CP_ERROR +#undef DUK__CP_RETRY +#line 1 "duk_bi_error.c" +/* + * Error built-ins + */ + +/* #include duk_internal.h -> already included */ + +DUK_INTERNAL duk_ret_t duk_bi_error_constructor_shared(duk_hthread *thr) { + /* Behavior for constructor and non-constructor call is + * the same except for augmenting the created error. When + * called as a constructor, the caller (duk_new()) will handle + * augmentation; when called as normal function, we need to do + * it here. + */ + + duk_small_int_t bidx_prototype = duk_get_current_magic(thr); + + /* same for both error and each subclass like TypeError */ + duk_uint_t flags_and_class = + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_ERROR); + + (void) duk_push_object_helper(thr, flags_and_class, bidx_prototype); + + /* If message is undefined, the own property 'message' is not set at + * all to save property space. An empty message is inherited anyway. + */ + if (!duk_is_undefined(thr, 0)) { + duk_to_string(thr, 0); + duk_dup_0(thr); /* [ message error message ] */ + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_MESSAGE, DUK_PROPDESC_FLAGS_WC); + } + + /* Augment the error if called as a normal function. __FILE__ and __LINE__ + * are not desirable in this case. + */ + +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) + if (!duk_is_constructor_call(thr)) { + duk_err_augment_error_create(thr, thr, NULL, 0, DUK_AUGMENT_FLAG_NOBLAME_FILELINE); + } +#endif + + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_to_string(duk_hthread *thr) { + /* XXX: optimize with more direct internal access */ + + duk_push_this(thr); + (void) duk_require_hobject_promote_mask(thr, -1, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + + /* [ ... this ] */ + + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_NAME); + if (duk_is_undefined(thr, -1)) { + duk_pop(thr); + duk_push_literal(thr, "Error"); + } else { + duk_to_string(thr, -1); + } + + /* [ ... this name ] */ + + /* XXX: Are steps 6 and 7 in E5 Section 15.11.4.4 duplicated by + * accident or are they actually needed? The first ToString() + * could conceivably return 'undefined'. + */ + duk_get_prop_stridx_short(thr, -2, DUK_STRIDX_MESSAGE); + if (duk_is_undefined(thr, -1)) { + duk_pop(thr); + duk_push_hstring_empty(thr); + } else { + duk_to_string(thr, -1); + } + + /* [ ... this name message ] */ + + if (duk_get_length(thr, -2) == 0) { + /* name is empty -> return message */ + return 1; + } + if (duk_get_length(thr, -1) == 0) { + /* message is empty -> return name */ + duk_pop(thr); + return 1; + } + duk_push_literal(thr, ": "); + duk_insert(thr, -2); /* ... name ': ' message */ + duk_concat(thr, 3); + + return 1; +} + +#if defined(DUK_USE_TRACEBACKS) + +/* + * Traceback handling + * + * The unified helper decodes the traceback and produces various requested + * outputs. It should be optimized for size, and may leave garbage on stack, + * only the topmost return value matters. For instance, traceback separator + * and decoded strings are pushed even when looking for filename only. + * + * NOTE: although _Tracedata is an internal property, user code can currently + * write to the array (or replace it with something other than an array). + * The code below must tolerate arbitrary _Tracedata. It can throw errors + * etc, but cannot cause a segfault or memory unsafe behavior. + */ + +/* constants arbitrary, chosen for small loads */ +#define DUK__OUTPUT_TYPE_TRACEBACK (-1) +#define DUK__OUTPUT_TYPE_FILENAME 0 +#define DUK__OUTPUT_TYPE_LINENUMBER 1 + +DUK_LOCAL duk_ret_t duk__error_getter_helper(duk_hthread *thr, duk_small_int_t output_type) { + duk_idx_t idx_td; + duk_small_int_t i; /* traceback depth fits into 16 bits */ + duk_small_int_t t; /* stack type fits into 16 bits */ + duk_small_int_t count_func = 0; /* traceback depth ensures fits into 16 bits */ + const char *str_tailcall = " tailcall"; + const char *str_strict = " strict"; + const char *str_construct = " construct"; + const char *str_prevyield = " preventsyield"; + const char *str_directeval = " directeval"; + const char *str_empty = ""; + + DUK_ASSERT_TOP(thr, 0); /* fixed arg count */ + + duk_push_this(thr); + duk_xget_owndataprop_stridx_short(thr, -1, DUK_STRIDX_INT_TRACEDATA); + idx_td = duk_get_top_index(thr); + + duk_push_hstring_stridx(thr, DUK_STRIDX_NEWLINE_4SPACE); + duk_push_this(thr); + + /* [ ... this tracedata sep this ] */ + + /* XXX: skip null filename? */ + + if (duk_check_type(thr, idx_td, DUK_TYPE_OBJECT)) { + /* Current tracedata contains 2 entries per callstack entry. */ + for (i = 0;; i += 2) { + duk_int_t pc; + duk_uint_t line; + duk_uint_t flags; + duk_double_t d; + const char *funcname; + const char *filename; + duk_hobject *h_func; + duk_hstring *h_name; + + duk_require_stack(thr, 5); + duk_get_prop_index(thr, idx_td, (duk_uarridx_t) i); + duk_get_prop_index(thr, idx_td, (duk_uarridx_t) (i + 1)); + d = duk_to_number_m1(thr); + pc = duk_double_to_int_t(DUK_FMOD(d, DUK_DOUBLE_2TO32)); + flags = duk_double_to_uint_t(DUK_FLOOR(d / DUK_DOUBLE_2TO32)); + t = (duk_small_int_t) duk_get_type(thr, -2); + + if (t == DUK_TYPE_OBJECT || t == DUK_TYPE_LIGHTFUNC) { + /* + * ECMAScript/native function call or lightfunc call + */ + + count_func++; + + /* [ ... v1(func) v2(pc+flags) ] */ + + /* These may be systematically omitted by Duktape + * with certain config options, but allow user to + * set them on a case-by-case basis. + */ + duk_get_prop_stridx_short(thr, -2, DUK_STRIDX_NAME); + duk_get_prop_stridx_short(thr, -3, DUK_STRIDX_FILE_NAME); + +#if defined(DUK_USE_PC2LINE) + line = (duk_uint_t) duk_hobject_pc2line_query(thr, -4, (duk_uint_fast32_t) pc); +#else + line = 0; +#endif + + /* [ ... v1 v2 name filename ] */ + + /* When looking for .fileName/.lineNumber, blame first + * function which has a .fileName. + */ + if (duk_is_string_notsymbol(thr, -1)) { + if (output_type == DUK__OUTPUT_TYPE_FILENAME) { + return 1; + } else if (output_type == DUK__OUTPUT_TYPE_LINENUMBER) { + duk_push_uint(thr, line); + return 1; + } + } + + /* XXX: Change 'anon' handling here too, to use empty string for anonymous functions? */ + /* XXX: Could be improved by coercing to a readable duk_tval (especially string escaping) */ + h_name = duk_get_hstring_notsymbol(thr, -2); /* may be NULL */ + funcname = (h_name == NULL || h_name == DUK_HTHREAD_STRING_EMPTY_STRING(thr)) ? + "[anon]" : + (const char *) DUK_HSTRING_GET_DATA(h_name); + filename = duk_get_string_notsymbol(thr, -1); + filename = filename ? filename : ""; + DUK_ASSERT(funcname != NULL); + DUK_ASSERT(filename != NULL); + + h_func = duk_get_hobject(thr, -4); /* NULL for lightfunc */ + + if (h_func == NULL) { + duk_push_sprintf( + thr, + "at %s light%s%s%s%s%s", + (const char *) funcname, + (const char *) ((flags & DUK_ACT_FLAG_STRICT) ? str_strict : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_TAILCALLED) ? str_tailcall : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_CONSTRUCT) ? str_construct : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_DIRECT_EVAL) ? str_directeval : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_PREVENT_YIELD) ? str_prevyield : str_empty)); + } else if (DUK_HOBJECT_HAS_NATFUNC(h_func)) { + duk_push_sprintf( + thr, + "at %s (%s) native%s%s%s%s%s", + (const char *) funcname, + (const char *) filename, + (const char *) ((flags & DUK_ACT_FLAG_STRICT) ? str_strict : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_TAILCALLED) ? str_tailcall : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_CONSTRUCT) ? str_construct : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_DIRECT_EVAL) ? str_directeval : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_PREVENT_YIELD) ? str_prevyield : str_empty)); + } else { + duk_push_sprintf( + thr, + "at %s (%s:%lu)%s%s%s%s%s", + (const char *) funcname, + (const char *) filename, + (unsigned long) line, + (const char *) ((flags & DUK_ACT_FLAG_STRICT) ? str_strict : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_TAILCALLED) ? str_tailcall : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_CONSTRUCT) ? str_construct : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_DIRECT_EVAL) ? str_directeval : str_empty), + (const char *) ((flags & DUK_ACT_FLAG_PREVENT_YIELD) ? str_prevyield : str_empty)); + } + duk_replace(thr, -5); /* [ ... v1 v2 name filename str ] -> [ ... str v2 name filename ] */ + duk_pop_3(thr); /* -> [ ... str ] */ + } else if (t == DUK_TYPE_STRING) { + const char *str_file; + + /* + * __FILE__ / __LINE__ entry, here 'pc' is line number directly. + * Sometimes __FILE__ / __LINE__ is reported as the source for + * the error (fileName, lineNumber), sometimes not. + */ + + /* [ ... v1(filename) v2(line+flags) ] */ + + /* When looking for .fileName/.lineNumber, blame compilation + * or C call site unless flagged not to do so. + */ + if (!(flags & DUK_TB_FLAG_NOBLAME_FILELINE)) { + if (output_type == DUK__OUTPUT_TYPE_FILENAME) { + duk_pop(thr); + return 1; + } else if (output_type == DUK__OUTPUT_TYPE_LINENUMBER) { + duk_push_int(thr, pc); + return 1; + } + } + + /* Tracedata is trusted but avoid any risk of using a NULL + * for %s format because it has undefined behavior. Symbols + * don't need to be explicitly rejected as they pose no memory + * safety issues. + */ + str_file = (const char *) duk_get_string(thr, -2); + duk_push_sprintf(thr, + "at [anon] (%s:%ld) internal", + (const char *) (str_file ? str_file : "null"), + (long) pc); + duk_replace(thr, -3); /* [ ... v1 v2 str ] -> [ ... str v2 ] */ + duk_pop(thr); /* -> [ ... str ] */ + } else { + /* unknown, ignore */ + duk_pop_2(thr); + break; + } + } + + if (count_func >= DUK_USE_TRACEBACK_DEPTH) { + /* Possibly truncated; there is no explicit truncation + * marker so this is the best we can do. + */ + + duk_push_hstring_stridx(thr, DUK_STRIDX_BRACKETED_ELLIPSIS); + } + } + + /* [ ... this tracedata sep this str1 ... strN ] */ + + if (output_type != DUK__OUTPUT_TYPE_TRACEBACK) { + return 0; + } else { + /* The 'this' after 'sep' will get ToString() coerced by + * duk_join() automatically. We don't want to do that + * coercion when providing .fileName or .lineNumber (GH-254). + */ + duk_join(thr, duk_get_top(thr) - (idx_td + 2) /*count, not including sep*/); + return 1; + } +} + +/* XXX: Output type could be encoded into native function 'magic' value to + * save space. For setters the stridx could be encoded into 'magic'. + */ + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_stack_getter(duk_hthread *thr) { + return duk__error_getter_helper(thr, DUK__OUTPUT_TYPE_TRACEBACK); +} + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_filename_getter(duk_hthread *thr) { + return duk__error_getter_helper(thr, DUK__OUTPUT_TYPE_FILENAME); +} + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_linenumber_getter(duk_hthread *thr) { + return duk__error_getter_helper(thr, DUK__OUTPUT_TYPE_LINENUMBER); +} + +#else /* DUK_USE_TRACEBACKS */ + +/* + * Traceback handling when tracebacks disabled. + * + * The fileName / lineNumber stubs are now necessary because built-in + * data will include the accessor properties in Error.prototype. If those + * are removed for builds without tracebacks, these can also be removed. + * 'stack' should still be present and produce a ToString() equivalent: + * this is useful for user code which prints a stacktrace and expects to + * see something useful. A normal stacktrace also begins with a ToString() + * of the error so this makes sense. + */ + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_stack_getter(duk_hthread *thr) { + /* XXX: remove this native function and map 'stack' accessor + * to the toString() implementation directly. + */ + return duk_bi_error_prototype_to_string(thr); +} + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_filename_getter(duk_hthread *thr) { + DUK_UNREF(thr); + return 0; +} + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_linenumber_getter(duk_hthread *thr) { + DUK_UNREF(thr); + return 0; +} + +#endif /* DUK_USE_TRACEBACKS */ + +DUK_LOCAL duk_ret_t duk__error_setter_helper(duk_hthread *thr, duk_small_uint_t stridx_key) { + /* Attempt to write 'stack', 'fileName', 'lineNumber' works as if + * user code called Object.defineProperty() to create an overriding + * own property. This allows user code to overwrite .fileName etc + * intuitively as e.g. "err.fileName = 'dummy'" as one might expect. + * See https://github.com/svaarala/duktape/issues/387. + */ + + DUK_ASSERT_TOP(thr, 1); /* fixed arg count: value */ + + duk_push_this(thr); + duk_push_hstring_stridx(thr, stridx_key); + duk_dup_0(thr); + + /* [ ... obj key value ] */ + + DUK_DD(DUK_DDPRINT("error setter: %!T %!T %!T", duk_get_tval(thr, -3), duk_get_tval(thr, -2), duk_get_tval(thr, -1))); + + duk_def_prop(thr, + -3, + DUK_DEFPROP_HAVE_VALUE | DUK_DEFPROP_HAVE_WRITABLE | DUK_DEFPROP_WRITABLE | + DUK_DEFPROP_HAVE_ENUMERABLE | /*not enumerable*/ + DUK_DEFPROP_HAVE_CONFIGURABLE | DUK_DEFPROP_CONFIGURABLE); + return 0; +} + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_stack_setter(duk_hthread *thr) { + return duk__error_setter_helper(thr, DUK_STRIDX_STACK); +} + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_filename_setter(duk_hthread *thr) { + return duk__error_setter_helper(thr, DUK_STRIDX_FILE_NAME); +} + +DUK_INTERNAL duk_ret_t duk_bi_error_prototype_linenumber_setter(duk_hthread *thr) { + return duk__error_setter_helper(thr, DUK_STRIDX_LINE_NUMBER); +} + +/* automatic undefs */ +#undef DUK__OUTPUT_TYPE_FILENAME +#undef DUK__OUTPUT_TYPE_LINENUMBER +#undef DUK__OUTPUT_TYPE_TRACEBACK +#line 1 "duk_bi_function.c" +/* + * Function built-ins + */ + +/* #include duk_internal.h -> already included */ + +/* Needed even when Function built-in is disabled. */ +DUK_INTERNAL duk_ret_t duk_bi_function_prototype(duk_hthread *thr) { + /* ignore arguments, return undefined (E5 Section 15.3.4) */ + DUK_UNREF(thr); + return 0; +} + +#if defined(DUK_USE_FUNCTION_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_function_constructor(duk_hthread *thr) { + duk_hstring *h_sourcecode; + duk_idx_t nargs; + duk_idx_t i; + duk_small_uint_t comp_flags; + duk_hcompfunc *func; + duk_hobject *outer_lex_env; + duk_hobject *outer_var_env; + + /* normal and constructor calls have identical semantics */ + + nargs = duk_get_top(thr); + for (i = 0; i < nargs; i++) { + duk_to_string(thr, i); /* Rejects Symbols during coercion. */ + } + + if (nargs == 0) { + duk_push_hstring_empty(thr); + duk_push_hstring_empty(thr); + } else if (nargs == 1) { + /* XXX: cover this with the generic >1 case? */ + duk_push_hstring_empty(thr); + } else { + duk_insert(thr, 0); /* [ arg1 ... argN-1 body] -> [body arg1 ... argN-1] */ + duk_push_literal(thr, ","); + duk_insert(thr, 1); + duk_join(thr, nargs - 1); + } + + /* [ body formals ], formals is comma separated list that needs to be parsed */ + + DUK_ASSERT_TOP(thr, 2); + + /* XXX: this placeholder is not always correct, but use for now. + * It will fail in corner cases; see test-dev-func-cons-args.js. + */ + duk_push_literal(thr, "function("); + duk_dup_1(thr); + duk_push_literal(thr, "){"); + duk_dup_0(thr); + duk_push_literal(thr, "\n}"); /* Newline is important to handle trailing // comment. */ + duk_concat(thr, 5); + + /* [ body formals source ] */ + + DUK_ASSERT_TOP(thr, 3); + + /* strictness is not inherited, intentional */ + comp_flags = DUK_COMPILE_FUNCEXPR; + + duk_push_hstring_stridx(thr, DUK_STRIDX_COMPILE); /* XXX: copy from caller? */ /* XXX: ignored now */ + h_sourcecode = duk_require_hstring(thr, -2); /* no symbol check needed; -2 is concat'd code */ + duk_js_compile(thr, + (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_sourcecode), + (duk_size_t) DUK_HSTRING_GET_BYTELEN(h_sourcecode), + comp_flags); + + /* Force .name to 'anonymous' (ES2015). */ + duk_push_literal(thr, "anonymous"); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_NAME, DUK_PROPDESC_FLAGS_C); + + func = (duk_hcompfunc *) duk_known_hobject(thr, -1); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC((duk_hobject *) func)); + DUK_ASSERT(DUK_HOBJECT_HAS_CONSTRUCTABLE((duk_hobject *) func)); + + /* [ body formals source template ] */ + + /* only outer_lex_env matters, as functions always get a new + * variable declaration environment. + */ + + outer_lex_env = thr->builtins[DUK_BIDX_GLOBAL_ENV]; + outer_var_env = thr->builtins[DUK_BIDX_GLOBAL_ENV]; + + duk_js_push_closure(thr, func, outer_var_env, outer_lex_env, 1 /*add_auto_proto*/); + + /* [ body formals source template closure ] */ + + return 1; +} +#endif /* DUK_USE_FUNCTION_BUILTIN */ + +#if defined(DUK_USE_FUNCTION_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_function_prototype_to_string(duk_hthread *thr) { + duk_tval *tv; + + /* + * E5 Section 15.3.4.2 places few requirements on the output of + * this function: the result is implementation dependent, must + * follow FunctionDeclaration syntax (in particular, must have a + * name even for anonymous functions or functions with empty name). + * The output does NOT need to compile into anything useful. + * + * E6 Section 19.2.3.5 changes the requirements completely: the + * result must either eval() to a functionally equivalent object + * OR eval() to a SyntaxError. + * + * We opt for the SyntaxError approach for now, with a syntax that + * mimics V8's native function syntax: + * + * 'function cos() { [native code] }' + * + * but extended with [ecmascript code], [bound code], and + * [lightfunc code]. + */ + + duk_push_this(thr); + tv = DUK_GET_TVAL_NEGIDX(thr, -1); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *obj = DUK_TVAL_GET_OBJECT(tv); + const char *func_name; + + /* Function name: missing/undefined is mapped to empty string, + * otherwise coerce to string. No handling for invalid identifier + * characters or e.g. '{' in the function name. This doesn't + * really matter as long as a SyntaxError results. Technically + * if the name contained a suitable prefix followed by '//' it + * might cause the result to parse without error. + */ + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_NAME); + if (duk_is_undefined(thr, -1)) { + func_name = ""; + } else { + func_name = duk_to_string(thr, -1); + DUK_ASSERT(func_name != NULL); + } + + if (DUK_HOBJECT_IS_COMPFUNC(obj)) { + duk_push_sprintf(thr, "function %s() { [ecmascript code] }", (const char *) func_name); + } else if (DUK_HOBJECT_IS_NATFUNC(obj)) { + duk_push_sprintf(thr, "function %s() { [native code] }", (const char *) func_name); + } else if (DUK_HOBJECT_IS_BOUNDFUNC(obj)) { + duk_push_sprintf(thr, "function %s() { [bound code] }", (const char *) func_name); + } else { + goto type_error; + } + } else if (DUK_TVAL_IS_LIGHTFUNC(tv)) { + duk_push_lightfunc_tostring(thr, tv); + } else { + goto type_error; + } + + return 1; + +type_error: + DUK_DCERROR_TYPE_INVALID_ARGS(thr); +} +#endif + +/* Always present because the native function pointer is needed in call + * handling. + */ +DUK_INTERNAL duk_ret_t duk_bi_function_prototype_call(duk_hthread *thr) { + /* .call() is dealt with in call handling by simulating its + * effects so this function is actually never called. + */ + DUK_UNREF(thr); + return DUK_RET_TYPE_ERROR; +} + +DUK_INTERNAL duk_ret_t duk_bi_function_prototype_apply(duk_hthread *thr) { + /* Like .call(), never actually called. */ + DUK_UNREF(thr); + return DUK_RET_TYPE_ERROR; +} + +DUK_INTERNAL duk_ret_t duk_bi_reflect_apply(duk_hthread *thr) { + /* Like .call(), never actually called. */ + DUK_UNREF(thr); + return DUK_RET_TYPE_ERROR; +} + +DUK_INTERNAL duk_ret_t duk_bi_reflect_construct(duk_hthread *thr) { + /* Like .call(), never actually called. */ + DUK_UNREF(thr); + return DUK_RET_TYPE_ERROR; +} + +#if defined(DUK_USE_FUNCTION_BUILTIN) +/* Create a bound function which points to a target function which may + * be bound or non-bound. If the target is bound, the argument lists + * and 'this' binding of the functions are merged and the resulting + * function points directly to the non-bound target. + */ +DUK_INTERNAL duk_ret_t duk_bi_function_prototype_bind(duk_hthread *thr) { + duk_hboundfunc *h_bound; + duk_idx_t nargs; /* bound args, not counting 'this' binding */ + duk_idx_t bound_nargs; + duk_int_t bound_len; + duk_tval *tv_prevbound; + duk_idx_t n_prevbound; + duk_tval *tv_res; + duk_tval *tv_tmp; + + /* XXX: C API call, e.g. duk_push_bound_function(thr, target_idx, nargs); */ + + /* Vararg function, careful arg handling, e.g. thisArg may not + * be present. + */ + nargs = duk_get_top(thr) - 1; /* actual args, not counting 'this' binding */ + if (nargs < 0) { + nargs++; + duk_push_undefined(thr); + } + DUK_ASSERT(nargs >= 0); + + /* Limit 'nargs' for bound functions to guarantee arithmetic + * below will never wrap. + */ + if (nargs > (duk_idx_t) DUK_HBOUNDFUNC_MAX_ARGS) { + DUK_DCERROR_RANGE_INVALID_COUNT(thr); + } + + duk_push_this(thr); + duk_require_callable(thr, -1); + + /* [ thisArg arg1 ... argN func ] (thisArg+args == nargs+1 total) */ + DUK_ASSERT_TOP(thr, nargs + 2); + + /* Create bound function object. */ + h_bound = duk_push_hboundfunc(thr); + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(&h_bound->target)); + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(&h_bound->this_binding)); + DUK_ASSERT(h_bound->args == NULL); + DUK_ASSERT(h_bound->nargs == 0); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) h_bound) == NULL); + + /* [ thisArg arg1 ... argN func boundFunc ] */ + + /* If the target is a bound function, argument lists must be + * merged. The 'this' binding closest to the target function + * wins because in call handling the 'this' gets replaced over + * and over again until we call the non-bound function. + */ + tv_prevbound = NULL; + n_prevbound = 0; + tv_tmp = DUK_GET_TVAL_POSIDX(thr, 0); + DUK_TVAL_SET_TVAL(&h_bound->this_binding, tv_tmp); + tv_tmp = DUK_GET_TVAL_NEGIDX(thr, -2); + DUK_TVAL_SET_TVAL(&h_bound->target, tv_tmp); + + if (DUK_TVAL_IS_OBJECT(tv_tmp)) { + duk_hobject *h_target; + duk_hobject *bound_proto; + + h_target = DUK_TVAL_GET_OBJECT(tv_tmp); + DUK_ASSERT(DUK_HOBJECT_IS_CALLABLE(h_target)); + + /* Internal prototype must be copied from the target. + * For lightfuncs Function.prototype is used and is already + * in place. + */ + bound_proto = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h_target); + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, (duk_hobject *) h_bound, bound_proto); + + /* The 'strict' flag is copied to get the special [[Get]] of E5.1 + * Section 15.3.5.4 to apply when a 'caller' value is a strict bound + * function. Not sure if this is correct, because the specification + * is a bit ambiguous on this point but it would make sense. + */ + /* Strictness is inherited from target. */ + if (DUK_HOBJECT_HAS_STRICT(h_target)) { + DUK_HOBJECT_SET_STRICT((duk_hobject *) h_bound); + } + + if (DUK_HOBJECT_HAS_BOUNDFUNC(h_target)) { + duk_hboundfunc *h_boundtarget; + + h_boundtarget = (duk_hboundfunc *) (void *) h_target; + + /* The final function should always be non-bound, unless + * there's a bug in the internals. Assert for it. + */ + DUK_ASSERT(DUK_TVAL_IS_LIGHTFUNC(&h_boundtarget->target) || + (DUK_TVAL_IS_OBJECT(&h_boundtarget->target) && + DUK_HOBJECT_IS_CALLABLE(DUK_TVAL_GET_OBJECT(&h_boundtarget->target)) && + !DUK_HOBJECT_IS_BOUNDFUNC(DUK_TVAL_GET_OBJECT(&h_boundtarget->target)))); + + DUK_TVAL_SET_TVAL(&h_bound->target, &h_boundtarget->target); + DUK_TVAL_SET_TVAL(&h_bound->this_binding, &h_boundtarget->this_binding); + + tv_prevbound = h_boundtarget->args; + n_prevbound = h_boundtarget->nargs; + } + } else { + /* Lightfuncs are always strict. */ + duk_hobject *bound_proto; + + DUK_ASSERT(DUK_TVAL_IS_LIGHTFUNC(tv_tmp)); + DUK_HOBJECT_SET_STRICT((duk_hobject *) h_bound); + bound_proto = thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]; + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, (duk_hobject *) h_bound, bound_proto); + } + + DUK_TVAL_INCREF(thr, &h_bound->target); /* old values undefined, no decref needed */ + DUK_TVAL_INCREF(thr, &h_bound->this_binding); + + bound_nargs = n_prevbound + nargs; + if (bound_nargs > (duk_idx_t) DUK_HBOUNDFUNC_MAX_ARGS) { + DUK_DCERROR_RANGE_INVALID_COUNT(thr); + } + tv_res = (duk_tval *) DUK_ALLOC_CHECKED(thr, ((duk_size_t) bound_nargs) * sizeof(duk_tval)); + DUK_ASSERT(tv_res != NULL || bound_nargs == 0); + DUK_ASSERT(h_bound->args == NULL); + DUK_ASSERT(h_bound->nargs == 0); + h_bound->args = tv_res; + h_bound->nargs = bound_nargs; + + DUK_ASSERT(n_prevbound >= 0); + duk_copy_tvals_incref(thr, tv_res, tv_prevbound, (duk_size_t) n_prevbound); + DUK_ASSERT(nargs >= 0); + duk_copy_tvals_incref(thr, tv_res + n_prevbound, DUK_GET_TVAL_POSIDX(thr, 1), (duk_size_t) nargs); + + /* [ thisArg arg1 ... argN func boundFunc ] */ + + /* Bound function 'length' property is interesting. + * For lightfuncs, simply read the virtual property. + */ + duk_get_prop_stridx_short(thr, -2, DUK_STRIDX_LENGTH); + bound_len = duk_get_int(thr, -1); /* ES2015: no coercion */ + if (bound_len < nargs) { + bound_len = 0; + } else { + bound_len -= nargs; + } + if (sizeof(duk_int_t) > 4 && bound_len > (duk_int_t) DUK_UINT32_MAX) { + bound_len = (duk_int_t) DUK_UINT32_MAX; + } + duk_pop(thr); + DUK_ASSERT(bound_len >= 0); + tv_tmp = thr->valstack_top++; + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(tv_tmp)); + DUK_ASSERT(!DUK_TVAL_NEEDS_REFCOUNT_UPDATE(tv_tmp)); + DUK_TVAL_SET_U32(tv_tmp, (duk_uint32_t) bound_len); /* in-place update, fastint */ + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_C); /* attrs in E6 Section 9.2.4 */ + + /* XXX: could these be virtual? */ + /* Caller and arguments must use the same thrower, [[ThrowTypeError]]. */ + duk_xdef_prop_stridx_thrower(thr, -1, DUK_STRIDX_CALLER); + duk_xdef_prop_stridx_thrower(thr, -1, DUK_STRIDX_LC_ARGUMENTS); + + /* Function name and fileName (non-standard). */ + duk_push_literal(thr, "bound "); /* ES2015 19.2.3.2. */ + duk_get_prop_stridx(thr, -3, DUK_STRIDX_NAME); + if (!duk_is_string_notsymbol(thr, -1)) { + /* ES2015 has requirement to check that .name of target is a string + * (also must check for Symbol); if not, targetName should be the + * empty string. ES2015 19.2.3.2. + */ + duk_pop(thr); + duk_push_hstring_empty(thr); + } + duk_concat(thr, 2); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_NAME, DUK_PROPDESC_FLAGS_C); +#if defined(DUK_USE_FUNC_FILENAME_PROPERTY) + duk_get_prop_stridx_short(thr, -2, DUK_STRIDX_FILE_NAME); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_FILE_NAME, DUK_PROPDESC_FLAGS_C); +#endif + + DUK_DDD(DUK_DDDPRINT("created bound function: %!iT", (duk_tval *) duk_get_tval(thr, -1))); + + return 1; +} +#endif /* DUK_USE_FUNCTION_BUILTIN */ + +/* %NativeFunctionPrototype% .length getter. */ +DUK_INTERNAL duk_ret_t duk_bi_native_function_length(duk_hthread *thr) { + duk_tval *tv; + duk_hnatfunc *h; + duk_int16_t func_nargs; + + tv = duk_get_borrowed_this_tval(thr); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_IS_OBJECT(tv)) { + h = (duk_hnatfunc *) DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + if (!DUK_HOBJECT_IS_NATFUNC((duk_hobject *) h)) { + goto fail_type; + } + func_nargs = h->nargs; + duk_push_int(thr, func_nargs == DUK_HNATFUNC_NARGS_VARARGS ? 0 : func_nargs); + } else if (DUK_TVAL_IS_LIGHTFUNC(tv)) { + duk_small_uint_t lf_flags; + duk_small_uint_t lf_len; + + lf_flags = DUK_TVAL_GET_LIGHTFUNC_FLAGS(tv); + lf_len = DUK_LFUNC_FLAGS_GET_LENGTH(lf_flags); + duk_push_uint(thr, lf_len); + } else { + goto fail_type; + } + return 1; + +fail_type: + DUK_DCERROR_TYPE_INVALID_ARGS(thr); +} + +/* %NativeFunctionPrototype% .name getter. */ +DUK_INTERNAL duk_ret_t duk_bi_native_function_name(duk_hthread *thr) { + duk_tval *tv; + duk_hnatfunc *h; + + tv = duk_get_borrowed_this_tval(thr); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_IS_OBJECT(tv)) { + h = (duk_hnatfunc *) DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + if (!DUK_HOBJECT_IS_NATFUNC((duk_hobject *) h)) { + goto fail_type; + } +#if 0 + duk_push_hnatfunc_name(thr, h); +#endif + duk_push_hstring_empty(thr); + } else if (DUK_TVAL_IS_LIGHTFUNC(tv)) { + duk_push_lightfunc_name(thr, tv); + } else { + goto fail_type; + } + return 1; + +fail_type: + DUK_DCERROR_TYPE_INVALID_ARGS(thr); +} + +#if defined(DUK_USE_SYMBOL_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_function_prototype_hasinstance(duk_hthread *thr) { + /* This binding: RHS, stack index 0: LHS. */ + duk_bool_t ret; + + ret = duk_js_instanceof_ordinary(thr, DUK_GET_TVAL_POSIDX(thr, 0), DUK_GET_THIS_TVAL_PTR(thr)); + duk_push_boolean(thr, ret); + return 1; +} +#endif /* DUK_USE_SYMBOL_BUILTIN */ +#line 1 "duk_bi_global.c" +/* + * Global object built-ins + */ + +/* #include duk_internal.h -> already included */ + +/* + * Encoding/decoding helpers + */ + +/* XXX: Could add fast path (for each transform callback) with direct byte + * lookups (no shifting) and no explicit check for x < 0x80 before table + * lookup. + */ + +/* Macros for creating and checking bitmasks for character encoding. + * Bit number is a bit counterintuitive, but minimizes code size. + */ +#define DUK__MKBITS(a, b, c, d, e, f, g, h) \ + ((duk_uint8_t) (((a) << 0) | ((b) << 1) | ((c) << 2) | ((d) << 3) | ((e) << 4) | ((f) << 5) | ((g) << 6) | ((h) << 7))) +#define DUK__CHECK_BITMASK(table, cp) ((table)[(cp) >> 3] & (1 << ((cp) &0x07))) + +/* E5.1 Section 15.1.3.3: uriReserved + uriUnescaped + '#' */ +DUK_LOCAL const duk_uint8_t duk__encode_uriunescaped_table[16] = { + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x00-0x0f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x10-0x1f */ + DUK__MKBITS(0, 1, 0, 1, 1, 0, 1, 1), DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), /* 0x20-0x2f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 1, 0, 1, 0, 1), /* 0x30-0x3f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), /* 0x40-0x4f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 0, 0, 0, 0, 1), /* 0x50-0x5f */ + DUK__MKBITS(0, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), /* 0x60-0x6f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 0, 0, 0, 1, 0), /* 0x70-0x7f */ +}; + +/* E5.1 Section 15.1.3.4: uriUnescaped */ +DUK_LOCAL const duk_uint8_t duk__encode_uricomponent_unescaped_table[16] = { + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x00-0x0f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x10-0x1f */ + DUK__MKBITS(0, 1, 0, 0, 0, 0, 0, 1), DUK__MKBITS(1, 1, 1, 0, 0, 1, 1, 0), /* 0x20-0x2f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 0, 0, 0, 0, 0, 0), /* 0x30-0x3f */ + DUK__MKBITS(0, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), /* 0x40-0x4f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 0, 0, 0, 0, 1), /* 0x50-0x5f */ + DUK__MKBITS(0, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), /* 0x60-0x6f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 0, 0, 0, 1, 0), /* 0x70-0x7f */ +}; + +/* E5.1 Section 15.1.3.1: uriReserved + '#' */ +DUK_LOCAL const duk_uint8_t duk__decode_uri_reserved_table[16] = { + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x00-0x0f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x10-0x1f */ + DUK__MKBITS(0, 0, 0, 1, 1, 0, 1, 0), DUK__MKBITS(0, 0, 0, 1, 1, 0, 0, 1), /* 0x20-0x2f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 1, 1, 0, 1, 0, 1), /* 0x30-0x3f */ + DUK__MKBITS(1, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x40-0x4f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x50-0x5f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x60-0x6f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x70-0x7f */ +}; + +/* E5.1 Section 15.1.3.2: empty */ +DUK_LOCAL const duk_uint8_t duk__decode_uri_component_reserved_table[16] = { + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x00-0x0f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x10-0x1f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x20-0x2f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x30-0x3f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x40-0x4f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x50-0x5f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x60-0x6f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x70-0x7f */ +}; + +#if defined(DUK_USE_SECTION_B) +/* E5.1 Section B.2.2, step 7. */ +DUK_LOCAL const duk_uint8_t duk__escape_unescaped_table[16] = { + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x00-0x0f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), /* 0x10-0x1f */ + DUK__MKBITS(0, 0, 0, 0, 0, 0, 0, 0), DUK__MKBITS(0, 0, 1, 1, 0, 1, 1, 1), /* 0x20-0x2f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 0, 0, 0, 0, 0, 0), /* 0x30-0x3f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), /* 0x40-0x4f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 0, 0, 0, 0, 1), /* 0x50-0x5f */ + DUK__MKBITS(0, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), /* 0x60-0x6f */ + DUK__MKBITS(1, 1, 1, 1, 1, 1, 1, 1), DUK__MKBITS(1, 1, 1, 0, 0, 0, 0, 0) /* 0x70-0x7f */ +}; +#endif /* DUK_USE_SECTION_B */ + +typedef struct { + duk_hthread *thr; + duk_hstring *h_str; + duk_bufwriter_ctx bw; + const duk_uint8_t *p; + const duk_uint8_t *p_start; + const duk_uint8_t *p_end; +} duk__transform_context; + +typedef void (*duk__transform_callback)(duk__transform_context *tfm_ctx, const void *udata, duk_codepoint_t cp); + +/* XXX: refactor and share with other code */ +DUK_LOCAL duk_small_int_t duk__decode_hex_escape(const duk_uint8_t *p, duk_small_int_t n) { + duk_small_int_t ch; + duk_small_int_t t = 0; + + while (n > 0) { + t = t * 16; + ch = (duk_small_int_t) duk_hex_dectab[*p++]; + if (DUK_LIKELY(ch >= 0)) { + t += ch; + } else { + return -1; + } + n--; + } + return t; +} + +DUK_LOCAL int duk__transform_helper(duk_hthread *thr, duk__transform_callback callback, const void *udata) { + duk__transform_context tfm_ctx_alloc; + duk__transform_context *tfm_ctx = &tfm_ctx_alloc; + duk_codepoint_t cp; + + tfm_ctx->thr = thr; + + tfm_ctx->h_str = duk_to_hstring(thr, 0); + DUK_ASSERT(tfm_ctx->h_str != NULL); + + DUK_BW_INIT_PUSHBUF(thr, &tfm_ctx->bw, DUK_HSTRING_GET_BYTELEN(tfm_ctx->h_str)); /* initial size guess */ + + tfm_ctx->p_start = DUK_HSTRING_GET_DATA(tfm_ctx->h_str); + tfm_ctx->p_end = tfm_ctx->p_start + DUK_HSTRING_GET_BYTELEN(tfm_ctx->h_str); + tfm_ctx->p = tfm_ctx->p_start; + + while (tfm_ctx->p < tfm_ctx->p_end) { + cp = (duk_codepoint_t) duk_unicode_decode_xutf8_checked(thr, &tfm_ctx->p, tfm_ctx->p_start, tfm_ctx->p_end); + callback(tfm_ctx, udata, cp); + } + + DUK_BW_COMPACT(thr, &tfm_ctx->bw); + + (void) duk_buffer_to_string(thr, -1); /* Safe if transform is safe. */ + return 1; +} + +DUK_LOCAL void duk__transform_callback_encode_uri(duk__transform_context *tfm_ctx, const void *udata, duk_codepoint_t cp) { + duk_uint8_t xutf8_buf[DUK_UNICODE_MAX_XUTF8_LENGTH]; + duk_small_int_t len; + duk_codepoint_t cp1, cp2; + duk_small_int_t i, t; + const duk_uint8_t *unescaped_table = (const duk_uint8_t *) udata; + + /* UTF-8 encoded bytes escaped as %xx%xx%xx... -> 3 * nbytes. + * Codepoint range is restricted so this is a slightly too large + * but doesn't matter. + */ + DUK_BW_ENSURE(tfm_ctx->thr, &tfm_ctx->bw, 3 * DUK_UNICODE_MAX_XUTF8_LENGTH); + + if (cp < 0) { + goto uri_error; + } else if ((cp < 0x80L) && DUK__CHECK_BITMASK(unescaped_table, cp)) { + DUK_BW_WRITE_RAW_U8(tfm_ctx->thr, &tfm_ctx->bw, (duk_uint8_t) cp); + return; + } else if (cp >= 0xdc00L && cp <= 0xdfffL) { + goto uri_error; + } else if (cp >= 0xd800L && cp <= 0xdbffL) { + /* Needs lookahead */ + if (duk_unicode_decode_xutf8(tfm_ctx->thr, + &tfm_ctx->p, + tfm_ctx->p_start, + tfm_ctx->p_end, + (duk_ucodepoint_t *) &cp2) == 0) { + goto uri_error; + } + if (!(cp2 >= 0xdc00L && cp2 <= 0xdfffL)) { + goto uri_error; + } + cp1 = cp; + cp = (duk_codepoint_t) (((cp1 - 0xd800L) << 10) + (cp2 - 0xdc00L) + 0x10000L); + } else if (cp > 0x10ffffL) { + /* Although we can allow non-BMP characters (they'll decode + * back into surrogate pairs), we don't allow extended UTF-8 + * characters; they would encode to URIs which won't decode + * back because of strict UTF-8 checks in URI decoding. + * (However, we could just as well allow them here.) + */ + goto uri_error; + } else { + /* Non-BMP characters within valid UTF-8 range: encode as is. + * They'll decode back into surrogate pairs if the escaped + * output is decoded. + */ + ; + } + + len = duk_unicode_encode_xutf8((duk_ucodepoint_t) cp, xutf8_buf); + for (i = 0; i < len; i++) { + t = (duk_small_int_t) xutf8_buf[i]; + DUK_BW_WRITE_RAW_U8_3(tfm_ctx->thr, + &tfm_ctx->bw, + DUK_ASC_PERCENT, + (duk_uint8_t) duk_uc_nybbles[t >> 4], + (duk_uint8_t) duk_uc_nybbles[t & 0x0f]); + } + + return; + +uri_error: + DUK_ERROR_URI(tfm_ctx->thr, DUK_STR_INVALID_INPUT); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__transform_callback_decode_uri(duk__transform_context *tfm_ctx, const void *udata, duk_codepoint_t cp) { + const duk_uint8_t *reserved_table = (const duk_uint8_t *) udata; + duk_small_uint_t utf8_blen; + duk_codepoint_t min_cp; + duk_small_int_t t; /* must be signed */ + duk_small_uint_t i; + + /* Maximum write size: XUTF8 path writes max DUK_UNICODE_MAX_XUTF8_LENGTH, + * percent escape path writes max two times CESU-8 encoded BMP length. + */ + DUK_BW_ENSURE(tfm_ctx->thr, + &tfm_ctx->bw, + (DUK_UNICODE_MAX_XUTF8_LENGTH >= 2 * DUK_UNICODE_MAX_CESU8_BMP_LENGTH ? DUK_UNICODE_MAX_XUTF8_LENGTH : + DUK_UNICODE_MAX_CESU8_BMP_LENGTH)); + + if (cp == (duk_codepoint_t) '%') { + const duk_uint8_t *p = tfm_ctx->p; + duk_size_t left = (duk_size_t) (tfm_ctx->p_end - p); /* bytes left */ + + DUK_DDD(DUK_DDDPRINT("percent encoding, left=%ld", (long) left)); + + if (left < 2) { + goto uri_error; + } + + t = duk__decode_hex_escape(p, 2); + DUK_DDD(DUK_DDDPRINT("first byte: %ld", (long) t)); + if (t < 0) { + goto uri_error; + } + + if (t < 0x80) { + if (DUK__CHECK_BITMASK(reserved_table, t)) { + /* decode '%xx' to '%xx' if decoded char in reserved set */ + DUK_ASSERT(tfm_ctx->p - 1 >= tfm_ctx->p_start); + DUK_BW_WRITE_RAW_U8_3(tfm_ctx->thr, &tfm_ctx->bw, DUK_ASC_PERCENT, p[0], p[1]); + } else { + DUK_BW_WRITE_RAW_U8(tfm_ctx->thr, &tfm_ctx->bw, (duk_uint8_t) t); + } + tfm_ctx->p += 2; + return; + } + + /* Decode UTF-8 codepoint from a sequence of hex escapes. The + * first byte of the sequence has been decoded to 't'. + * + * Note that UTF-8 validation must be strict according to the + * specification: E5.1 Section 15.1.3, decode algorithm step + * 4.d.vii.8. URIError from non-shortest encodings is also + * specifically noted in the spec. + */ + + DUK_ASSERT(t >= 0x80); + if (t < 0xc0) { + /* continuation byte */ + goto uri_error; + } else if (t < 0xe0) { + /* 110x xxxx; 2 bytes */ + utf8_blen = 2; + min_cp = 0x80L; + cp = t & 0x1f; + } else if (t < 0xf0) { + /* 1110 xxxx; 3 bytes */ + utf8_blen = 3; + min_cp = 0x800L; + cp = t & 0x0f; + } else if (t < 0xf8) { + /* 1111 0xxx; 4 bytes */ + utf8_blen = 4; + min_cp = 0x10000L; + cp = t & 0x07; + } else { + /* extended utf-8 not allowed for URIs */ + goto uri_error; + } + + if (left < utf8_blen * 3 - 1) { + /* '%xx%xx...%xx', p points to char after first '%' */ + goto uri_error; + } + + p += 3; + for (i = 1; i < utf8_blen; i++) { + /* p points to digit part ('%xy', p points to 'x') */ + t = duk__decode_hex_escape(p, 2); + DUK_DDD(DUK_DDDPRINT("i=%ld utf8_blen=%ld cp=%ld t=0x%02lx", + (long) i, + (long) utf8_blen, + (long) cp, + (unsigned long) t)); + if (t < 0) { + goto uri_error; + } + if ((t & 0xc0) != 0x80) { + goto uri_error; + } + cp = (cp << 6) + (t & 0x3f); + p += 3; + } + p--; /* p overshoots */ + tfm_ctx->p = p; + + DUK_DDD(DUK_DDDPRINT("final cp=%ld, min_cp=%ld", (long) cp, (long) min_cp)); + + if (cp < min_cp || cp > 0x10ffffL || (cp >= 0xd800L && cp <= 0xdfffL)) { + goto uri_error; + } + + /* The E5.1 algorithm checks whether or not a decoded codepoint + * is below 0x80 and perhaps may be in the "reserved" set. + * This seems pointless because the single byte UTF-8 case is + * handled separately, and non-shortest encodings are rejected. + * So, 'cp' cannot be below 0x80 here, and thus cannot be in + * the reserved set. + */ + + /* utf-8 validation ensures these */ + DUK_ASSERT(cp >= 0x80L && cp <= 0x10ffffL); + + if (cp >= 0x10000L) { + cp -= 0x10000L; + DUK_ASSERT(cp < 0x100000L); + + DUK_BW_WRITE_RAW_XUTF8(tfm_ctx->thr, &tfm_ctx->bw, ((cp >> 10) + 0xd800L)); + DUK_BW_WRITE_RAW_XUTF8(tfm_ctx->thr, &tfm_ctx->bw, ((cp & 0x03ffL) + 0xdc00L)); + } else { + DUK_BW_WRITE_RAW_XUTF8(tfm_ctx->thr, &tfm_ctx->bw, cp); + } + } else { + DUK_BW_WRITE_RAW_XUTF8(tfm_ctx->thr, &tfm_ctx->bw, cp); + } + return; + +uri_error: + DUK_ERROR_URI(tfm_ctx->thr, DUK_STR_INVALID_INPUT); + DUK_WO_NORETURN(return;); +} + +#if defined(DUK_USE_SECTION_B) +DUK_LOCAL void duk__transform_callback_escape(duk__transform_context *tfm_ctx, const void *udata, duk_codepoint_t cp) { + DUK_UNREF(udata); + + DUK_BW_ENSURE(tfm_ctx->thr, &tfm_ctx->bw, 6); + + if (cp < 0) { + goto esc_error; + } else if ((cp < 0x80L) && DUK__CHECK_BITMASK(duk__escape_unescaped_table, cp)) { + DUK_BW_WRITE_RAW_U8(tfm_ctx->thr, &tfm_ctx->bw, (duk_uint8_t) cp); + } else if (cp < 0x100L) { + DUK_BW_WRITE_RAW_U8_3(tfm_ctx->thr, + &tfm_ctx->bw, + (duk_uint8_t) DUK_ASC_PERCENT, + (duk_uint8_t) duk_uc_nybbles[cp >> 4], + (duk_uint8_t) duk_uc_nybbles[cp & 0x0f]); + } else if (cp < 0x10000L) { + DUK_BW_WRITE_RAW_U8_6(tfm_ctx->thr, + &tfm_ctx->bw, + (duk_uint8_t) DUK_ASC_PERCENT, + (duk_uint8_t) DUK_ASC_LC_U, + (duk_uint8_t) duk_uc_nybbles[cp >> 12], + (duk_uint8_t) duk_uc_nybbles[(cp >> 8) & 0x0f], + (duk_uint8_t) duk_uc_nybbles[(cp >> 4) & 0x0f], + (duk_uint8_t) duk_uc_nybbles[cp & 0x0f]); + } else { + /* Characters outside BMP cannot be escape()'d. We could + * encode them as surrogate pairs (for codepoints inside + * valid UTF-8 range, but not extended UTF-8). Because + * escape() and unescape() are legacy functions, we don't. + */ + goto esc_error; + } + + return; + +esc_error: + DUK_ERROR_TYPE(tfm_ctx->thr, DUK_STR_INVALID_INPUT); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__transform_callback_unescape(duk__transform_context *tfm_ctx, const void *udata, duk_codepoint_t cp) { + duk_small_int_t t; + + DUK_UNREF(udata); + + if (cp == (duk_codepoint_t) '%') { + const duk_uint8_t *p = tfm_ctx->p; + duk_size_t left = (duk_size_t) (tfm_ctx->p_end - p); /* bytes left */ + + if (left >= 5 && p[0] == 'u' && ((t = duk__decode_hex_escape(p + 1, 4)) >= 0)) { + cp = (duk_codepoint_t) t; + tfm_ctx->p += 5; + } else if (left >= 2 && ((t = duk__decode_hex_escape(p, 2)) >= 0)) { + cp = (duk_codepoint_t) t; + tfm_ctx->p += 2; + } + } + + DUK_BW_WRITE_ENSURE_XUTF8(tfm_ctx->thr, &tfm_ctx->bw, cp); +} +#endif /* DUK_USE_SECTION_B */ + +/* + * Eval + * + * Eval needs to handle both a "direct eval" and an "indirect eval". + * Direct eval handling needs access to the caller's activation so that its + * lexical environment can be accessed. A direct eval is only possible from + * ECMAScript code; an indirect eval call is possible also from C code. + * When an indirect eval call is made from C code, there may not be a + * calling activation at all which needs careful handling. + */ + +DUK_INTERNAL duk_ret_t duk_bi_global_object_eval(duk_hthread *thr) { + duk_hstring *h; + duk_activation *act_caller; + duk_activation *act_eval; + duk_hcompfunc *func; + duk_hobject *outer_lex_env; + duk_hobject *outer_var_env; + duk_bool_t this_to_global = 1; + duk_small_uint_t comp_flags; + duk_int_t level = -2; + duk_small_uint_t call_flags; + + DUK_ASSERT(duk_get_top(thr) == 1 || duk_get_top(thr) == 2); /* 2 when called by debugger */ + DUK_ASSERT(thr->callstack_top >= 1); /* at least this function exists */ + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT((thr->callstack_curr->flags & DUK_ACT_FLAG_DIRECT_EVAL) == 0 || /* indirect eval */ + (thr->callstack_top >= 2)); /* if direct eval, calling activation must exist */ + + /* + * callstack_top - 1 --> this function + * callstack_top - 2 --> caller (may not exist) + * + * If called directly from C, callstack_top might be 1. If calling + * activation doesn't exist, call must be indirect. + */ + + h = duk_get_hstring_notsymbol(thr, 0); + if (!h) { + /* Symbol must be returned as is, like any non-string values. */ + return 1; /* return arg as-is */ + } + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + /* NOTE: level is used only by the debugger and should never be present + * for an ECMAScript eval(). + */ + DUK_ASSERT(level == -2); /* by default, use caller's environment */ + if (duk_get_top(thr) >= 2 && duk_is_number(thr, 1)) { + level = duk_get_int(thr, 1); + } + DUK_ASSERT(level <= -2); /* This is guaranteed by debugger code. */ +#endif + + /* [ source ] */ + + comp_flags = DUK_COMPILE_EVAL; + act_eval = thr->callstack_curr; /* this function */ + DUK_ASSERT(act_eval != NULL); + act_caller = duk_hthread_get_activation_for_level(thr, level); + if (act_caller != NULL) { + /* Have a calling activation, check for direct eval (otherwise + * assume indirect eval. + */ + if ((act_caller->flags & DUK_ACT_FLAG_STRICT) && (act_eval->flags & DUK_ACT_FLAG_DIRECT_EVAL)) { + /* Only direct eval inherits strictness from calling code + * (E5.1 Section 10.1.1). + */ + comp_flags |= DUK_COMPILE_STRICT; + } + } else { + DUK_ASSERT((act_eval->flags & DUK_ACT_FLAG_DIRECT_EVAL) == 0); + } + + duk_push_hstring_stridx(thr, DUK_STRIDX_INPUT); /* XXX: copy from caller? */ + duk_js_compile(thr, (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h), (duk_size_t) DUK_HSTRING_GET_BYTELEN(h), comp_flags); + func = (duk_hcompfunc *) duk_known_hobject(thr, -1); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC((duk_hobject *) func)); + + /* [ source template ] */ + + /* E5 Section 10.4.2 */ + + if (act_eval->flags & DUK_ACT_FLAG_DIRECT_EVAL) { + DUK_ASSERT(thr->callstack_top >= 2); + DUK_ASSERT(act_caller != NULL); + if (act_caller->lex_env == NULL) { + DUK_ASSERT(act_caller->var_env == NULL); + DUK_DDD(DUK_DDDPRINT("delayed environment initialization")); + + /* this may have side effects, so re-lookup act */ + duk_js_init_activation_environment_records_delayed(thr, act_caller); + } + DUK_ASSERT(act_caller->lex_env != NULL); + DUK_ASSERT(act_caller->var_env != NULL); + + this_to_global = 0; + + if (DUK_HOBJECT_HAS_STRICT((duk_hobject *) func)) { + duk_hdecenv *new_env; + duk_hobject *act_lex_env; + + DUK_DDD(DUK_DDDPRINT("direct eval call to a strict function -> " + "var_env and lex_env to a fresh env, " + "this_binding to caller's this_binding")); + + act_lex_env = act_caller->lex_env; + + new_env = + duk_hdecenv_alloc(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_DECENV)); + DUK_ASSERT(new_env != NULL); + duk_push_hobject(thr, (duk_hobject *) new_env); + + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) new_env) == NULL); + DUK_HOBJECT_SET_PROTOTYPE(thr->heap, (duk_hobject *) new_env, act_lex_env); + DUK_HOBJECT_INCREF_ALLOWNULL(thr, act_lex_env); + DUK_DDD(DUK_DDDPRINT("new_env allocated: %!iO", (duk_heaphdr *) new_env)); + + outer_lex_env = (duk_hobject *) new_env; + outer_var_env = (duk_hobject *) new_env; + + duk_insert(thr, 0); /* stash to bottom of value stack to keep new_env reachable for duration of eval */ + + /* compiler's responsibility */ + DUK_ASSERT(DUK_HOBJECT_HAS_NEWENV((duk_hobject *) func)); + } else { + DUK_DDD(DUK_DDDPRINT("direct eval call to a non-strict function -> " + "var_env and lex_env to caller's envs, " + "this_binding to caller's this_binding")); + + outer_lex_env = act_caller->lex_env; + outer_var_env = act_caller->var_env; + + /* compiler's responsibility */ + DUK_ASSERT(!DUK_HOBJECT_HAS_NEWENV((duk_hobject *) func)); + } + } else { + DUK_DDD(DUK_DDDPRINT("indirect eval call -> var_env and lex_env to " + "global object, this_binding to global object")); + + this_to_global = 1; + outer_lex_env = thr->builtins[DUK_BIDX_GLOBAL_ENV]; + outer_var_env = thr->builtins[DUK_BIDX_GLOBAL_ENV]; + } + + /* Eval code doesn't need an automatic .prototype object. */ + duk_js_push_closure(thr, func, outer_var_env, outer_lex_env, 0 /*add_auto_proto*/); + + /* [ env? source template closure ] */ + + if (this_to_global) { + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + duk_push_hobject_bidx(thr, DUK_BIDX_GLOBAL); + } else { + duk_tval *tv; + DUK_ASSERT(thr->callstack_top >= 2); + DUK_ASSERT(act_caller != NULL); + tv = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + act_caller->bottom_byteoff - + sizeof(duk_tval)); /* this is just beneath bottom */ + DUK_ASSERT(tv >= thr->valstack); + duk_push_tval(thr, tv); + } + + DUK_DDD(DUK_DDDPRINT("eval -> lex_env=%!iO, var_env=%!iO, this_binding=%!T", + (duk_heaphdr *) outer_lex_env, + (duk_heaphdr *) outer_var_env, + duk_get_tval(thr, -1))); + + /* [ env? source template closure this ] */ + + call_flags = 0; + if (act_eval->flags & DUK_ACT_FLAG_DIRECT_EVAL) { + /* Set DIRECT_EVAL flag for the call; it's not strictly + * needed for the 'inner' eval call (the eval body) but + * current new.target implementation expects to find it + * so it can traverse direct eval chains up to the real + * calling function. + */ + call_flags |= DUK_CALL_FLAG_DIRECT_EVAL; + } + duk_handle_call_unprotected_nargs(thr, 0, call_flags); + + /* [ env? source template result ] */ + + return 1; +} + +/* + * Parsing of ints and floats + */ + +#if defined(DUK_USE_GLOBAL_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_global_object_parse_int(duk_hthread *thr) { + duk_int32_t radix; + duk_small_uint_t s2n_flags; + + DUK_ASSERT_TOP(thr, 2); + duk_to_string(thr, 0); /* Reject symbols. */ + + radix = duk_to_int32(thr, 1); + + /* While parseInt() recognizes 0xdeadbeef, it doesn't recognize + * ES2015 0o123 or 0b10001. + */ + s2n_flags = DUK_S2N_FLAG_TRIM_WHITE | DUK_S2N_FLAG_ALLOW_GARBAGE | DUK_S2N_FLAG_ALLOW_PLUS | DUK_S2N_FLAG_ALLOW_MINUS | + DUK_S2N_FLAG_ALLOW_LEADING_ZERO | DUK_S2N_FLAG_ALLOW_AUTO_HEX_INT; + + /* Specification stripPrefix maps to DUK_S2N_FLAG_ALLOW_AUTO_HEX_INT. + * + * Don't autodetect octals (from leading zeroes), require user code to + * provide an explicit radix 8 for parsing octal. See write-up from Mozilla: + * https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Global_Objects/parseInt#ECMAScript_5_Removes_Octal_Interpretation + */ + + if (radix != 0) { + if (radix < 2 || radix > 36) { + goto ret_nan; + } + if (radix != 16) { + s2n_flags &= ~DUK_S2N_FLAG_ALLOW_AUTO_HEX_INT; + } + } else { + radix = 10; + } + + duk_dup_0(thr); + duk_numconv_parse(thr, (duk_small_int_t) radix, s2n_flags); + return 1; + +ret_nan: + duk_push_nan(thr); + return 1; +} +#endif /* DUK_USE_GLOBAL_BUILTIN */ + +#if defined(DUK_USE_GLOBAL_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_global_object_parse_float(duk_hthread *thr) { + duk_small_uint_t s2n_flags; + + DUK_ASSERT_TOP(thr, 1); + duk_to_string(thr, 0); /* Reject symbols. */ + + /* XXX: check flags */ + s2n_flags = DUK_S2N_FLAG_TRIM_WHITE | DUK_S2N_FLAG_ALLOW_EXP | DUK_S2N_FLAG_ALLOW_GARBAGE | DUK_S2N_FLAG_ALLOW_PLUS | + DUK_S2N_FLAG_ALLOW_MINUS | DUK_S2N_FLAG_ALLOW_INF | DUK_S2N_FLAG_ALLOW_FRAC | DUK_S2N_FLAG_ALLOW_NAKED_FRAC | + DUK_S2N_FLAG_ALLOW_EMPTY_FRAC | DUK_S2N_FLAG_ALLOW_LEADING_ZERO; + + duk_numconv_parse(thr, 10 /*radix*/, s2n_flags); + return 1; +} +#endif /* DUK_USE_GLOBAL_BUILTIN */ + +/* + * Number checkers + */ + +#if defined(DUK_USE_GLOBAL_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_global_object_is_nan(duk_hthread *thr) { + duk_double_t d = duk_to_number(thr, 0); + duk_push_boolean(thr, (duk_bool_t) DUK_ISNAN(d)); + return 1; +} +#endif /* DUK_USE_GLOBAL_BUILTIN */ + +#if defined(DUK_USE_GLOBAL_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_global_object_is_finite(duk_hthread *thr) { + duk_double_t d = duk_to_number(thr, 0); + duk_push_boolean(thr, (duk_bool_t) DUK_ISFINITE(d)); + return 1; +} +#endif /* DUK_USE_GLOBAL_BUILTIN */ + +/* + * URI handling + */ + +#if defined(DUK_USE_GLOBAL_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_global_object_decode_uri(duk_hthread *thr) { + return duk__transform_helper(thr, duk__transform_callback_decode_uri, (const void *) duk__decode_uri_reserved_table); +} + +DUK_INTERNAL duk_ret_t duk_bi_global_object_decode_uri_component(duk_hthread *thr) { + return duk__transform_helper(thr, + duk__transform_callback_decode_uri, + (const void *) duk__decode_uri_component_reserved_table); +} + +DUK_INTERNAL duk_ret_t duk_bi_global_object_encode_uri(duk_hthread *thr) { + return duk__transform_helper(thr, duk__transform_callback_encode_uri, (const void *) duk__encode_uriunescaped_table); +} + +DUK_INTERNAL duk_ret_t duk_bi_global_object_encode_uri_component(duk_hthread *thr) { + return duk__transform_helper(thr, + duk__transform_callback_encode_uri, + (const void *) duk__encode_uricomponent_unescaped_table); +} + +#if defined(DUK_USE_SECTION_B) +DUK_INTERNAL duk_ret_t duk_bi_global_object_escape(duk_hthread *thr) { + return duk__transform_helper(thr, duk__transform_callback_escape, (const void *) NULL); +} + +DUK_INTERNAL duk_ret_t duk_bi_global_object_unescape(duk_hthread *thr) { + return duk__transform_helper(thr, duk__transform_callback_unescape, (const void *) NULL); +} +#endif /* DUK_USE_SECTION_B */ +#endif /* DUK_USE_GLOBAL_BUILTIN */ + +/* automatic undefs */ +#undef DUK__CHECK_BITMASK +#undef DUK__MKBITS +#line 1 "duk_bi_json.c" +/* + * JSON built-ins. + * + * See doc/json.rst. + * + * Codepoints are handled as duk_uint_fast32_t to ensure that the full + * unsigned 32-bit range is supported. This matters to e.g. JX. + * + * Input parsing doesn't do an explicit end-of-input check at all. This is + * safe: input string data is always NUL-terminated (0x00) and valid JSON + * inputs never contain plain NUL characters, so that as long as syntax checks + * are correct, we'll never read past the NUL. This approach reduces code size + * and improves parsing performance, but it's critical that syntax checks are + * indeed correct! + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_JSON_SUPPORT) + +/* + * Local defines and forward declarations. + */ + +#define DUK__JSON_DECSTR_BUFSIZE 128 +#define DUK__JSON_DECSTR_CHUNKSIZE 64 +#define DUK__JSON_ENCSTR_CHUNKSIZE 64 +#define DUK__JSON_STRINGIFY_BUFSIZE 128 +#define DUK__JSON_MAX_ESC_LEN 10 /* '\Udeadbeef' */ + +DUK_LOCAL_DECL void duk__json_dec_syntax_error(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_dec_eat_white(duk_json_dec_ctx *js_ctx); +#if defined(DUK_USE_JX) +DUK_LOCAL_DECL duk_uint8_t duk__json_dec_peek(duk_json_dec_ctx *js_ctx); +#endif +DUK_LOCAL_DECL duk_uint8_t duk__json_dec_get(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL duk_uint8_t duk__json_dec_get_nonwhite(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL duk_uint_fast32_t duk__json_dec_decode_hex_escape(duk_json_dec_ctx *js_ctx, duk_small_uint_t n); +DUK_LOCAL_DECL void duk__json_dec_req_stridx(duk_json_dec_ctx *js_ctx, duk_small_uint_t stridx); +DUK_LOCAL_DECL void duk__json_dec_string(duk_json_dec_ctx *js_ctx); +#if defined(DUK_USE_JX) +DUK_LOCAL_DECL void duk__json_dec_plain_string(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_dec_pointer(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_dec_buffer(duk_json_dec_ctx *js_ctx); +#endif +DUK_LOCAL_DECL void duk__json_dec_number(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_dec_objarr_entry(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_dec_objarr_exit(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_dec_object(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_dec_array(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_dec_value(duk_json_dec_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_dec_reviver_walk(duk_json_dec_ctx *js_ctx); + +DUK_LOCAL_DECL void duk__emit_1(duk_json_enc_ctx *js_ctx, duk_uint_fast8_t ch); +DUK_LOCAL_DECL void duk__emit_2(duk_json_enc_ctx *js_ctx, duk_uint_fast8_t ch1, duk_uint_fast8_t ch2); +DUK_LOCAL_DECL void duk__unemit_1(duk_json_enc_ctx *js_ctx); +DUK_LOCAL_DECL void duk__emit_hstring(duk_json_enc_ctx *js_ctx, duk_hstring *h); +#if defined(DUK_USE_FASTINT) +DUK_LOCAL_DECL void duk__emit_cstring(duk_json_enc_ctx *js_ctx, const char *p); +#endif +DUK_LOCAL_DECL void duk__emit_stridx(duk_json_enc_ctx *js_ctx, duk_small_uint_t stridx); +DUK_LOCAL_DECL duk_uint8_t *duk__emit_esc_auto_fast(duk_json_enc_ctx *js_ctx, duk_uint_fast32_t cp, duk_uint8_t *q); +DUK_LOCAL_DECL void duk__json_enc_key_autoquote(duk_json_enc_ctx *js_ctx, duk_hstring *k); +DUK_LOCAL_DECL void duk__json_enc_quote_string(duk_json_enc_ctx *js_ctx, duk_hstring *h_str); +DUK_LOCAL_DECL void duk__json_enc_objarr_entry(duk_json_enc_ctx *js_ctx, duk_idx_t *entry_top); +DUK_LOCAL_DECL void duk__json_enc_objarr_exit(duk_json_enc_ctx *js_ctx, duk_idx_t *entry_top); +DUK_LOCAL_DECL void duk__json_enc_object(duk_json_enc_ctx *js_ctx); +DUK_LOCAL_DECL void duk__json_enc_array(duk_json_enc_ctx *js_ctx); +DUK_LOCAL_DECL duk_bool_t duk__json_enc_value(duk_json_enc_ctx *js_ctx, duk_idx_t idx_holder); +DUK_LOCAL_DECL duk_bool_t duk__json_enc_allow_into_proplist(duk_tval *tv); +DUK_LOCAL_DECL void duk__json_enc_double(duk_json_enc_ctx *js_ctx); +#if defined(DUK_USE_FASTINT) +DUK_LOCAL_DECL void duk__json_enc_fastint_tval(duk_json_enc_ctx *js_ctx, duk_tval *tv); +#endif +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) +DUK_LOCAL_DECL void duk__json_enc_buffer_jx_jc(duk_json_enc_ctx *js_ctx, duk_hbuffer *h); +DUK_LOCAL_DECL void duk__json_enc_pointer(duk_json_enc_ctx *js_ctx, void *ptr); +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_LOCAL_DECL void duk__json_enc_bufobj(duk_json_enc_ctx *js_ctx, duk_hbufobj *h_bufobj); +#endif +#endif +#if defined(DUK_USE_JSON_STRINGIFY_FASTPATH) +DUK_LOCAL_DECL void duk__json_enc_buffer_json_fastpath(duk_json_enc_ctx *js_ctx, duk_hbuffer *h); +#endif +DUK_LOCAL_DECL void duk__json_enc_newline_indent(duk_json_enc_ctx *js_ctx, duk_uint_t depth); + +/* + * Helper tables + */ + +#if defined(DUK_USE_JSON_QUOTESTRING_FASTPATH) +DUK_LOCAL const duk_uint8_t duk__json_quotestr_lookup[256] = { + /* 0x00 ... 0x7f: as is + * 0x80: escape generically + * 0x81: slow path + * 0xa0 ... 0xff: backslash + one char + */ + + 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0xe2, 0xf4, 0xee, 0x80, 0xe6, 0xf2, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, + 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x80, 0x20, 0x21, 0xa2, 0x23, 0x24, 0x25, 0x26, 0x27, + 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b, + 0x3c, 0x3d, 0x3e, 0x3f, 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, + 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a, 0x5b, 0xdc, 0x5d, 0x5e, 0x5f, 0x60, 0x61, 0x62, 0x63, + 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, + 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, + 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81, 0x81 +}; +#else /* DUK_USE_JSON_QUOTESTRING_FASTPATH */ +DUK_LOCAL const duk_uint8_t duk__json_quotestr_esc[14] = { DUK_ASC_NUL, DUK_ASC_NUL, DUK_ASC_NUL, DUK_ASC_NUL, DUK_ASC_NUL, + DUK_ASC_NUL, DUK_ASC_NUL, DUK_ASC_NUL, DUK_ASC_LC_B, DUK_ASC_LC_T, + DUK_ASC_LC_N, DUK_ASC_NUL, DUK_ASC_LC_F, DUK_ASC_LC_R }; +#endif /* DUK_USE_JSON_QUOTESTRING_FASTPATH */ + +#if defined(DUK_USE_JSON_DECSTRING_FASTPATH) +DUK_LOCAL const duk_uint8_t duk__json_decstr_lookup[256] = { + /* 0x00: slow path + * other: as is + */ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x20, 0x21, 0x00, 0x23, 0x24, 0x25, 0x26, 0x27, + 0x28, 0x29, 0x2a, 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, 0x3b, + 0x3c, 0x3d, 0x3e, 0x3f, 0x40, 0x41, 0x42, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4a, 0x4b, 0x4c, 0x4d, 0x4e, 0x4f, + 0x50, 0x51, 0x52, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59, 0x5a, 0x5b, 0x00, 0x5d, 0x5e, 0x5f, 0x60, 0x61, 0x62, 0x63, + 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6a, 0x6b, 0x6c, 0x6d, 0x6e, 0x6f, 0x70, 0x71, 0x72, 0x73, 0x74, 0x75, 0x76, 0x77, + 0x78, 0x79, 0x7a, 0x7b, 0x7c, 0x7d, 0x7e, 0x7f, 0x80, 0x81, 0x82, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8a, 0x8b, + 0x8c, 0x8d, 0x8e, 0x8f, 0x90, 0x91, 0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9a, 0x9b, 0x9c, 0x9d, 0x9e, 0x9f, + 0xa0, 0xa1, 0xa2, 0xa3, 0xa4, 0xa5, 0xa6, 0xa7, 0xa8, 0xa9, 0xaa, 0xab, 0xac, 0xad, 0xae, 0xaf, 0xb0, 0xb1, 0xb2, 0xb3, + 0xb4, 0xb5, 0xb6, 0xb7, 0xb8, 0xb9, 0xba, 0xbb, 0xbc, 0xbd, 0xbe, 0xbf, 0xc0, 0xc1, 0xc2, 0xc3, 0xc4, 0xc5, 0xc6, 0xc7, + 0xc8, 0xc9, 0xca, 0xcb, 0xcc, 0xcd, 0xce, 0xcf, 0xd0, 0xd1, 0xd2, 0xd3, 0xd4, 0xd5, 0xd6, 0xd7, 0xd8, 0xd9, 0xda, 0xdb, + 0xdc, 0xdd, 0xde, 0xdf, 0xe0, 0xe1, 0xe2, 0xe3, 0xe4, 0xe5, 0xe6, 0xe7, 0xe8, 0xe9, 0xea, 0xeb, 0xec, 0xed, 0xee, 0xef, + 0xf0, 0xf1, 0xf2, 0xf3, 0xf4, 0xf5, 0xf6, 0xf7, 0xf8, 0xf9, 0xfa, 0xfb, 0xfc, 0xfd, 0xfe, 0xff +}; +#endif /* DUK_USE_JSON_DECSTRING_FASTPATH */ + +#if defined(DUK_USE_JSON_EATWHITE_FASTPATH) +DUK_LOCAL const duk_uint8_t duk__json_eatwhite_lookup[256] = { + /* 0x00: finish (non-white) + * 0x01: continue + */ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x01, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 +}; +#endif /* DUK_USE_JSON_EATWHITE_FASTPATH */ + +#if defined(DUK_USE_JSON_DECNUMBER_FASTPATH) +DUK_LOCAL const duk_uint8_t duk__json_decnumber_lookup[256] = { + /* 0x00: finish (not part of number) + * 0x01: continue + */ + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x01, 0x00, 0x01, 0x01, 0x00, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x01, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 +}; +#endif /* DUK_USE_JSON_DECNUMBER_FASTPATH */ + +/* + * Parsing implementation. + * + * JSON lexer is now separate from duk_lexer.c because there are numerous + * small differences making it difficult to share the lexer. + * + * The parser here works with raw bytes directly; this works because all + * JSON delimiters are ASCII characters. Invalid xUTF-8 encoded values + * inside strings will be passed on without normalization; this is not a + * compliance concern because compliant inputs will always be valid + * CESU-8 encodings. + */ + +DUK_LOCAL void duk__json_dec_syntax_error(duk_json_dec_ctx *js_ctx) { + /* Shared handler to minimize parser size. Cause will be + * hidden, unfortunately, but we'll have an offset which + * is often quite enough. + */ + DUK_ERROR_FMT1(js_ctx->thr, DUK_ERR_SYNTAX_ERROR, DUK_STR_FMT_INVALID_JSON, (long) (js_ctx->p - js_ctx->p_start)); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__json_dec_eat_white(duk_json_dec_ctx *js_ctx) { + const duk_uint8_t *p; + duk_uint8_t t; + + p = js_ctx->p; + for (;;) { + DUK_ASSERT(p <= js_ctx->p_end); + t = *p; + +#if defined(DUK_USE_JSON_EATWHITE_FASTPATH) + /* This fast path is pretty marginal in practice. + * XXX: candidate for removal. + */ + DUK_ASSERT(duk__json_eatwhite_lookup[0x00] == 0x00); /* end-of-input breaks */ + if (duk__json_eatwhite_lookup[t] == 0) { + break; + } +#else /* DUK_USE_JSON_EATWHITE_FASTPATH */ + if (!(t == 0x20 || t == 0x0a || t == 0x0d || t == 0x09)) { + /* NUL also comes here. Comparison order matters, 0x20 + * is most common whitespace. + */ + break; + } +#endif /* DUK_USE_JSON_EATWHITE_FASTPATH */ + p++; + } + js_ctx->p = p; +} + +#if defined(DUK_USE_JX) +DUK_LOCAL duk_uint8_t duk__json_dec_peek(duk_json_dec_ctx *js_ctx) { + DUK_ASSERT(js_ctx->p <= js_ctx->p_end); + return *js_ctx->p; +} +#endif + +DUK_LOCAL duk_uint8_t duk__json_dec_get(duk_json_dec_ctx *js_ctx) { + DUK_ASSERT(js_ctx->p <= js_ctx->p_end); + return *js_ctx->p++; +} + +DUK_LOCAL duk_uint8_t duk__json_dec_get_nonwhite(duk_json_dec_ctx *js_ctx) { + duk__json_dec_eat_white(js_ctx); + return duk__json_dec_get(js_ctx); +} + +/* For JX, expressing the whole unsigned 32-bit range matters. */ +DUK_LOCAL duk_uint_fast32_t duk__json_dec_decode_hex_escape(duk_json_dec_ctx *js_ctx, duk_small_uint_t n) { + duk_small_uint_t i; + duk_uint_fast32_t res = 0; + duk_uint8_t x; + duk_small_int_t t; + + for (i = 0; i < n; i++) { + /* XXX: share helper from lexer; duk_lexer.c / hexval(). */ + + x = duk__json_dec_get(js_ctx); + DUK_DDD(DUK_DDDPRINT("decode_hex_escape: i=%ld, n=%ld, res=%ld, x=%ld", (long) i, (long) n, (long) res, (long) x)); + + /* x == 0x00 (EOF) causes syntax_error */ + DUK_ASSERT(duk_hex_dectab[0] == -1); + t = duk_hex_dectab[x & 0xff]; + if (DUK_LIKELY(t >= 0)) { + res = (res * 16) + (duk_uint_fast32_t) t; + } else { + /* catches EOF and invalid digits */ + goto syntax_error; + } + } + + DUK_DDD(DUK_DDDPRINT("final hex decoded value: %ld", (long) res)); + return res; + +syntax_error: + duk__json_dec_syntax_error(js_ctx); + DUK_UNREACHABLE(); + return 0; +} + +DUK_LOCAL void duk__json_dec_req_stridx(duk_json_dec_ctx *js_ctx, duk_small_uint_t stridx) { + duk_hstring *h; + const duk_uint8_t *p; + duk_uint8_t x, y; + + /* First character has already been eaten and checked by the caller. + * We can scan until a NUL in stridx string because no built-in strings + * have internal NULs. + */ + + DUK_ASSERT_STRIDX_VALID(stridx); + h = DUK_HTHREAD_GET_STRING(js_ctx->thr, stridx); + DUK_ASSERT(h != NULL); + + p = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h) + 1; + DUK_ASSERT(*(js_ctx->p - 1) == *(p - 1)); /* first character has been matched */ + + for (;;) { + x = *p; + if (x == 0) { + break; + } + y = duk__json_dec_get(js_ctx); + if (x != y) { + /* Catches EOF of JSON input. */ + goto syntax_error; + } + p++; + } + + return; + +syntax_error: + duk__json_dec_syntax_error(js_ctx); + DUK_UNREACHABLE(); +} + +DUK_LOCAL duk_small_int_t duk__json_dec_string_escape(duk_json_dec_ctx *js_ctx, duk_uint8_t **ext_p) { + duk_uint_fast32_t cp; + + /* EOF (-1) will be cast to an unsigned value first + * and then re-cast for the switch. In any case, it + * will match the default case (syntax error). + */ + cp = (duk_uint_fast32_t) duk__json_dec_get(js_ctx); + switch (cp) { + case DUK_ASC_BACKSLASH: + break; + case DUK_ASC_DOUBLEQUOTE: + break; + case DUK_ASC_SLASH: + break; + case DUK_ASC_LC_T: + cp = 0x09; + break; + case DUK_ASC_LC_N: + cp = 0x0a; + break; + case DUK_ASC_LC_R: + cp = 0x0d; + break; + case DUK_ASC_LC_F: + cp = 0x0c; + break; + case DUK_ASC_LC_B: + cp = 0x08; + break; + case DUK_ASC_LC_U: { + cp = duk__json_dec_decode_hex_escape(js_ctx, 4); + break; + } +#if defined(DUK_USE_JX) + case DUK_ASC_UC_U: { + if (js_ctx->flag_ext_custom) { + cp = duk__json_dec_decode_hex_escape(js_ctx, 8); + } else { + return 1; /* syntax error */ + } + break; + } + case DUK_ASC_LC_X: { + if (js_ctx->flag_ext_custom) { + cp = duk__json_dec_decode_hex_escape(js_ctx, 2); + } else { + return 1; /* syntax error */ + } + break; + } +#endif /* DUK_USE_JX */ + default: + /* catches EOF (0x00) */ + return 1; /* syntax error */ + } + + DUK_RAW_WRITEINC_XUTF8(*ext_p, cp); + + return 0; +} + +DUK_LOCAL void duk__json_dec_string(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + duk_bufwriter_ctx bw_alloc; + duk_bufwriter_ctx *bw; + duk_uint8_t *q; + + /* '"' was eaten by caller */ + + /* Note that we currently parse -bytes-, not codepoints. + * All non-ASCII extended UTF-8 will encode to bytes >= 0x80, + * so they'll simply pass through (valid UTF-8 or not). + */ + + bw = &bw_alloc; + DUK_BW_INIT_PUSHBUF(js_ctx->thr, bw, DUK__JSON_DECSTR_BUFSIZE); + q = DUK_BW_GET_PTR(js_ctx->thr, bw); + +#if defined(DUK_USE_JSON_DECSTRING_FASTPATH) + for (;;) { + duk_small_uint_t safe; + duk_uint8_t b, x; + const duk_uint8_t *p; + + /* Select a safe loop count where no output checks are + * needed assuming we won't encounter escapes. Input + * bound checks are not necessary as a NUL (guaranteed) + * will cause a SyntaxError before we read out of bounds. + */ + + safe = DUK__JSON_DECSTR_CHUNKSIZE; + + /* Ensure space for 1:1 output plus one escape. */ + q = DUK_BW_ENSURE_RAW(js_ctx->thr, bw, safe + DUK_UNICODE_MAX_XUTF8_LENGTH, q); + + p = js_ctx->p; /* temp copy, write back for next loop */ + for (;;) { + if (safe == 0) { + js_ctx->p = p; + break; + } + safe--; + + /* End of input (NUL) goes through slow path and causes SyntaxError. */ + DUK_ASSERT(duk__json_decstr_lookup[0] == 0x00); + + b = *p++; + x = (duk_small_int_t) duk__json_decstr_lookup[b]; + if (DUK_LIKELY(x != 0)) { + /* Fast path, decode as is. */ + *q++ = b; + } else if (b == DUK_ASC_DOUBLEQUOTE) { + js_ctx->p = p; + goto found_quote; + } else if (b == DUK_ASC_BACKSLASH) { + /* We've ensured space for one escaped input; then + * bail out and recheck (this makes escape handling + * quite slow but it's uncommon). + */ + js_ctx->p = p; + if (duk__json_dec_string_escape(js_ctx, &q) != 0) { + goto syntax_error; + } + break; + } else { + js_ctx->p = p; + goto syntax_error; + } + } + } +found_quote: +#else /* DUK_USE_JSON_DECSTRING_FASTPATH */ + for (;;) { + duk_uint8_t x; + + q = DUK_BW_ENSURE_RAW(js_ctx->thr, bw, DUK_UNICODE_MAX_XUTF8_LENGTH, q); + + x = duk__json_dec_get(js_ctx); + + if (x == DUK_ASC_DOUBLEQUOTE) { + break; + } else if (x == DUK_ASC_BACKSLASH) { + if (duk__json_dec_string_escape(js_ctx, &q) != 0) { + goto syntax_error; + } + } else if (x < 0x20) { + /* catches EOF (NUL) */ + goto syntax_error; + } else { + *q++ = (duk_uint8_t) x; + } + } +#endif /* DUK_USE_JSON_DECSTRING_FASTPATH */ + + DUK_BW_SETPTR_AND_COMPACT(js_ctx->thr, bw, q); + (void) duk_buffer_to_string(thr, -1); /* Safe if input string is safe. */ + + /* [ ... str ] */ + + return; + +syntax_error: + duk__json_dec_syntax_error(js_ctx); + DUK_UNREACHABLE(); +} + +#if defined(DUK_USE_JX) +/* Decode a plain string consisting entirely of identifier characters. + * Used to parse plain keys (e.g. "foo: 123"). + */ +DUK_LOCAL void duk__json_dec_plain_string(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + const duk_uint8_t *p; + duk_small_int_t x; + + /* Caller has already eaten the first char so backtrack one byte. */ + + js_ctx->p--; /* safe */ + p = js_ctx->p; + + /* Here again we parse bytes, and non-ASCII UTF-8 will cause end of + * parsing (which is correct except if there are non-shortest encodings). + * There is also no need to check explicitly for end of input buffer as + * the input is NUL padded and NUL will exit the parsing loop. + * + * Because no unescaping takes place, we can just scan to the end of the + * plain string and intern from the input buffer. + */ + + for (;;) { + x = *p; + + /* There is no need to check the first character specially here + * (i.e. reject digits): the caller only accepts valid initial + * characters and won't call us if the first character is a digit. + * This also ensures that the plain string won't be empty. + */ + + if (!duk_unicode_is_identifier_part((duk_codepoint_t) x)) { + break; + } + p++; + } + + duk_push_lstring(thr, (const char *) js_ctx->p, (duk_size_t) (p - js_ctx->p)); + js_ctx->p = p; + + /* [ ... str ] */ +} +#endif /* DUK_USE_JX */ + +#if defined(DUK_USE_JX) +DUK_LOCAL void duk__json_dec_pointer(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + const duk_uint8_t *p; + duk_small_int_t x; + void *voidptr; + + /* Caller has already eaten the first character ('(') which we don't need. */ + + p = js_ctx->p; + + for (;;) { + x = *p; + + /* Assume that the native representation never contains a closing + * parenthesis. + */ + + if (x == DUK_ASC_RPAREN) { + break; + } else if (x <= 0) { + /* NUL term or -1 (EOF), NUL check would suffice */ + goto syntax_error; + } + p++; + } + + /* There is no need to NUL delimit the sscanf() call: trailing garbage is + * ignored and there is always a NUL terminator which will force an error + * if no error is encountered before it. It's possible that the scan + * would scan further than between [js_ctx->p,p[ though and we'd advance + * by less than the scanned value. + * + * Because pointers are platform specific, a failure to scan a pointer + * results in a null pointer which is a better placeholder than a missing + * value or an error. + */ + + voidptr = NULL; + (void) DUK_SSCANF((const char *) js_ctx->p, DUK_STR_FMT_PTR, &voidptr); + duk_push_pointer(thr, voidptr); + js_ctx->p = p + 1; /* skip ')' */ + + /* [ ... ptr ] */ + + return; + +syntax_error: + duk__json_dec_syntax_error(js_ctx); + DUK_UNREACHABLE(); +} +#endif /* DUK_USE_JX */ + +#if defined(DUK_USE_JX) +DUK_LOCAL void duk__json_dec_buffer(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + const duk_uint8_t *p; + duk_uint8_t *buf; + duk_size_t src_len; + duk_small_int_t x; + + /* Caller has already eaten the first character ('|') which we don't need. */ + + p = js_ctx->p; + + /* XXX: Would be nice to share the fast path loop from duk_hex_decode() + * and avoid creating a temporary buffer. However, there are some + * differences which prevent trivial sharing: + * + * - Pipe char detection + * - EOF detection + * - Unknown length of input and output + * + * The best approach here would be a bufwriter and a reasonaly sized + * safe inner loop (e.g. 64 output bytes at a time). + */ + + for (;;) { + x = *p; + + /* This loop intentionally does not ensure characters are valid + * ([0-9a-fA-F]) because the hex decode call below will do that. + */ + if (x == DUK_ASC_PIPE) { + break; + } else if (x <= 0) { + /* NUL term or -1 (EOF), NUL check would suffice */ + goto syntax_error; + } + p++; + } + + /* XXX: this is not very nice; unnecessary copy is made. */ + src_len = (duk_size_t) (p - js_ctx->p); + buf = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, src_len); + DUK_ASSERT(buf != NULL); + duk_memcpy((void *) buf, (const void *) js_ctx->p, src_len); + duk_hex_decode(thr, -1); + + js_ctx->p = p + 1; /* skip '|' */ + + /* [ ... buf ] */ + + return; + +syntax_error: + duk__json_dec_syntax_error(js_ctx); + DUK_UNREACHABLE(); +} +#endif /* DUK_USE_JX */ + +/* Parse a number, other than NaN or +/- Infinity */ +DUK_LOCAL void duk__json_dec_number(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + const duk_uint8_t *p_start; + const duk_uint8_t *p; + duk_uint8_t x; + duk_small_uint_t s2n_flags; + + DUK_DDD(DUK_DDDPRINT("parse_number")); + + p_start = js_ctx->p; + + /* First pass parse is very lenient (e.g. allows '1.2.3') and extracts a + * string for strict number parsing. + */ + + p = js_ctx->p; + for (;;) { + x = *p; + + DUK_DDD(DUK_DDDPRINT("parse_number: p_start=%p, p=%p, p_end=%p, x=%ld", + (const void *) p_start, + (const void *) p, + (const void *) js_ctx->p_end, + (long) x)); + +#if defined(DUK_USE_JSON_DECNUMBER_FASTPATH) + /* This fast path is pretty marginal in practice. + * XXX: candidate for removal. + */ + DUK_ASSERT(duk__json_decnumber_lookup[0x00] == 0x00); /* end-of-input breaks */ + if (duk__json_decnumber_lookup[x] == 0) { + break; + } +#else /* DUK_USE_JSON_DECNUMBER_FASTPATH */ + if (!((x >= DUK_ASC_0 && x <= DUK_ASC_9) || + (x == DUK_ASC_PERIOD || x == DUK_ASC_LC_E || x == DUK_ASC_UC_E || x == DUK_ASC_MINUS || x == DUK_ASC_PLUS))) { + /* Plus sign must be accepted for positive exponents + * (e.g. '1.5e+2'). This clause catches NULs. + */ + break; + } +#endif /* DUK_USE_JSON_DECNUMBER_FASTPATH */ + p++; /* safe, because matched (NUL causes a break) */ + } + js_ctx->p = p; + + DUK_ASSERT(js_ctx->p > p_start); + duk_push_lstring(thr, (const char *) p_start, (duk_size_t) (p - p_start)); + + s2n_flags = DUK_S2N_FLAG_ALLOW_EXP | DUK_S2N_FLAG_ALLOW_MINUS | /* but don't allow leading plus */ + DUK_S2N_FLAG_ALLOW_FRAC; + + DUK_DDD(DUK_DDDPRINT("parse_number: string before parsing: %!T", (duk_tval *) duk_get_tval(thr, -1))); + duk_numconv_parse(thr, 10 /*radix*/, s2n_flags); + if (duk_is_nan(thr, -1)) { + duk__json_dec_syntax_error(js_ctx); + } + DUK_ASSERT(duk_is_number(thr, -1)); + DUK_DDD(DUK_DDDPRINT("parse_number: final number: %!T", (duk_tval *) duk_get_tval(thr, -1))); + + /* [ ... num ] */ +} + +DUK_LOCAL void duk__json_dec_objarr_entry(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + duk_require_stack(thr, DUK_JSON_DEC_REQSTACK); + + /* c recursion check */ + + duk_native_stack_check(thr); + + DUK_ASSERT_DISABLE(js_ctx->recursion_depth >= 0); /* unsigned */ + DUK_ASSERT(js_ctx->recursion_depth <= js_ctx->recursion_limit); + if (js_ctx->recursion_depth >= js_ctx->recursion_limit) { + DUK_ERROR_RANGE(thr, DUK_STR_DEC_RECLIMIT); + DUK_WO_NORETURN(return;); + } + js_ctx->recursion_depth++; +} + +DUK_LOCAL void duk__json_dec_objarr_exit(duk_json_dec_ctx *js_ctx) { + /* c recursion check */ + + DUK_ASSERT(js_ctx->recursion_depth > 0); + DUK_ASSERT(js_ctx->recursion_depth <= js_ctx->recursion_limit); + js_ctx->recursion_depth--; +} + +DUK_LOCAL void duk__json_dec_object(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + duk_int_t key_count; /* XXX: a "first" flag would suffice */ + duk_uint8_t x; + + DUK_DDD(DUK_DDDPRINT("parse_object")); + + duk__json_dec_objarr_entry(js_ctx); + + duk_push_object(thr); + + /* Initial '{' has been checked and eaten by caller. */ + + key_count = 0; + for (;;) { + x = duk__json_dec_get_nonwhite(js_ctx); + + DUK_DDD(DUK_DDDPRINT("parse_object: obj=%!T, x=%ld, key_count=%ld", + (duk_tval *) duk_get_tval(thr, -1), + (long) x, + (long) key_count)); + + /* handle comma and closing brace */ + + if (x == DUK_ASC_COMMA && key_count > 0) { + /* accept comma, expect new value */ + x = duk__json_dec_get_nonwhite(js_ctx); + } else if (x == DUK_ASC_RCURLY) { + /* eat closing brace */ + break; + } else if (key_count == 0) { + /* accept anything, expect first value (EOF will be + * caught by key parsing below. + */ + ; + } else { + /* catches EOF (NUL) and initial comma */ + goto syntax_error; + } + + /* parse key and value */ + + if (x == DUK_ASC_DOUBLEQUOTE) { + duk__json_dec_string(js_ctx); +#if defined(DUK_USE_JX) + } else if (js_ctx->flag_ext_custom && duk_unicode_is_identifier_start((duk_codepoint_t) x)) { + duk__json_dec_plain_string(js_ctx); +#endif + } else { + goto syntax_error; + } + + /* [ ... obj key ] */ + + x = duk__json_dec_get_nonwhite(js_ctx); + if (x != DUK_ASC_COLON) { + goto syntax_error; + } + + duk__json_dec_value(js_ctx); + + /* [ ... obj key val ] */ + + duk_xdef_prop_wec(thr, -3); + + /* [ ... obj ] */ + + key_count++; + } + + /* [ ... obj ] */ + + DUK_DDD(DUK_DDDPRINT("parse_object: final object is %!T", (duk_tval *) duk_get_tval(thr, -1))); + + duk__json_dec_objarr_exit(js_ctx); + return; + +syntax_error: + duk__json_dec_syntax_error(js_ctx); + DUK_UNREACHABLE(); +} + +DUK_LOCAL void duk__json_dec_array(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + duk_uarridx_t arr_idx; + duk_uint8_t x; + + DUK_DDD(DUK_DDDPRINT("parse_array")); + + duk__json_dec_objarr_entry(js_ctx); + + duk_push_array(thr); + + /* Initial '[' has been checked and eaten by caller. */ + + arr_idx = 0; + for (;;) { + x = duk__json_dec_get_nonwhite(js_ctx); + + DUK_DDD(DUK_DDDPRINT("parse_array: arr=%!T, x=%ld, arr_idx=%ld", + (duk_tval *) duk_get_tval(thr, -1), + (long) x, + (long) arr_idx)); + + /* handle comma and closing bracket */ + + if ((x == DUK_ASC_COMMA) && (arr_idx != 0)) { + /* accept comma, expect new value */ + ; + } else if (x == DUK_ASC_RBRACKET) { + /* eat closing bracket */ + break; + } else if (arr_idx == 0) { + /* accept anything, expect first value (EOF will be + * caught by duk__json_dec_value() below. + */ + js_ctx->p--; /* backtrack (safe) */ + } else { + /* catches EOF (NUL) and initial comma */ + goto syntax_error; + } + + /* parse value */ + + duk__json_dec_value(js_ctx); + + /* [ ... arr val ] */ + + duk_xdef_prop_index_wec(thr, -2, arr_idx); + arr_idx++; + } + + /* Must set 'length' explicitly when using duk_xdef_prop_xxx() to + * set the values. + */ + + duk_set_length(thr, -1, arr_idx); + + /* [ ... arr ] */ + + DUK_DDD(DUK_DDDPRINT("parse_array: final array is %!T", (duk_tval *) duk_get_tval(thr, -1))); + + duk__json_dec_objarr_exit(js_ctx); + return; + +syntax_error: + duk__json_dec_syntax_error(js_ctx); + DUK_UNREACHABLE(); +} + +DUK_LOCAL void duk__json_dec_value(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + duk_uint8_t x; + + x = duk__json_dec_get_nonwhite(js_ctx); + + DUK_DDD(DUK_DDDPRINT("parse_value: initial x=%ld", (long) x)); + + /* Note: duk__json_dec_req_stridx() backtracks one char */ + + if (x == DUK_ASC_DOUBLEQUOTE) { + duk__json_dec_string(js_ctx); + } else if ((x >= DUK_ASC_0 && x <= DUK_ASC_9) || (x == DUK_ASC_MINUS)) { +#if defined(DUK_USE_JX) + if (js_ctx->flag_ext_custom && x == DUK_ASC_MINUS && duk__json_dec_peek(js_ctx) == DUK_ASC_UC_I) { + duk__json_dec_req_stridx(js_ctx, DUK_STRIDX_MINUS_INFINITY); /* "-Infinity", '-' has been eaten */ + duk_push_number(thr, -DUK_DOUBLE_INFINITY); + } else { +#else + { /* unconditional block */ +#endif + /* We already ate 'x', so backup one byte. */ + js_ctx->p--; /* safe */ + duk__json_dec_number(js_ctx); + } + } else if (x == DUK_ASC_LC_T) { + duk__json_dec_req_stridx(js_ctx, DUK_STRIDX_TRUE); + duk_push_true(thr); + } else if (x == DUK_ASC_LC_F) { + duk__json_dec_req_stridx(js_ctx, DUK_STRIDX_FALSE); + duk_push_false(thr); + } else if (x == DUK_ASC_LC_N) { + duk__json_dec_req_stridx(js_ctx, DUK_STRIDX_LC_NULL); + duk_push_null(thr); +#if defined(DUK_USE_JX) + } else if (js_ctx->flag_ext_custom && x == DUK_ASC_LC_U) { + duk__json_dec_req_stridx(js_ctx, DUK_STRIDX_LC_UNDEFINED); + duk_push_undefined(thr); + } else if (js_ctx->flag_ext_custom && x == DUK_ASC_UC_N) { + duk__json_dec_req_stridx(js_ctx, DUK_STRIDX_NAN); + duk_push_nan(thr); + } else if (js_ctx->flag_ext_custom && x == DUK_ASC_UC_I) { + duk__json_dec_req_stridx(js_ctx, DUK_STRIDX_INFINITY); + duk_push_number(thr, DUK_DOUBLE_INFINITY); + } else if (js_ctx->flag_ext_custom && x == DUK_ASC_LPAREN) { + duk__json_dec_pointer(js_ctx); + } else if (js_ctx->flag_ext_custom && x == DUK_ASC_PIPE) { + duk__json_dec_buffer(js_ctx); +#endif + } else if (x == DUK_ASC_LCURLY) { + duk__json_dec_object(js_ctx); + } else if (x == DUK_ASC_LBRACKET) { + duk__json_dec_array(js_ctx); + } else { + /* catches EOF (NUL) */ + goto syntax_error; + } + + duk__json_dec_eat_white(js_ctx); + + /* [ ... val ] */ + return; + +syntax_error: + duk__json_dec_syntax_error(js_ctx); + DUK_UNREACHABLE(); +} + +/* Recursive value reviver, implements the Walk() algorithm. The parsing + * step ensures there is a reasonable depth limit to the input. However, + * the reviver may create more depth by editing object or array entries, so + * we have both C recursion limit and native stack checks here. + */ +DUK_LOCAL void duk__json_dec_reviver_walk(duk_json_dec_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + duk_hobject *h; + duk_uarridx_t i, arr_len; + + duk__json_dec_objarr_entry(js_ctx); + + DUK_DDD(DUK_DDDPRINT("walk: top=%ld, holder=%!T, name=%!T", + (long) duk_get_top(thr), + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + + duk_dup_top(thr); + duk_get_prop(thr, -3); /* -> [ ... holder name val ] */ + + h = duk_get_hobject(thr, -1); + if (h != NULL) { + if (duk_js_isarray_hobject(h)) { + arr_len = (duk_uarridx_t) duk_get_length(thr, -1); + for (i = 0; i < arr_len; i++) { + /* [ ... holder name val ] */ + + DUK_DDD(DUK_DDDPRINT("walk: array, top=%ld, i=%ld, arr_len=%ld, holder=%!T, name=%!T, val=%!T", + (long) duk_get_top(thr), + (long) i, + (long) arr_len, + (duk_tval *) duk_get_tval(thr, -3), + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + + duk_dup_top(thr); + (void) duk_push_uint_to_hstring(thr, + (duk_uint_t) i); /* -> [ ... holder name val val ToString(i) ] */ + duk__json_dec_reviver_walk(js_ctx); /* -> [ ... holder name val new_elem ] */ + + if (duk_is_undefined(thr, -1)) { + duk_pop(thr); + duk_del_prop_index(thr, -1, i); + } else { + /* XXX: duk_xdef_prop_index_wec() would be more appropriate + * here but it currently makes some assumptions that might + * not hold (e.g. that previous property is not an accessor). + */ + duk_put_prop_index(thr, -2, i); + } + } + } else { + /* [ ... holder name val ] */ + duk_enum(thr, -1, DUK_ENUM_OWN_PROPERTIES_ONLY /*flags*/); + while (duk_next(thr, -1 /*enum_index*/, 0 /*get_value*/)) { + DUK_DDD(DUK_DDDPRINT("walk: object, top=%ld, holder=%!T, name=%!T, val=%!T, enum=%!iT, obj_key=%!T", + (long) duk_get_top(thr), + (duk_tval *) duk_get_tval(thr, -5), + (duk_tval *) duk_get_tval(thr, -4), + (duk_tval *) duk_get_tval(thr, -3), + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + + /* [ ... holder name val enum obj_key ] */ + duk_dup_m3(thr); + duk_dup_m2(thr); + + /* [ ... holder name val enum obj_key val obj_key ] */ + duk__json_dec_reviver_walk(js_ctx); + + /* [ ... holder name val enum obj_key new_elem ] */ + if (duk_is_undefined(thr, -1)) { + duk_pop(thr); + duk_del_prop(thr, -3); + } else { + /* XXX: duk_xdef_prop_index_wec() would be more appropriate + * here but it currently makes some assumptions that might + * not hold (e.g. that previous property is not an accessor). + * + * Using duk_put_prop() works incorrectly with '__proto__' + * if the own property with that name has been deleted. This + * does not happen normally, but a clever reviver can trigger + * that, see complex reviver case in: test-bug-json-parse-__proto__.js. + */ + duk_put_prop(thr, -4); + } + } + duk_pop(thr); /* pop enum */ + } + } + + /* [ ... holder name val ] */ + + duk_dup(thr, js_ctx->idx_reviver); + duk_insert(thr, -4); /* -> [ ... reviver holder name val ] */ + duk_call_method(thr, 2); /* -> [ ... res ] */ + + duk__json_dec_objarr_exit(js_ctx); + + DUK_DDD(DUK_DDDPRINT("walk: top=%ld, result=%!T", (long) duk_get_top(thr), (duk_tval *) duk_get_tval(thr, -1))); +} + +/* + * Stringify implementation. + */ + +#define DUK__EMIT_1(js_ctx, ch) duk__emit_1((js_ctx), (duk_uint_fast8_t) (ch)) +#define DUK__EMIT_2(js_ctx, ch1, ch2) duk__emit_2((js_ctx), (duk_uint_fast8_t) (ch1), (duk_uint_fast8_t) (ch2)) +#define DUK__EMIT_HSTR(js_ctx, h) duk__emit_hstring((js_ctx), (h)) +#if defined(DUK_USE_FASTINT) || defined(DUK_USE_JX) || defined(DUK_USE_JC) +#define DUK__EMIT_CSTR(js_ctx, p) duk__emit_cstring((js_ctx), (p)) +#endif +#define DUK__EMIT_STRIDX(js_ctx, i) duk__emit_stridx((js_ctx), (i)) +#define DUK__UNEMIT_1(js_ctx) duk__unemit_1((js_ctx)) + +DUK_LOCAL void duk__emit_1(duk_json_enc_ctx *js_ctx, duk_uint_fast8_t ch) { + DUK_BW_WRITE_ENSURE_U8(js_ctx->thr, &js_ctx->bw, ch); +} + +DUK_LOCAL void duk__emit_2(duk_json_enc_ctx *js_ctx, duk_uint_fast8_t ch1, duk_uint_fast8_t ch2) { + DUK_BW_WRITE_ENSURE_U8_2(js_ctx->thr, &js_ctx->bw, ch1, ch2); +} + +DUK_LOCAL void duk__emit_hstring(duk_json_enc_ctx *js_ctx, duk_hstring *h) { + DUK_BW_WRITE_ENSURE_HSTRING(js_ctx->thr, &js_ctx->bw, h); +} + +#if defined(DUK_USE_FASTINT) || defined(DUK_USE_JX) || defined(DUK_USE_JC) +DUK_LOCAL void duk__emit_cstring(duk_json_enc_ctx *js_ctx, const char *str) { + DUK_BW_WRITE_ENSURE_CSTRING(js_ctx->thr, &js_ctx->bw, str); +} +#endif + +DUK_LOCAL void duk__emit_stridx(duk_json_enc_ctx *js_ctx, duk_small_uint_t stridx) { + duk_hstring *h; + + DUK_ASSERT_STRIDX_VALID(stridx); + h = DUK_HTHREAD_GET_STRING(js_ctx->thr, stridx); + DUK_ASSERT(h != NULL); + + DUK_BW_WRITE_ENSURE_HSTRING(js_ctx->thr, &js_ctx->bw, h); +} + +DUK_LOCAL void duk__unemit_1(duk_json_enc_ctx *js_ctx) { + DUK_ASSERT(DUK_BW_GET_SIZE(js_ctx->thr, &js_ctx->bw) >= 1); + DUK_BW_ADD_PTR(js_ctx->thr, &js_ctx->bw, -1); +} + +#define DUK__MKESC(nybbles, esc1, esc2) \ + (((duk_uint_fast32_t) (nybbles)) << 16) | (((duk_uint_fast32_t) (esc1)) << 8) | ((duk_uint_fast32_t) (esc2)) + +DUK_LOCAL duk_uint8_t *duk__emit_esc_auto_fast(duk_json_enc_ctx *js_ctx, duk_uint_fast32_t cp, duk_uint8_t *q) { + duk_uint_fast32_t tmp; + duk_small_uint_t dig; + + DUK_UNREF(js_ctx); + + /* Caller ensures space for at least DUK__JSON_MAX_ESC_LEN. */ + + /* Select appropriate escape format automatically, and set 'tmp' to a + * value encoding both the escape format character and the nybble count: + * + * (nybble_count << 16) | (escape_char1) | (escape_char2) + */ + +#if defined(DUK_USE_JX) + if (DUK_LIKELY(cp < 0x100UL)) { + if (DUK_UNLIKELY(js_ctx->flag_ext_custom != 0U)) { + tmp = DUK__MKESC(2, DUK_ASC_BACKSLASH, DUK_ASC_LC_X); + } else { + tmp = DUK__MKESC(4, DUK_ASC_BACKSLASH, DUK_ASC_LC_U); + } + } else +#endif + if (DUK_LIKELY(cp < 0x10000UL)) { + tmp = DUK__MKESC(4, DUK_ASC_BACKSLASH, DUK_ASC_LC_U); + } else { +#if defined(DUK_USE_JX) + if (DUK_LIKELY(js_ctx->flag_ext_custom != 0U)) { + tmp = DUK__MKESC(8, DUK_ASC_BACKSLASH, DUK_ASC_UC_U); + } else +#endif + { + /* In compatible mode and standard JSON mode, output + * something useful for non-BMP characters. This won't + * roundtrip but will still be more or less readable and + * more useful than an error. + */ + tmp = DUK__MKESC(8, DUK_ASC_UC_U, DUK_ASC_PLUS); + } + } + + *q++ = (duk_uint8_t) ((tmp >> 8) & 0xff); + *q++ = (duk_uint8_t) (tmp & 0xff); + + tmp = tmp >> 16; + while (tmp > 0) { + tmp--; + dig = (duk_small_uint_t) ((cp >> (4 * tmp)) & 0x0f); + *q++ = duk_lc_digits[dig]; + } + + return q; +} + +DUK_LOCAL void duk__json_enc_key_autoquote(duk_json_enc_ctx *js_ctx, duk_hstring *k) { + const duk_int8_t *p, *p_start, *p_end; /* Note: intentionally signed. */ + duk_size_t k_len; + duk_codepoint_t cp; + + DUK_ASSERT(k != NULL); + + /* Accept ASCII strings which conform to identifier requirements + * as being emitted without key quotes. Since we only accept ASCII + * there's no need for actual decoding: 'p' is intentionally signed + * so that bytes >= 0x80 extend to negative values and are rejected + * as invalid identifier codepoints. + */ + + if (js_ctx->flag_avoid_key_quotes) { + k_len = DUK_HSTRING_GET_BYTELEN(k); + p_start = (const duk_int8_t *) DUK_HSTRING_GET_DATA(k); + p_end = p_start + k_len; + p = p_start; + + if (p == p_end) { + /* Zero length string is not accepted without quotes */ + goto quote_normally; + } + cp = (duk_codepoint_t) (*p++); + if (DUK_UNLIKELY(!duk_unicode_is_identifier_start(cp))) { + goto quote_normally; + } + while (p < p_end) { + cp = (duk_codepoint_t) (*p++); + if (DUK_UNLIKELY(!duk_unicode_is_identifier_part(cp))) { + goto quote_normally; + } + } + + /* This seems faster than emitting bytes one at a time and + * then potentially rewinding. + */ + DUK__EMIT_HSTR(js_ctx, k); + return; + } + +quote_normally: + duk__json_enc_quote_string(js_ctx, k); +} + +/* The Quote(value) operation: quote a string. + * + * Stack policy: [ ] -> [ ]. + */ + +DUK_LOCAL void duk__json_enc_quote_string(duk_json_enc_ctx *js_ctx, duk_hstring *h_str) { + duk_hthread *thr = js_ctx->thr; + const duk_uint8_t *p, *p_start, *p_end, *p_now, *p_tmp; + duk_uint8_t *q; + duk_ucodepoint_t cp; /* typed for duk_unicode_decode_xutf8() */ + + DUK_DDD(DUK_DDDPRINT("duk__json_enc_quote_string: h_str=%!O", (duk_heaphdr *) h_str)); + + DUK_ASSERT(h_str != NULL); + p_start = DUK_HSTRING_GET_DATA(h_str); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h_str); + p = p_start; + + DUK__EMIT_1(js_ctx, DUK_ASC_DOUBLEQUOTE); + + /* Encode string in small chunks, estimating the maximum expansion so that + * there's no need to ensure space while processing the chunk. + */ + + while (p < p_end) { + duk_size_t left, now, space; + + left = (duk_size_t) (p_end - p); + now = (left > DUK__JSON_ENCSTR_CHUNKSIZE ? DUK__JSON_ENCSTR_CHUNKSIZE : left); + + /* Maximum expansion per input byte is 6: + * - invalid UTF-8 byte causes "\uXXXX" to be emitted (6/1 = 6). + * - 2-byte UTF-8 encodes as "\uXXXX" (6/2 = 3). + * - 4-byte UTF-8 encodes as "\Uxxxxxxxx" (10/4 = 2.5). + */ + space = now * 6; + q = DUK_BW_ENSURE_GETPTR(thr, &js_ctx->bw, space); + + p_now = p + now; + + while (p < p_now) { +#if defined(DUK_USE_JSON_QUOTESTRING_FASTPATH) + duk_uint8_t b; + + b = duk__json_quotestr_lookup[*p++]; + if (DUK_LIKELY(b < 0x80)) { + /* Most input bytes go through here. */ + *q++ = b; + } else if (b >= 0xa0) { + *q++ = DUK_ASC_BACKSLASH; + *q++ = (duk_uint8_t) (b - 0x80); + } else if (b == 0x80) { + cp = (duk_ucodepoint_t) (*(p - 1)); + q = duk__emit_esc_auto_fast(js_ctx, cp, q); + } else if (b == 0x7f && js_ctx->flag_ascii_only) { + /* 0x7F is special */ + DUK_ASSERT(b == 0x81); + cp = (duk_ucodepoint_t) 0x7f; + q = duk__emit_esc_auto_fast(js_ctx, cp, q); + } else { + DUK_ASSERT(b == 0x81); + p--; + + /* slow path is shared */ +#else /* DUK_USE_JSON_QUOTESTRING_FASTPATH */ + cp = *p; + + if (DUK_LIKELY(cp <= 0x7f)) { + /* ascii fast path: avoid decoding utf-8 */ + p++; + if (cp == 0x22 || cp == 0x5c) { + /* double quote or backslash */ + *q++ = DUK_ASC_BACKSLASH; + *q++ = (duk_uint8_t) cp; + } else if (cp < 0x20) { + duk_uint_fast8_t esc_char; + + /* This approach is a bit shorter than a straight + * if-else-ladder and also a bit faster. + */ + if (cp < (sizeof(duk__json_quotestr_esc) / sizeof(duk_uint8_t)) && + (esc_char = duk__json_quotestr_esc[cp]) != 0) { + *q++ = DUK_ASC_BACKSLASH; + *q++ = (duk_uint8_t) esc_char; + } else { + q = duk__emit_esc_auto_fast(js_ctx, cp, q); + } + } else if (cp == 0x7f && js_ctx->flag_ascii_only) { + q = duk__emit_esc_auto_fast(js_ctx, cp, q); + } else { + /* any other printable -> as is */ + *q++ = (duk_uint8_t) cp; + } + } else { + /* slow path is shared */ +#endif /* DUK_USE_JSON_QUOTESTRING_FASTPATH */ + + /* slow path decode */ + + /* If XUTF-8 decoding fails, treat the offending byte as a codepoint directly + * and go forward one byte. This is of course very lossy, but allows some kind + * of output to be produced even for internal strings which don't conform to + * XUTF-8. All standard ECMAScript strings are always CESU-8, so this behavior + * does not violate the ECMAScript specification. The behavior is applied to + * all modes, including ECMAScript standard JSON. Because the current XUTF-8 + * decoding is not very strict, this behavior only really affects initial bytes + * and truncated codepoints. + * + * Another alternative would be to scan forwards to start of next codepoint + * (or end of input) and emit just one replacement codepoint. + */ + + p_tmp = p; + if (!duk_unicode_decode_xutf8(thr, &p, p_start, p_end, &cp)) { + /* Decode failed. */ + cp = *p_tmp; + p = p_tmp + 1; + } + +#if defined(DUK_USE_NONSTD_JSON_ESC_U2028_U2029) + if (js_ctx->flag_ascii_only || cp == 0x2028 || cp == 0x2029) { +#else + if (js_ctx->flag_ascii_only) { +#endif + q = duk__emit_esc_auto_fast(js_ctx, cp, q); + } else { + /* as is */ + DUK_RAW_WRITEINC_XUTF8(q, cp); + } + } + } + + DUK_BW_SET_PTR(thr, &js_ctx->bw, q); + } + + DUK__EMIT_1(js_ctx, DUK_ASC_DOUBLEQUOTE); +} + +/* Encode a double (checked by caller) from stack top. Stack top may be + * replaced by serialized string but is not popped (caller does that). + */ +DUK_LOCAL void duk__json_enc_double(duk_json_enc_ctx *js_ctx) { + duk_hthread *thr; + duk_tval *tv; + duk_double_t d; + duk_small_int_t c; + duk_small_int_t s; + duk_small_uint_t stridx; + duk_small_uint_t n2s_flags; + duk_hstring *h_str; + + DUK_ASSERT(js_ctx != NULL); + thr = js_ctx->thr; + DUK_ASSERT(thr != NULL); + + /* Caller must ensure 'tv' is indeed a double and not a fastint! */ + tv = DUK_GET_TVAL_NEGIDX(thr, -1); + DUK_ASSERT(DUK_TVAL_IS_DOUBLE(tv)); + d = DUK_TVAL_GET_DOUBLE(tv); + + c = (duk_small_int_t) DUK_FPCLASSIFY(d); + s = (duk_small_int_t) DUK_SIGNBIT(d); + DUK_UNREF(s); + + if (DUK_LIKELY(!(c == DUK_FP_INFINITE || c == DUK_FP_NAN))) { + DUK_ASSERT(DUK_ISFINITE(d)); + +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + /* Negative zero needs special handling in JX/JC because + * it would otherwise serialize to '0', not '-0'. + */ + if (DUK_UNLIKELY(c == DUK_FP_ZERO && s != 0 && (js_ctx->flag_ext_custom_or_compatible))) { + duk_push_hstring_stridx(thr, DUK_STRIDX_MINUS_ZERO); /* '-0' */ + } else +#endif /* DUK_USE_JX || DUK_USE_JC */ + { + n2s_flags = 0; + /* [ ... number ] -> [ ... string ] */ + duk_numconv_stringify(thr, 10 /*radix*/, 0 /*digits*/, n2s_flags); + } + h_str = duk_known_hstring(thr, -1); + DUK__EMIT_HSTR(js_ctx, h_str); + return; + } + +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + if (!(js_ctx->flags & (DUK_JSON_FLAG_EXT_CUSTOM | DUK_JSON_FLAG_EXT_COMPATIBLE))) { + stridx = DUK_STRIDX_LC_NULL; + } else if (c == DUK_FP_NAN) { + stridx = js_ctx->stridx_custom_nan; + } else if (s == 0) { + stridx = js_ctx->stridx_custom_posinf; + } else { + stridx = js_ctx->stridx_custom_neginf; + } +#else + stridx = DUK_STRIDX_LC_NULL; +#endif + DUK__EMIT_STRIDX(js_ctx, stridx); +} + +#if defined(DUK_USE_FASTINT) +/* Encode a fastint from duk_tval ptr, no value stack effects. */ +DUK_LOCAL void duk__json_enc_fastint_tval(duk_json_enc_ctx *js_ctx, duk_tval *tv) { + duk_int64_t v; + + /* Fastint range is signed 48-bit so longest value is -2^47 = -140737488355328 + * (16 chars long), longest signed 64-bit value is -2^63 = -9223372036854775808 + * (20 chars long). Alloc space for 64-bit range to be safe. + */ + duk_uint8_t buf[20 + 1]; + + /* Caller must ensure 'tv' is indeed a fastint! */ + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv)); + v = DUK_TVAL_GET_FASTINT(tv); + + /* XXX: There are no format strings in duk_config.h yet, could add + * one for formatting duk_int64_t. For now, assumes "%lld" and that + * "long long" type exists. Could also rely on C99 directly but that + * won't work for older MSVC. + */ + DUK_SPRINTF((char *) buf, "%lld", (long long) v); + DUK__EMIT_CSTR(js_ctx, (const char *) buf); +} +#endif + +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) +#if defined(DUK_USE_HEX_FASTPATH) +DUK_LOCAL duk_uint8_t *duk__json_enc_buffer_data_hex(const duk_uint8_t *src, duk_size_t src_len, duk_uint8_t *dst) { + duk_uint8_t *q; + duk_uint16_t *q16; + duk_small_uint_t x; + duk_size_t i, len_safe; +#if !defined(DUK_USE_UNALIGNED_ACCESSES_POSSIBLE) + duk_bool_t shift_dst; +#endif + + /* Unlike in duk_hex_encode() 'dst' is not necessarily aligned by 2. + * For platforms where unaligned accesses are not allowed, shift 'dst' + * ahead by 1 byte to get alignment and then duk_memmove() the result + * in place. The faster encoding loop makes up the difference. + * There's always space for one extra byte because a terminator always + * follows the hex data and that's been accounted for by the caller. + */ + +#if defined(DUK_USE_UNALIGNED_ACCESSES_POSSIBLE) + q16 = (duk_uint16_t *) (void *) dst; +#else + shift_dst = (duk_bool_t) (((duk_size_t) dst) & 0x01U); + if (shift_dst) { + DUK_DD(DUK_DDPRINT("unaligned accesses not possible, dst not aligned -> step to dst + 1")); + q16 = (duk_uint16_t *) (void *) (dst + 1); + } else { + DUK_DD(DUK_DDPRINT("unaligned accesses not possible, dst is aligned")); + q16 = (duk_uint16_t *) (void *) dst; + } + DUK_ASSERT((((duk_size_t) q16) & 0x01U) == 0); +#endif + + len_safe = src_len & ~0x03U; + for (i = 0; i < len_safe; i += 4) { + q16[0] = duk_hex_enctab[src[i]]; + q16[1] = duk_hex_enctab[src[i + 1]]; + q16[2] = duk_hex_enctab[src[i + 2]]; + q16[3] = duk_hex_enctab[src[i + 3]]; + q16 += 4; + } + q = (duk_uint8_t *) q16; + +#if !defined(DUK_USE_UNALIGNED_ACCESSES_POSSIBLE) + if (shift_dst) { + q--; + duk_memmove((void *) dst, (const void *) (dst + 1), 2 * len_safe); + DUK_ASSERT(dst + 2 * len_safe == q); + } +#endif + + for (; i < src_len; i++) { + x = src[i]; + *q++ = duk_lc_digits[x >> 4]; + *q++ = duk_lc_digits[x & 0x0f]; + } + + return q; +} +#else /* DUK_USE_HEX_FASTPATH */ +DUK_LOCAL duk_uint8_t *duk__json_enc_buffer_data_hex(const duk_uint8_t *src, duk_size_t src_len, duk_uint8_t *dst) { + const duk_uint8_t *p; + const duk_uint8_t *p_end; + duk_uint8_t *q; + duk_small_uint_t x; + + p = src; + p_end = src + src_len; + q = dst; + while (p != p_end) { + x = *p++; + *q++ = duk_lc_digits[x >> 4]; + *q++ = duk_lc_digits[x & 0x0f]; + } + + return q; +} +#endif /* DUK_USE_HEX_FASTPATH */ + +DUK_LOCAL void duk__json_enc_buffer_data(duk_json_enc_ctx *js_ctx, duk_uint8_t *buf_data, duk_size_t buf_len) { + duk_hthread *thr; + duk_uint8_t *q; + duk_size_t space; + + thr = js_ctx->thr; + + DUK_ASSERT(js_ctx->flag_ext_custom || js_ctx->flag_ext_compatible); /* caller checks */ + DUK_ASSERT(js_ctx->flag_ext_custom_or_compatible); + + /* Buffer values are encoded in (lowercase) hex to make the + * binary data readable. Base64 or similar would be more + * compact but less readable, and the point of JX/JC + * variants is to be as useful to a programmer as possible. + */ + + /* The #if defined() clutter here needs to handle the three + * cases: (1) JX+JC, (2) JX only, (3) JC only. + */ + + /* Note: space must cater for both JX and JC. */ + space = 9 + buf_len * 2 + 2; + DUK_ASSERT(DUK_HBUFFER_MAX_BYTELEN <= 0x7ffffffeUL); + DUK_ASSERT((space - 2) / 2 >= buf_len); /* overflow not possible, buffer limits */ + q = DUK_BW_ENSURE_GETPTR(thr, &js_ctx->bw, space); + +#if defined(DUK_USE_JX) && defined(DUK_USE_JC) + if (js_ctx->flag_ext_custom) +#endif +#if defined(DUK_USE_JX) + { + *q++ = DUK_ASC_PIPE; + q = duk__json_enc_buffer_data_hex(buf_data, buf_len, q); + *q++ = DUK_ASC_PIPE; + + } +#endif +#if defined(DUK_USE_JX) && defined(DUK_USE_JC) + else +#endif +#if defined(DUK_USE_JC) + { + DUK_ASSERT(js_ctx->flag_ext_compatible); + duk_memcpy((void *) q, (const void *) "{\"_buf\":\"", 9); /* len: 9 */ + q += 9; + q = duk__json_enc_buffer_data_hex(buf_data, buf_len, q); + *q++ = DUK_ASC_DOUBLEQUOTE; + *q++ = DUK_ASC_RCURLY; + } +#endif + + DUK_BW_SET_PTR(thr, &js_ctx->bw, q); +} + +DUK_LOCAL void duk__json_enc_buffer_jx_jc(duk_json_enc_ctx *js_ctx, duk_hbuffer *h) { + duk__json_enc_buffer_data(js_ctx, + (duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(js_ctx->thr->heap, h), + (duk_size_t) DUK_HBUFFER_GET_SIZE(h)); +} +#endif /* DUK_USE_JX || DUK_USE_JC */ + +#if defined(DUK_USE_JSON_STRINGIFY_FASTPATH) +DUK_LOCAL void duk__json_enc_buffer_json_fastpath(duk_json_enc_ctx *js_ctx, duk_hbuffer *h) { + duk_size_t i, n; + const duk_uint8_t *buf; + duk_uint8_t *q; + + n = DUK_HBUFFER_GET_SIZE(h); + if (n == 0) { + DUK__EMIT_2(js_ctx, DUK_ASC_LCURLY, DUK_ASC_RCURLY); + return; + } + + DUK__EMIT_1(js_ctx, DUK_ASC_LCURLY); + + /* Maximum encoded length with 32-bit index: 1 + 10 + 2 + 3 + 1 + 1 = 18, + * with 64-bit index: 1 + 20 + 2 + 3 + 1 + 1 = 28. 32 has some slack. + * + * Note that because the output buffer is reallocated from time to time, + * side effects (such as finalizers) affecting the buffer 'h' must be + * disabled. This is the case in the JSON.stringify() fast path. + */ + + buf = (const duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(js_ctx->thr->heap, h); + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + for (i = 0; i < n; i++) { + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth + 1); + q = DUK_BW_ENSURE_GETPTR(js_ctx->thr, &js_ctx->bw, 32); + q += DUK_SPRINTF((char *) q, "\"%lu\": %u,", (unsigned long) i, (unsigned int) buf[i]); + DUK_BW_SET_PTR(js_ctx->thr, &js_ctx->bw, q); + } + } else { + q = DUK_BW_GET_PTR(js_ctx->thr, &js_ctx->bw); + for (i = 0; i < n; i++) { + q = DUK_BW_ENSURE_RAW(js_ctx->thr, &js_ctx->bw, 32, q); + q += DUK_SPRINTF((char *) q, "\"%lu\":%u,", (unsigned long) i, (unsigned int) buf[i]); + } + DUK_BW_SET_PTR(js_ctx->thr, &js_ctx->bw, q); + } + DUK__UNEMIT_1(js_ctx); /* eat trailing comma */ + + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth); + } + DUK__EMIT_1(js_ctx, DUK_ASC_RCURLY); +} +#endif /* DUK_USE_JSON_STRINGIFY_FASTPATH */ + +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) +DUK_LOCAL void duk__json_enc_pointer(duk_json_enc_ctx *js_ctx, void *ptr) { + char buf[64]; /* XXX: how to figure correct size? */ + const char *fmt; + + DUK_ASSERT(js_ctx->flag_ext_custom || js_ctx->flag_ext_compatible); /* caller checks */ + DUK_ASSERT(js_ctx->flag_ext_custom_or_compatible); + + duk_memzero(buf, sizeof(buf)); + + /* The #if defined() clutter here needs to handle the three + * cases: (1) JX+JC, (2) JX only, (3) JC only. + */ +#if defined(DUK_USE_JX) && defined(DUK_USE_JC) + if (js_ctx->flag_ext_custom) +#endif +#if defined(DUK_USE_JX) + { + fmt = ptr ? "(%p)" : "(null)"; + } +#endif +#if defined(DUK_USE_JX) && defined(DUK_USE_JC) + else +#endif +#if defined(DUK_USE_JC) + { + DUK_ASSERT(js_ctx->flag_ext_compatible); + fmt = ptr ? "{\"_ptr\":\"%p\"}" : "{\"_ptr\":\"null\"}"; + } +#endif + + /* When ptr == NULL, the format argument is unused. */ + DUK_SNPRINTF(buf, sizeof(buf) - 1, fmt, ptr); /* must not truncate */ + DUK__EMIT_CSTR(js_ctx, buf); +} +#endif /* DUK_USE_JX || DUK_USE_JC */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) +DUK_LOCAL void duk__json_enc_bufobj(duk_json_enc_ctx *js_ctx, duk_hbufobj *h_bufobj) { + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + + if (h_bufobj->buf == NULL || !DUK_HBUFOBJ_VALID_SLICE(h_bufobj)) { + DUK__EMIT_STRIDX(js_ctx, DUK_STRIDX_LC_NULL); + } else { + /* Handle both full and partial slice (as long as covered). */ + duk__json_enc_buffer_data(js_ctx, + (duk_uint8_t *) DUK_HBUFOBJ_GET_SLICE_BASE(js_ctx->thr->heap, h_bufobj), + (duk_size_t) h_bufobj->length); + } +} +#endif /* DUK_USE_JX || DUK_USE_JC */ +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* Indent helper. Calling code relies on js_ctx->recursion_depth also being + * directly related to indent depth. + */ +#if defined(DUK_USE_PREFER_SIZE) +DUK_LOCAL void duk__json_enc_newline_indent(duk_json_enc_ctx *js_ctx, duk_uint_t depth) { + DUK_ASSERT(js_ctx->h_gap != NULL); + DUK_ASSERT(DUK_HSTRING_GET_BYTELEN(js_ctx->h_gap) > 0); /* caller guarantees */ + + DUK__EMIT_1(js_ctx, 0x0a); + while (depth-- > 0) { + DUK__EMIT_HSTR(js_ctx, js_ctx->h_gap); + } +} +#else /* DUK_USE_PREFER_SIZE */ +DUK_LOCAL void duk__json_enc_newline_indent(duk_json_enc_ctx *js_ctx, duk_uint_t depth) { + const duk_uint8_t *gap_data; + duk_size_t gap_len; + duk_size_t avail_bytes; /* bytes of indent available for copying */ + duk_size_t need_bytes; /* bytes of indent still needed */ + duk_uint8_t *p_start; + duk_uint8_t *p; + + DUK_ASSERT(js_ctx->h_gap != NULL); + DUK_ASSERT(DUK_HSTRING_GET_BYTELEN(js_ctx->h_gap) > 0); /* caller guarantees */ + + DUK__EMIT_1(js_ctx, 0x0a); + if (DUK_UNLIKELY(depth == 0)) { + return; + } + + /* To handle deeper indents efficiently, make use of copies we've + * already emitted. In effect we can emit a sequence of 1, 2, 4, + * 8, etc copies, and then finish the last run. Byte counters + * avoid multiply with gap_len on every loop. + */ + + gap_data = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(js_ctx->h_gap); + gap_len = (duk_size_t) DUK_HSTRING_GET_BYTELEN(js_ctx->h_gap); + DUK_ASSERT(gap_len > 0); + + need_bytes = gap_len * depth; + p = DUK_BW_ENSURE_GETPTR(js_ctx->thr, &js_ctx->bw, need_bytes); + p_start = p; + + duk_memcpy((void *) p, (const void *) gap_data, (size_t) gap_len); + p += gap_len; + avail_bytes = gap_len; + DUK_ASSERT(need_bytes >= gap_len); + need_bytes -= gap_len; + + while (need_bytes >= avail_bytes) { + duk_memcpy((void *) p, (const void *) p_start, (size_t) avail_bytes); + p += avail_bytes; + need_bytes -= avail_bytes; + avail_bytes <<= 1; + } + + DUK_ASSERT(need_bytes < avail_bytes); /* need_bytes may be zero */ + duk_memcpy((void *) p, (const void *) p_start, (size_t) need_bytes); + p += need_bytes; + /*avail_bytes += need_bytes*/ + + DUK_BW_SET_PTR(js_ctx->thr, &js_ctx->bw, p); +} +#endif /* DUK_USE_PREFER_SIZE */ + +/* Shared entry handling for object/array serialization. */ +DUK_LOCAL void duk__json_enc_objarr_entry(duk_json_enc_ctx *js_ctx, duk_idx_t *entry_top) { + duk_hthread *thr = js_ctx->thr; + duk_hobject *h_target; + duk_uint_fast32_t i, n; + + *entry_top = duk_get_top(thr); + + duk_native_stack_check(thr); + duk_require_stack(thr, DUK_JSON_ENC_REQSTACK); + + /* Loop check using a hybrid approach: a fixed-size visited[] array + * with overflow in a loop check object. + */ + + h_target = duk_known_hobject(thr, -1); /* object or array */ + + n = js_ctx->recursion_depth; + if (DUK_UNLIKELY(n > DUK_JSON_ENC_LOOPARRAY)) { + n = DUK_JSON_ENC_LOOPARRAY; + } + for (i = 0; i < n; i++) { + if (DUK_UNLIKELY(js_ctx->visiting[i] == h_target)) { + DUK_DD(DUK_DDPRINT("slow path loop detect")); + DUK_ERROR_TYPE(thr, DUK_STR_CYCLIC_INPUT); + DUK_WO_NORETURN(return;); + } + } + if (js_ctx->recursion_depth < DUK_JSON_ENC_LOOPARRAY) { + js_ctx->visiting[js_ctx->recursion_depth] = h_target; + } else { + duk_push_sprintf(thr, DUK_STR_FMT_PTR, (void *) h_target); + duk_dup_top(thr); /* -> [ ... voidp voidp ] */ + if (duk_has_prop(thr, js_ctx->idx_loop)) { + DUK_ERROR_TYPE(thr, DUK_STR_CYCLIC_INPUT); + DUK_WO_NORETURN(return;); + } + duk_push_true(thr); /* -> [ ... voidp true ] */ + duk_put_prop(thr, js_ctx->idx_loop); /* -> [ ... ] */ + } + + /* C recursion check. */ + + DUK_ASSERT_DISABLE(js_ctx->recursion_depth >= 0); /* unsigned */ + DUK_ASSERT(js_ctx->recursion_depth <= js_ctx->recursion_limit); + if (js_ctx->recursion_depth >= js_ctx->recursion_limit) { + DUK_ERROR_RANGE(thr, DUK_STR_ENC_RECLIMIT); + DUK_WO_NORETURN(return;); + } + js_ctx->recursion_depth++; + + DUK_DDD(DUK_DDDPRINT("shared entry finished: top=%ld, loop=%!T", + (long) duk_get_top(thr), + (duk_tval *) duk_get_tval(thr, js_ctx->idx_loop))); +} + +/* Shared exit handling for object/array serialization. */ +DUK_LOCAL void duk__json_enc_objarr_exit(duk_json_enc_ctx *js_ctx, duk_idx_t *entry_top) { + duk_hthread *thr = js_ctx->thr; + duk_hobject *h_target; + + /* C recursion check. */ + + DUK_ASSERT(js_ctx->recursion_depth > 0); + DUK_ASSERT(js_ctx->recursion_depth <= js_ctx->recursion_limit); + js_ctx->recursion_depth--; + + /* Loop check. */ + + h_target = duk_known_hobject(thr, *entry_top - 1); /* original target at entry_top - 1 */ + + if (js_ctx->recursion_depth < DUK_JSON_ENC_LOOPARRAY) { + /* Previous entry was inside visited[], nothing to do. */ + } else { + duk_push_sprintf(thr, DUK_STR_FMT_PTR, (void *) h_target); + duk_del_prop(thr, js_ctx->idx_loop); /* -> [ ... ] */ + } + + /* Restore stack top after unbalanced code paths. */ + duk_set_top(thr, *entry_top); + + DUK_DDD(DUK_DDDPRINT("shared entry finished: top=%ld, loop=%!T", + (long) duk_get_top(thr), + (duk_tval *) duk_get_tval(thr, js_ctx->idx_loop))); +} + +/* The JO(value) operation: encode object. + * + * Stack policy: [ object ] -> [ object ]. + */ +DUK_LOCAL void duk__json_enc_object(duk_json_enc_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + duk_hstring *h_key; + duk_idx_t entry_top; + duk_idx_t idx_obj; + duk_idx_t idx_keys; + duk_bool_t emitted; + duk_uarridx_t arr_len, i; + duk_size_t prev_size; + + DUK_DDD(DUK_DDDPRINT("duk__json_enc_object: obj=%!T", (duk_tval *) duk_get_tval(thr, -1))); + + duk__json_enc_objarr_entry(js_ctx, &entry_top); + + idx_obj = entry_top - 1; + + if (js_ctx->idx_proplist >= 0) { + idx_keys = js_ctx->idx_proplist; + } else { + /* XXX: would be nice to enumerate an object at specified index */ + duk_dup(thr, idx_obj); + (void) duk_hobject_get_enumerated_keys( + thr, + DUK_ENUM_OWN_PROPERTIES_ONLY /*flags*/); /* [ ... target ] -> [ ... target keys ] */ + idx_keys = duk_require_normalize_index(thr, -1); + /* leave stack unbalanced on purpose */ + } + + DUK_DDD(DUK_DDDPRINT("idx_keys=%ld, h_keys=%!T", (long) idx_keys, (duk_tval *) duk_get_tval(thr, idx_keys))); + + /* Steps 8-10 have been merged to avoid a "partial" variable. */ + + DUK__EMIT_1(js_ctx, DUK_ASC_LCURLY); + + /* XXX: keys is an internal object with all keys to be processed + * in its (gapless) array part. Because nobody can touch the keys + * object, we could iterate its array part directly (keeping in mind + * that it can be reallocated). + */ + + arr_len = (duk_uarridx_t) duk_get_length(thr, idx_keys); + emitted = 0; + for (i = 0; i < arr_len; i++) { + duk_get_prop_index(thr, idx_keys, i); /* -> [ ... key ] */ + + DUK_DDD(DUK_DDDPRINT("object property loop: holder=%!T, key=%!T", + (duk_tval *) duk_get_tval(thr, idx_obj), + (duk_tval *) duk_get_tval(thr, -1))); + + h_key = duk_known_hstring(thr, -1); + DUK_ASSERT(h_key != NULL); + DUK_ASSERT(!DUK_HSTRING_HAS_SYMBOL(h_key)); /* proplist filtering; enum options */ + + prev_size = DUK_BW_GET_SIZE(js_ctx->thr, &js_ctx->bw); + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth); + duk__json_enc_key_autoquote(js_ctx, h_key); + DUK__EMIT_2(js_ctx, DUK_ASC_COLON, DUK_ASC_SPACE); + } else { + duk__json_enc_key_autoquote(js_ctx, h_key); + DUK__EMIT_1(js_ctx, DUK_ASC_COLON); + } + + /* [ ... key ] */ + + if (DUK_UNLIKELY(duk__json_enc_value(js_ctx, idx_obj) == 0)) { + /* Value would yield 'undefined', so skip key altogether. + * Side effects have already happened. + */ + DUK_BW_SET_SIZE(js_ctx->thr, &js_ctx->bw, prev_size); + } else { + DUK__EMIT_1(js_ctx, DUK_ASC_COMMA); + emitted = 1; + } + + /* [ ... ] */ + } + + if (emitted) { + DUK_ASSERT(*((duk_uint8_t *) DUK_BW_GET_PTR(js_ctx->thr, &js_ctx->bw) - 1) == DUK_ASC_COMMA); + DUK__UNEMIT_1(js_ctx); /* eat trailing comma */ + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + DUK_ASSERT(js_ctx->recursion_depth >= 1); + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth - 1U); + } + } + DUK__EMIT_1(js_ctx, DUK_ASC_RCURLY); + + duk__json_enc_objarr_exit(js_ctx, &entry_top); + + DUK_ASSERT_TOP(thr, entry_top); +} + +/* The JA(value) operation: encode array. + * + * Stack policy: [ array ] -> [ array ]. + */ +DUK_LOCAL void duk__json_enc_array(duk_json_enc_ctx *js_ctx) { + duk_hthread *thr = js_ctx->thr; + duk_idx_t entry_top; + duk_idx_t idx_arr; + duk_bool_t emitted; + duk_uarridx_t i, arr_len; + + DUK_DDD(DUK_DDDPRINT("duk__json_enc_array: array=%!T", (duk_tval *) duk_get_tval(thr, -1))); + + duk__json_enc_objarr_entry(js_ctx, &entry_top); + + idx_arr = entry_top - 1; + + /* Steps 8-10 have been merged to avoid a "partial" variable. */ + + DUK__EMIT_1(js_ctx, DUK_ASC_LBRACKET); + + arr_len = (duk_uarridx_t) duk_get_length(thr, idx_arr); + emitted = 0; + for (i = 0; i < arr_len; i++) { + DUK_DDD(DUK_DDDPRINT("array entry loop: array=%!T, index=%ld, arr_len=%ld", + (duk_tval *) duk_get_tval(thr, idx_arr), + (long) i, + (long) arr_len)); + + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + DUK_ASSERT(js_ctx->recursion_depth >= 1); + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth); + } + + (void) duk_push_uint_to_hstring(thr, (duk_uint_t) i); /* -> [ ... key ] */ + + /* [ ... key ] */ + + if (DUK_UNLIKELY(duk__json_enc_value(js_ctx, idx_arr) == 0)) { + /* Value would normally be omitted, replace with 'null'. */ + DUK__EMIT_STRIDX(js_ctx, DUK_STRIDX_LC_NULL); + } else { + ; + } + + /* [ ... ] */ + + DUK__EMIT_1(js_ctx, DUK_ASC_COMMA); + emitted = 1; + } + + if (emitted) { + DUK_ASSERT(*((duk_uint8_t *) DUK_BW_GET_PTR(js_ctx->thr, &js_ctx->bw) - 1) == DUK_ASC_COMMA); + DUK__UNEMIT_1(js_ctx); /* eat trailing comma */ + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + DUK_ASSERT(js_ctx->recursion_depth >= 1); + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth - 1U); + } + } + DUK__EMIT_1(js_ctx, DUK_ASC_RBRACKET); + + duk__json_enc_objarr_exit(js_ctx, &entry_top); + + DUK_ASSERT_TOP(thr, entry_top); +} + +/* The Str(key, holder) operation. + * + * Stack policy: [ ... key ] -> [ ... ] + */ +DUK_LOCAL duk_bool_t duk__json_enc_value(duk_json_enc_ctx *js_ctx, duk_idx_t idx_holder) { + duk_hthread *thr = js_ctx->thr; + duk_tval *tv; + duk_tval *tv_holder; + duk_tval *tv_key; + duk_small_int_t c; + + DUK_DDD(DUK_DDDPRINT("duk__json_enc_value: idx_holder=%ld, holder=%!T, key=%!T", + (long) idx_holder, + (duk_tval *) duk_get_tval(thr, idx_holder), + (duk_tval *) duk_get_tval(thr, -1))); + + tv_holder = DUK_GET_TVAL_POSIDX(thr, idx_holder); + DUK_ASSERT(DUK_TVAL_IS_OBJECT(tv_holder)); + tv_key = DUK_GET_TVAL_NEGIDX(thr, -1); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv_key)); + DUK_ASSERT(!DUK_HSTRING_HAS_SYMBOL(DUK_TVAL_GET_STRING(tv_key))); /* Caller responsible. */ + (void) duk_hobject_getprop(thr, tv_holder, tv_key); + + /* -> [ ... key val ] */ + + DUK_DDD(DUK_DDDPRINT("value=%!T", (duk_tval *) duk_get_tval(thr, -1))); + + /* Standard JSON checks for .toJSON() only for actual objects; for + * example, setting Number.prototype.toJSON and then serializing a + * number won't invoke the .toJSON() method. However, lightfuncs and + * plain buffers mimic objects so we check for their .toJSON() method. + */ + if (duk_check_type_mask(thr, -1, DUK_TYPE_MASK_OBJECT | DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER)) { + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_TO_JSON); + if (duk_is_callable(thr, -1)) { /* toJSON() can also be a lightfunc */ + DUK_DDD(DUK_DDDPRINT("value is object, has callable toJSON() -> call it")); + /* XXX: duk_dup_unvalidated(thr, -2) etc. */ + duk_dup_m2(thr); /* -> [ ... key val toJSON val ] */ + duk_dup_m4(thr); /* -> [ ... key val toJSON val key ] */ + duk_call_method(thr, 1); /* -> [ ... key val val' ] */ + duk_remove_m2(thr); /* -> [ ... key val' ] */ + } else { + duk_pop(thr); /* -> [ ... key val ] */ + } + } + + /* [ ... key val ] */ + + DUK_DDD(DUK_DDDPRINT("value=%!T", (duk_tval *) duk_get_tval(thr, -1))); + + if (js_ctx->h_replacer) { + /* XXX: Here a "slice copy" would be useful. */ + DUK_DDD(DUK_DDDPRINT("replacer is set, call replacer")); + duk_push_hobject(thr, js_ctx->h_replacer); /* -> [ ... key val replacer ] */ + duk_dup(thr, idx_holder); /* -> [ ... key val replacer holder ] */ + duk_dup_m4(thr); /* -> [ ... key val replacer holder key ] */ + duk_dup_m4(thr); /* -> [ ... key val replacer holder key val ] */ + duk_call_method(thr, 2); /* -> [ ... key val val' ] */ + duk_remove_m2(thr); /* -> [ ... key val' ] */ + } + + /* [ ... key val ] */ + + DUK_DDD(DUK_DDDPRINT("value=%!T", (duk_tval *) duk_get_tval(thr, -1))); + + tv = DUK_GET_TVAL_NEGIDX(thr, -1); + if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h; + + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + if (DUK_HOBJECT_IS_BUFOBJ(h) && js_ctx->flags & (DUK_JSON_FLAG_EXT_CUSTOM | DUK_JSON_FLAG_EXT_COMPATIBLE)) { + /* With JX/JC a bufferobject gets serialized specially. */ + duk_hbufobj *h_bufobj; + h_bufobj = (duk_hbufobj *) h; + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + duk__json_enc_bufobj(js_ctx, h_bufobj); + goto pop2_emitted; + } + /* Otherwise bufferobjects get serialized as normal objects. */ +#endif /* JX || JC */ +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + c = (duk_small_int_t) DUK_HOBJECT_GET_CLASS_NUMBER(h); + switch (c) { + case DUK_HOBJECT_CLASS_NUMBER: { + DUK_DDD(DUK_DDDPRINT("value is a Number object -> coerce with ToNumber()")); + duk_to_number_m1(thr); + /* The coercion potentially invokes user .valueOf() and .toString() + * but can't result in a function value because ToPrimitive() would + * reject such a result: test-dev-json-stringify-coercion-1.js. + */ + DUK_ASSERT(!duk_is_callable(thr, -1)); + break; + } + case DUK_HOBJECT_CLASS_STRING: { + DUK_DDD(DUK_DDDPRINT("value is a String object -> coerce with ToString()")); + duk_to_string(thr, -1); + /* Same coercion behavior as for Number. */ + DUK_ASSERT(!duk_is_callable(thr, -1)); + break; + } +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + case DUK_HOBJECT_CLASS_POINTER: +#endif + case DUK_HOBJECT_CLASS_BOOLEAN: { + DUK_DDD(DUK_DDDPRINT("value is a Boolean/Buffer/Pointer object -> get internal value")); + duk_xget_owndataprop_stridx_short(thr, -1, DUK_STRIDX_INT_VALUE); + duk_remove_m2(thr); + break; + } + default: { + /* Normal object which doesn't get automatically coerced to a + * primitive value. Functions are checked for specially. The + * primitive value coercions for Number, String, Pointer, and + * Boolean can't result in functions so suffices to check here. + * Symbol objects are handled like plain objects (their primitive + * value is NOT looked up like for e.g. String objects). + */ + DUK_ASSERT(h != NULL); + if (DUK_HOBJECT_IS_CALLABLE(h)) { +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + if (js_ctx->flags & (DUK_JSON_FLAG_EXT_CUSTOM | DUK_JSON_FLAG_EXT_COMPATIBLE)) { + /* We only get here when doing non-standard JSON encoding */ + DUK_DDD(DUK_DDDPRINT("-> function allowed, serialize to custom format")); + DUK_ASSERT(js_ctx->flag_ext_custom || js_ctx->flag_ext_compatible); + DUK__EMIT_STRIDX(js_ctx, js_ctx->stridx_custom_function); + goto pop2_emitted; + } else { + DUK_DDD(DUK_DDDPRINT("-> will result in undefined (function)")); + goto pop2_undef; + } +#else /* DUK_USE_JX || DUK_USE_JC */ + DUK_DDD(DUK_DDDPRINT("-> will result in undefined (function)")); + goto pop2_undef; +#endif /* DUK_USE_JX || DUK_USE_JC */ + } + } + } /* end switch */ + } + + /* [ ... key val ] */ + + DUK_DDD(DUK_DDDPRINT("value=%!T", (duk_tval *) duk_get_tval(thr, -1))); + + if (duk_check_type_mask(thr, -1, js_ctx->mask_for_undefined)) { + /* will result in undefined */ + DUK_DDD(DUK_DDDPRINT("-> will result in undefined (type mask check)")); + goto pop2_undef; + } + tv = DUK_GET_TVAL_NEGIDX(thr, -1); + + switch (DUK_TVAL_GET_TAG(tv)) { +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + /* When JX/JC not in use, the type mask above will avoid this case if needed. */ + case DUK_TAG_UNDEFINED: { + DUK__EMIT_STRIDX(js_ctx, js_ctx->stridx_custom_undefined); + break; + } +#endif + case DUK_TAG_NULL: { + DUK__EMIT_STRIDX(js_ctx, DUK_STRIDX_LC_NULL); + break; + } + case DUK_TAG_BOOLEAN: { + DUK__EMIT_STRIDX(js_ctx, DUK_TVAL_GET_BOOLEAN(tv) ? DUK_STRIDX_TRUE : DUK_STRIDX_FALSE); + break; + } +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + /* When JX/JC not in use, the type mask above will avoid this case if needed. */ + case DUK_TAG_POINTER: { + duk__json_enc_pointer(js_ctx, DUK_TVAL_GET_POINTER(tv)); + break; + } +#endif /* DUK_USE_JX || DUK_USE_JC */ + case DUK_TAG_STRING: { + duk_hstring *h = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h != NULL); + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + goto pop2_undef; + } + duk__json_enc_quote_string(js_ctx, h); + break; + } + case DUK_TAG_OBJECT: { + duk_hobject *h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + + /* Function values are handled completely above (including + * coercion results): + */ + DUK_ASSERT(!DUK_HOBJECT_IS_CALLABLE(h)); + + if (duk_js_isarray_hobject(h)) { + duk__json_enc_array(js_ctx); + } else { + duk__json_enc_object(js_ctx); + } + break; + } + /* Because plain buffers mimics Uint8Array, they have enumerable + * index properties [0,byteLength[. Because JSON only serializes + * enumerable own properties, no properties can be serialized for + * plain buffers (all virtual properties are non-enumerable). However, + * there may be a .toJSON() method which was already handled above. + */ + case DUK_TAG_BUFFER: { +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + if (js_ctx->flag_ext_custom_or_compatible) { + duk__json_enc_buffer_jx_jc(js_ctx, DUK_TVAL_GET_BUFFER(tv)); + break; + } +#endif + + /* Could implement a fastpath, but the fast path would need + * to handle realloc side effects correctly. + */ + duk_to_object(thr, -1); + duk__json_enc_object(js_ctx); + break; + } + case DUK_TAG_LIGHTFUNC: { +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + /* We only get here when doing non-standard JSON encoding */ + DUK_ASSERT(js_ctx->flag_ext_custom || js_ctx->flag_ext_compatible); + DUK__EMIT_STRIDX(js_ctx, js_ctx->stridx_custom_function); +#else + /* Standard JSON omits functions */ + DUK_UNREACHABLE(); +#endif + break; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: + /* Number serialization has a significant impact relative to + * other fast path code, so careful fast path for fastints. + */ + duk__json_enc_fastint_tval(js_ctx, tv); + break; +#endif + default: { + /* number */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + /* XXX: A fast path for usual integers would be useful when + * fastint support is not enabled. + */ + duk__json_enc_double(js_ctx); + break; + } + } + +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) +pop2_emitted: +#endif + duk_pop_2(thr); /* [ ... key val ] -> [ ... ] */ + return 1; /* emitted */ + +pop2_undef: + duk_pop_2(thr); /* [ ... key val ] -> [ ... ] */ + return 0; /* not emitted */ +} + +/* E5 Section 15.12.3, main algorithm, step 4.b.ii steps 1-4. */ +DUK_LOCAL duk_bool_t duk__json_enc_allow_into_proplist(duk_tval *tv) { + duk_small_int_t c; + + /* XXX: some kind of external internal type checker? + * - type mask; symbol flag; class mask + */ + DUK_ASSERT(tv != NULL); + if (DUK_TVAL_IS_STRING(tv)) { + duk_hstring *h; + h = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h != NULL); + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + return 0; + } + return 1; + } else if (DUK_TVAL_IS_NUMBER(tv)) { + return 1; + } else if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h; + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + c = (duk_small_int_t) DUK_HOBJECT_GET_CLASS_NUMBER(h); + if (c == DUK_HOBJECT_CLASS_STRING || c == DUK_HOBJECT_CLASS_NUMBER) { + return 1; + } + } + + return 0; +} + +/* + * JSON.stringify() fast path + * + * Otherwise supports full JSON, JX, and JC features, but bails out on any + * possible side effect which might change the value being serialized. The + * fast path can take advantage of the fact that the value being serialized + * is unchanged so that we can walk directly through property tables etc. + */ + +#if defined(DUK_USE_JSON_STRINGIFY_FASTPATH) +DUK_LOCAL duk_bool_t duk__json_stringify_fast_value(duk_json_enc_ctx *js_ctx, duk_tval *tv) { + duk_uint_fast32_t i, n; + + DUK_DDD(DUK_DDDPRINT("stringify fast: %!T", tv)); + + DUK_ASSERT(js_ctx != NULL); + DUK_ASSERT(js_ctx->thr != NULL); + +#if 0 /* disabled for now */ + restart_match: +#endif + + DUK_ASSERT(tv != NULL); + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNDEFINED: { +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + if (js_ctx->flag_ext_custom || js_ctx->flag_ext_compatible) { + DUK__EMIT_STRIDX(js_ctx, js_ctx->stridx_custom_undefined); + break; + } else { + goto emit_undefined; + } +#else + goto emit_undefined; +#endif + } + case DUK_TAG_NULL: { + DUK__EMIT_STRIDX(js_ctx, DUK_STRIDX_LC_NULL); + break; + } + case DUK_TAG_BOOLEAN: { + DUK__EMIT_STRIDX(js_ctx, DUK_TVAL_GET_BOOLEAN(tv) ? DUK_STRIDX_TRUE : DUK_STRIDX_FALSE); + break; + } + case DUK_TAG_STRING: { + duk_hstring *h; + h = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h != NULL); + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + goto emit_undefined; + } + duk__json_enc_quote_string(js_ctx, h); + break; + } + case DUK_TAG_OBJECT: { + duk_hobject *obj; + duk_tval *tv_val; + duk_bool_t emitted = 0; + duk_uint32_t c_bit, c_all, c_array, c_unbox, c_undef, c_func, c_bufobj, c_object, c_abort; + + /* For objects JSON.stringify() only looks for own, enumerable + * properties which is nice for the fast path here. + * + * For arrays JSON.stringify() uses [[Get]] so it will actually + * inherit properties during serialization! This fast path + * supports gappy arrays as long as there's no actual inherited + * property (which might be a getter etc). + * + * Since recursion only happens for objects, we can have both + * recursion and loop checks here. We use a simple, depth-limited + * loop check in the fast path because the object-based tracking + * is very slow (when tested, it accounted for 50% of fast path + * execution time for input data with a lot of small objects!). + */ + + /* XXX: for real world code, could just ignore array inheritance + * and only look at array own properties. + */ + + /* We rely on a few object flag / class number relationships here, + * assert for them. + */ + + obj = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(obj != NULL); + DUK_HOBJECT_ASSERT_VALID(obj); + + /* Once recursion depth is increased, exit path must decrease + * it (though it's OK to abort the fast path). + */ + + DUK_ASSERT_DISABLE(js_ctx->recursion_depth >= 0); /* unsigned */ + DUK_ASSERT(js_ctx->recursion_depth <= js_ctx->recursion_limit); + if (js_ctx->recursion_depth >= js_ctx->recursion_limit) { + DUK_DD(DUK_DDPRINT("fast path recursion limit")); + DUK_ERROR_RANGE(js_ctx->thr, DUK_STR_DEC_RECLIMIT); + DUK_WO_NORETURN(return 0;); + } + + for (i = 0, n = (duk_uint_fast32_t) js_ctx->recursion_depth; i < n; i++) { + if (DUK_UNLIKELY(js_ctx->visiting[i] == obj)) { + DUK_DD(DUK_DDPRINT("fast path loop detect")); + DUK_ERROR_TYPE(js_ctx->thr, DUK_STR_CYCLIC_INPUT); + DUK_WO_NORETURN(return 0;); + } + } + + /* Guaranteed by recursion_limit setup so we don't have to + * check twice. + */ + DUK_ASSERT(js_ctx->recursion_depth < DUK_JSON_ENC_LOOPARRAY); + js_ctx->visiting[js_ctx->recursion_depth] = obj; + js_ctx->recursion_depth++; + + /* If object has a .toJSON() property, we can't be certain + * that it wouldn't mutate any value arbitrarily, so bail + * out of the fast path. + * + * If an object is a Proxy we also can't avoid side effects + * so abandon. + */ + /* XXX: non-callable .toJSON() doesn't need to cause an abort + * but does at the moment, probably not worth fixing. + */ + if (duk_hobject_hasprop_raw(js_ctx->thr, obj, DUK_HTHREAD_STRING_TO_JSON(js_ctx->thr)) || + DUK_HOBJECT_IS_PROXY(obj)) { + DUK_DD(DUK_DDPRINT("object has a .toJSON property or object is a Proxy, abort fast path")); + goto abort_fastpath; + } + + /* We could use a switch-case for the class number but it turns out + * a small if-else ladder on class masks is better. The if-ladder + * should be in order of relevancy. + */ + + /* XXX: move masks to js_ctx? they don't change during one + * fast path invocation. + */ + DUK_ASSERT(DUK_HOBJECT_CLASS_MAX <= 31); +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + if (js_ctx->flag_ext_custom_or_compatible) { + c_all = DUK_HOBJECT_CMASK_ALL; + c_array = DUK_HOBJECT_CMASK_ARRAY; + c_unbox = DUK_HOBJECT_CMASK_NUMBER | DUK_HOBJECT_CMASK_STRING | DUK_HOBJECT_CMASK_BOOLEAN | + DUK_HOBJECT_CMASK_POINTER; /* Symbols are not unboxed. */ + c_func = DUK_HOBJECT_CMASK_FUNCTION; + c_bufobj = DUK_HOBJECT_CMASK_ALL_BUFOBJS; + c_undef = 0; + c_abort = 0; + c_object = c_all & ~(c_array | c_unbox | c_func | c_bufobj | c_undef | c_abort); + } else +#endif + { + c_all = DUK_HOBJECT_CMASK_ALL; + c_array = DUK_HOBJECT_CMASK_ARRAY; + c_unbox = DUK_HOBJECT_CMASK_NUMBER | DUK_HOBJECT_CMASK_STRING | + DUK_HOBJECT_CMASK_BOOLEAN; /* Symbols are not unboxed. */ + c_func = 0; + c_bufobj = 0; + c_undef = DUK_HOBJECT_CMASK_FUNCTION | DUK_HOBJECT_CMASK_POINTER; + /* As the fast path doesn't currently properly support + * duk_hbufobj virtual properties, abort fast path if + * we encounter them in plain JSON mode. + */ + c_abort = DUK_HOBJECT_CMASK_ALL_BUFOBJS; + c_object = c_all & ~(c_array | c_unbox | c_func | c_bufobj | c_undef | c_abort); + } + + c_bit = (duk_uint32_t) DUK_HOBJECT_GET_CLASS_MASK(obj); + if (c_bit & c_object) { + /* All other object types. */ + DUK__EMIT_1(js_ctx, DUK_ASC_LCURLY); + + /* A non-Array object should not have an array part in practice. + * But since it is supported internally (and perhaps used at some + * point), check and abandon if that's the case. + */ + if (DUK_HOBJECT_HAS_ARRAY_PART(obj)) { + DUK_DD(DUK_DDPRINT("non-Array object has array part, abort fast path")); + goto abort_fastpath; + } + + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ENEXT(obj); i++) { + duk_hstring *k; + duk_size_t prev_size; + + k = DUK_HOBJECT_E_GET_KEY(js_ctx->thr->heap, obj, i); + if (!k) { + continue; + } + if (DUK_HSTRING_HAS_ARRIDX(k)) { + /* If an object has array index keys we would need + * to sort them into the ES2015 enumeration order to + * be consistent with the slow path. Abort the fast + * path and handle in the slow path for now. + */ + DUK_DD(DUK_DDPRINT("property key is an array index, abort fast path")); + goto abort_fastpath; + } + if (!DUK_HOBJECT_E_SLOT_IS_ENUMERABLE(js_ctx->thr->heap, obj, i)) { + continue; + } + if (DUK_HOBJECT_E_SLOT_IS_ACCESSOR(js_ctx->thr->heap, obj, i)) { + /* Getter might have arbitrary side effects, + * so bail out. + */ + DUK_DD(DUK_DDPRINT("property is an accessor, abort fast path")); + goto abort_fastpath; + } + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(k))) { + continue; + } + + tv_val = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(js_ctx->thr->heap, obj, i); + + prev_size = DUK_BW_GET_SIZE(js_ctx->thr, &js_ctx->bw); + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth); + duk__json_enc_key_autoquote(js_ctx, k); + DUK__EMIT_2(js_ctx, DUK_ASC_COLON, DUK_ASC_SPACE); + } else { + duk__json_enc_key_autoquote(js_ctx, k); + DUK__EMIT_1(js_ctx, DUK_ASC_COLON); + } + + if (duk__json_stringify_fast_value(js_ctx, tv_val) == 0) { + DUK_DD(DUK_DDPRINT("prop value not supported, rewind key and colon")); + DUK_BW_SET_SIZE(js_ctx->thr, &js_ctx->bw, prev_size); + } else { + DUK__EMIT_1(js_ctx, DUK_ASC_COMMA); + emitted = 1; + } + } + + /* If any non-Array value had enumerable virtual own + * properties, they should be serialized here (actually, + * before the explicit properties). Standard types don't. + */ + + if (emitted) { + DUK_ASSERT(*((duk_uint8_t *) DUK_BW_GET_PTR(js_ctx->thr, &js_ctx->bw) - 1) == DUK_ASC_COMMA); + DUK__UNEMIT_1(js_ctx); /* eat trailing comma */ + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + DUK_ASSERT(js_ctx->recursion_depth >= 1); + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth - 1U); + } + } + DUK__EMIT_1(js_ctx, DUK_ASC_RCURLY); + } else if (c_bit & c_array) { + duk_uint_fast32_t arr_len; + duk_uint_fast32_t asize; + + DUK__EMIT_1(js_ctx, DUK_ASC_LBRACKET); + + /* Assume arrays are dense in the fast path. */ + if (!DUK_HOBJECT_HAS_ARRAY_PART(obj)) { + DUK_DD(DUK_DDPRINT("Array object is sparse, abort fast path")); + goto abort_fastpath; + } + + arr_len = (duk_uint_fast32_t) ((duk_harray *) obj)->length; + asize = (duk_uint_fast32_t) DUK_HOBJECT_GET_ASIZE(obj); + /* Array part may be larger than 'length'; if so, iterate + * only up to array 'length'. Array part may also be smaller + * than 'length' in some cases. + */ + for (i = 0; i < arr_len; i++) { + duk_tval *tv_arrval; + duk_hstring *h_tmp; + duk_bool_t has_inherited; + + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth); + } + + if (DUK_LIKELY(i < asize)) { + tv_arrval = DUK_HOBJECT_A_GET_VALUE_PTR(js_ctx->thr->heap, obj, i); + if (DUK_LIKELY(!DUK_TVAL_IS_UNUSED(tv_arrval))) { + /* Expected case: element is present. */ + if (duk__json_stringify_fast_value(js_ctx, tv_arrval) == 0) { + DUK__EMIT_STRIDX(js_ctx, DUK_STRIDX_LC_NULL); + } + goto elem_done; + } + } + + /* Gap in array; check for inherited property, + * bail out if one exists. This should be enough + * to support gappy arrays for all practical code. + */ + + h_tmp = duk_push_uint_to_hstring(js_ctx->thr, (duk_uint_t) i); + has_inherited = duk_hobject_hasprop_raw(js_ctx->thr, obj, h_tmp); + duk_pop(js_ctx->thr); + if (has_inherited) { + DUK_D(DUK_DPRINT("gap in array, conflicting inherited property, abort fast path")); + goto abort_fastpath; + } + + /* Ordinary gap, undefined encodes to 'null' in + * standard JSON, but JX/JC use their form for + * undefined to better preserve the typing. + */ + DUK_D(DUK_DPRINT("gap in array, no conflicting inherited property, remain on fast path")); +#if defined(DUK_USE_JX) + DUK__EMIT_STRIDX(js_ctx, js_ctx->stridx_custom_undefined); +#else + DUK__EMIT_STRIDX(js_ctx, DUK_STRIDX_LC_NULL); +#endif + /* fall through */ + + elem_done: + DUK__EMIT_1(js_ctx, DUK_ASC_COMMA); + emitted = 1; + } + + if (emitted) { + DUK_ASSERT(*((duk_uint8_t *) DUK_BW_GET_PTR(js_ctx->thr, &js_ctx->bw) - 1) == DUK_ASC_COMMA); + DUK__UNEMIT_1(js_ctx); /* eat trailing comma */ + if (DUK_UNLIKELY(js_ctx->h_gap != NULL)) { + DUK_ASSERT(js_ctx->recursion_depth >= 1); + duk__json_enc_newline_indent(js_ctx, js_ctx->recursion_depth - 1U); + } + } + DUK__EMIT_1(js_ctx, DUK_ASC_RBRACKET); + } else if (c_bit & c_unbox) { + /* Certain boxed types are required to go through + * automatic unboxing. Rely on internal value being + * sane (to avoid infinite recursion). + */ + DUK_ASSERT((c_bit & DUK_HOBJECT_CMASK_SYMBOL) == 0); /* Symbols are not unboxed. */ + +#if 1 + /* The code below is incorrect if .toString() or .valueOf() have + * have been overridden. The correct approach would be to look up + * the method(s) and if they resolve to the built-in function we + * can safely bypass it and look up the internal value directly. + * Unimplemented for now, abort fast path for boxed values. + */ + goto abort_fastpath; +#else /* disabled */ + /* Disabled until fixed, see above. */ + duk_tval *tv_internal; + + DUK_DD(DUK_DDPRINT("auto unboxing in fast path")); + + tv_internal = duk_hobject_get_internal_value_tval_ptr(js_ctx->thr->heap, obj); + DUK_ASSERT(tv_internal != NULL); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv_internal) || DUK_TVAL_IS_NUMBER(tv_internal) || + DUK_TVAL_IS_BOOLEAN(tv_internal) || DUK_TVAL_IS_POINTER(tv_internal)); + + tv = tv_internal; + DUK_ASSERT(js_ctx->recursion_depth > 0); + js_ctx->recursion_depth--; /* required to keep recursion depth correct */ + goto restart_match; +#endif /* disabled */ +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + } else if (c_bit & c_func) { + DUK__EMIT_STRIDX(js_ctx, js_ctx->stridx_custom_function); +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + } else if (c_bit & c_bufobj) { + duk__json_enc_bufobj(js_ctx, (duk_hbufobj *) obj); +#endif +#endif + } else if (c_bit & c_abort) { + DUK_DD(DUK_DDPRINT("abort fast path for unsupported type")); + goto abort_fastpath; + } else { + DUK_ASSERT((c_bit & c_undef) != 0); + + /* Must decrease recursion depth before returning. */ + DUK_ASSERT(js_ctx->recursion_depth > 0); + DUK_ASSERT(js_ctx->recursion_depth <= js_ctx->recursion_limit); + js_ctx->recursion_depth--; + goto emit_undefined; + } + + DUK_ASSERT(js_ctx->recursion_depth > 0); + DUK_ASSERT(js_ctx->recursion_depth <= js_ctx->recursion_limit); + js_ctx->recursion_depth--; + break; + } + case DUK_TAG_BUFFER: { + /* Plain buffers are treated like Uint8Arrays: they have + * enumerable indices. Other virtual properties are not + * enumerable, and inherited properties are not serialized. + * However, there can be a replacer (not relevant here) or + * a .toJSON() method (which we need to check for explicitly). + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + if (duk_hobject_hasprop_raw(js_ctx->thr, + js_ctx->thr->builtins[DUK_BIDX_UINT8ARRAY_PROTOTYPE], + DUK_HTHREAD_STRING_TO_JSON(js_ctx->thr))) { + DUK_DD(DUK_DDPRINT("value is a plain buffer and there's an inherited .toJSON, abort fast path")); + goto abort_fastpath; + } +#endif + +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + if (js_ctx->flag_ext_custom_or_compatible) { + duk__json_enc_buffer_jx_jc(js_ctx, DUK_TVAL_GET_BUFFER(tv)); + break; + } +#endif + + /* Plain buffers mimic Uint8Arrays, and have enumerable index + * properties. + */ + duk__json_enc_buffer_json_fastpath(js_ctx, DUK_TVAL_GET_BUFFER(tv)); + break; + } + case DUK_TAG_POINTER: { +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + if (js_ctx->flag_ext_custom_or_compatible) { + duk__json_enc_pointer(js_ctx, DUK_TVAL_GET_POINTER(tv)); + break; + } else { + goto emit_undefined; + } +#else + goto emit_undefined; +#endif + } + case DUK_TAG_LIGHTFUNC: { + /* A lightfunc might also inherit a .toJSON() so just bail out. */ + /* XXX: Could just lookup .toJSON() and continue in fast path, + * as it would almost never be defined. + */ + DUK_DD(DUK_DDPRINT("value is a lightfunc, abort fast path")); + goto abort_fastpath; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: { + /* Number serialization has a significant impact relative to + * other fast path code, so careful fast path for fastints. + */ + duk__json_enc_fastint_tval(js_ctx, tv); + break; + } +#endif + default: { + /* XXX: A fast path for usual integers would be useful when + * fastint support is not enabled. + */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + + /* XXX: Stack discipline is annoying, could be changed in numconv. */ + duk_push_tval(js_ctx->thr, tv); + duk__json_enc_double(js_ctx); + duk_pop(js_ctx->thr); + +#if 0 + /* Could also rely on native sprintf(), but it will handle + * values like NaN, Infinity, -0, exponent notation etc in + * a JSON-incompatible way. + */ + duk_double_t d; + char buf[64]; + + DUK_ASSERT(DUK_TVAL_IS_DOUBLE(tv)); + d = DUK_TVAL_GET_DOUBLE(tv); + DUK_SPRINTF(buf, "%lg", d); + DUK__EMIT_CSTR(js_ctx, buf); +#endif + } + } + return 1; /* not undefined */ + +emit_undefined: + return 0; /* value was undefined/unsupported */ + +abort_fastpath: + /* Error message doesn't matter: the error is ignored anyway. */ + DUK_DD(DUK_DDPRINT("aborting fast path")); + DUK_ERROR_INTERNAL(js_ctx->thr); + DUK_WO_NORETURN(return 0;); +} + +DUK_LOCAL duk_ret_t duk__json_stringify_fast(duk_hthread *thr, void *udata) { + duk_json_enc_ctx *js_ctx; + duk_tval *tv; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(udata != NULL); + + js_ctx = (duk_json_enc_ctx *) udata; + DUK_ASSERT(js_ctx != NULL); + + tv = DUK_GET_TVAL_NEGIDX(thr, -1); + if (duk__json_stringify_fast_value(js_ctx, tv) == 0) { + DUK_DD(DUK_DDPRINT("top level value not supported, fail fast path")); + DUK_DCERROR_TYPE_INVALID_ARGS(thr); /* Error message is ignored, so doesn't matter. */ + } + + return 0; +} +#endif /* DUK_USE_JSON_STRINGIFY_FASTPATH */ + +/* + * Top level wrappers + */ + +DUK_INTERNAL +void duk_bi_json_parse_helper(duk_hthread *thr, duk_idx_t idx_value, duk_idx_t idx_reviver, duk_small_uint_t flags) { + duk_json_dec_ctx js_ctx_alloc; + duk_json_dec_ctx *js_ctx = &js_ctx_alloc; + duk_hstring *h_text; +#if defined(DUK_USE_ASSERTIONS) + duk_idx_t entry_top = duk_get_top(thr); +#endif + + /* negative top-relative indices not allowed now */ + DUK_ASSERT(idx_value == DUK_INVALID_INDEX || idx_value >= 0); + DUK_ASSERT(idx_reviver == DUK_INVALID_INDEX || idx_reviver >= 0); + + DUK_DDD(DUK_DDDPRINT("JSON parse start: text=%!T, reviver=%!T, flags=0x%08lx, stack_top=%ld", + (duk_tval *) duk_get_tval(thr, idx_value), + (duk_tval *) duk_get_tval(thr, idx_reviver), + (unsigned long) flags, + (long) duk_get_top(thr))); + + duk_memzero(&js_ctx_alloc, sizeof(js_ctx_alloc)); + js_ctx->thr = thr; +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + /* nothing now */ +#endif + js_ctx->recursion_limit = DUK_USE_JSON_DEC_RECLIMIT; + DUK_ASSERT(js_ctx->recursion_depth == 0); + + /* Flag handling currently assumes that flags are consistent. This is OK + * because the call sites are now strictly controlled. + */ + + js_ctx->flags = flags; +#if defined(DUK_USE_JX) + js_ctx->flag_ext_custom = flags & DUK_JSON_FLAG_EXT_CUSTOM; +#endif +#if defined(DUK_USE_JC) + js_ctx->flag_ext_compatible = flags & DUK_JSON_FLAG_EXT_COMPATIBLE; +#endif +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + js_ctx->flag_ext_custom_or_compatible = flags & (DUK_JSON_FLAG_EXT_CUSTOM | DUK_JSON_FLAG_EXT_COMPATIBLE); +#endif + + h_text = duk_to_hstring(thr, idx_value); /* coerce in-place; rejects Symbols */ + DUK_ASSERT(h_text != NULL); + + /* JSON parsing code is allowed to read [p_start,p_end]: p_end is + * valid and points to the string NUL terminator (which is always + * guaranteed for duk_hstrings. + */ + js_ctx->p_start = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_text); + js_ctx->p = js_ctx->p_start; + js_ctx->p_end = ((const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_text)) + DUK_HSTRING_GET_BYTELEN(h_text); + DUK_ASSERT(*(js_ctx->p_end) == 0x00); + + duk__json_dec_value(js_ctx); /* -> [ ... value ] */ + DUK_ASSERT(js_ctx->recursion_depth == 0); + + /* Trailing whitespace has been eaten by duk__json_dec_value(), so if + * we're not at end of input here, it's a SyntaxError. + */ + + if (js_ctx->p != js_ctx->p_end) { + duk__json_dec_syntax_error(js_ctx); + } + + if (duk_is_callable(thr, idx_reviver)) { + DUK_DDD(DUK_DDDPRINT("applying reviver: %!T", (duk_tval *) duk_get_tval(thr, idx_reviver))); + + js_ctx->idx_reviver = idx_reviver; + + duk_push_object(thr); + duk_dup_m2(thr); /* -> [ ... val root val ] */ + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_EMPTY_STRING); /* default attrs ok */ + duk_push_hstring_stridx(thr, DUK_STRIDX_EMPTY_STRING); /* -> [ ... val root "" ] */ + + DUK_DDD(DUK_DDDPRINT("start reviver walk, root=%!T, name=%!T", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + + DUK_ASSERT(js_ctx->recursion_depth == 0); + duk__json_dec_reviver_walk(js_ctx); /* [ ... val root "" ] -> [ ... val val' ] */ + DUK_ASSERT(js_ctx->recursion_depth == 0); + duk_remove_m2(thr); /* -> [ ... val' ] */ + } else { + DUK_DDD( + DUK_DDDPRINT("reviver does not exist or is not callable: %!T", (duk_tval *) duk_get_tval(thr, idx_reviver))); + } + + /* Final result is at stack top. */ + + DUK_DDD(DUK_DDDPRINT("JSON parse end: text=%!T, reviver=%!T, flags=0x%08lx, result=%!T, stack_top=%ld", + (duk_tval *) duk_get_tval(thr, idx_value), + (duk_tval *) duk_get_tval(thr, idx_reviver), + (unsigned long) flags, + (duk_tval *) duk_get_tval(thr, -1), + (long) duk_get_top(thr))); + + DUK_ASSERT(duk_get_top(thr) == entry_top + 1); +} + +DUK_INTERNAL +void duk_bi_json_stringify_helper(duk_hthread *thr, + duk_idx_t idx_value, + duk_idx_t idx_replacer, + duk_idx_t idx_space, + duk_small_uint_t flags) { + duk_json_enc_ctx js_ctx_alloc; + duk_json_enc_ctx *js_ctx = &js_ctx_alloc; + duk_hobject *h; + duk_idx_t idx_holder; + duk_idx_t entry_top; + + /* negative top-relative indices not allowed now */ + DUK_ASSERT(idx_value == DUK_INVALID_INDEX || idx_value >= 0); + DUK_ASSERT(idx_replacer == DUK_INVALID_INDEX || idx_replacer >= 0); + DUK_ASSERT(idx_space == DUK_INVALID_INDEX || idx_space >= 0); + + DUK_DDD(DUK_DDDPRINT("JSON stringify start: value=%!T, replacer=%!T, space=%!T, flags=0x%08lx, stack_top=%ld", + (duk_tval *) duk_get_tval(thr, idx_value), + (duk_tval *) duk_get_tval(thr, idx_replacer), + (duk_tval *) duk_get_tval(thr, idx_space), + (unsigned long) flags, + (long) duk_get_top(thr))); + + entry_top = duk_get_top(thr); + + /* + * Context init + */ + + duk_memzero(&js_ctx_alloc, sizeof(js_ctx_alloc)); + js_ctx->thr = thr; +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + js_ctx->h_replacer = NULL; + js_ctx->h_gap = NULL; +#endif + js_ctx->idx_proplist = -1; + + /* Flag handling currently assumes that flags are consistent. This is OK + * because the call sites are now strictly controlled. + */ + + js_ctx->flags = flags; + js_ctx->flag_ascii_only = flags & DUK_JSON_FLAG_ASCII_ONLY; + js_ctx->flag_avoid_key_quotes = flags & DUK_JSON_FLAG_AVOID_KEY_QUOTES; +#if defined(DUK_USE_JX) + js_ctx->flag_ext_custom = flags & DUK_JSON_FLAG_EXT_CUSTOM; +#endif +#if defined(DUK_USE_JC) + js_ctx->flag_ext_compatible = flags & DUK_JSON_FLAG_EXT_COMPATIBLE; +#endif +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + js_ctx->flag_ext_custom_or_compatible = flags & (DUK_JSON_FLAG_EXT_CUSTOM | DUK_JSON_FLAG_EXT_COMPATIBLE); +#endif + + /* The #if defined() clutter here handles the JX/JC enable/disable + * combinations properly. + */ +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + js_ctx->stridx_custom_undefined = DUK_STRIDX_LC_NULL; /* standard JSON; array gaps */ +#if defined(DUK_USE_JX) + if (flags & DUK_JSON_FLAG_EXT_CUSTOM) { + js_ctx->stridx_custom_undefined = DUK_STRIDX_LC_UNDEFINED; + js_ctx->stridx_custom_nan = DUK_STRIDX_NAN; + js_ctx->stridx_custom_neginf = DUK_STRIDX_MINUS_INFINITY; + js_ctx->stridx_custom_posinf = DUK_STRIDX_INFINITY; + js_ctx->stridx_custom_function = + (flags & DUK_JSON_FLAG_AVOID_KEY_QUOTES) ? DUK_STRIDX_JSON_EXT_FUNCTION2 : DUK_STRIDX_JSON_EXT_FUNCTION1; + } +#endif /* DUK_USE_JX */ +#if defined(DUK_USE_JX) && defined(DUK_USE_JC) + else +#endif /* DUK_USE_JX && DUK_USE_JC */ +#if defined(DUK_USE_JC) + if (js_ctx->flags & DUK_JSON_FLAG_EXT_COMPATIBLE) { + js_ctx->stridx_custom_undefined = DUK_STRIDX_JSON_EXT_UNDEFINED; + js_ctx->stridx_custom_nan = DUK_STRIDX_JSON_EXT_NAN; + js_ctx->stridx_custom_neginf = DUK_STRIDX_JSON_EXT_NEGINF; + js_ctx->stridx_custom_posinf = DUK_STRIDX_JSON_EXT_POSINF; + js_ctx->stridx_custom_function = DUK_STRIDX_JSON_EXT_FUNCTION1; + } +#endif /* DUK_USE_JC */ +#endif /* DUK_USE_JX || DUK_USE_JC */ + +#if defined(DUK_USE_JX) || defined(DUK_USE_JC) + if (js_ctx->flags & (DUK_JSON_FLAG_EXT_CUSTOM | DUK_JSON_FLAG_EXT_COMPATIBLE)) { + DUK_ASSERT(js_ctx->mask_for_undefined == 0); /* already zero */ + } else +#endif /* DUK_USE_JX || DUK_USE_JC */ + { + /* Plain buffer is treated like ArrayBuffer and serialized. + * Lightfuncs are treated like objects, but JSON explicitly + * skips serializing Function objects so we can just reject + * lightfuncs here. + */ + js_ctx->mask_for_undefined = DUK_TYPE_MASK_UNDEFINED | DUK_TYPE_MASK_POINTER | DUK_TYPE_MASK_LIGHTFUNC; + } + + DUK_BW_INIT_PUSHBUF(thr, &js_ctx->bw, DUK__JSON_STRINGIFY_BUFSIZE); + + js_ctx->idx_loop = duk_push_bare_object(thr); + DUK_ASSERT(js_ctx->idx_loop >= 0); + + /* [ ... buf loop ] */ + + /* + * Process replacer/proplist (2nd argument to JSON.stringify) + */ + + h = duk_get_hobject(thr, idx_replacer); + if (h != NULL) { + if (DUK_HOBJECT_IS_CALLABLE(h)) { + js_ctx->h_replacer = h; + } else if (duk_js_isarray_hobject(h)) { + /* Here the specification requires correct array index enumeration + * which is a bit tricky for sparse arrays (it is handled by the + * enum setup code). We now enumerate ancestors too, although the + * specification is not very clear on whether that is required. + */ + + duk_uarridx_t plist_idx = 0; + duk_small_uint_t enum_flags; + + js_ctx->idx_proplist = duk_push_bare_array(thr); + + enum_flags = DUK_ENUM_ARRAY_INDICES_ONLY | DUK_ENUM_SORT_ARRAY_INDICES; /* expensive flag */ + duk_enum(thr, idx_replacer, enum_flags); + while (duk_next(thr, -1 /*enum_index*/, 1 /*get_value*/)) { + /* [ ... proplist enum_obj key val ] */ + if (duk__json_enc_allow_into_proplist(duk_get_tval(thr, -1))) { + /* XXX: duplicates should be eliminated here */ + DUK_DDD(DUK_DDDPRINT("proplist enum: key=%!T, val=%!T --> accept", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + duk_to_string(thr, -1); /* extra coercion of strings is OK */ + duk_put_prop_index(thr, -4, plist_idx); /* -> [ ... proplist enum_obj key ] */ + plist_idx++; + duk_pop(thr); + } else { + DUK_DDD(DUK_DDDPRINT("proplist enum: key=%!T, val=%!T --> reject", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + duk_pop_2(thr); + } + } + duk_pop(thr); /* pop enum */ + + /* [ ... proplist ] */ + } + } + + /* [ ... buf loop (proplist) ] */ + + /* + * Process space (3rd argument to JSON.stringify) + */ + + h = duk_get_hobject(thr, idx_space); + if (h != NULL) { + duk_small_uint_t c = DUK_HOBJECT_GET_CLASS_NUMBER(h); + if (c == DUK_HOBJECT_CLASS_NUMBER) { + duk_to_number(thr, idx_space); + } else if (c == DUK_HOBJECT_CLASS_STRING) { + duk_to_string(thr, idx_space); + } + } + + if (duk_is_number(thr, idx_space)) { + duk_small_int_t nspace; + /* spaces[] must be static to allow initializer with old compilers like BCC */ + static const char spaces[10] = { + DUK_ASC_SPACE, DUK_ASC_SPACE, DUK_ASC_SPACE, DUK_ASC_SPACE, DUK_ASC_SPACE, + DUK_ASC_SPACE, DUK_ASC_SPACE, DUK_ASC_SPACE, DUK_ASC_SPACE, DUK_ASC_SPACE + }; /* XXX: helper */ + + /* ToInteger() coercion; NaN -> 0, infinities are clamped to 0 and 10 */ + nspace = (duk_small_int_t) duk_to_int_clamped(thr, idx_space, 0 /*minval*/, 10 /*maxval*/); + DUK_ASSERT(nspace >= 0 && nspace <= 10); + + duk_push_lstring(thr, spaces, (duk_size_t) nspace); + js_ctx->h_gap = duk_known_hstring(thr, -1); + DUK_ASSERT(js_ctx->h_gap != NULL); + } else if (duk_is_string_notsymbol(thr, idx_space)) { + duk_dup(thr, idx_space); + duk_substring(thr, -1, 0, 10); /* clamp to 10 chars */ + js_ctx->h_gap = duk_known_hstring(thr, -1); + } else { + /* nop */ + } + + if (js_ctx->h_gap != NULL) { + /* If gap is empty, behave as if not given at all. Check + * against byte length because character length is more + * expensive. + */ + if (DUK_HSTRING_GET_BYTELEN(js_ctx->h_gap) == 0) { + js_ctx->h_gap = NULL; + } + } + + /* [ ... buf loop (proplist) (gap) ] */ + + /* + * Fast path: assume no mutation, iterate object property tables + * directly; bail out if that assumption doesn't hold. + */ + +#if defined(DUK_USE_JSON_STRINGIFY_FASTPATH) + if (js_ctx->h_replacer == NULL && /* replacer is a mutation risk */ + js_ctx->idx_proplist == -1) { /* proplist is very rare */ + duk_int_t pcall_rc; + duk_small_uint_t prev_ms_base_flags; + + DUK_DD(DUK_DDPRINT("try JSON.stringify() fast path")); + + /* Use recursion_limit to ensure we don't overwrite js_ctx->visiting[] + * array so we don't need two counter checks in the fast path. The + * slow path has a much larger recursion limit which we'll use if + * necessary. + */ + DUK_ASSERT(DUK_USE_JSON_ENC_RECLIMIT >= DUK_JSON_ENC_LOOPARRAY); + js_ctx->recursion_limit = DUK_JSON_ENC_LOOPARRAY; + DUK_ASSERT(js_ctx->recursion_depth == 0); + + /* Execute the fast path in a protected call. If any error is thrown, + * fall back to the slow path. This includes e.g. recursion limit + * because the fast path has a smaller recursion limit (and simpler, + * limited loop detection). + */ + + duk_dup(thr, idx_value); + + /* Must prevent finalizers which may have arbitrary side effects. */ + prev_ms_base_flags = thr->heap->ms_base_flags; + thr->heap->ms_base_flags |= DUK_MS_FLAG_NO_OBJECT_COMPACTION; /* Avoid attempt to compact any objects. */ + thr->heap->pf_prevent_count++; /* Prevent finalizers. */ + DUK_ASSERT(thr->heap->pf_prevent_count != 0); /* Wrap. */ + + pcall_rc = duk_safe_call(thr, duk__json_stringify_fast, (void *) js_ctx /*udata*/, 1 /*nargs*/, 0 /*nret*/); + + DUK_ASSERT(thr->heap->pf_prevent_count > 0); + thr->heap->pf_prevent_count--; + thr->heap->ms_base_flags = prev_ms_base_flags; + + if (pcall_rc == DUK_EXEC_SUCCESS) { + DUK_DD(DUK_DDPRINT("fast path successful")); + DUK_BW_PUSH_AS_STRING(thr, &js_ctx->bw); + goto replace_finished; + } + + /* We come here for actual aborts (like encountering .toJSON()) + * but also for recursion/loop errors. Bufwriter size can be + * kept because we'll probably need at least as much as we've + * allocated so far. + */ + DUK_D(DUK_DPRINT("fast path failed, serialize using slow path instead")); + DUK_BW_RESET_SIZE(thr, &js_ctx->bw); + js_ctx->recursion_depth = 0; + } +#endif + + /* + * Create wrapper object and serialize + */ + + idx_holder = duk_push_object(thr); + duk_dup(thr, idx_value); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_EMPTY_STRING); + + DUK_DDD(DUK_DDDPRINT("before: flags=0x%08lx, loop=%!T, replacer=%!O, " + "proplist=%!T, gap=%!O, holder=%!T", + (unsigned long) js_ctx->flags, + (duk_tval *) duk_get_tval(thr, js_ctx->idx_loop), + (duk_heaphdr *) js_ctx->h_replacer, + (duk_tval *) (js_ctx->idx_proplist >= 0 ? duk_get_tval(thr, js_ctx->idx_proplist) : NULL), + (duk_heaphdr *) js_ctx->h_gap, + (duk_tval *) duk_get_tval(thr, -1))); + + /* serialize the wrapper with empty string key */ + + duk_push_hstring_empty(thr); + + /* [ ... buf loop (proplist) (gap) holder "" ] */ + + js_ctx->recursion_limit = DUK_USE_JSON_ENC_RECLIMIT; + DUK_ASSERT(js_ctx->recursion_depth == 0); + + if (DUK_UNLIKELY(duk__json_enc_value(js_ctx, idx_holder) == 0)) { /* [ ... holder key ] -> [ ... holder ] */ + /* Result is undefined. */ + duk_push_undefined(thr); + } else { + /* Convert buffer to result string. */ + DUK_BW_PUSH_AS_STRING(thr, &js_ctx->bw); + } + + DUK_DDD(DUK_DDDPRINT("after: flags=0x%08lx, loop=%!T, replacer=%!O, " + "proplist=%!T, gap=%!O, holder=%!T", + (unsigned long) js_ctx->flags, + (duk_tval *) duk_get_tval(thr, js_ctx->idx_loop), + (duk_heaphdr *) js_ctx->h_replacer, + (duk_tval *) (js_ctx->idx_proplist >= 0 ? duk_get_tval(thr, js_ctx->idx_proplist) : NULL), + (duk_heaphdr *) js_ctx->h_gap, + (duk_tval *) duk_get_tval(thr, idx_holder))); + + /* The stack has a variable shape here, so force it to the + * desired one explicitly. + */ + +#if defined(DUK_USE_JSON_STRINGIFY_FASTPATH) +replace_finished: +#endif + duk_replace(thr, entry_top); + duk_set_top(thr, entry_top + 1); + + DUK_DDD(DUK_DDDPRINT("JSON stringify end: value=%!T, replacer=%!T, space=%!T, " + "flags=0x%08lx, result=%!T, stack_top=%ld", + (duk_tval *) duk_get_tval(thr, idx_value), + (duk_tval *) duk_get_tval(thr, idx_replacer), + (duk_tval *) duk_get_tval(thr, idx_space), + (unsigned long) flags, + (duk_tval *) duk_get_tval(thr, -1), + (long) duk_get_top(thr))); + + DUK_ASSERT(duk_get_top(thr) == entry_top + 1); +} + +#if defined(DUK_USE_JSON_BUILTIN) + +/* + * Entry points + */ + +DUK_INTERNAL duk_ret_t duk_bi_json_object_parse(duk_hthread *thr) { + duk_bi_json_parse_helper(thr, 0 /*idx_value*/, 1 /*idx_replacer*/, 0 /*flags*/); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_json_object_stringify(duk_hthread *thr) { + duk_bi_json_stringify_helper(thr, 0 /*idx_value*/, 1 /*idx_replacer*/, 2 /*idx_space*/, 0 /*flags*/); + return 1; +} + +#endif /* DUK_USE_JSON_BUILTIN */ + +#endif /* DUK_USE_JSON_SUPPORT */ + +/* automatic undefs */ +#undef DUK__EMIT_1 +#undef DUK__EMIT_2 +#undef DUK__EMIT_CSTR +#undef DUK__EMIT_HSTR +#undef DUK__EMIT_STRIDX +#undef DUK__JSON_DECSTR_BUFSIZE +#undef DUK__JSON_DECSTR_CHUNKSIZE +#undef DUK__JSON_ENCSTR_CHUNKSIZE +#undef DUK__JSON_MAX_ESC_LEN +#undef DUK__JSON_STRINGIFY_BUFSIZE +#undef DUK__MKESC +#undef DUK__UNEMIT_1 +#line 1 "duk_bi_math.c" +/* + * Math built-ins + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_MATH_BUILTIN) + +/* + * Use static helpers which can work with math.h functions matching + * the following signatures. This is not portable if any of these math + * functions is actually a macro. + * + * Typing here is intentionally 'double' wherever values interact with + * the standard library APIs. + */ + +typedef double (*duk__one_arg_func)(double); +typedef double (*duk__two_arg_func)(double, double); + +DUK_LOCAL duk_ret_t duk__math_minmax(duk_hthread *thr, duk_double_t initial, duk__two_arg_func min_max) { + duk_idx_t n = duk_get_top(thr); + duk_idx_t i; + duk_double_t res = initial; + duk_double_t t; + + /* + * Note: fmax() does not match the E5 semantics. E5 requires + * that if -any- input to Math.max() is a NaN, the result is a + * NaN. fmax() will return a NaN only if -both- inputs are NaN. + * Same applies to fmin(). + * + * Note: every input value must be coerced with ToNumber(), even + * if we know the result will be a NaN anyway: ToNumber() may have + * side effects for which even order of evaluation matters. + */ + + for (i = 0; i < n; i++) { + t = duk_to_number(thr, i); + if (DUK_FPCLASSIFY(t) == DUK_FP_NAN || DUK_FPCLASSIFY(res) == DUK_FP_NAN) { + /* Note: not normalized, but duk_push_number() will normalize */ + res = (duk_double_t) DUK_DOUBLE_NAN; + } else { + res = (duk_double_t) min_max(res, (double) t); + } + } + + duk_push_number(thr, res); + return 1; +} + +DUK_LOCAL double duk__fmin_fixed(double x, double y) { + /* fmin() with args -0 and +0 is not guaranteed to return + * -0 as ECMAScript requires. + */ + if (duk_double_equals(x, 0.0) && duk_double_equals(y, 0.0)) { + duk_double_union du1, du2; + du1.d = x; + du2.d = y; + + /* Already checked to be zero so these must hold, and allow us + * to check for "x is -0 or y is -0" by ORing the high parts + * for comparison. + */ + DUK_ASSERT(du1.ui[DUK_DBL_IDX_UI0] == 0 || du1.ui[DUK_DBL_IDX_UI0] == 0x80000000UL); + DUK_ASSERT(du2.ui[DUK_DBL_IDX_UI0] == 0 || du2.ui[DUK_DBL_IDX_UI0] == 0x80000000UL); + + /* XXX: what's the safest way of creating a negative zero? */ + if ((du1.ui[DUK_DBL_IDX_UI0] | du2.ui[DUK_DBL_IDX_UI0]) != 0) { + /* Enter here if either x or y (or both) is -0. */ + return -0.0; + } else { + return +0.0; + } + } + return duk_double_fmin(x, y); +} + +DUK_LOCAL double duk__fmax_fixed(double x, double y) { + /* fmax() with args -0 and +0 is not guaranteed to return + * +0 as ECMAScript requires. + */ + if (duk_double_equals(x, 0.0) && duk_double_equals(y, 0.0)) { + if (DUK_SIGNBIT(x) == 0 || DUK_SIGNBIT(y) == 0) { + return +0.0; + } else { + return -0.0; + } + } + return duk_double_fmax(x, y); +} + +#if defined(DUK_USE_ES6) +DUK_LOCAL double duk__cbrt(double x) { + /* cbrt() is C99. To avoid hassling embedders with the need to provide a + * cube root function, we can get by with pow(). The result is not + * identical, but that's OK: ES2015 says it's implementation-dependent. + */ + +#if defined(DUK_CBRT) + /* cbrt() matches ES2015 requirements. */ + return DUK_CBRT(x); +#else + duk_small_int_t c = (duk_small_int_t) DUK_FPCLASSIFY(x); + + /* pow() does not, however. */ + if (c == DUK_FP_NAN || c == DUK_FP_INFINITE || c == DUK_FP_ZERO) { + return x; + } + if (DUK_SIGNBIT(x)) { + return -DUK_POW(-x, 1.0 / 3.0); + } else { + return DUK_POW(x, 1.0 / 3.0); + } +#endif +} + +DUK_LOCAL double duk__log2(double x) { +#if defined(DUK_LOG2) + return DUK_LOG2(x); +#else + return DUK_LOG(x) * DUK_DOUBLE_LOG2E; +#endif +} + +DUK_LOCAL double duk__log10(double x) { +#if defined(DUK_LOG10) + return DUK_LOG10(x); +#else + return DUK_LOG(x) * DUK_DOUBLE_LOG10E; +#endif +} + +DUK_LOCAL double duk__trunc(double x) { +#if defined(DUK_TRUNC) + return DUK_TRUNC(x); +#else + /* Handles -0 correctly: -0.0 matches 'x >= 0.0' but floor() + * is required to return -0 when the argument is -0. + */ + return x >= 0.0 ? DUK_FLOOR(x) : DUK_CEIL(x); +#endif +} +#endif /* DUK_USE_ES6 */ + +DUK_LOCAL double duk__round_fixed(double x) { + /* Numbers half-way between integers must be rounded towards +Infinity, + * e.g. -3.5 must be rounded to -3 (not -4). When rounded to zero, zero + * sign must be set appropriately. E5.1 Section 15.8.2.15. + * + * Note that ANSI C round() is "round to nearest integer, away from zero", + * which is incorrect for negative values. Here we make do with floor(). + */ + + duk_small_int_t c = (duk_small_int_t) DUK_FPCLASSIFY(x); + if (c == DUK_FP_NAN || c == DUK_FP_INFINITE || c == DUK_FP_ZERO) { + return x; + } + + /* + * x is finite and non-zero + * + * -1.6 -> floor(-1.1) -> -2 + * -1.5 -> floor(-1.0) -> -1 (towards +Inf) + * -1.4 -> floor(-0.9) -> -1 + * -0.5 -> -0.0 (special case) + * -0.1 -> -0.0 (special case) + * +0.1 -> +0.0 (special case) + * +0.5 -> floor(+1.0) -> 1 (towards +Inf) + * +1.4 -> floor(+1.9) -> 1 + * +1.5 -> floor(+2.0) -> 2 (towards +Inf) + * +1.6 -> floor(+2.1) -> 2 + */ + + if (x >= -0.5 && x < 0.5) { + /* +0.5 is handled by floor, this is on purpose */ + if (x < 0.0) { + return -0.0; + } else { + return +0.0; + } + } + + return DUK_FLOOR(x + 0.5); +} + +/* Wrappers for calling standard math library methods. These may be required + * on platforms where one or more of the math built-ins are defined as macros + * or inline functions and are thus not suitable to be used as function pointers. + */ +#if defined(DUK_USE_AVOID_PLATFORM_FUNCPTRS) +DUK_LOCAL double duk__fabs(double x) { + return DUK_FABS(x); +} +DUK_LOCAL double duk__acos(double x) { + return DUK_ACOS(x); +} +DUK_LOCAL double duk__asin(double x) { + return DUK_ASIN(x); +} +DUK_LOCAL double duk__atan(double x) { + return DUK_ATAN(x); +} +DUK_LOCAL double duk__ceil(double x) { + return DUK_CEIL(x); +} +DUK_LOCAL double duk__cos(double x) { + return DUK_COS(x); +} +DUK_LOCAL double duk__exp(double x) { + return DUK_EXP(x); +} +DUK_LOCAL double duk__floor(double x) { + return DUK_FLOOR(x); +} +DUK_LOCAL double duk__log(double x) { + return DUK_LOG(x); +} +DUK_LOCAL double duk__sin(double x) { + return DUK_SIN(x); +} +DUK_LOCAL double duk__sqrt(double x) { + return DUK_SQRT(x); +} +DUK_LOCAL double duk__tan(double x) { + return DUK_TAN(x); +} +DUK_LOCAL double duk__atan2_fixed(double x, double y) { +#if defined(DUK_USE_ATAN2_WORKAROUNDS) + /* Specific fixes to common atan2() implementation issues: + * - test-bug-mingw-math-issues.js + */ + if (DUK_ISINF(x) && DUK_ISINF(y)) { + if (DUK_SIGNBIT(x)) { + if (DUK_SIGNBIT(y)) { + return -2.356194490192345; + } else { + return -0.7853981633974483; + } + } else { + if (DUK_SIGNBIT(y)) { + return 2.356194490192345; + } else { + return 0.7853981633974483; + } + } + } +#else + /* Some ISO C assumptions. */ + + DUK_ASSERT(duk_double_equals(DUK_ATAN2(DUK_DOUBLE_INFINITY, DUK_DOUBLE_INFINITY), 0.7853981633974483)); + DUK_ASSERT(duk_double_equals(DUK_ATAN2(-DUK_DOUBLE_INFINITY, DUK_DOUBLE_INFINITY), -0.7853981633974483)); + DUK_ASSERT(duk_double_equals(DUK_ATAN2(DUK_DOUBLE_INFINITY, -DUK_DOUBLE_INFINITY), 2.356194490192345)); + DUK_ASSERT(duk_double_equals(DUK_ATAN2(-DUK_DOUBLE_INFINITY, -DUK_DOUBLE_INFINITY), -2.356194490192345)); +#endif + + return DUK_ATAN2(x, y); +} +#endif /* DUK_USE_AVOID_PLATFORM_FUNCPTRS */ + +/* order must match constants in genbuiltins.py */ +DUK_LOCAL const duk__one_arg_func duk__one_arg_funcs[] = { +#if defined(DUK_USE_AVOID_PLATFORM_FUNCPTRS) + duk__fabs, duk__acos, duk__asin, duk__atan, duk__ceil, duk__cos, duk__exp, + duk__floor, duk__log, duk__round_fixed, duk__sin, duk__sqrt, duk__tan, +#if defined(DUK_USE_ES6) + duk__cbrt, duk__log2, duk__log10, duk__trunc +#endif +#else /* DUK_USE_AVOID_PLATFORM_FUNCPTRS */ + DUK_FABS, DUK_ACOS, DUK_ASIN, DUK_ATAN, DUK_CEIL, DUK_COS, DUK_EXP, + DUK_FLOOR, DUK_LOG, duk__round_fixed, DUK_SIN, DUK_SQRT, DUK_TAN, +#if defined(DUK_USE_ES6) + duk__cbrt, duk__log2, duk__log10, duk__trunc +#endif +#endif /* DUK_USE_AVOID_PLATFORM_FUNCPTRS */ +}; + +/* order must match constants in genbuiltins.py */ +DUK_LOCAL const duk__two_arg_func duk__two_arg_funcs[] = { +#if defined(DUK_USE_AVOID_PLATFORM_FUNCPTRS) + duk__atan2_fixed, + duk_js_arith_pow +#else + duk__atan2_fixed, + duk_js_arith_pow +#endif +}; + +DUK_INTERNAL duk_ret_t duk_bi_math_object_onearg_shared(duk_hthread *thr) { + duk_small_int_t fun_idx = duk_get_current_magic(thr); + duk__one_arg_func fun; + duk_double_t arg1; + + DUK_ASSERT(fun_idx >= 0); + DUK_ASSERT(fun_idx < (duk_small_int_t) (sizeof(duk__one_arg_funcs) / sizeof(duk__one_arg_func))); + arg1 = duk_to_number(thr, 0); + fun = duk__one_arg_funcs[fun_idx]; + duk_push_number(thr, (duk_double_t) fun((double) arg1)); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_math_object_twoarg_shared(duk_hthread *thr) { + duk_small_int_t fun_idx = duk_get_current_magic(thr); + duk__two_arg_func fun; + duk_double_t arg1; + duk_double_t arg2; + + DUK_ASSERT(fun_idx >= 0); + DUK_ASSERT(fun_idx < (duk_small_int_t) (sizeof(duk__two_arg_funcs) / sizeof(duk__two_arg_func))); + arg1 = duk_to_number(thr, 0); /* explicit ordered evaluation to match coercion semantics */ + arg2 = duk_to_number(thr, 1); + fun = duk__two_arg_funcs[fun_idx]; + duk_push_number(thr, (duk_double_t) fun((double) arg1, (double) arg2)); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_math_object_max(duk_hthread *thr) { + return duk__math_minmax(thr, -DUK_DOUBLE_INFINITY, duk__fmax_fixed); +} + +DUK_INTERNAL duk_ret_t duk_bi_math_object_min(duk_hthread *thr) { + return duk__math_minmax(thr, DUK_DOUBLE_INFINITY, duk__fmin_fixed); +} + +DUK_INTERNAL duk_ret_t duk_bi_math_object_random(duk_hthread *thr) { + duk_push_number(thr, (duk_double_t) duk_util_get_random_double(thr)); + return 1; +} + +#if defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_math_object_hypot(duk_hthread *thr) { + /* + * E6 Section 20.2.2.18: Math.hypot + * + * - If no arguments are passed, the result is +0. + * - If any argument is +inf, the result is +inf. + * - If any argument is -inf, the result is +inf. + * - If no argument is +inf or -inf, and any argument is NaN, the result is + * NaN. + * - If all arguments are either +0 or -0, the result is +0. + */ + + duk_idx_t nargs; + duk_idx_t i; + duk_bool_t found_nan; + duk_double_t max; + duk_double_t sum, summand; + duk_double_t comp, prelim; + duk_double_t t; + + nargs = duk_get_top(thr); + + /* Find the highest value. Also ToNumber() coerces. */ + max = 0.0; + found_nan = 0; + for (i = 0; i < nargs; i++) { + t = DUK_FABS(duk_to_number(thr, i)); + if (DUK_FPCLASSIFY(t) == DUK_FP_NAN) { + found_nan = 1; + } else { + max = duk_double_fmax(max, t); + } + } + + /* Early return cases. */ + if (duk_double_equals(max, DUK_DOUBLE_INFINITY)) { + duk_push_number(thr, DUK_DOUBLE_INFINITY); + return 1; + } else if (found_nan) { + duk_push_number(thr, DUK_DOUBLE_NAN); + return 1; + } else if (duk_double_equals(max, 0.0)) { + duk_push_number(thr, 0.0); + /* Otherwise we'd divide by zero. */ + return 1; + } + + /* Use Kahan summation and normalize to the highest value to minimize + * floating point rounding error and avoid overflow. + * + * https://en.wikipedia.org/wiki/Kahan_summation_algorithm + */ + sum = 0.0; + comp = 0.0; + for (i = 0; i < nargs; i++) { + t = DUK_FABS(duk_get_number(thr, i)) / max; + summand = (t * t) - comp; + prelim = sum + summand; + comp = (prelim - sum) - summand; + sum = prelim; + } + + duk_push_number(thr, (duk_double_t) DUK_SQRT(sum) * max); + return 1; +} +#endif /* DUK_USE_ES6 */ + +#if defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_math_object_sign(duk_hthread *thr) { + duk_double_t d; + + d = duk_to_number(thr, 0); + if (duk_double_is_nan(d)) { + DUK_ASSERT(duk_is_nan(thr, -1)); + return 1; /* NaN input -> return NaN */ + } + if (duk_double_equals(d, 0.0)) { + /* Zero sign kept, i.e. -0 -> -0, +0 -> +0. */ + return 1; + } + duk_push_int(thr, (d > 0.0 ? 1 : -1)); + return 1; +} +#endif /* DUK_USE_ES6 */ + +#if defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_math_object_clz32(duk_hthread *thr) { + duk_uint32_t x; + duk_small_uint_t i; + +#if defined(DUK_USE_PREFER_SIZE) + duk_uint32_t mask; + + x = duk_to_uint32(thr, 0); + for (i = 0, mask = 0x80000000UL; mask != 0; mask >>= 1) { + if (x & mask) { + break; + } + i++; + } + DUK_ASSERT(i <= 32); + duk_push_uint(thr, i); + return 1; +#else /* DUK_USE_PREFER_SIZE */ + i = 0; + x = duk_to_uint32(thr, 0); + if (x & 0xffff0000UL) { + x >>= 16; + } else { + i += 16; + } + if (x & 0x0000ff00UL) { + x >>= 8; + } else { + i += 8; + } + if (x & 0x000000f0UL) { + x >>= 4; + } else { + i += 4; + } + if (x & 0x0000000cUL) { + x >>= 2; + } else { + i += 2; + } + if (x & 0x00000002UL) { + x >>= 1; + } else { + i += 1; + } + if (x & 0x00000001UL) { + ; + } else { + i += 1; + } + DUK_ASSERT(i <= 32); + duk_push_uint(thr, i); + return 1; +#endif /* DUK_USE_PREFER_SIZE */ +} +#endif /* DUK_USE_ES6 */ + +#if defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_math_object_imul(duk_hthread *thr) { + duk_uint32_t x, y, z; + + x = duk_to_uint32(thr, 0); + y = duk_to_uint32(thr, 1); + z = x * y; + + /* While arguments are ToUint32() coerced and the multiplication + * is unsigned as such, the final result is curiously interpreted + * as a signed 32-bit value. + */ + duk_push_i32(thr, (duk_int32_t) z); + return 1; +} +#endif /* DUK_USE_ES6 */ + +#endif /* DUK_USE_MATH_BUILTIN */ +#line 1 "duk_bi_number.c" +/* + * Number built-ins + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_NUMBER_BUILTIN) + +DUK_LOCAL duk_double_t duk__push_this_number_plain(duk_hthread *thr) { + duk_hobject *h; + + /* Number built-in accepts a plain number or a Number object (whose + * internal value is operated on). Other types cause TypeError. + */ + + duk_push_this(thr); + if (duk_is_number(thr, -1)) { + DUK_DDD(DUK_DDDPRINT("plain number value: %!T", (duk_tval *) duk_get_tval(thr, -1))); + goto done; + } + h = duk_get_hobject(thr, -1); + if (!h || (DUK_HOBJECT_GET_CLASS_NUMBER(h) != DUK_HOBJECT_CLASS_NUMBER)) { + DUK_DDD(DUK_DDDPRINT("unacceptable this value: %!T", (duk_tval *) duk_get_tval(thr, -1))); + DUK_ERROR_TYPE(thr, "number expected"); + DUK_WO_NORETURN(return 0.0;); + } + duk_xget_owndataprop_stridx_short(thr, -1, DUK_STRIDX_INT_VALUE); + DUK_ASSERT(duk_is_number(thr, -1)); + DUK_DDD(DUK_DDDPRINT("number object: %!T, internal value: %!T", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + duk_remove_m2(thr); + +done: + return duk_get_number(thr, -1); +} + +DUK_INTERNAL duk_ret_t duk_bi_number_constructor(duk_hthread *thr) { + duk_idx_t nargs; + duk_hobject *h_this; + + /* + * The Number constructor uses ToNumber(arg) for number coercion + * (coercing an undefined argument to NaN). However, if the + * argument is not given at all, +0 must be used instead. To do + * this, a vararg function is used. + */ + + nargs = duk_get_top(thr); + if (nargs == 0) { + duk_push_int(thr, 0); + } + duk_to_number(thr, 0); + duk_set_top(thr, 1); + DUK_ASSERT_TOP(thr, 1); + + if (!duk_is_constructor_call(thr)) { + return 1; + } + + /* + * E5 Section 15.7.2.1 requires that the constructed object + * must have the original Number.prototype as its internal + * prototype. However, since Number.prototype is non-writable + * and non-configurable, this doesn't have to be enforced here: + * The default object (bound to 'this') is OK, though we have + * to change its class. + * + * Internal value set to ToNumber(arg) or +0; if no arg given, + * ToNumber(undefined) = NaN, so special treatment is needed + * (above). String internal value is immutable. + */ + + /* XXX: helper */ + duk_push_this(thr); + h_this = duk_known_hobject(thr, -1); + DUK_HOBJECT_SET_CLASS_NUMBER(h_this, DUK_HOBJECT_CLASS_NUMBER); + + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h_this) == thr->builtins[DUK_BIDX_NUMBER_PROTOTYPE]); + DUK_ASSERT(DUK_HOBJECT_GET_CLASS_NUMBER(h_this) == DUK_HOBJECT_CLASS_NUMBER); + DUK_ASSERT(DUK_HOBJECT_HAS_EXTENSIBLE(h_this)); + + duk_dup_0(thr); /* -> [ val obj val ] */ + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_VALUE, DUK_PROPDESC_FLAGS_NONE); + return 0; /* no return value -> don't replace created value */ +} + +DUK_INTERNAL duk_ret_t duk_bi_number_prototype_value_of(duk_hthread *thr) { + (void) duk__push_this_number_plain(thr); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_number_prototype_to_string(duk_hthread *thr) { + duk_small_int_t radix; + duk_small_uint_t n2s_flags; + + (void) duk__push_this_number_plain(thr); + if (duk_is_undefined(thr, 0)) { + radix = 10; + } else { + radix = (duk_small_int_t) duk_to_int_check_range(thr, 0, 2, 36); + } + DUK_DDD(DUK_DDDPRINT("radix=%ld", (long) radix)); + + n2s_flags = 0; + + duk_numconv_stringify(thr, radix /*radix*/, 0 /*digits*/, n2s_flags /*flags*/); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_number_prototype_to_locale_string(duk_hthread *thr) { + /* XXX: just use toString() for now; permitted although not recommended. + * nargs==1, so radix is passed to toString(). + */ + return duk_bi_number_prototype_to_string(thr); +} + +/* + * toFixed(), toExponential(), toPrecision() + */ + +/* XXX: shared helper for toFixed(), toExponential(), toPrecision()? */ + +DUK_INTERNAL duk_ret_t duk_bi_number_prototype_to_fixed(duk_hthread *thr) { + duk_small_int_t frac_digits; + duk_double_t d; + duk_small_int_t c; + duk_small_uint_t n2s_flags; + + /* In ES5.1 frac_digits is coerced first; in ES2015 the 'this number + * value' check is done first. + */ + d = duk__push_this_number_plain(thr); + frac_digits = (duk_small_int_t) duk_to_int_check_range(thr, 0, 0, 20); + + c = (duk_small_int_t) DUK_FPCLASSIFY(d); + if (c == DUK_FP_NAN || c == DUK_FP_INFINITE) { + goto use_to_string; + } + + if (d >= 1.0e21 || d <= -1.0e21) { + goto use_to_string; + } + + n2s_flags = DUK_N2S_FLAG_FIXED_FORMAT | DUK_N2S_FLAG_FRACTION_DIGITS; + + duk_numconv_stringify(thr, 10 /*radix*/, frac_digits /*digits*/, n2s_flags /*flags*/); + return 1; + +use_to_string: + DUK_ASSERT_TOP(thr, 2); + duk_to_string(thr, -1); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_number_prototype_to_exponential(duk_hthread *thr) { + duk_bool_t frac_undefined; + duk_small_int_t frac_digits; + duk_double_t d; + duk_small_int_t c; + duk_small_uint_t n2s_flags; + + d = duk__push_this_number_plain(thr); + + frac_undefined = duk_is_undefined(thr, 0); + duk_to_int(thr, 0); /* for side effects */ + + c = (duk_small_int_t) DUK_FPCLASSIFY(d); + if (c == DUK_FP_NAN || c == DUK_FP_INFINITE) { + goto use_to_string; + } + + frac_digits = (duk_small_int_t) duk_to_int_check_range(thr, 0, 0, 20); + + n2s_flags = DUK_N2S_FLAG_FORCE_EXP | (frac_undefined ? 0 : DUK_N2S_FLAG_FIXED_FORMAT); + + duk_numconv_stringify(thr, 10 /*radix*/, frac_digits + 1 /*leading digit + fractions*/, n2s_flags /*flags*/); + return 1; + +use_to_string: + DUK_ASSERT_TOP(thr, 2); + duk_to_string(thr, -1); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_number_prototype_to_precision(duk_hthread *thr) { + /* The specification has quite awkward order of coercion and + * checks for toPrecision(). The operations below are a bit + * reordered, within constraints of observable side effects. + */ + + duk_double_t d; + duk_small_int_t prec; + duk_small_int_t c; + duk_small_uint_t n2s_flags; + + DUK_ASSERT_TOP(thr, 1); + + d = duk__push_this_number_plain(thr); + if (duk_is_undefined(thr, 0)) { + goto use_to_string; + } + DUK_ASSERT_TOP(thr, 2); + + duk_to_int(thr, 0); /* for side effects */ + + c = (duk_small_int_t) DUK_FPCLASSIFY(d); + if (c == DUK_FP_NAN || c == DUK_FP_INFINITE) { + goto use_to_string; + } + + prec = (duk_small_int_t) duk_to_int_check_range(thr, 0, 1, 21); + + n2s_flags = DUK_N2S_FLAG_FIXED_FORMAT | DUK_N2S_FLAG_NO_ZERO_PAD; + + duk_numconv_stringify(thr, 10 /*radix*/, prec /*digits*/, n2s_flags /*flags*/); + return 1; + +use_to_string: + /* Used when precision is undefined; also used for NaN (-> "NaN"), + * and +/- infinity (-> "Infinity", "-Infinity"). + */ + + DUK_ASSERT_TOP(thr, 2); + duk_to_string(thr, -1); + return 1; +} + +/* + * ES2015 isFinite() etc + */ + +#if defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_number_check_shared(duk_hthread *thr) { + duk_int_t magic; + duk_bool_t ret = 0; + + if (duk_is_number(thr, 0)) { + duk_double_t d; + + magic = duk_get_current_magic(thr); + d = duk_get_number(thr, 0); + + switch (magic) { + case 0: /* isFinite() */ + ret = duk_double_is_finite(d); + break; + case 1: /* isInteger() */ + ret = duk_double_is_integer(d); + break; + case 2: /* isNaN() */ + ret = duk_double_is_nan(d); + break; + default: /* isSafeInteger() */ + DUK_ASSERT(magic == 3); + ret = duk_double_is_safe_integer(d); + } + } + + duk_push_boolean(thr, ret); + return 1; +} +#endif /* DUK_USE_ES6 */ + +#endif /* DUK_USE_NUMBER_BUILTIN */ +#line 1 "duk_bi_object.c" +/* + * Object built-ins + */ + +/* #include duk_internal.h -> already included */ + +/* Needed even when Object built-in disabled. */ +DUK_INTERNAL duk_ret_t duk_bi_object_prototype_to_string(duk_hthread *thr) { + duk_tval *tv; + + tv = DUK_HTHREAD_THIS_PTR(thr); + duk_push_class_string_tval(thr, tv, 0 /*avoid_side_effects*/); + return 1; +} + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor(duk_hthread *thr) { + duk_uint_t arg_mask; + + arg_mask = duk_get_type_mask(thr, 0); + + if (!duk_is_constructor_call(thr) && /* not a constructor call */ + ((arg_mask & (DUK_TYPE_MASK_NULL | DUK_TYPE_MASK_UNDEFINED)) == 0)) { /* and argument not null or undefined */ + duk_to_object(thr, 0); + return 1; + } + + /* Pointer and buffer primitive values are treated like other + * primitives values which have a fully fledged object counterpart: + * promote to an object value. Lightfuncs and plain buffers are + * coerced with ToObject() even they could also be returned as is. + */ + if (arg_mask & (DUK_TYPE_MASK_OBJECT | DUK_TYPE_MASK_STRING | DUK_TYPE_MASK_BOOLEAN | DUK_TYPE_MASK_NUMBER | + DUK_TYPE_MASK_POINTER | DUK_TYPE_MASK_BUFFER | DUK_TYPE_MASK_LIGHTFUNC)) { + /* For DUK_TYPE_OBJECT the coercion is a no-op and could + * be checked for explicitly, but Object(obj) calls are + * not very common so opt for minimal footprint. + */ + duk_to_object(thr, 0); + return 1; + } + + (void) duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJECT), + DUK_BIDX_OBJECT_PROTOTYPE); + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) && defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_assign(duk_hthread *thr) { + duk_idx_t nargs; + duk_int_t idx; + + nargs = duk_get_top_require_min(thr, 1 /*min_top*/); + + duk_to_object(thr, 0); + for (idx = 1; idx < nargs; idx++) { + /* E7 19.1.2.1 (step 4a) */ + if (duk_is_null_or_undefined(thr, idx)) { + continue; + } + + /* duk_enum() respects ES2015+ [[OwnPropertyKeys]] ordering, which is + * convenient here. + */ + duk_to_object(thr, idx); + duk_enum(thr, idx, DUK_ENUM_OWN_PROPERTIES_ONLY); + while (duk_next(thr, -1, 1 /*get_value*/)) { + /* [ target ... enum key value ] */ + duk_put_prop(thr, 0); + /* [ target ... enum ] */ + } + /* Could pop enumerator, but unnecessary because of duk_set_top() + * below. + */ + } + + duk_set_top(thr, 1); + return 1; +} +#endif + +#if defined(DUK_USE_OBJECT_BUILTIN) && defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_is(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 2); + duk_push_boolean(thr, duk_samevalue(thr, 0, 1)); + return 1; +} +#endif + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_create(duk_hthread *thr) { + duk_hobject *proto; + + DUK_ASSERT_TOP(thr, 2); + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + duk_hbufobj_promote_plain(thr, 0); +#endif + proto = duk_require_hobject_accept_mask(thr, 0, DUK_TYPE_MASK_NULL); + DUK_ASSERT(proto != NULL || duk_is_null(thr, 0)); + + (void) duk_push_object_helper_proto(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJECT), + proto); + + if (!duk_is_undefined(thr, 1)) { + /* [ O Properties obj ] */ + + duk_replace(thr, 0); + + /* [ obj Properties ] */ + + /* Just call the "original" Object.defineProperties() to + * finish up. + */ + + return duk_bi_object_constructor_define_properties(thr); + } + + /* [ O Properties obj ] */ + + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_define_properties(duk_hthread *thr) { + duk_small_uint_t pass; + duk_uint_t defprop_flags; + duk_hobject *obj; + duk_idx_t idx_value; + duk_hobject *get; + duk_hobject *set; + + /* Lightfunc and plain buffer handling by ToObject() coercion. */ + obj = duk_require_hobject_promote_mask(thr, 0, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + DUK_ASSERT(obj != NULL); + + duk_to_object(thr, 1); /* properties object */ + + DUK_DDD(DUK_DDDPRINT("target=%!iT, properties=%!iT", (duk_tval *) duk_get_tval(thr, 0), (duk_tval *) duk_get_tval(thr, 1))); + + /* + * Two pass approach to processing the property descriptors. + * On first pass validate and normalize all descriptors before + * any changes are made to the target object. On second pass + * make the actual modifications to the target object. + * + * Right now we'll just use the same normalize/validate helper + * on both passes, ignoring its outputs on the first pass. + */ + + for (pass = 0; pass < 2; pass++) { + duk_set_top(thr, 2); /* -> [ hobject props ] */ + duk_enum(thr, 1, DUK_ENUM_OWN_PROPERTIES_ONLY | DUK_ENUM_INCLUDE_SYMBOLS /*enum_flags*/); + + for (;;) { + duk_hstring *key; + + /* [ hobject props enum(props) ] */ + + duk_set_top(thr, 3); + + if (!duk_next(thr, 2, 1 /*get_value*/)) { + break; + } + + DUK_DDD(DUK_DDDPRINT("-> key=%!iT, desc=%!iT", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + + /* [ hobject props enum(props) key desc ] */ + + duk_hobject_prepare_property_descriptor(thr, 4 /*idx_desc*/, &defprop_flags, &idx_value, &get, &set); + + /* [ hobject props enum(props) key desc [multiple values] ] */ + + if (pass == 0) { + continue; + } + + /* This allows symbols on purpose. */ + key = duk_known_hstring(thr, 3); + DUK_ASSERT(key != NULL); + + duk_hobject_define_property_helper(thr, defprop_flags, obj, key, idx_value, get, set, 1 /*throw_flag*/); + } + } + + /* + * Return target object + */ + + duk_dup_0(thr); + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_seal_freeze_shared(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 1); + + duk_seal_freeze_raw(thr, 0, (duk_bool_t) duk_get_current_magic(thr) /*is_freeze*/); + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_is_sealed_frozen_shared(duk_hthread *thr) { + duk_hobject *h; + duk_bool_t is_frozen; + duk_uint_t mask; + + is_frozen = (duk_bool_t) duk_get_current_magic(thr); + mask = duk_get_type_mask(thr, 0); + if (mask & (DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER)) { + DUK_ASSERT(is_frozen == 0 || is_frozen == 1); + duk_push_boolean(thr, + (mask & DUK_TYPE_MASK_LIGHTFUNC) ? 1 : /* lightfunc always frozen and sealed */ + (is_frozen ^ 1)); /* buffer sealed but not frozen (index props writable) */ + } else { + /* ES2015 Sections 19.1.2.12, 19.1.2.13: anything other than an object + * is considered to be already sealed and frozen. + */ + h = duk_get_hobject(thr, 0); + duk_push_boolean(thr, (h == NULL) || duk_hobject_object_is_sealed_frozen_helper(thr, h, is_frozen /*is_frozen*/)); + } + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_prototype_to_locale_string(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 0); + (void) duk_push_this_coercible_to_object(thr); + duk_get_prop_stridx_short(thr, 0, DUK_STRIDX_TO_STRING); +#if 0 /* This is mentioned explicitly in the E5.1 spec, but duk_call_method() checks for it in practice. */ + duk_require_callable(thr, 1); +#endif + duk_dup_0(thr); /* -> [ O toString O ] */ + duk_call_method(thr, 0); /* XXX: call method tail call? */ + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_prototype_value_of(duk_hthread *thr) { + /* For lightfuncs and plain buffers, returns Object() coerced. */ + (void) duk_push_this_coercible_to_object(thr); + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_prototype_is_prototype_of(duk_hthread *thr) { + duk_hobject *h_v; + duk_hobject *h_obj; + + DUK_ASSERT_TOP(thr, 1); + + h_v = duk_get_hobject(thr, 0); + if (!h_v) { + duk_push_false(thr); /* XXX: tail call: return duk_push_false(thr) */ + return 1; + } + + h_obj = duk_push_this_coercible_to_object(thr); + DUK_ASSERT(h_obj != NULL); + + /* E5.1 Section 15.2.4.6, step 3.a, lookup proto once before compare. + * Prototype loops should cause an error to be thrown. + */ + duk_push_boolean( + thr, + duk_hobject_prototype_chain_contains(thr, DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h_v), h_obj, 0 /*ignore_loop*/)); + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_prototype_has_own_property(duk_hthread *thr) { + return (duk_ret_t) duk_hobject_object_ownprop_helper(thr, 0 /*required_desc_flags*/); +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_prototype_property_is_enumerable(duk_hthread *thr) { + return (duk_ret_t) duk_hobject_object_ownprop_helper(thr, DUK_PROPDESC_FLAG_ENUMERABLE /*required_desc_flags*/); +} +#endif /* DUK_USE_OBJECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) || defined(DUK_USE_REFLECT_BUILTIN) +/* Shared helper to implement Object.getPrototypeOf, + * Object.prototype.__proto__ getter, and Reflect.getPrototypeOf. + * + * http://www.ecma-international.org/ecma-262/6.0/index.html#sec-get-object.prototype.__proto__ + */ +DUK_INTERNAL duk_ret_t duk_bi_object_getprototype_shared(duk_hthread *thr) { + /* + * magic = 0: __proto__ getter + * magic = 1: Object.getPrototypeOf() + * magic = 2: Reflect.getPrototypeOf() + */ + + duk_hobject *h; + duk_hobject *proto; + duk_tval *tv; + duk_int_t magic; + + magic = duk_get_current_magic(thr); + + if (magic == 0) { + DUK_ASSERT_TOP(thr, 0); + duk_push_this_coercible_to_object(thr); + } + DUK_ASSERT(duk_get_top(thr) >= 1); + if (magic < 2) { + /* ES2015 Section 19.1.2.9, step 1 */ + duk_to_object(thr, 0); + } + tv = DUK_GET_TVAL_POSIDX(thr, 0); + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_BUFFER: + proto = thr->builtins[DUK_BIDX_UINT8ARRAY_PROTOTYPE]; + break; + case DUK_TAG_LIGHTFUNC: + proto = thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]; + break; + case DUK_TAG_OBJECT: + h = DUK_TVAL_GET_OBJECT(tv); + proto = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h); + break; + default: + /* This implicitly handles CheckObjectCoercible() caused + * TypeError. + */ + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + if (proto != NULL) { + duk_push_hobject(thr, proto); + } else { + duk_push_null(thr); + } + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN || DUK_USE_REFLECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) || defined(DUK_USE_REFLECT_BUILTIN) +/* Shared helper to implement ES2015 Object.setPrototypeOf, + * Object.prototype.__proto__ setter, and Reflect.setPrototypeOf. + * + * http://www.ecma-international.org/ecma-262/6.0/index.html#sec-get-object.prototype.__proto__ + * http://www.ecma-international.org/ecma-262/6.0/index.html#sec-object.setprototypeof + */ +DUK_INTERNAL duk_ret_t duk_bi_object_setprototype_shared(duk_hthread *thr) { + /* + * magic = 0: __proto__ setter + * magic = 1: Object.setPrototypeOf() + * magic = 2: Reflect.setPrototypeOf() + */ + + duk_hobject *h_obj; + duk_hobject *h_new_proto; + duk_hobject *h_curr; + duk_ret_t ret_success = 1; /* retval for success path */ + duk_uint_t mask; + duk_int_t magic; + + /* Preliminaries for __proto__ and setPrototypeOf (E6 19.1.2.18 steps 1-4). */ + magic = duk_get_current_magic(thr); + if (magic == 0) { + duk_push_this_check_object_coercible(thr); + duk_insert(thr, 0); + if (!duk_check_type_mask(thr, 1, DUK_TYPE_MASK_NULL | DUK_TYPE_MASK_OBJECT)) { + return 0; + } + + /* __proto__ setter returns 'undefined' on success unlike the + * setPrototypeOf() call which returns the target object. + */ + ret_success = 0; + } else { + if (magic == 1) { + duk_require_object_coercible(thr, 0); + } else { + duk_require_hobject_accept_mask(thr, 0, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + } + duk_require_type_mask(thr, 1, DUK_TYPE_MASK_NULL | DUK_TYPE_MASK_OBJECT); + } + + h_new_proto = duk_get_hobject(thr, 1); + /* h_new_proto may be NULL */ + + mask = duk_get_type_mask(thr, 0); + if (mask & (DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER)) { + duk_hobject *curr_proto; + curr_proto = + thr->builtins[(mask & DUK_TYPE_MASK_LIGHTFUNC) ? DUK_BIDX_FUNCTION_PROTOTYPE : DUK_BIDX_UINT8ARRAY_PROTOTYPE]; + if (h_new_proto == curr_proto) { + goto skip; + } + goto fail_nonextensible; + } + h_obj = duk_get_hobject(thr, 0); + if (h_obj == NULL) { + goto skip; + } + DUK_ASSERT(h_obj != NULL); + + /* [[SetPrototypeOf]] standard behavior, E6 9.1.2. */ + /* TODO: implement Proxy object support here */ + + if (h_new_proto == DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h_obj)) { + goto skip; + } + if (!DUK_HOBJECT_HAS_EXTENSIBLE(h_obj)) { + goto fail_nonextensible; + } + for (h_curr = h_new_proto; h_curr != NULL; h_curr = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h_curr)) { + /* Loop prevention. */ + if (h_curr == h_obj) { + goto fail_loop; + } + } + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, h_obj, h_new_proto); + /* fall thru */ + +skip: + duk_set_top(thr, 1); + if (magic == 2) { + duk_push_true(thr); + } + return ret_success; + +fail_nonextensible: +fail_loop: + if (magic != 2) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } else { + duk_push_false(thr); + return 1; + } +} +#endif /* DUK_USE_OBJECT_BUILTIN || DUK_USE_REFLECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) || defined(DUK_USE_REFLECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_define_property(duk_hthread *thr) { + /* + * magic = 0: Object.defineProperty() + * magic = 1: Reflect.defineProperty() + */ + + duk_hobject *obj; + duk_hstring *key; + duk_hobject *get; + duk_hobject *set; + duk_idx_t idx_value; + duk_uint_t defprop_flags; + duk_small_uint_t magic; + duk_bool_t throw_flag; + duk_bool_t ret; + + DUK_ASSERT(thr != NULL); + + DUK_DDD(DUK_DDDPRINT("Object.defineProperty(): ctx=%p obj=%!T key=%!T desc=%!T", + (void *) thr, + (duk_tval *) duk_get_tval(thr, 0), + (duk_tval *) duk_get_tval(thr, 1), + (duk_tval *) duk_get_tval(thr, 2))); + + /* [ obj key desc ] */ + + magic = (duk_small_uint_t) duk_get_current_magic(thr); + + /* Lightfuncs are currently supported by coercing to a temporary + * Function object; changes will be allowed (the coerced value is + * extensible) but will be lost. Same for plain buffers. + */ + obj = duk_require_hobject_promote_mask(thr, 0, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + DUK_ASSERT(obj != NULL); + key = duk_to_property_key_hstring(thr, 1); + (void) duk_require_hobject(thr, 2); + + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + DUK_ASSERT(duk_get_hobject(thr, 2) != NULL); + + /* + * Validate and convert argument property descriptor (an ECMAScript + * object) into a set of defprop_flags and possibly property value, + * getter, and/or setter values on the value stack. + * + * Lightfunc set/get values are coerced to full Functions. + */ + + duk_hobject_prepare_property_descriptor(thr, 2 /*idx_desc*/, &defprop_flags, &idx_value, &get, &set); + + /* + * Use Object.defineProperty() helper for the actual operation. + */ + + DUK_ASSERT(magic == 0U || magic == 1U); + throw_flag = magic ^ 1U; + ret = duk_hobject_define_property_helper(thr, defprop_flags, obj, key, idx_value, get, set, throw_flag); + + /* Ignore the normalize/validate helper outputs on the value stack, + * they're popped automatically. + */ + + if (magic == 0U) { + /* Object.defineProperty(): return target object. */ + duk_push_hobject(thr, obj); + } else { + /* Reflect.defineProperty(): return success/fail. */ + duk_push_boolean(thr, ret); + } + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN || DUK_USE_REFLECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) || defined(DUK_USE_REFLECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_get_own_property_descriptor(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 2); + + /* ES2015 Section 19.1.2.6, step 1 */ + if (duk_get_current_magic(thr) == 0) { + duk_to_object(thr, 0); + } + + /* [ obj key ] */ + + duk_hobject_object_get_own_property_descriptor(thr, -2); + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN || DUK_USE_REFLECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) || defined(DUK_USE_REFLECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_is_extensible(duk_hthread *thr) { + /* + * magic = 0: Object.isExtensible() + * magic = 1: Reflect.isExtensible() + */ + + duk_hobject *h; + + if (duk_get_current_magic(thr) == 0) { + h = duk_get_hobject(thr, 0); + } else { + /* Reflect.isExtensible(): throw if non-object, but we accept lightfuncs + * and plain buffers here because they pretend to be objects. + */ + h = duk_require_hobject_accept_mask(thr, 0, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + } + + duk_push_boolean(thr, (h != NULL) && DUK_HOBJECT_HAS_EXTENSIBLE(h)); + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN || DUK_USE_REFLECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) || defined(DUK_USE_REFLECT_BUILTIN) +/* Shared helper for various key/symbol listings, magic: + * 0=Object.keys() + * 1=Object.getOwnPropertyNames(), + * 2=Object.getOwnPropertySymbols(), + * 3=Reflect.ownKeys() + */ +DUK_LOCAL const duk_small_uint_t duk__object_keys_enum_flags[4] = { + /* Object.keys() */ + DUK_ENUM_OWN_PROPERTIES_ONLY | DUK_ENUM_NO_PROXY_BEHAVIOR, + + /* Object.getOwnPropertyNames() */ + DUK_ENUM_INCLUDE_NONENUMERABLE | DUK_ENUM_OWN_PROPERTIES_ONLY | DUK_ENUM_NO_PROXY_BEHAVIOR, + + /* Object.getOwnPropertySymbols() */ + DUK_ENUM_INCLUDE_SYMBOLS | DUK_ENUM_OWN_PROPERTIES_ONLY | DUK_ENUM_EXCLUDE_STRINGS | DUK_ENUM_INCLUDE_NONENUMERABLE | + DUK_ENUM_NO_PROXY_BEHAVIOR, + + /* Reflect.ownKeys() */ + DUK_ENUM_INCLUDE_SYMBOLS | DUK_ENUM_OWN_PROPERTIES_ONLY | DUK_ENUM_INCLUDE_NONENUMERABLE | DUK_ENUM_NO_PROXY_BEHAVIOR +}; + +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_keys_shared(duk_hthread *thr) { + duk_hobject *obj; +#if defined(DUK_USE_ES6_PROXY) + duk_hobject *h_proxy_target; + duk_hobject *h_proxy_handler; + duk_hobject *h_trap_result; +#endif + duk_small_uint_t enum_flags; + duk_int_t magic; + + DUK_ASSERT_TOP(thr, 1); + + magic = duk_get_current_magic(thr); + if (magic == 3) { + /* ES2015 Section 26.1.11 requires a TypeError for non-objects. Lightfuncs + * and plain buffers pretend to be objects, so accept those too. + */ + obj = duk_require_hobject_promote_mask(thr, 0, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + } else { + /* ES2015: ToObject coerce. */ + obj = duk_to_hobject(thr, 0); + } + DUK_ASSERT(obj != NULL); + DUK_UNREF(obj); + + /* XXX: proxy chains */ + +#if defined(DUK_USE_ES6_PROXY) + /* XXX: better sharing of code between proxy target call sites */ + if (DUK_LIKELY(!duk_hobject_proxy_check(obj, &h_proxy_target, &h_proxy_handler))) { + goto skip_proxy; + } + + duk_push_hobject(thr, h_proxy_handler); + if (!duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_OWN_KEYS)) { + /* Careful with reachability here: don't pop 'obj' before pushing + * proxy target. + */ + DUK_DDD(DUK_DDDPRINT("no ownKeys trap, get keys of target instead")); + duk_pop_2(thr); + duk_push_hobject(thr, h_proxy_target); + duk_replace(thr, 0); + DUK_ASSERT_TOP(thr, 1); + goto skip_proxy; + } + + /* [ obj handler trap ] */ + duk_insert(thr, -2); + duk_push_hobject(thr, h_proxy_target); /* -> [ obj trap handler target ] */ + duk_call_method(thr, 1 /*nargs*/); /* -> [ obj trap_result ] */ + h_trap_result = duk_require_hobject(thr, -1); + DUK_UNREF(h_trap_result); + + magic = duk_get_current_magic(thr); + DUK_ASSERT(magic >= 0 && magic < (duk_int_t) (sizeof(duk__object_keys_enum_flags) / sizeof(duk_small_uint_t))); + enum_flags = duk__object_keys_enum_flags[magic]; + + duk_proxy_ownkeys_postprocess(thr, h_proxy_target, enum_flags); + return 1; + +skip_proxy: +#endif /* DUK_USE_ES6_PROXY */ + + DUK_ASSERT_TOP(thr, 1); + magic = duk_get_current_magic(thr); + DUK_ASSERT(magic >= 0 && magic < (duk_int_t) (sizeof(duk__object_keys_enum_flags) / sizeof(duk_small_uint_t))); + enum_flags = duk__object_keys_enum_flags[magic]; + return duk_hobject_get_enumerated_keys(thr, enum_flags); +} +#endif /* DUK_USE_OBJECT_BUILTIN || DUK_USE_REFLECT_BUILTIN */ + +#if defined(DUK_USE_OBJECT_BUILTIN) || defined(DUK_USE_REFLECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_object_constructor_prevent_extensions(duk_hthread *thr) { + /* + * magic = 0: Object.preventExtensions() + * magic = 1: Reflect.preventExtensions() + */ + + duk_hobject *h; + duk_uint_t mask; + duk_int_t magic; + + magic = duk_get_current_magic(thr); + + /* Silent success for lightfuncs and plain buffers always. */ + mask = DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER; + + /* Object.preventExtensions() silent success for non-object. */ + if (magic == 0) { + mask |= DUK_TYPE_MASK_UNDEFINED | DUK_TYPE_MASK_NULL | DUK_TYPE_MASK_BOOLEAN | DUK_TYPE_MASK_NUMBER | + DUK_TYPE_MASK_STRING | DUK_TYPE_MASK_POINTER; + } + + if (duk_check_type_mask(thr, 0, mask)) { + /* Not an object, already non-extensible so always success. */ + goto done; + } + h = duk_require_hobject(thr, 0); + DUK_ASSERT(h != NULL); + + DUK_HOBJECT_CLEAR_EXTENSIBLE(h); + + /* A non-extensible object cannot gain any more properties, + * so this is a good time to compact. + */ + duk_hobject_compact_props(thr, h); + +done: + if (magic == 1) { + duk_push_true(thr); + } + return 1; +} +#endif /* DUK_USE_OBJECT_BUILTIN || DUK_USE_REFLECT_BUILTIN */ + +/* + * __defineGetter__, __defineSetter__, __lookupGetter__, __lookupSetter__ + */ + +#if defined(DUK_USE_ES8) +DUK_INTERNAL duk_ret_t duk_bi_object_prototype_defineaccessor(duk_hthread *thr) { + duk_push_this(thr); + duk_insert(thr, 0); + duk_to_object(thr, 0); + duk_require_callable(thr, 2); + + /* [ ToObject(this) key getter/setter ] */ + + /* ToPropertyKey() coercion is not needed, duk_def_prop() does it. */ + duk_def_prop(thr, + 0, + DUK_DEFPROP_SET_ENUMERABLE | DUK_DEFPROP_SET_CONFIGURABLE | + (duk_get_current_magic(thr) ? DUK_DEFPROP_HAVE_SETTER : DUK_DEFPROP_HAVE_GETTER)); + return 0; +} +DUK_INTERNAL duk_ret_t duk_bi_object_prototype_lookupaccessor(duk_hthread *thr) { + duk_uint_t sanity; + + duk_push_this(thr); + duk_to_object(thr, -1); + + /* XXX: Prototype walk (with sanity) should be a core property + * operation, could add a flag to e.g. duk_get_prop_desc(). + */ + + /* ToPropertyKey() coercion is not needed, duk_get_prop_desc() does it. */ + sanity = DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY; + while (!duk_is_undefined(thr, -1)) { + /* [ key obj ] */ + duk_dup(thr, 0); + duk_get_prop_desc(thr, 1, 0 /*flags*/); + if (!duk_is_undefined(thr, -1)) { + duk_get_prop_stridx(thr, -1, (duk_get_current_magic(thr) != 0 ? DUK_STRIDX_SET : DUK_STRIDX_GET)); + return 1; + } + duk_pop(thr); + + if (DUK_UNLIKELY(sanity-- == 0)) { + DUK_ERROR_RANGE(thr, DUK_STR_PROTOTYPE_CHAIN_LIMIT); + DUK_WO_NORETURN(return 0;); + } + + duk_get_prototype(thr, -1); + duk_remove(thr, -2); + } + return 1; +} +#endif /* DUK_USE_ES8 */ +#line 1 "duk_bi_performance.c" +/* + * High resolution time API (performance.now() et al) + * + * API specification: https://encoding.spec.whatwg.org/#ap://www.w3.org/TR/hr-time/ + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_PERFORMANCE_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_performance_now(duk_hthread *thr) { + /* From API spec: + * The DOMHighResTimeStamp type is used to store a time value in + * milliseconds, measured relative from the time origin, global + * monotonic clock, or a time value that represents a duration + * between two DOMHighResTimeStamp's. + */ + duk_push_number(thr, duk_time_get_monotonic_time(thr)); + return 1; +} + +#if 0 /* Missing until semantics decided. */ +DUK_INTERNAL duk_ret_t duk_bi_performance_timeorigin_getter(duk_hthread *thr) { + /* No decision yet how to handle timeOrigins, e.g. should one be + * initialized per heap, or per global object set. See + * https://www.w3.org/TR/hr-time/#time-origin. + */ + duk_push_uint(thr, 0); + return 1; +} +#endif /* 0 */ +#endif /* DUK_USE_PERFORMANCE_BUILTIN */ +#line 1 "duk_bi_pointer.c" +/* + * Pointer built-ins + */ + +/* #include duk_internal.h -> already included */ + +/* + * Constructor + */ + +DUK_INTERNAL duk_ret_t duk_bi_pointer_constructor(duk_hthread *thr) { + /* XXX: this behavior is quite useless now; it would be nice to be able + * to create pointer values from e.g. numbers or strings. Numbers are + * problematic on 64-bit platforms though. Hex encoded strings? + */ + if (duk_get_top(thr) == 0) { + duk_push_pointer(thr, NULL); + } else { + duk_to_pointer(thr, 0); + } + DUK_ASSERT(duk_is_pointer(thr, 0)); + duk_set_top(thr, 1); + + if (duk_is_constructor_call(thr)) { + (void) duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_POINTER), + DUK_BIDX_POINTER_PROTOTYPE); + + /* Pointer object internal value is immutable. */ + duk_dup_0(thr); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_VALUE, DUK_PROPDESC_FLAGS_NONE); + } + /* Note: unbalanced stack on purpose */ + + return 1; +} + +/* + * toString(), valueOf() + */ + +DUK_INTERNAL duk_ret_t duk_bi_pointer_prototype_tostring_shared(duk_hthread *thr) { + duk_tval *tv; + duk_small_int_t to_string = duk_get_current_magic(thr); + + duk_push_this(thr); + tv = duk_require_tval(thr, -1); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_IS_POINTER(tv)) { + /* nop */ + } else if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + + /* Must be a "pointer object", i.e. class "Pointer" */ + if (DUK_HOBJECT_GET_CLASS_NUMBER(h) != DUK_HOBJECT_CLASS_POINTER) { + goto type_error; + } + + duk_xget_owndataprop_stridx_short(thr, -1, DUK_STRIDX_INT_VALUE); + } else { + goto type_error; + } + + if (to_string) { + duk_to_string(thr, -1); + } + return 1; + +type_error: + DUK_DCERROR_TYPE_INVALID_ARGS(thr); +} +#line 1 "duk_bi_promise.c" +/* + * Promise built-in + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_PROMISE_BUILTIN) + +DUK_INTERNAL duk_ret_t duk_bi_promise_constructor(duk_hthread *thr) { + DUK_ERROR_TYPE(thr, "unimplemented"); + DUK_WO_NORETURN(return 0;); +} + +DUK_INTERNAL duk_ret_t duk_bi_promise_all(duk_hthread *thr) { + DUK_ERROR_TYPE(thr, "unimplemented"); + DUK_WO_NORETURN(return 0;); +} + +DUK_INTERNAL duk_ret_t duk_bi_promise_race(duk_hthread *thr) { + DUK_ERROR_TYPE(thr, "unimplemented"); + DUK_WO_NORETURN(return 0;); +} + +DUK_INTERNAL duk_ret_t duk_bi_promise_reject(duk_hthread *thr) { + DUK_ERROR_TYPE(thr, "unimplemented"); + DUK_WO_NORETURN(return 0;); +} + +DUK_INTERNAL duk_ret_t duk_bi_promise_resolve(duk_hthread *thr) { + DUK_ERROR_TYPE(thr, "unimplemented"); + DUK_WO_NORETURN(return 0;); +} + +DUK_INTERNAL duk_ret_t duk_bi_promise_catch(duk_hthread *thr) { + DUK_ERROR_TYPE(thr, "unimplemented"); + DUK_WO_NORETURN(return 0;); +} + +DUK_INTERNAL duk_ret_t duk_bi_promise_then(duk_hthread *thr) { + DUK_ERROR_TYPE(thr, "unimplemented"); + DUK_WO_NORETURN(return 0;); +} + +#endif /* DUK_USE_PROMISE_BUILTIN */ +#line 1 "duk_bi_proxy.c" +/* + * Proxy built-in (ES2015) + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_ES6_PROXY) +/* Post-process a Proxy ownKeys() result at stack top. Push a cleaned up + * array of valid result keys (strings or symbols). TypeError for invalid + * values. Flags are shared with duk_enum(). + */ +DUK_INTERNAL void duk_proxy_ownkeys_postprocess(duk_hthread *thr, duk_hobject *h_proxy_target, duk_uint_t flags) { + duk_uarridx_t i, len, idx; + duk_propdesc desc; + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(h_proxy_target != NULL); + + len = (duk_uarridx_t) duk_get_length(thr, -1); + idx = 0; + duk_push_array(thr); + /* XXX: preallocated dense array, fill in directly */ + for (i = 0; i < len; i++) { + duk_hstring *h; + + /* [ obj trap_result res_arr ] */ + (void) duk_get_prop_index(thr, -2, i); + h = duk_get_hstring(thr, -1); + if (h == NULL) { + DUK_ERROR_TYPE_INVALID_TRAP_RESULT(thr); + DUK_WO_NORETURN(return;); + } + + if (!(flags & DUK_ENUM_INCLUDE_NONENUMERABLE)) { + /* No support for 'getOwnPropertyDescriptor' trap yet, + * so check enumerability always from target object + * descriptor. + */ + if (duk_hobject_get_own_propdesc(thr, h_proxy_target, duk_known_hstring(thr, -1), &desc, 0 /*flags*/)) { + if ((desc.flags & DUK_PROPDESC_FLAG_ENUMERABLE) == 0) { + DUK_DDD(DUK_DDDPRINT("ignore non-enumerable property: %!T", duk_get_tval(thr, -1))); + goto skip_key; + } + } else { + DUK_DDD(DUK_DDDPRINT("ignore non-existent property: %!T", duk_get_tval(thr, -1))); + goto skip_key; + } + } + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + if (!(flags & DUK_ENUM_INCLUDE_SYMBOLS)) { + DUK_DDD(DUK_DDDPRINT("ignore symbol property: %!T", duk_get_tval(thr, -1))); + goto skip_key; + } + if (DUK_HSTRING_HAS_HIDDEN(h) && !(flags & DUK_ENUM_INCLUDE_HIDDEN)) { + DUK_DDD(DUK_DDDPRINT("ignore hidden symbol property: %!T", duk_get_tval(thr, -1))); + goto skip_key; + } + } else { + if (flags & DUK_ENUM_EXCLUDE_STRINGS) { + DUK_DDD(DUK_DDDPRINT("ignore string property: %!T", duk_get_tval(thr, -1))); + goto skip_key; + } + } + + /* [ obj trap_result res_arr propname ] */ + duk_push_uarridx(thr, idx++); + duk_insert(thr, -2); + duk_def_prop(thr, -3, DUK_DEFPROP_HAVE_VALUE | DUK_DEFPROP_SET_WEC); + continue; + + skip_key: + duk_pop(thr); + continue; + } + + /* XXX: Missing trap result validation for non-configurable target keys + * (must be present), for non-extensible target all target keys must be + * present and no extra keys can be present. + * http://www.ecma-international.org/ecma-262/6.0/#sec-proxy-object-internal-methods-and-internal-slots-ownpropertykeys + */ + + /* XXX: The key enumerability check should trigger the "getOwnPropertyDescriptor" + * trap which has not yet been implemented. In the absence of such a trap, + * the enumerability should be checked from the target object; this is + * handled above. + */ +} +#endif /* DUK_USE_ES6_PROXY */ + +#if defined(DUK_USE_ES6_PROXY) +DUK_INTERNAL duk_ret_t duk_bi_proxy_constructor(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 2); /* [ target handler ] */ + + duk_require_constructor_call(thr); + duk_push_proxy(thr, 0 /*flags*/); /* [ target handler ] -> [ proxy ] */ + return 1; /* replacement */ +} +#endif /* DUK_USE_ES6_PROXY */ +#line 1 "duk_bi_reflect.c" +/* + * 'Reflect' built-in (ES2016 Section 26.1) + * http://www.ecma-international.org/ecma-262/7.0/#sec-reflect-object + * + * Many Reflect built-in functions are provided by shared helpers in + * duk_bi_object.c or duk_bi_function.c. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_REFLECT_BUILTIN) +DUK_INTERNAL duk_ret_t duk_bi_reflect_object_delete_property(duk_hthread *thr) { + duk_tval *tv_obj; + duk_tval *tv_key; + duk_bool_t ret; + + DUK_ASSERT_TOP(thr, 2); + (void) duk_require_hobject(thr, 0); + (void) duk_to_string(thr, 1); + + /* [ target key ] */ + + DUK_ASSERT(thr != NULL); + tv_obj = DUK_GET_TVAL_POSIDX(thr, 0); + tv_key = DUK_GET_TVAL_POSIDX(thr, 1); + ret = duk_hobject_delprop(thr, tv_obj, tv_key, 0 /*throw_flag*/); + duk_push_boolean(thr, ret); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_reflect_object_get(duk_hthread *thr) { + duk_tval *tv_obj; + duk_tval *tv_key; + duk_idx_t nargs; + + DUK_ASSERT(thr != NULL); + nargs = duk_get_top_require_min(thr, 2 /*min_top*/); + (void) duk_require_hobject(thr, 0); + (void) duk_to_string(thr, 1); + if (nargs >= 3 && !duk_strict_equals(thr, 0, 2)) { + /* XXX: [[Get]] receiver currently unsupported */ + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return 0;); + } + + /* [ target key receiver? ...? ] */ + + tv_obj = DUK_GET_TVAL_POSIDX(thr, 0); + tv_key = DUK_GET_TVAL_POSIDX(thr, 1); + (void) duk_hobject_getprop(thr, tv_obj, tv_key); /* This could also be a duk_get_prop(). */ + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_reflect_object_has(duk_hthread *thr) { + duk_tval *tv_obj; + duk_tval *tv_key; + duk_bool_t ret; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT_TOP(thr, 2); + (void) duk_require_hobject(thr, 0); + (void) duk_to_string(thr, 1); + + /* [ target key ] */ + + tv_obj = DUK_GET_TVAL_POSIDX(thr, 0); + tv_key = DUK_GET_TVAL_POSIDX(thr, 1); + ret = duk_hobject_hasprop(thr, tv_obj, tv_key); + duk_push_boolean(thr, ret); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_reflect_object_set(duk_hthread *thr) { + duk_tval *tv_obj; + duk_tval *tv_key; + duk_tval *tv_val; + duk_idx_t nargs; + duk_bool_t ret; + + DUK_ASSERT(thr != NULL); + nargs = duk_get_top_require_min(thr, 3 /*min_top*/); + (void) duk_require_hobject(thr, 0); + (void) duk_to_string(thr, 1); + if (nargs >= 4 && !duk_strict_equals(thr, 0, 3)) { + /* XXX: [[Set]] receiver currently unsupported */ + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return 0;); + } + + /* [ target key value receiver? ...? ] */ + + tv_obj = DUK_GET_TVAL_POSIDX(thr, 0); + tv_key = DUK_GET_TVAL_POSIDX(thr, 1); + tv_val = DUK_GET_TVAL_POSIDX(thr, 2); + ret = duk_hobject_putprop(thr, tv_obj, tv_key, tv_val, 0 /*throw_flag*/); + duk_push_boolean(thr, ret); + return 1; +} +#endif /* DUK_USE_REFLECT_BUILTIN */ +#line 1 "duk_bi_regexp.c" +/* + * RegExp built-ins + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_REGEXP_SUPPORT) + +DUK_LOCAL void duk__get_this_regexp(duk_hthread *thr) { + duk_hobject *h; + + duk_push_this(thr); + h = duk_require_hobject_with_class(thr, -1, DUK_HOBJECT_CLASS_REGEXP); + DUK_ASSERT(h != NULL); + DUK_UNREF(h); + duk_insert(thr, 0); /* prepend regexp to valstack 0 index */ +} + +/* XXX: much to improve (code size) */ +DUK_INTERNAL duk_ret_t duk_bi_regexp_constructor(duk_hthread *thr) { + duk_hobject *h_pattern; + + DUK_ASSERT_TOP(thr, 2); + h_pattern = duk_get_hobject(thr, 0); + + if (!duk_is_constructor_call(thr) && h_pattern != NULL && + DUK_HOBJECT_GET_CLASS_NUMBER(h_pattern) == DUK_HOBJECT_CLASS_REGEXP && duk_is_undefined(thr, 1)) { + /* Called as a function, pattern has [[Class]] "RegExp" and + * flags is undefined -> return object as is. + */ + /* XXX: ES2015 has a NewTarget SameValue() check which is not + * yet implemented. + */ + duk_dup_0(thr); + return 1; + } + + /* Else functionality is identical for function call and constructor + * call. + */ + + if (h_pattern != NULL && DUK_HOBJECT_GET_CLASS_NUMBER(h_pattern) == DUK_HOBJECT_CLASS_REGEXP) { + duk_get_prop_stridx_short(thr, 0, DUK_STRIDX_SOURCE); + if (duk_is_undefined(thr, 1)) { + /* In ES5 one would need to read the flags individually; + * in ES2015 just read .flags. + */ + duk_get_prop_stridx(thr, 0, DUK_STRIDX_FLAGS); + } else { + /* In ES2015 allowed; overrides argument RegExp flags. */ + duk_dup_1(thr); + } + } else { + if (duk_is_undefined(thr, 0)) { + duk_push_hstring_empty(thr); + } else { + duk_dup_0(thr); + duk_to_string(thr, -1); /* Rejects Symbols. */ + } + if (duk_is_undefined(thr, 1)) { + duk_push_hstring_empty(thr); + } else { + duk_dup_1(thr); + duk_to_string(thr, -1); /* Rejects Symbols. */ + } + + /* [ ... pattern flags ] */ + } + + DUK_DDD(DUK_DDDPRINT("RegExp constructor/function call, pattern=%!T, flags=%!T", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + + /* [ ... pattern flags ] (both uncoerced) */ + + duk_to_string(thr, -2); + duk_to_string(thr, -1); + duk_regexp_compile(thr); + + /* [ ... bytecode escaped_source ] */ + + duk_regexp_create_instance(thr); + + /* [ ... RegExp ] */ + + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_regexp_prototype_exec(duk_hthread *thr) { + duk__get_this_regexp(thr); + + /* [ regexp input ] */ + + duk_regexp_match(thr); + + /* [ result ] */ + + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_regexp_prototype_test(duk_hthread *thr) { + duk__get_this_regexp(thr); + + /* [ regexp input ] */ + + /* result object is created and discarded; wasteful but saves code space */ + duk_regexp_match(thr); + + /* [ result ] */ + + duk_push_boolean(thr, (duk_is_null(thr, -1) ? 0 : 1)); + + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_regexp_prototype_tostring(duk_hthread *thr) { + /* This must be generic in ES2015 and later. */ + DUK_ASSERT_TOP(thr, 0); + duk_push_this(thr); + duk_push_literal(thr, "/"); + duk_get_prop_stridx(thr, 0, DUK_STRIDX_SOURCE); + duk_dup_m2(thr); /* another "/" */ + duk_get_prop_stridx(thr, 0, DUK_STRIDX_FLAGS); + duk_concat(thr, 4); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_regexp_prototype_flags(duk_hthread *thr) { + /* .flags is ES2015 but present even when ES2015 bindings are + * disabled because the constructor relies on it. + */ + duk_uint8_t buf[8]; /* enough for all flags + NUL */ + duk_uint8_t *p = buf; + + /* .flags is generic and works on any object. */ + duk_push_this(thr); + (void) duk_require_hobject(thr, -1); + if (duk_get_prop_stridx_boolean(thr, 0, DUK_STRIDX_GLOBAL, NULL)) { + *p++ = DUK_ASC_LC_G; + } + if (duk_get_prop_stridx_boolean(thr, 0, DUK_STRIDX_IGNORE_CASE, NULL)) { + *p++ = DUK_ASC_LC_I; + } + if (duk_get_prop_stridx_boolean(thr, 0, DUK_STRIDX_MULTILINE, NULL)) { + *p++ = DUK_ASC_LC_M; + } + /* .unicode: to be added */ + /* .sticky: to be added */ + *p++ = DUK_ASC_NUL; + DUK_ASSERT((duk_size_t) (p - buf) <= sizeof(buf)); + + duk_push_string(thr, (const char *) buf); + return 1; +} + +/* Shared helper for providing .source, .global, .multiline, etc getters. */ +DUK_INTERNAL duk_ret_t duk_bi_regexp_prototype_shared_getter(duk_hthread *thr) { + duk_hstring *h_bc; + duk_small_uint_t re_flags; + duk_hobject *h; + duk_int_t magic; + + DUK_ASSERT_TOP(thr, 0); + + duk_push_this(thr); + h = duk_require_hobject(thr, -1); + magic = duk_get_current_magic(thr); + + if (DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_REGEXP) { + duk_xget_owndataprop_stridx_short(thr, 0, DUK_STRIDX_INT_SOURCE); + duk_xget_owndataprop_stridx_short(thr, 0, DUK_STRIDX_INT_BYTECODE); + h_bc = duk_require_hstring(thr, -1); + re_flags = (duk_small_uint_t) DUK_HSTRING_GET_DATA(h_bc)[0]; /* Safe even if h_bc length is 0 (= NUL) */ + duk_pop(thr); + } else if (h == thr->builtins[DUK_BIDX_REGEXP_PROTOTYPE]) { + /* In ES2015 and ES2016 a TypeError would be thrown here. + * However, this had real world issues so ES2017 draft + * allows RegExp.prototype specifically, returning '(?:)' + * for .source and undefined for all flags. + */ + if (magic != 16 /* .source */) { + return 0; + } + duk_push_literal(thr, "(?:)"); /* .source handled by switch-case */ + re_flags = 0; + } else { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); + } + + /* [ regexp source ] */ + + switch (magic) { + case 0: { /* global */ + duk_push_boolean(thr, (re_flags & DUK_RE_FLAG_GLOBAL)); + break; + } + case 1: { /* ignoreCase */ + duk_push_boolean(thr, (re_flags & DUK_RE_FLAG_IGNORE_CASE)); + break; + } + case 2: { /* multiline */ + duk_push_boolean(thr, (re_flags & DUK_RE_FLAG_MULTILINE)); + break; + } +#if 0 + /* Don't provide until implemented to avoid interfering with feature + * detection in user code. + */ + case 3: /* sticky */ + case 4: { /* unicode */ + duk_push_false(thr); + break; + } +#endif + default: { /* source */ + /* leave 'source' on top */ + break; + } + } + + return 1; +} + +#endif /* DUK_USE_REGEXP_SUPPORT */ +#line 1 "duk_bi_string.c" +/* + * String built-ins + * + * Most String built-ins must only accept strings (or String objects). + * Symbols, represented internally as strings, must be generally rejected. + * The duk_push_this_coercible_to_string() helper does this automatically. + */ + +/* XXX: There are several limitations in the current implementation for + * strings with >= 0x80000000UL characters. In some cases one would need + * to be able to represent the range [-0xffffffff,0xffffffff] and so on. + * Generally character and byte length are assumed to fit into signed 32 + * bits (< 0x80000000UL). Places with issues are not marked explicitly + * below in all cases, look for signed type usage (duk_int_t etc) for + * offsets/lengths. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_STRING_BUILTIN) + +/* + * Helpers + */ + +DUK_LOCAL duk_hstring *duk__str_tostring_notregexp(duk_hthread *thr, duk_idx_t idx) { + duk_hstring *h; + + if (duk_get_class_number(thr, idx) == DUK_HOBJECT_CLASS_REGEXP) { + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return NULL;); + } + h = duk_to_hstring(thr, idx); + DUK_ASSERT(h != NULL); + + return h; +} + +DUK_LOCAL duk_int_t +duk__str_search_shared(duk_hthread *thr, duk_hstring *h_this, duk_hstring *h_search, duk_int_t start_cpos, duk_bool_t backwards) { + duk_int_t cpos; + duk_int_t bpos; + const duk_uint8_t *p_start, *p_end, *p; + const duk_uint8_t *q_start; + duk_int_t q_blen; + duk_uint8_t firstbyte; + duk_uint8_t t; + + cpos = start_cpos; + + /* Empty searchstring always matches; cpos must be clamped here. + * (If q_blen were < 0 due to clamped coercion, it would also be + * caught here.) + */ + q_start = DUK_HSTRING_GET_DATA(h_search); + q_blen = (duk_int_t) DUK_HSTRING_GET_BYTELEN(h_search); + if (q_blen <= 0) { + return cpos; + } + DUK_ASSERT(q_blen > 0); + + bpos = (duk_int_t) duk_heap_strcache_offset_char2byte(thr, h_this, (duk_uint32_t) cpos); + + p_start = DUK_HSTRING_GET_DATA(h_this); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h_this); + p = p_start + bpos; + + /* This loop is optimized for size. For speed, there should be + * two separate loops, and we should ensure that memcmp() can be + * used without an extra "will searchstring fit" check. Doing + * the preconditioning for 'p' and 'p_end' is easy but cpos + * must be updated if 'p' is wound back (backward scanning). + */ + + firstbyte = q_start[0]; /* leading byte of match string */ + while (p <= p_end && p >= p_start) { + t = *p; + + /* For ECMAScript strings, this check can only match for + * initial UTF-8 bytes (not continuation bytes). For other + * strings all bets are off. + */ + + if ((t == firstbyte) && ((duk_size_t) (p_end - p) >= (duk_size_t) q_blen)) { + DUK_ASSERT(q_blen > 0); + if (duk_memcmp((const void *) p, (const void *) q_start, (size_t) q_blen) == 0) { + return cpos; + } + } + + /* track cpos while scanning */ + if (backwards) { + /* when going backwards, we decrement cpos 'early'; + * 'p' may point to a continuation byte of the char + * at offset 'cpos', but that's OK because we'll + * backtrack all the way to the initial byte. + */ + if ((t & 0xc0) != 0x80) { + cpos--; + } + p--; + } else { + if ((t & 0xc0) != 0x80) { + cpos++; + } + p++; + } + } + + /* Not found. Empty string case is handled specially above. */ + return -1; +} + +/* + * Constructor + */ + +DUK_INTERNAL duk_ret_t duk_bi_string_constructor(duk_hthread *thr) { + duk_hstring *h; + duk_uint_t flags; + + /* String constructor needs to distinguish between an argument not given at all + * vs. given as 'undefined'. We're a vararg function to handle this properly. + */ + + /* XXX: copy current activation flags to thr, including current magic, + * is_constructor_call etc. This takes a few bytes in duk_hthread but + * makes call sites smaller (there are >30 is_constructor_call and get + * current magic call sites. + */ + + if (duk_get_top(thr) == 0) { + duk_push_hstring_empty(thr); + } else { + h = duk_to_hstring_acceptsymbol(thr, 0); + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h) && !duk_is_constructor_call(thr))) { + duk_push_symbol_descriptive_string(thr, h); + duk_replace(thr, 0); + } + } + duk_to_string(thr, 0); /* catches symbol argument for constructor call */ + DUK_ASSERT(duk_is_string(thr, 0)); + duk_set_top(thr, 1); /* Top may be 1 or larger. */ + + if (duk_is_constructor_call(thr)) { + /* String object internal value is immutable */ + flags = DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_STRING); + duk_push_object_helper(thr, flags, DUK_BIDX_STRING_PROTOTYPE); + duk_dup_0(thr); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_VALUE, DUK_PROPDESC_FLAGS_NONE); + } + /* Note: unbalanced stack on purpose */ + + return 1; +} + +DUK_LOCAL duk_ret_t duk__construct_from_codepoints(duk_hthread *thr, duk_bool_t nonbmp) { + duk_bufwriter_ctx bw_alloc; + duk_bufwriter_ctx *bw; + duk_idx_t i, n; + duk_ucodepoint_t cp; + + /* XXX: It would be nice to build the string directly but ToUint16() + * coercion is needed so a generic helper would not be very + * helpful (perhaps coerce the value stack first here and then + * build a string from a duk_tval number sequence in one go?). + */ + + n = duk_get_top(thr); + + bw = &bw_alloc; + DUK_BW_INIT_PUSHBUF(thr, bw, (duk_size_t) n); /* initial estimate for ASCII only codepoints */ + + for (i = 0; i < n; i++) { + /* XXX: could improve bufwriter handling to write multiple codepoints + * with one ensure call but the relative benefit would be quite small. + */ + + if (nonbmp) { + /* ES2015 requires that (1) SameValue(cp, ToInteger(cp)) and + * (2) cp >= 0 and cp <= 0x10ffff. This check does not + * implement the steps exactly but the outcome should be + * the same. + */ + duk_int32_t i32 = 0; + if (!duk_is_whole_get_int32(duk_to_number(thr, i), &i32) || i32 < 0 || i32 > 0x10ffffL) { + DUK_DCERROR_RANGE_INVALID_ARGS(thr); + } + DUK_ASSERT(i32 >= 0 && i32 <= 0x10ffffL); + cp = (duk_ucodepoint_t) i32; + DUK_BW_WRITE_ENSURE_CESU8(thr, bw, cp); + } else { +#if defined(DUK_USE_NONSTD_STRING_FROMCHARCODE_32BIT) + /* ToUint16() coercion is mandatory in the E5.1 specification, but + * this non-compliant behavior makes more sense because we support + * non-BMP codepoints. Don't use CESU-8 because that'd create + * surrogate pairs. + */ + cp = (duk_ucodepoint_t) duk_to_uint32(thr, i); + DUK_BW_WRITE_ENSURE_XUTF8(thr, bw, cp); +#else + cp = (duk_ucodepoint_t) duk_to_uint16(thr, i); + DUK_ASSERT(cp >= 0 && cp <= 0x10ffffL); + DUK_BW_WRITE_ENSURE_CESU8(thr, bw, cp); +#endif + } + } + + DUK_BW_COMPACT(thr, bw); + (void) duk_buffer_to_string(thr, -1); /* Safe, extended UTF-8 or CESU-8 encoded. */ + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_string_constructor_from_char_code(duk_hthread *thr) { + return duk__construct_from_codepoints(thr, 0 /*nonbmp*/); +} + +#if defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_string_constructor_from_code_point(duk_hthread *thr) { + return duk__construct_from_codepoints(thr, 1 /*nonbmp*/); +} +#endif + +/* + * toString(), valueOf() + */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_to_string(duk_hthread *thr) { + duk_tval *tv; + + duk_push_this(thr); + tv = duk_require_tval(thr, -1); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_IS_STRING(tv)) { + /* return as is */ + } else if (DUK_TVAL_IS_OBJECT(tv)) { + duk_hobject *h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + + /* Must be a "string object", i.e. class "String" */ + if (DUK_HOBJECT_GET_CLASS_NUMBER(h) != DUK_HOBJECT_CLASS_STRING) { + goto type_error; + } + + duk_xget_owndataprop_stridx_short(thr, -1, DUK_STRIDX_INT_VALUE); + DUK_ASSERT(duk_is_string(thr, -1)); + } else { + goto type_error; + } + + (void) duk_require_hstring_notsymbol(thr, -1); /* Reject symbols (and wrapped symbols). */ + return 1; + +type_error: + DUK_DCERROR_TYPE_INVALID_ARGS(thr); +} + +/* + * Character and charcode access + */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_char_at(duk_hthread *thr) { + duk_hstring *h; + duk_int_t pos; + + /* XXX: faster implementation */ + + h = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h != NULL); + + pos = duk_to_int(thr, 0); + + if (sizeof(duk_size_t) >= sizeof(duk_uint_t)) { + /* Cast to duk_size_t works in this case: + * - If pos < 0, (duk_size_t) pos will always be + * >= max_charlen, and result will be the empty string + * (see duk_substring()). + * - If pos >= 0, pos + 1 cannot wrap. + */ + DUK_ASSERT((duk_size_t) DUK_INT_MIN >= DUK_HSTRING_MAX_BYTELEN); + DUK_ASSERT((duk_size_t) DUK_INT_MAX + 1U > (duk_size_t) DUK_INT_MAX); + duk_substring(thr, -1, (duk_size_t) pos, (duk_size_t) pos + 1U); + } else { + /* If size_t is smaller than int, explicit bounds checks + * are needed because an int may wrap multiple times. + */ + if (DUK_UNLIKELY(pos < 0 || (duk_uint_t) pos >= (duk_uint_t) DUK_HSTRING_GET_CHARLEN(h))) { + duk_push_hstring_empty(thr); + } else { + duk_substring(thr, -1, (duk_size_t) pos, (duk_size_t) pos + 1U); + } + } + + return 1; +} + +/* Magic: 0=charCodeAt, 1=codePointAt */ +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_char_code_at(duk_hthread *thr) { + duk_int_t pos; + duk_hstring *h; + duk_bool_t clamped; + duk_uint32_t cp; + duk_int_t magic; + + /* XXX: faster implementation */ + + DUK_DDD(DUK_DDDPRINT("arg=%!T", (duk_tval *) duk_get_tval(thr, 0))); + + h = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h != NULL); + + pos = duk_to_int_clamped_raw(thr, + 0 /*index*/, + 0 /*min(incl)*/, + (duk_int_t) DUK_HSTRING_GET_CHARLEN(h) - 1 /*max(incl)*/, + &clamped /*out_clamped*/); +#if defined(DUK_USE_ES6) + magic = duk_get_current_magic(thr); +#else + DUK_ASSERT(duk_get_current_magic(thr) == 0); + magic = 0; +#endif + if (clamped) { + /* For out-of-bounds indices .charCodeAt() returns NaN and + * .codePointAt() returns undefined. + */ + if (magic != 0) { + return 0; + } + duk_push_nan(thr); + } else { + DUK_ASSERT(pos >= 0); + cp = (duk_uint32_t) duk_hstring_char_code_at_raw(thr, h, (duk_uint_t) pos, (duk_bool_t) magic /*surrogate_aware*/); + duk_push_u32(thr, cp); + } + return 1; +} + +/* + * substring(), substr(), slice() + */ + +/* XXX: any chance of merging these three similar but still slightly + * different algorithms so that footprint would be reduced? + */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_substring(duk_hthread *thr) { + duk_hstring *h; + duk_int_t start_pos, end_pos; + duk_int_t len; + + h = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h != NULL); + len = (duk_int_t) DUK_HSTRING_GET_CHARLEN(h); + + /* [ start end str ] */ + + start_pos = duk_to_int_clamped(thr, 0, 0, len); + if (duk_is_undefined(thr, 1)) { + end_pos = len; + } else { + end_pos = duk_to_int_clamped(thr, 1, 0, len); + } + DUK_ASSERT(start_pos >= 0 && start_pos <= len); + DUK_ASSERT(end_pos >= 0 && end_pos <= len); + + if (start_pos > end_pos) { + duk_int_t tmp = start_pos; + start_pos = end_pos; + end_pos = tmp; + } + + DUK_ASSERT(end_pos >= start_pos); + + duk_substring(thr, -1, (duk_size_t) start_pos, (duk_size_t) end_pos); + return 1; +} + +#if defined(DUK_USE_SECTION_B) +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_substr(duk_hthread *thr) { + duk_hstring *h; + duk_int_t start_pos, end_pos; + duk_int_t len; + + /* Unlike non-obsolete String calls, substr() algorithm in E5.1 + * specification will happily coerce undefined and null to strings + * ("undefined" and "null"). + */ + duk_push_this(thr); + h = duk_to_hstring_m1(thr); /* Reject Symbols. */ + DUK_ASSERT(h != NULL); + len = (duk_int_t) DUK_HSTRING_GET_CHARLEN(h); + + /* [ start length str ] */ + + /* The implementation for computing of start_pos and end_pos differs + * from the standard algorithm, but is intended to result in the exactly + * same behavior. This is not always obvious. + */ + + /* combines steps 2 and 5; -len ensures max() not needed for step 5 */ + start_pos = duk_to_int_clamped(thr, 0, -len, len); + if (start_pos < 0) { + start_pos = len + start_pos; + } + DUK_ASSERT(start_pos >= 0 && start_pos <= len); + + /* combines steps 3, 6; step 7 is not needed */ + if (duk_is_undefined(thr, 1)) { + end_pos = len; + } else { + DUK_ASSERT(start_pos <= len); + end_pos = start_pos + duk_to_int_clamped(thr, 1, 0, len - start_pos); + } + DUK_ASSERT(start_pos >= 0 && start_pos <= len); + DUK_ASSERT(end_pos >= 0 && end_pos <= len); + DUK_ASSERT(end_pos >= start_pos); + + duk_substring(thr, -1, (duk_size_t) start_pos, (duk_size_t) end_pos); + return 1; +} +#endif /* DUK_USE_SECTION_B */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_slice(duk_hthread *thr) { + duk_hstring *h; + duk_int_t start_pos, end_pos; + duk_int_t len; + + h = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h != NULL); + len = (duk_int_t) DUK_HSTRING_GET_CHARLEN(h); + + /* [ start end str ] */ + + start_pos = duk_to_int_clamped(thr, 0, -len, len); + if (start_pos < 0) { + start_pos = len + start_pos; + } + if (duk_is_undefined(thr, 1)) { + end_pos = len; + } else { + end_pos = duk_to_int_clamped(thr, 1, -len, len); + if (end_pos < 0) { + end_pos = len + end_pos; + } + } + DUK_ASSERT(start_pos >= 0 && start_pos <= len); + DUK_ASSERT(end_pos >= 0 && end_pos <= len); + + if (end_pos < start_pos) { + end_pos = start_pos; + } + + DUK_ASSERT(end_pos >= start_pos); + + duk_substring(thr, -1, (duk_size_t) start_pos, (duk_size_t) end_pos); + return 1; +} + +/* + * Case conversion + */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_caseconv_shared(duk_hthread *thr) { + duk_small_int_t uppercase = duk_get_current_magic(thr); + + (void) duk_push_this_coercible_to_string(thr); + duk_unicode_case_convert_string(thr, (duk_bool_t) uppercase); + return 1; +} + +/* + * indexOf() and lastIndexOf() + */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_indexof_shared(duk_hthread *thr) { + duk_hstring *h_this; + duk_hstring *h_search; + duk_int_t clen_this; + duk_int_t cpos; + duk_small_uint_t is_lastindexof = (duk_small_uint_t) duk_get_current_magic(thr); /* 0=indexOf, 1=lastIndexOf */ + + h_this = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h_this != NULL); + clen_this = (duk_int_t) DUK_HSTRING_GET_CHARLEN(h_this); + + h_search = duk_to_hstring(thr, 0); + DUK_ASSERT(h_search != NULL); + + duk_to_number(thr, 1); + if (duk_is_nan(thr, 1) && is_lastindexof) { + /* indexOf: NaN should cause pos to be zero. + * lastIndexOf: NaN should cause pos to be +Infinity + * (and later be clamped to len). + */ + cpos = clen_this; + } else { + cpos = duk_to_int_clamped(thr, 1, 0, clen_this); + } + + cpos = duk__str_search_shared(thr, h_this, h_search, cpos, is_lastindexof /*backwards*/); + duk_push_int(thr, cpos); + return 1; +} + +/* + * replace() + */ + +/* XXX: the current implementation works but is quite clunky; it compiles + * to almost 1,4kB of x86 code so it needs to be simplified (better approach, + * shared helpers, etc). Some ideas for refactoring: + * + * - a primitive to convert a string into a regexp matcher (reduces matching + * code at the cost of making matching much slower) + * - use replace() as a basic helper for match() and split(), which are both + * much simpler + * - API call to get_prop and to_boolean + */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_replace(duk_hthread *thr) { + duk_hstring *h_input; + duk_hstring *h_match; + duk_hstring *h_search; + duk_hobject *h_re; + duk_bufwriter_ctx bw_alloc; + duk_bufwriter_ctx *bw; +#if defined(DUK_USE_REGEXP_SUPPORT) + duk_bool_t is_regexp; + duk_bool_t is_global; +#endif + duk_bool_t is_repl_func; + duk_uint32_t match_start_coff, match_start_boff; +#if defined(DUK_USE_REGEXP_SUPPORT) + duk_int_t match_caps; +#endif + duk_uint32_t prev_match_end_boff; + const duk_uint8_t *r_start, *r_end, *r; /* repl string scan */ + duk_size_t tmp_sz; + + DUK_ASSERT_TOP(thr, 2); + h_input = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h_input != NULL); + + bw = &bw_alloc; + DUK_BW_INIT_PUSHBUF(thr, bw, DUK_HSTRING_GET_BYTELEN(h_input)); /* input size is good output starting point */ + + DUK_ASSERT_TOP(thr, 4); + + /* stack[0] = search value + * stack[1] = replace value + * stack[2] = input string + * stack[3] = result buffer + */ + + h_re = duk_get_hobject_with_class(thr, 0, DUK_HOBJECT_CLASS_REGEXP); + if (h_re) { +#if defined(DUK_USE_REGEXP_SUPPORT) + is_regexp = 1; + is_global = duk_get_prop_stridx_boolean(thr, 0, DUK_STRIDX_GLOBAL, NULL); + + if (is_global) { + /* start match from beginning */ + duk_push_int(thr, 0); + duk_put_prop_stridx_short(thr, 0, DUK_STRIDX_LAST_INDEX); + } +#else /* DUK_USE_REGEXP_SUPPORT */ + DUK_DCERROR_UNSUPPORTED(thr); +#endif /* DUK_USE_REGEXP_SUPPORT */ + } else { + duk_to_string(thr, 0); /* rejects symbols */ +#if defined(DUK_USE_REGEXP_SUPPORT) + is_regexp = 0; + is_global = 0; +#endif + } + + if (duk_is_function(thr, 1)) { + is_repl_func = 1; + r_start = NULL; + r_end = NULL; + } else { + duk_hstring *h_repl; + + is_repl_func = 0; + h_repl = duk_to_hstring(thr, 1); /* reject symbols */ + DUK_ASSERT(h_repl != NULL); + r_start = DUK_HSTRING_GET_DATA(h_repl); + r_end = r_start + DUK_HSTRING_GET_BYTELEN(h_repl); + } + + prev_match_end_boff = 0; + + for (;;) { + /* + * If matching with a regexp: + * - non-global RegExp: lastIndex not touched on a match, zeroed + * on a non-match + * - global RegExp: on match, lastIndex will be updated by regexp + * executor to point to next char after the matching part (so that + * characters in the matching part are not matched again) + * + * If matching with a string: + * - always non-global match, find first occurrence + * + * We need: + * - The character offset of start-of-match for the replacer function + * - The byte offsets for start-of-match and end-of-match to implement + * the replacement values $&, $`, and $', and to copy non-matching + * input string portions (including header and trailer) verbatim. + * + * NOTE: the E5.1 specification is a bit vague how the RegExp should + * behave in the replacement process; e.g. is matching done first for + * all matches (in the global RegExp case) before any replacer calls + * are made? See: test-bi-string-proto-replace.js for discussion. + */ + + DUK_ASSERT_TOP(thr, 4); + +#if defined(DUK_USE_REGEXP_SUPPORT) + if (is_regexp) { + duk_dup_0(thr); + duk_dup_2(thr); + duk_regexp_match(thr); /* [ ... regexp input ] -> [ res_obj ] */ + if (!duk_is_object(thr, -1)) { + duk_pop(thr); + break; + } + + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_INDEX); + DUK_ASSERT(duk_is_number(thr, -1)); + match_start_coff = duk_get_uint(thr, -1); + duk_pop(thr); + + duk_get_prop_index(thr, -1, 0); + DUK_ASSERT(duk_is_string(thr, -1)); + h_match = duk_known_hstring(thr, -1); + duk_pop(thr); /* h_match is borrowed, remains reachable through match_obj */ + + if (DUK_HSTRING_GET_BYTELEN(h_match) == 0) { + /* This should be equivalent to match() algorithm step 8.f.iii.2: + * detect an empty match and allow it, but don't allow it twice. + */ + duk_uint32_t last_index; + + duk_get_prop_stridx_short(thr, 0, DUK_STRIDX_LAST_INDEX); + last_index = (duk_uint32_t) duk_get_uint(thr, -1); + DUK_DDD(DUK_DDDPRINT("empty match, bump lastIndex: %ld -> %ld", + (long) last_index, + (long) (last_index + 1))); + duk_pop(thr); + duk_push_uint(thr, (duk_uint_t) (last_index + 1)); + duk_put_prop_stridx_short(thr, 0, DUK_STRIDX_LAST_INDEX); + } + + DUK_ASSERT(duk_get_length(thr, -1) <= DUK_INT_MAX); /* string limits */ + match_caps = (duk_int_t) duk_get_length(thr, -1); + } else { +#else /* DUK_USE_REGEXP_SUPPORT */ + { /* unconditionally */ +#endif /* DUK_USE_REGEXP_SUPPORT */ + const duk_uint8_t *p_start, *p_end, *p; /* input string scan */ + const duk_uint8_t *q_start; /* match string */ + duk_size_t p_blen; + duk_size_t q_blen; + +#if defined(DUK_USE_REGEXP_SUPPORT) + DUK_ASSERT(!is_global); /* single match always */ +#endif + + p_start = DUK_HSTRING_GET_DATA(h_input); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h_input); + p_blen = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h_input); + p = p_start; + + h_search = duk_known_hstring(thr, 0); + q_start = DUK_HSTRING_GET_DATA(h_search); + q_blen = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h_search); + + if (q_blen > p_blen) { + break; /* no match */ + } + + p_end -= q_blen; /* ensure full memcmp() fits in while */ + DUK_ASSERT(p_end >= p); + + match_start_coff = 0; + + while (p <= p_end) { + DUK_ASSERT(p + q_blen <= DUK_HSTRING_GET_DATA(h_input) + DUK_HSTRING_GET_BYTELEN(h_input)); + if (duk_memcmp((const void *) p, (const void *) q_start, (size_t) q_blen) == 0) { + duk_dup_0(thr); + h_match = duk_known_hstring(thr, -1); +#if defined(DUK_USE_REGEXP_SUPPORT) + match_caps = 0; +#endif + goto found; + } + + /* track utf-8 non-continuation bytes */ + if ((p[0] & 0xc0) != 0x80) { + match_start_coff++; + } + p++; + } + + /* not found */ + break; + } + found: + + /* stack[0] = search value + * stack[1] = replace value + * stack[2] = input string + * stack[3] = result buffer + * stack[4] = regexp match OR match string + */ + + match_start_boff = (duk_uint32_t) duk_heap_strcache_offset_char2byte(thr, h_input, match_start_coff); + + tmp_sz = (duk_size_t) (match_start_boff - prev_match_end_boff); + DUK_BW_WRITE_ENSURE_BYTES(thr, bw, DUK_HSTRING_GET_DATA(h_input) + prev_match_end_boff, tmp_sz); + + prev_match_end_boff = match_start_boff + DUK_HSTRING_GET_BYTELEN(h_match); + + if (is_repl_func) { + duk_idx_t idx_args; + duk_hstring *h_repl; + + /* regexp res_obj is at index 4 */ + + duk_dup_1(thr); + idx_args = duk_get_top(thr); + +#if defined(DUK_USE_REGEXP_SUPPORT) + if (is_regexp) { + duk_int_t idx; + duk_require_stack(thr, match_caps + 2); + for (idx = 0; idx < match_caps; idx++) { + /* match followed by capture(s) */ + duk_get_prop_index(thr, 4, (duk_uarridx_t) idx); + } + } else { +#else /* DUK_USE_REGEXP_SUPPORT */ + { /* unconditionally */ +#endif /* DUK_USE_REGEXP_SUPPORT */ + /* match == search string, by definition */ + duk_dup_0(thr); + } + duk_push_uint(thr, (duk_uint_t) match_start_coff); + duk_dup_2(thr); + + /* [ ... replacer match [captures] match_char_offset input ] */ + + duk_call(thr, duk_get_top(thr) - idx_args); + h_repl = duk_to_hstring_m1(thr); /* -> [ ... repl_value ] */ + DUK_ASSERT(h_repl != NULL); + + DUK_BW_WRITE_ENSURE_HSTRING(thr, bw, h_repl); + + duk_pop(thr); /* repl_value */ + } else { + r = r_start; + + while (r < r_end) { + duk_int_t ch1; + duk_int_t ch2; +#if defined(DUK_USE_REGEXP_SUPPORT) + duk_int_t ch3; +#endif + duk_size_t left; + + ch1 = *r++; + if (ch1 != DUK_ASC_DOLLAR) { + goto repl_write; + } + DUK_ASSERT(r <= r_end); + left = (duk_size_t) (r_end - r); + + if (left <= 0) { + goto repl_write; + } + + ch2 = r[0]; + switch (ch2) { + case DUK_ASC_DOLLAR: { + ch1 = (1 << 8) + DUK_ASC_DOLLAR; + goto repl_write; + } + case DUK_ASC_AMP: { + DUK_BW_WRITE_ENSURE_HSTRING(thr, bw, h_match); + r++; + continue; + } + case DUK_ASC_GRAVE: { + tmp_sz = (duk_size_t) match_start_boff; + DUK_BW_WRITE_ENSURE_BYTES(thr, bw, DUK_HSTRING_GET_DATA(h_input), tmp_sz); + r++; + continue; + } + case DUK_ASC_SINGLEQUOTE: { + duk_uint32_t match_end_boff; + + /* Use match charlen instead of bytelen, just in case the input and + * match codepoint encodings would have different lengths. + */ + /* XXX: charlen computed here, and also in char2byte helper. */ + match_end_boff = (duk_uint32_t) duk_heap_strcache_offset_char2byte( + thr, + h_input, + match_start_coff + (duk_uint_fast32_t) DUK_HSTRING_GET_CHARLEN(h_match)); + + tmp_sz = (duk_size_t) (DUK_HSTRING_GET_BYTELEN(h_input) - match_end_boff); + DUK_BW_WRITE_ENSURE_BYTES(thr, bw, DUK_HSTRING_GET_DATA(h_input) + match_end_boff, tmp_sz); + r++; + continue; + } + default: { +#if defined(DUK_USE_REGEXP_SUPPORT) + duk_int_t capnum, captmp, capadv; + /* XXX: optional check, match_caps is zero if no regexp, + * so dollar will be interpreted literally anyway. + */ + + if (!is_regexp) { + goto repl_write; + } + + if (!(ch2 >= DUK_ASC_0 && ch2 <= DUK_ASC_9)) { + goto repl_write; + } + capnum = ch2 - DUK_ASC_0; + capadv = 1; + + if (left >= 2) { + ch3 = r[1]; + if (ch3 >= DUK_ASC_0 && ch3 <= DUK_ASC_9) { + captmp = capnum * 10 + (ch3 - DUK_ASC_0); + if (captmp < match_caps) { + capnum = captmp; + capadv = 2; + } + } + } + + if (capnum > 0 && capnum < match_caps) { + DUK_ASSERT(is_regexp != 0); /* match_caps == 0 without regexps */ + + /* regexp res_obj is at offset 4 */ + duk_get_prop_index(thr, 4, (duk_uarridx_t) capnum); + if (duk_is_string(thr, -1)) { + duk_hstring *h_tmp_str; + + h_tmp_str = duk_known_hstring(thr, -1); + + DUK_BW_WRITE_ENSURE_HSTRING(thr, bw, h_tmp_str); + } else { + /* undefined -> skip (replaced with empty) */ + } + duk_pop(thr); + r += capadv; + continue; + } else { + goto repl_write; + } +#else /* DUK_USE_REGEXP_SUPPORT */ + goto repl_write; /* unconditionally */ +#endif /* DUK_USE_REGEXP_SUPPORT */ + } /* default case */ + } /* switch (ch2) */ + + repl_write: + /* ch1 = (r_increment << 8) + byte */ + + DUK_BW_WRITE_ENSURE_U8(thr, bw, (duk_uint8_t) (ch1 & 0xff)); + r += ch1 >> 8; + } /* while repl */ + } /* if (is_repl_func) */ + + duk_pop(thr); /* pop regexp res_obj or match string */ + +#if defined(DUK_USE_REGEXP_SUPPORT) + if (!is_global) { +#else + { /* unconditionally; is_global==0 */ +#endif + break; + } + } + + /* trailer */ + tmp_sz = (duk_size_t) (DUK_HSTRING_GET_BYTELEN(h_input) - prev_match_end_boff); + DUK_BW_WRITE_ENSURE_BYTES(thr, bw, DUK_HSTRING_GET_DATA(h_input) + prev_match_end_boff, tmp_sz); + + DUK_ASSERT_TOP(thr, 4); + DUK_BW_COMPACT(thr, bw); + (void) duk_buffer_to_string(thr, -1); /* Safe if inputs are safe. */ + return 1; +} + +/* + * split() + */ + +/* XXX: very messy now, but works; clean up, remove unused variables (nomimally + * used so compiler doesn't complain). + */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_split(duk_hthread *thr) { + duk_hstring *h_input; + duk_hstring *h_sep; + duk_uint32_t limit; + duk_uint32_t arr_idx; +#if defined(DUK_USE_REGEXP_SUPPORT) + duk_bool_t is_regexp; +#endif + duk_bool_t matched; /* set to 1 if any match exists (needed for empty input special case) */ + duk_uint32_t prev_match_end_coff, prev_match_end_boff; + duk_uint32_t match_start_boff, match_start_coff; + duk_uint32_t match_end_boff, match_end_coff; + + h_input = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h_input != NULL); + + duk_push_array(thr); + + if (duk_is_undefined(thr, 1)) { + limit = 0xffffffffUL; + } else { + limit = duk_to_uint32(thr, 1); + } + + if (limit == 0) { + return 1; + } + + /* If the separator is a RegExp, make a "clone" of it. The specification + * algorithm calls [[Match]] directly for specific indices; we emulate this + * by tweaking lastIndex and using a "force global" variant of duk_regexp_match() + * which will use global-style matching even when the RegExp itself is non-global. + */ + + if (duk_is_undefined(thr, 0)) { + /* The spec algorithm first does "R = ToString(separator)" before checking + * whether separator is undefined. Since this is side effect free, we can + * skip the ToString() here. + */ + duk_dup_2(thr); + duk_put_prop_index(thr, 3, 0); + return 1; + } else if (duk_get_hobject_with_class(thr, 0, DUK_HOBJECT_CLASS_REGEXP) != NULL) { +#if defined(DUK_USE_REGEXP_SUPPORT) + duk_push_hobject_bidx(thr, DUK_BIDX_REGEXP_CONSTRUCTOR); + duk_dup_0(thr); + duk_new(thr, 1); /* [ ... RegExp val ] -> [ ... res ] */ + duk_replace(thr, 0); + /* lastIndex is initialized to zero by new RegExp() */ + is_regexp = 1; +#else + DUK_DCERROR_UNSUPPORTED(thr); +#endif + } else { + duk_to_string(thr, 0); +#if defined(DUK_USE_REGEXP_SUPPORT) + is_regexp = 0; +#endif + } + + /* stack[0] = separator (string or regexp) + * stack[1] = limit + * stack[2] = input string + * stack[3] = result array + */ + + prev_match_end_boff = 0; + prev_match_end_coff = 0; + arr_idx = 0; + matched = 0; + + for (;;) { + /* + * The specification uses RegExp [[Match]] to attempt match at specific + * offsets. We don't have such a primitive, so we use an actual RegExp + * and tweak lastIndex. Since the RegExp may be non-global, we use a + * special variant which forces global-like behavior for matching. + */ + + DUK_ASSERT_TOP(thr, 4); + +#if defined(DUK_USE_REGEXP_SUPPORT) + if (is_regexp) { + duk_dup_0(thr); + duk_dup_2(thr); + duk_regexp_match_force_global(thr); /* [ ... regexp input ] -> [ res_obj ] */ + if (!duk_is_object(thr, -1)) { + duk_pop(thr); + break; + } + matched = 1; + + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_INDEX); + DUK_ASSERT(duk_is_number(thr, -1)); + match_start_coff = duk_get_uint(thr, -1); + match_start_boff = (duk_uint32_t) duk_heap_strcache_offset_char2byte(thr, h_input, match_start_coff); + duk_pop(thr); + + if (match_start_coff == DUK_HSTRING_GET_CHARLEN(h_input)) { + /* don't allow an empty match at the end of the string */ + duk_pop(thr); + break; + } + + duk_get_prop_stridx_short(thr, 0, DUK_STRIDX_LAST_INDEX); + DUK_ASSERT(duk_is_number(thr, -1)); + match_end_coff = duk_get_uint(thr, -1); + match_end_boff = (duk_uint32_t) duk_heap_strcache_offset_char2byte(thr, h_input, match_end_coff); + duk_pop(thr); + + /* empty match -> bump and continue */ + if (prev_match_end_boff == match_end_boff) { + duk_push_uint(thr, (duk_uint_t) (match_end_coff + 1)); + duk_put_prop_stridx_short(thr, 0, DUK_STRIDX_LAST_INDEX); + duk_pop(thr); + continue; + } + } else { +#else /* DUK_USE_REGEXP_SUPPORT */ + { /* unconditionally */ +#endif /* DUK_USE_REGEXP_SUPPORT */ + const duk_uint8_t *p_start, *p_end, *p; /* input string scan */ + const duk_uint8_t *q_start; /* match string */ + duk_size_t q_blen, q_clen; + + p_start = DUK_HSTRING_GET_DATA(h_input); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h_input); + p = p_start + prev_match_end_boff; + + h_sep = duk_known_hstring(thr, 0); /* symbol already rejected above */ + q_start = DUK_HSTRING_GET_DATA(h_sep); + q_blen = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h_sep); + q_clen = (duk_size_t) DUK_HSTRING_GET_CHARLEN(h_sep); + + p_end -= q_blen; /* ensure full memcmp() fits in while */ + + match_start_coff = prev_match_end_coff; + + if (q_blen == 0) { + /* Handle empty separator case: it will always match, and always + * triggers the check in step 13.c.iii initially. Note that we + * must skip to either end of string or start of first codepoint, + * skipping over any continuation bytes! + * + * Don't allow an empty string to match at the end of the input. + */ + + matched = 1; /* empty separator can always match */ + + match_start_coff++; + p++; + while (p < p_end) { + if ((p[0] & 0xc0) != 0x80) { + goto found; + } + p++; + } + goto not_found; + } + + DUK_ASSERT(q_blen > 0 && q_clen > 0); + while (p <= p_end) { + DUK_ASSERT(p + q_blen <= DUK_HSTRING_GET_DATA(h_input) + DUK_HSTRING_GET_BYTELEN(h_input)); + DUK_ASSERT(q_blen > 0); /* no issues with empty memcmp() */ + if (duk_memcmp((const void *) p, (const void *) q_start, (size_t) q_blen) == 0) { + /* never an empty match, so step 13.c.iii can't be triggered */ + goto found; + } + + /* track utf-8 non-continuation bytes */ + if ((p[0] & 0xc0) != 0x80) { + match_start_coff++; + } + p++; + } + + not_found: + /* not found */ + break; + + found: + matched = 1; + match_start_boff = (duk_uint32_t) (p - p_start); + match_end_coff = (duk_uint32_t) (match_start_coff + q_clen); /* constrained by string length */ + match_end_boff = (duk_uint32_t) (match_start_boff + q_blen); /* ditto */ + + /* empty match (may happen with empty separator) -> bump and continue */ + if (prev_match_end_boff == match_end_boff) { + prev_match_end_boff++; + prev_match_end_coff++; + continue; + } + } /* if (is_regexp) */ + + /* stack[0] = separator (string or regexp) + * stack[1] = limit + * stack[2] = input string + * stack[3] = result array + * stack[4] = regexp res_obj (if is_regexp) + */ + + DUK_DDD(DUK_DDDPRINT("split; match_start b=%ld,c=%ld, match_end b=%ld,c=%ld, prev_end b=%ld,c=%ld", + (long) match_start_boff, + (long) match_start_coff, + (long) match_end_boff, + (long) match_end_coff, + (long) prev_match_end_boff, + (long) prev_match_end_coff)); + + duk_push_lstring(thr, + (const char *) (DUK_HSTRING_GET_DATA(h_input) + prev_match_end_boff), + (duk_size_t) (match_start_boff - prev_match_end_boff)); + duk_put_prop_index(thr, 3, arr_idx); + arr_idx++; + if (arr_idx >= limit) { + goto hit_limit; + } + +#if defined(DUK_USE_REGEXP_SUPPORT) + if (is_regexp) { + duk_size_t i, len; + + len = duk_get_length(thr, 4); + for (i = 1; i < len; i++) { + DUK_ASSERT(i <= DUK_UARRIDX_MAX); /* cannot have >4G captures */ + duk_get_prop_index(thr, 4, (duk_uarridx_t) i); + duk_put_prop_index(thr, 3, arr_idx); + arr_idx++; + if (arr_idx >= limit) { + goto hit_limit; + } + } + + duk_pop(thr); + /* lastIndex already set up for next match */ + } else { +#else /* DUK_USE_REGEXP_SUPPORT */ + { + /* unconditionally */ +#endif /* DUK_USE_REGEXP_SUPPORT */ + /* no action */ + } + + prev_match_end_boff = match_end_boff; + prev_match_end_coff = match_end_coff; + continue; + } /* for */ + + /* Combined step 11 (empty string special case) and 14-15. */ + + DUK_DDD(DUK_DDDPRINT("split trailer; prev_end b=%ld,c=%ld", (long) prev_match_end_boff, (long) prev_match_end_coff)); + + if (DUK_HSTRING_GET_BYTELEN(h_input) > 0 || !matched) { + /* Add trailer if: + * a) non-empty input + * b) empty input and no (zero size) match found (step 11) + */ + + duk_push_lstring(thr, + (const char *) DUK_HSTRING_GET_DATA(h_input) + prev_match_end_boff, + (duk_size_t) (DUK_HSTRING_GET_BYTELEN(h_input) - prev_match_end_boff)); + duk_put_prop_index(thr, 3, arr_idx); + /* No arr_idx update or limit check */ + } + + return 1; + +hit_limit: +#if defined(DUK_USE_REGEXP_SUPPORT) + if (is_regexp) { + duk_pop(thr); + } +#endif + + return 1; +} + +/* + * Various + */ + +#if defined(DUK_USE_REGEXP_SUPPORT) +DUK_LOCAL void duk__to_regexp_helper(duk_hthread *thr, duk_idx_t idx, duk_bool_t force_new) { + duk_hobject *h; + + /* Shared helper for match() steps 3-4, search() steps 3-4. */ + + DUK_ASSERT(idx >= 0); + + if (force_new) { + goto do_new; + } + + h = duk_get_hobject_with_class(thr, idx, DUK_HOBJECT_CLASS_REGEXP); + if (!h) { + goto do_new; + } + return; + +do_new: + duk_push_hobject_bidx(thr, DUK_BIDX_REGEXP_CONSTRUCTOR); + duk_dup(thr, idx); + duk_new(thr, 1); /* [ ... RegExp val ] -> [ ... res ] */ + duk_replace(thr, idx); +} +#endif /* DUK_USE_REGEXP_SUPPORT */ + +#if defined(DUK_USE_REGEXP_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_search(duk_hthread *thr) { + /* Easiest way to implement the search required by the specification + * is to do a RegExp test() with lastIndex forced to zero. To avoid + * side effects on the argument, "clone" the RegExp if a RegExp was + * given as input. + * + * The global flag of the RegExp should be ignored; setting lastIndex + * to zero (which happens when "cloning" the RegExp) should have an + * equivalent effect. + */ + + DUK_ASSERT_TOP(thr, 1); + (void) duk_push_this_coercible_to_string(thr); /* at index 1 */ + duk__to_regexp_helper(thr, 0 /*index*/, 1 /*force_new*/); + + /* stack[0] = regexp + * stack[1] = string + */ + + /* Avoid using RegExp.prototype methods, as they're writable and + * configurable and may have been changed. + */ + + duk_dup_0(thr); + duk_dup_1(thr); /* [ ... re_obj input ] */ + duk_regexp_match(thr); /* -> [ ... res_obj ] */ + + if (!duk_is_object(thr, -1)) { + duk_push_int(thr, -1); + return 1; + } + + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_INDEX); + DUK_ASSERT(duk_is_number(thr, -1)); + return 1; +} +#endif /* DUK_USE_REGEXP_SUPPORT */ + +#if defined(DUK_USE_REGEXP_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_match(duk_hthread *thr) { + duk_bool_t global; + duk_int_t prev_last_index; + duk_int_t this_index; + duk_int_t arr_idx; + + DUK_ASSERT_TOP(thr, 1); + (void) duk_push_this_coercible_to_string(thr); + duk__to_regexp_helper(thr, 0 /*index*/, 0 /*force_new*/); + global = duk_get_prop_stridx_boolean(thr, 0, DUK_STRIDX_GLOBAL, NULL); + DUK_ASSERT_TOP(thr, 2); + + /* stack[0] = regexp + * stack[1] = string + */ + + if (!global) { + duk_regexp_match(thr); /* -> [ res_obj ] */ + return 1; /* return 'res_obj' */ + } + + /* Global case is more complex. */ + + /* [ regexp string ] */ + + duk_push_int(thr, 0); + duk_put_prop_stridx_short(thr, 0, DUK_STRIDX_LAST_INDEX); + duk_push_array(thr); + + /* [ regexp string res_arr ] */ + + prev_last_index = 0; + arr_idx = 0; + + for (;;) { + DUK_ASSERT_TOP(thr, 3); + + duk_dup_0(thr); + duk_dup_1(thr); + duk_regexp_match(thr); /* -> [ ... regexp string ] -> [ ... res_obj ] */ + + if (!duk_is_object(thr, -1)) { + duk_pop(thr); + break; + } + + duk_get_prop_stridx_short(thr, 0, DUK_STRIDX_LAST_INDEX); + DUK_ASSERT(duk_is_number(thr, -1)); + this_index = duk_get_int(thr, -1); + duk_pop(thr); + + if (this_index == prev_last_index) { + this_index++; + duk_push_int(thr, this_index); + duk_put_prop_stridx_short(thr, 0, DUK_STRIDX_LAST_INDEX); + } + prev_last_index = this_index; + + duk_get_prop_index(thr, -1, 0); /* match string */ + duk_put_prop_index(thr, 2, (duk_uarridx_t) arr_idx); + arr_idx++; + duk_pop(thr); /* res_obj */ + } + + if (arr_idx == 0) { + duk_push_null(thr); + } + + return 1; /* return 'res_arr' or 'null' */ +} +#endif /* DUK_USE_REGEXP_SUPPORT */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_concat(duk_hthread *thr) { + /* duk_concat() coerces arguments with ToString() in correct order */ + (void) duk_push_this_coercible_to_string(thr); + duk_insert(thr, 0); /* this is relatively expensive */ + duk_concat(thr, duk_get_top(thr)); + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_trim(duk_hthread *thr) { + DUK_ASSERT_TOP(thr, 0); + (void) duk_push_this_coercible_to_string(thr); + duk_trim(thr, 0); + DUK_ASSERT_TOP(thr, 1); + return 1; +} + +#if defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_repeat(duk_hthread *thr) { + duk_hstring *h_input; + duk_size_t input_blen; + duk_size_t result_len; + duk_int_t count_signed; + duk_uint_t count; + const duk_uint8_t *src; + duk_uint8_t *buf; + duk_uint8_t *p; + duk_double_t d; +#if !defined(DUK_USE_PREFER_SIZE) + duk_size_t copy_size; + duk_uint8_t *p_end; +#endif + + DUK_ASSERT_TOP(thr, 1); + h_input = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h_input != NULL); + input_blen = DUK_HSTRING_GET_BYTELEN(h_input); + + /* Count is ToNumber() coerced; +Infinity must be always rejected + * (even if input string is zero length), as well as negative values + * and -Infinity. -Infinity doesn't require an explicit check + * because duk_get_int() clamps it to DUK_INT_MIN which gets rejected + * as a negative value (regardless of input string length). + */ + d = duk_to_number(thr, 0); + if (duk_double_is_posinf(d)) { + goto fail_range; + } + count_signed = duk_get_int(thr, 0); + if (count_signed < 0) { + goto fail_range; + } + count = (duk_uint_t) count_signed; + + /* Overflow check for result length. */ + result_len = count * input_blen; + if (count != 0 && result_len / count != input_blen) { + goto fail_range; + } + + /* Temporary fixed buffer, later converted to string. */ + buf = (duk_uint8_t *) duk_push_fixed_buffer_nozero(thr, result_len); + DUK_ASSERT(buf != NULL); + src = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_input); + DUK_ASSERT(src != NULL); + +#if defined(DUK_USE_PREFER_SIZE) + p = buf; + while (count-- > 0) { + duk_memcpy((void *) p, (const void *) src, input_blen); /* copy size may be zero, but pointers are valid */ + p += input_blen; + } +#else /* DUK_USE_PREFER_SIZE */ + /* Take advantage of already copied pieces to speed up the process + * especially for small repeated strings. + */ + p = buf; + p_end = p + result_len; + copy_size = input_blen; + for (;;) { + duk_size_t remain = (duk_size_t) (p_end - p); + DUK_DDD(DUK_DDDPRINT("remain=%ld, copy_size=%ld, input_blen=%ld, result_len=%ld", + (long) remain, + (long) copy_size, + (long) input_blen, + (long) result_len)); + if (remain <= copy_size) { + /* If result_len is zero, this case is taken and does + * a zero size copy (with valid pointers). + */ + duk_memcpy((void *) p, (const void *) src, remain); + break; + } else { + duk_memcpy((void *) p, (const void *) src, copy_size); + p += copy_size; + } + + src = (const duk_uint8_t *) buf; /* Use buf as source for larger copies. */ + copy_size = (duk_size_t) (p - buf); + } +#endif /* DUK_USE_PREFER_SIZE */ + + /* XXX: It would be useful to be able to create a duk_hstring with + * a certain byte size whose data area wasn't initialized and which + * wasn't in the string table yet. This would allow a string to be + * constructed directly without a buffer temporary and when it was + * finished, it could be injected into the string table. Currently + * this isn't possible because duk_hstrings are only tracked by the + * intern table (they are not in heap_allocated). + */ + + duk_buffer_to_string(thr, -1); /* Safe if input is safe. */ + return 1; + +fail_range: + DUK_DCERROR_RANGE_INVALID_ARGS(thr); +} +#endif /* DUK_USE_ES6 */ + +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_locale_compare(duk_hthread *thr) { + duk_hstring *h1; + duk_hstring *h2; + duk_size_t h1_len, h2_len, prefix_len; + duk_small_int_t ret = 0; + duk_small_int_t rc; + + /* The current implementation of localeCompare() is simply a codepoint + * by codepoint comparison, implemented with a simple string compare + * because UTF-8 should preserve codepoint ordering (assuming valid + * shortest UTF-8 encoding). + * + * The specification requires that the return value must be related + * to the sort order: e.g. negative means that 'this' comes before + * 'that' in sort order. We assume an ascending sort order. + */ + + /* XXX: could share code with duk_js_ops.c, duk_js_compare_helper */ + + h1 = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h1 != NULL); + + h2 = duk_to_hstring(thr, 0); + DUK_ASSERT(h2 != NULL); + + h1_len = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h1); + h2_len = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h2); + prefix_len = (h1_len <= h2_len ? h1_len : h2_len); + + rc = (duk_small_int_t) duk_memcmp((const void *) DUK_HSTRING_GET_DATA(h1), + (const void *) DUK_HSTRING_GET_DATA(h2), + (size_t) prefix_len); + + if (rc < 0) { + ret = -1; + goto done; + } else if (rc > 0) { + ret = 1; + goto done; + } + + /* prefix matches, lengths matter now */ + if (h1_len > h2_len) { + ret = 1; + goto done; + } else if (h1_len == h2_len) { + DUK_ASSERT(ret == 0); + goto done; + } + ret = -1; + goto done; + +done: + duk_push_int(thr, (duk_int_t) ret); + return 1; +} + +#if defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_startswith_endswith(duk_hthread *thr) { + duk_int_t magic; + duk_hstring *h_target; + duk_size_t blen_target; + duk_hstring *h_search; + duk_size_t blen_search; + duk_int_t off; + duk_bool_t result = 0; + duk_size_t blen_left; + + /* Because string byte lengths are in [0,DUK_INT_MAX] it's safe to + * subtract two string lengths without overflow. + */ + DUK_ASSERT(DUK_HSTRING_MAX_BYTELEN <= DUK_INT_MAX); + + h_target = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h_target != NULL); + + h_search = duk__str_tostring_notregexp(thr, 0); + DUK_ASSERT(h_search != NULL); + + magic = duk_get_current_magic(thr); + + /* Careful to avoid pointer overflows in the matching logic. */ + + blen_target = DUK_HSTRING_GET_BYTELEN(h_target); + blen_search = DUK_HSTRING_GET_BYTELEN(h_search); + +#if 0 + /* If search string is longer than the target string, we can + * never match. Could check explicitly, but should be handled + * correctly below. + */ + if (blen_search > blen_target) { + goto finish; + } +#endif + + off = 0; + if (duk_is_undefined(thr, 1)) { + if (magic) { + off = (duk_int_t) blen_target - (duk_int_t) blen_search; + } else { + DUK_ASSERT(off == 0); + } + } else { + duk_int_t len; + duk_int_t pos; + + DUK_ASSERT(DUK_HSTRING_MAX_BYTELEN <= DUK_INT_MAX); + len = (duk_int_t) DUK_HSTRING_GET_CHARLEN(h_target); + pos = duk_to_int_clamped(thr, 1, 0, len); + DUK_ASSERT(pos >= 0 && pos <= len); + + off = (duk_int_t) duk_heap_strcache_offset_char2byte(thr, h_target, (duk_uint_fast32_t) pos); + if (magic) { + off -= (duk_int_t) blen_search; + } + } + if (off < 0 || off > (duk_int_t) blen_target) { + goto finish; + } + + /* The main comparison can be done using a memcmp() rather than + * doing codepoint comparisons: for CESU-8 strings there is a + * canonical representation for every codepoint. But we do need + * to deal with the char/byte offset translation to find the + * comparison range. + */ + + DUK_ASSERT(off >= 0); + DUK_ASSERT((duk_size_t) off <= blen_target); + blen_left = blen_target - (duk_size_t) off; + if (blen_left >= blen_search) { + const duk_uint8_t *p_cmp_start = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_target) + off; + const duk_uint8_t *p_search = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_search); + if (duk_memcmp_unsafe((const void *) p_cmp_start, (const void *) p_search, (size_t) blen_search) == 0) { + result = 1; + } + } + +finish: + duk_push_boolean(thr, result); + return 1; +} +#endif /* DUK_USE_ES6 */ + +#if defined(DUK_USE_ES6) +DUK_INTERNAL duk_ret_t duk_bi_string_prototype_includes(duk_hthread *thr) { + duk_hstring *h; + duk_hstring *h_search; + duk_int_t len; + duk_int_t pos; + + h = duk_push_this_coercible_to_string(thr); + DUK_ASSERT(h != NULL); + + h_search = duk__str_tostring_notregexp(thr, 0); + DUK_ASSERT(h_search != NULL); + + len = (duk_int_t) DUK_HSTRING_GET_CHARLEN(h); + pos = duk_to_int_clamped(thr, 1, 0, len); + DUK_ASSERT(pos >= 0 && pos <= len); + + pos = duk__str_search_shared(thr, h, h_search, pos, 0 /*backwards*/); + duk_push_boolean(thr, pos >= 0); + return 1; +} +#endif /* DUK_USE_ES6 */ +#endif /* DUK_USE_STRING_BUILTIN */ +#line 1 "duk_bi_symbol.c" +/* + * Symbol built-in + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_SYMBOL_BUILTIN) + +/* + * Constructor + */ + +DUK_INTERNAL duk_ret_t duk_bi_symbol_constructor_shared(duk_hthread *thr) { + const duk_uint8_t *desc; + duk_size_t len; + duk_uint8_t *buf; + duk_uint8_t *p; + duk_int_t magic; + + magic = duk_get_current_magic(thr); + if (duk_is_undefined(thr, 0) && (magic == 0)) { + /* Symbol() accepts undefined and empty string, but they are + * treated differently. + */ + desc = NULL; + len = 0; + } else { + /* Symbol.for() coerces undefined to 'undefined' */ + desc = (const duk_uint8_t *) duk_to_lstring(thr, 0, &len); + } + + /* Maximum symbol data length: + * +1 initial byte (0x80 or 0x81) + * +len description + * +1 0xff after description, before unique suffix + * +17 autogenerated unique suffix: 'ffffffff-ffffffff' is longest + * +1 0xff after unique suffix for symbols with undefined description + */ + buf = (duk_uint8_t *) duk_push_fixed_buffer(thr, 1 + len + 1 + 17 + 1); + DUK_ASSERT(buf != NULL); + p = buf + 1; + DUK_ASSERT(desc != NULL || len == 0); /* may be NULL if len is 0 */ + duk_memcpy_unsafe((void *) p, (const void *) desc, len); + p += len; + if (magic == 0) { + /* Symbol(): create unique symbol. Use two 32-bit values + * to avoid dependency on 64-bit types and 64-bit integer + * formatting (at least for now). + */ + if (++thr->heap->sym_counter[0] == 0) { + thr->heap->sym_counter[1]++; + } + p += DUK_SPRINTF((char *) p, + "\xFF" + "%lx-%lx", + (unsigned long) thr->heap->sym_counter[1], + (unsigned long) thr->heap->sym_counter[0]); + if (desc == NULL) { + /* Special case for 'undefined' description, trailing + * 0xff distinguishes from empty string description, + * but needs minimal special case handling elsewhere. + */ + *p++ = 0xff; + } + buf[0] = 0x81; + } else { + /* Symbol.for(): create a global symbol */ + buf[0] = 0x80; + } + + duk_push_lstring(thr, (const char *) buf, (duk_size_t) (p - buf)); + DUK_DDD(DUK_DDDPRINT("created symbol: %!T", duk_get_tval(thr, -1))); + return 1; +} + +DUK_LOCAL duk_hstring *duk__auto_unbox_symbol(duk_hthread *thr, duk_tval *tv_arg) { + duk_tval *tv; + duk_hobject *h_obj; + duk_hstring *h_str; + + DUK_ASSERT(tv_arg != NULL); + + /* XXX: add internal helper: duk_auto_unbox_tval(thr, tv, mask); */ + /* XXX: add internal helper: duk_auto_unbox(thr, tv, idx); */ + + tv = tv_arg; + if (DUK_TVAL_IS_OBJECT(tv)) { + h_obj = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h_obj != NULL); + if (DUK_HOBJECT_GET_CLASS_NUMBER(h_obj) == DUK_HOBJECT_CLASS_SYMBOL) { + tv = duk_hobject_get_internal_value_tval_ptr(thr->heap, h_obj); + if (tv == NULL) { + return NULL; + } + } else { + return NULL; + } + } + + if (!DUK_TVAL_IS_STRING(tv)) { + return NULL; + } + h_str = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h_str != NULL); + + /* Here symbol is more expected than not. */ + if (DUK_UNLIKELY(!DUK_HSTRING_HAS_SYMBOL(h_str))) { + return NULL; + } + + return h_str; +} + +DUK_INTERNAL duk_ret_t duk_bi_symbol_tostring_shared(duk_hthread *thr) { + duk_hstring *h_str; + + h_str = duk__auto_unbox_symbol(thr, DUK_HTHREAD_THIS_PTR(thr)); + if (h_str == NULL) { + return DUK_RET_TYPE_ERROR; + } + + if (duk_get_current_magic(thr) == 0) { + /* .toString() */ + duk_push_symbol_descriptive_string(thr, h_str); + } else { + /* .valueOf() */ + duk_push_hstring(thr, h_str); + } + return 1; +} + +DUK_INTERNAL duk_ret_t duk_bi_symbol_key_for(duk_hthread *thr) { + duk_hstring *h; + const duk_uint8_t *p; + + /* Argument must be a symbol but not checked here. The initial byte + * check will catch non-symbol strings. + */ + h = duk_require_hstring(thr, 0); + DUK_ASSERT(h != NULL); + + p = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h); + DUK_ASSERT(p != NULL); + + /* Even for zero length strings there's at least one NUL byte so + * we can safely check the initial byte. + */ + if (p[0] == 0x80) { + /* Global symbol, return its key (bytes just after the initial byte). */ + duk_push_lstring(thr, (const char *) (p + 1), (duk_size_t) (DUK_HSTRING_GET_BYTELEN(h) - 1)); + return 1; + } else if (p[0] == 0x81 || p[0] == 0x82 || p[0] == 0xff) { + /* Local symbol or hidden symbol, return undefined. */ + return 0; + } + + /* Covers normal strings and unknown initial bytes. */ + return DUK_RET_TYPE_ERROR; +} + +DUK_INTERNAL duk_ret_t duk_bi_symbol_toprimitive(duk_hthread *thr) { + duk_hstring *h_str; + + h_str = duk__auto_unbox_symbol(thr, DUK_HTHREAD_THIS_PTR(thr)); + if (h_str == NULL) { + return DUK_RET_TYPE_ERROR; + } + duk_push_hstring(thr, h_str); + return 1; +} + +#endif /* DUK_USE_SYMBOL_BUILTIN */ +#line 1 "duk_bi_thread.c" +/* + * Thread builtins + */ + +/* #include duk_internal.h -> already included */ + +/* + * Constructor + */ + +#if defined(DUK_USE_COROUTINE_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_thread_constructor(duk_hthread *thr) { + duk_hthread *new_thr; + duk_hobject *func; + + /* Check that the argument is callable; this is not 100% because we + * don't allow native functions to be a thread's initial function. + * Resume will reject such functions in any case. + */ + /* XXX: need a duk_require_func_promote_lfunc() */ + func = duk_require_hobject_promote_lfunc(thr, 0); + DUK_ASSERT(func != NULL); + duk_require_callable(thr, 0); + + duk_push_thread(thr); + new_thr = (duk_hthread *) duk_known_hobject(thr, -1); + new_thr->state = DUK_HTHREAD_STATE_INACTIVE; + + /* push initial function call to new thread stack; this is + * picked up by resume(). + */ + duk_push_hobject(new_thr, func); + + return 1; /* return thread */ +} +#endif + +/* + * Resume a thread. + * + * The thread must be in resumable state, either (a) new thread which hasn't + * yet started, or (b) a thread which has previously yielded. This method + * must be called from an ECMAScript function. + * + * Args: + * - thread + * - value + * - isError (defaults to false) + * + * Note: yield and resume handling is currently asymmetric. + */ + +#if defined(DUK_USE_COROUTINE_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_thread_resume(duk_hthread *ctx) { + duk_hthread *thr = (duk_hthread *) ctx; + duk_hthread *thr_resume; + duk_hobject *caller_func; + duk_small_uint_t is_error; + + DUK_DDD(DUK_DDDPRINT("Duktape.Thread.resume(): thread=%!T, value=%!T, is_error=%!T", + (duk_tval *) duk_get_tval(thr, 0), + (duk_tval *) duk_get_tval(thr, 1), + (duk_tval *) duk_get_tval(thr, 2))); + + DUK_ASSERT(thr->state == DUK_HTHREAD_STATE_RUNNING); + DUK_ASSERT(thr->heap->curr_thread == thr); + + thr_resume = duk_require_hthread(thr, 0); + DUK_ASSERT(duk_get_top(thr) == 3); + is_error = (duk_small_uint_t) duk_to_boolean_top_pop(thr); + DUK_ASSERT(duk_get_top(thr) == 2); + + /* [ thread value ] */ + + /* + * Thread state and calling context checks + */ + + if (thr->callstack_top < 2) { + DUK_DD(DUK_DDPRINT( + "resume state invalid: callstack should contain at least 2 entries (caller and Duktape.Thread.resume)")); + goto state_error; + } + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(thr->callstack_curr->parent != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr) != NULL); /* us */ + DUK_ASSERT(DUK_HOBJECT_IS_NATFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr))); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr->parent) != NULL); /* caller */ + + caller_func = DUK_ACT_GET_FUNC(thr->callstack_curr->parent); + if (!DUK_HOBJECT_IS_COMPFUNC(caller_func)) { + DUK_DD(DUK_DDPRINT("resume state invalid: caller must be ECMAScript code")); + goto state_error; + } + + /* Note: there is no requirement that: 'thr->callstack_preventcount == 1' + * like for yield. + */ + + if (thr_resume->state != DUK_HTHREAD_STATE_INACTIVE && thr_resume->state != DUK_HTHREAD_STATE_YIELDED) { + DUK_DD(DUK_DDPRINT("resume state invalid: target thread must be INACTIVE or YIELDED")); + goto state_error; + } + + DUK_ASSERT(thr_resume->state == DUK_HTHREAD_STATE_INACTIVE || thr_resume->state == DUK_HTHREAD_STATE_YIELDED); + + /* Further state-dependent pre-checks */ + + if (thr_resume->state == DUK_HTHREAD_STATE_YIELDED) { + /* no pre-checks now, assume a previous yield() has left things in + * tip-top shape (longjmp handler will assert for these). + */ + } else { + duk_hobject *h_fun; + + DUK_ASSERT(thr_resume->state == DUK_HTHREAD_STATE_INACTIVE); + + /* The initial function must be an ECMAScript function (but + * can be bound). We must make sure of that before we longjmp + * because an error in the RESUME handler call processing will + * not be handled very cleanly. + */ + if ((thr_resume->callstack_top != 0) || (thr_resume->valstack_top - thr_resume->valstack != 1)) { + goto state_error; + } + + duk_push_tval(thr, DUK_GET_TVAL_NEGIDX(thr_resume, -1)); + duk_resolve_nonbound_function(thr); + h_fun = duk_require_hobject(thr, -1); /* reject lightfuncs on purpose */ + if (!DUK_HOBJECT_IS_CALLABLE(h_fun) || !DUK_HOBJECT_IS_COMPFUNC(h_fun)) { + goto state_error; + } + duk_pop(thr); + } + +#if 0 + /* This check would prevent a heap destruction time finalizer from + * launching a coroutine, which would ensure that during finalization + * 'thr' would always equal heap_thread. Normal runtime finalizers + * run with ms_running == 0, i.e. outside mark-and-sweep. See GH-2030. + */ + if (thr->heap->ms_running) { + DUK_D(DUK_DPRINT("refuse Duktape.Thread.resume() when ms_running != 0")); + goto state_error; + } +#endif + + /* + * The error object has been augmented with a traceback and other + * info from its creation point -- usually another thread. The + * error handler is called here right before throwing, but it also + * runs in the resumer's thread. It might be nice to get a traceback + * from the resumee but this is not the case now. + */ + +#if defined(DUK_USE_AUGMENT_ERROR_THROW) + if (is_error) { + DUK_ASSERT_TOP(thr, 2); /* value (error) is at stack top */ + duk_err_augment_error_throw(thr); /* in resumer's context */ + } +#endif + +#if defined(DUK_USE_DEBUG) + if (is_error) { + DUK_DDD(DUK_DDDPRINT("RESUME ERROR: thread=%!T, value=%!T", + (duk_tval *) duk_get_tval(thr, 0), + (duk_tval *) duk_get_tval(thr, 1))); + } else if (thr_resume->state == DUK_HTHREAD_STATE_YIELDED) { + DUK_DDD(DUK_DDDPRINT("RESUME NORMAL: thread=%!T, value=%!T", + (duk_tval *) duk_get_tval(thr, 0), + (duk_tval *) duk_get_tval(thr, 1))); + } else { + DUK_DDD(DUK_DDDPRINT("RESUME INITIAL: thread=%!T, value=%!T", + (duk_tval *) duk_get_tval(thr, 0), + (duk_tval *) duk_get_tval(thr, 1))); + } +#endif + + thr->heap->lj.type = DUK_LJ_TYPE_RESUME; + + /* lj value2: thread */ + DUK_ASSERT(thr->valstack_bottom < thr->valstack_top); + DUK_TVAL_SET_TVAL_UPDREF(thr, &thr->heap->lj.value2, &thr->valstack_bottom[0]); /* side effects */ + + /* lj value1: value */ + DUK_ASSERT(thr->valstack_bottom + 1 < thr->valstack_top); + DUK_TVAL_SET_TVAL_UPDREF(thr, &thr->heap->lj.value1, &thr->valstack_bottom[1]); /* side effects */ + DUK_TVAL_CHKFAST_INPLACE_SLOW(&thr->heap->lj.value1); + + thr->heap->lj.iserror = is_error; + + DUK_ASSERT(thr->heap->lj.jmpbuf_ptr != NULL); /* call is from executor, so we know we have a jmpbuf */ + duk_err_longjmp(thr); /* execution resumes in bytecode executor */ + DUK_UNREACHABLE(); + /* Never here, fall through to error (from compiler point of view). */ + +state_error: + DUK_DCERROR_TYPE_INVALID_STATE(thr); +} +#endif + +/* + * Yield the current thread. + * + * The thread must be in yieldable state: it must have a resumer, and there + * must not be any yield-preventing calls (native calls and constructor calls, + * currently) in the thread's call stack (otherwise a resume would not be + * possible later). This method must be called from an ECMAScript function. + * + * Args: + * - value + * - isError (defaults to false) + * + * Note: yield and resume handling is currently asymmetric. + */ + +#if defined(DUK_USE_COROUTINE_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_thread_yield(duk_hthread *thr) { + duk_hobject *caller_func; + duk_small_uint_t is_error; + + DUK_DDD(DUK_DDDPRINT("Duktape.Thread.yield(): value=%!T, is_error=%!T", + (duk_tval *) duk_get_tval(thr, 0), + (duk_tval *) duk_get_tval(thr, 1))); + + DUK_ASSERT(thr->state == DUK_HTHREAD_STATE_RUNNING); + DUK_ASSERT(thr->heap->curr_thread == thr); + + DUK_ASSERT(duk_get_top(thr) == 2); + is_error = (duk_small_uint_t) duk_to_boolean_top_pop(thr); + DUK_ASSERT(duk_get_top(thr) == 1); + + /* [ value ] */ + + /* + * Thread state and calling context checks + */ + + if (!thr->resumer) { + DUK_DD(DUK_DDPRINT("yield state invalid: current thread must have a resumer")); + goto state_error; + } + DUK_ASSERT(thr->resumer->state == DUK_HTHREAD_STATE_RESUMED); + + if (thr->callstack_top < 2) { + DUK_DD(DUK_DDPRINT( + "yield state invalid: callstack should contain at least 2 entries (caller and Duktape.Thread.yield)")); + goto state_error; + } + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(thr->callstack_curr->parent != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr) != NULL); /* us */ + DUK_ASSERT(DUK_HOBJECT_IS_NATFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr))); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr->parent) != NULL); /* caller */ + + caller_func = DUK_ACT_GET_FUNC(thr->callstack_curr->parent); + if (!DUK_HOBJECT_IS_COMPFUNC(caller_func)) { + DUK_DD(DUK_DDPRINT("yield state invalid: caller must be ECMAScript code")); + goto state_error; + } + + DUK_ASSERT(thr->callstack_preventcount >= 1); /* should never be zero, because we (Duktape.Thread.yield) are on the stack */ + if (thr->callstack_preventcount != 1) { + /* Note: the only yield-preventing call is Duktape.Thread.yield(), hence check for 1, not 0 */ + DUK_DD(DUK_DDPRINT("yield state invalid: there must be no yield-preventing calls in current thread callstack " + "(preventcount is %ld)", + (long) thr->callstack_preventcount)); + goto state_error; + } + + /* + * The error object has been augmented with a traceback and other + * info from its creation point -- usually the current thread. + * The error handler, however, is called right before throwing + * and runs in the yielder's thread. + */ + +#if defined(DUK_USE_AUGMENT_ERROR_THROW) + if (is_error) { + DUK_ASSERT_TOP(thr, 1); /* value (error) is at stack top */ + duk_err_augment_error_throw(thr); /* in yielder's context */ + } +#endif + +#if defined(DUK_USE_DEBUG) + if (is_error) { + DUK_DDD(DUK_DDDPRINT("YIELD ERROR: value=%!T", (duk_tval *) duk_get_tval(thr, 0))); + } else { + DUK_DDD(DUK_DDDPRINT("YIELD NORMAL: value=%!T", (duk_tval *) duk_get_tval(thr, 0))); + } +#endif + + /* + * Process yield + * + * After longjmp(), processing continues in bytecode executor longjmp + * handler, which will e.g. update thr->resumer to NULL. + */ + + thr->heap->lj.type = DUK_LJ_TYPE_YIELD; + + /* lj value1: value */ + DUK_ASSERT(thr->valstack_bottom < thr->valstack_top); + DUK_TVAL_SET_TVAL_UPDREF(thr, &thr->heap->lj.value1, &thr->valstack_bottom[0]); /* side effects */ + DUK_TVAL_CHKFAST_INPLACE_SLOW(&thr->heap->lj.value1); + + thr->heap->lj.iserror = is_error; + + DUK_ASSERT(thr->heap->lj.jmpbuf_ptr != NULL); /* call is from executor, so we know we have a jmpbuf */ + duk_err_longjmp(thr); /* execution resumes in bytecode executor */ + DUK_UNREACHABLE(); + /* Never here, fall through to error (from compiler point of view). */ + +state_error: + DUK_DCERROR_TYPE_INVALID_STATE(thr); +} +#endif + +#if defined(DUK_USE_COROUTINE_SUPPORT) +DUK_INTERNAL duk_ret_t duk_bi_thread_current(duk_hthread *thr) { + duk_push_current_thread(thr); + return 1; +} +#endif +#line 1 "duk_bi_thrower.c" +/* + * Type error thrower, E5 Section 13.2.3. + */ + +/* #include duk_internal.h -> already included */ + +DUK_INTERNAL duk_ret_t duk_bi_type_error_thrower(duk_hthread *thr) { + DUK_DCERROR_TYPE_INVALID_ARGS(thr); +} +#line 1 "duk_debug_fixedbuffer.c" +/* + * Fixed buffer helper useful for debugging, requires no allocation + * which is critical for debugging. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_DEBUG) + +DUK_INTERNAL void duk_fb_put_bytes(duk_fixedbuffer *fb, const duk_uint8_t *buffer, duk_size_t length) { + duk_size_t avail; + duk_size_t copylen; + + avail = (fb->offset >= fb->length ? (duk_size_t) 0 : (duk_size_t) (fb->length - fb->offset)); + if (length > avail) { + copylen = avail; + fb->truncated = 1; + } else { + copylen = length; + } + duk_memcpy_unsafe(fb->buffer + fb->offset, buffer, copylen); + fb->offset += copylen; +} + +DUK_INTERNAL void duk_fb_put_byte(duk_fixedbuffer *fb, duk_uint8_t x) { + duk_fb_put_bytes(fb, (const duk_uint8_t *) &x, 1); +} + +DUK_INTERNAL void duk_fb_put_cstring(duk_fixedbuffer *fb, const char *x) { + duk_fb_put_bytes(fb, (const duk_uint8_t *) x, (duk_size_t) DUK_STRLEN(x)); +} + +DUK_INTERNAL void duk_fb_sprintf(duk_fixedbuffer *fb, const char *fmt, ...) { + duk_size_t avail; + va_list ap; + + va_start(ap, fmt); + avail = (fb->offset >= fb->length ? (duk_size_t) 0 : (duk_size_t) (fb->length - fb->offset)); + if (avail > 0) { + duk_int_t res = (duk_int_t) DUK_VSNPRINTF((char *) (fb->buffer + fb->offset), avail, fmt, ap); + if (res < 0) { + /* error */ + } else if ((duk_size_t) res >= avail) { + /* (maybe) truncated */ + fb->offset += avail; + if ((duk_size_t) res > avail) { + /* actual chars dropped (not just NUL term) */ + fb->truncated = 1; + } + } else { + /* normal */ + fb->offset += (duk_size_t) res; + } + } + va_end(ap); +} + +DUK_INTERNAL void duk_fb_put_funcptr(duk_fixedbuffer *fb, duk_uint8_t *fptr, duk_size_t fptr_size) { + char buf[64 + 1]; + duk_debug_format_funcptr(buf, sizeof(buf), fptr, fptr_size); + buf[sizeof(buf) - 1] = (char) 0; + duk_fb_put_cstring(fb, buf); +} + +DUK_INTERNAL duk_bool_t duk_fb_is_full(duk_fixedbuffer *fb) { + return (fb->offset >= fb->length); +} + +#endif /* DUK_USE_DEBUG */ +#line 1 "duk_debug_vsnprintf.c" +/* + * Custom formatter for debug printing, allowing Duktape specific data + * structures (such as tagged values and heap objects) to be printed with + * a nice format string. Because debug printing should not affect execution + * state, formatting here must be independent of execution (see implications + * below) and must not allocate memory. + * + * Custom format tags begin with a '%!' to safely distinguish them from + * standard format tags. The following conversions are supported: + * + * %!T tagged value (duk_tval *) + * %!O heap object (duk_heaphdr *) + * %!I decoded bytecode instruction + * %!X bytecode instruction opcode name (arg is long) + * %!C catcher (duk_catcher *) + * %!A activation (duk_activation *) + * + * Everything is serialized in a JSON-like manner. The default depth is one + * level, internal prototype is not followed, and internal properties are not + * serialized. The following modifiers change this behavior: + * + * @ print pointers + * # print binary representations (where applicable) + * d deep traversal of own properties (not prototype) + * p follow prototype chain (useless without 'd') + * i include internal properties (other than prototype) + * x hexdump buffers + * h heavy formatting + * + * For instance, the following serializes objects recursively, but does not + * follow the prototype chain nor print internal properties: "%!dO". + * + * Notes: + * + * * Standard snprintf return value semantics seem to vary. This + * implementation returns the number of bytes it actually wrote + * (excluding the null terminator). If retval == buffer size, + * output was truncated (except for corner cases). + * + * * Output format is intentionally different from ECMAScript + * formatting requirements, as formatting here serves debugging + * of internals. + * + * * Depth checking (and updating) is done in each type printer + * separately, to allow them to call each other freely. + * + * * Some pathological structures might take ages to print (e.g. + * self recursion with 100 properties pointing to the object + * itself). To guard against these, each printer also checks + * whether the output buffer is full; if so, early exit. + * + * * Reference loops are detected using a loop stack. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_DEBUG) + +/* #include stdio.h -> already included */ +/* #include stdarg.h -> already included */ +#include + +/* list of conversion specifiers that terminate a format tag; + * this is unfortunately guesswork. + */ +#define DUK__ALLOWED_STANDARD_SPECIFIERS "diouxXeEfFgGaAcsCSpnm" + +/* maximum length of standard format tag that we support */ +#define DUK__MAX_FORMAT_TAG_LENGTH 32 + +/* heapobj recursion depth when deep printing is selected */ +#define DUK__DEEP_DEPTH_LIMIT 8 + +/* maximum recursion depth for loop detection stacks */ +#define DUK__LOOP_STACK_DEPTH 256 + +/* must match bytecode defines now; build autogenerate? */ +DUK_LOCAL const char * const duk__bc_optab[256] = { + "LDREG", "STREG", "JUMP", "LDCONST", "LDINT", "LDINTX", "LDTHIS", "LDUNDEF", + "LDNULL", "LDTRUE", "LDFALSE", "GETVAR", "BNOT", "LNOT", "UNM", "UNP", + "EQ_RR", "EQ_CR", "EQ_RC", "EQ_CC", "NEQ_RR", "NEQ_CR", "NEQ_RC", "NEQ_CC", + "SEQ_RR", "SEQ_CR", "SEQ_RC", "SEQ_CC", "SNEQ_RR", "SNEQ_CR", "SNEQ_RC", "SNEQ_CC", + + "GT_RR", "GT_CR", "GT_RC", "GT_CC", "GE_RR", "GE_CR", "GE_RC", "GE_CC", + "LT_RR", "LT_CR", "LT_RC", "LT_CC", "LE_RR", "LE_CR", "LE_RC", "LE_CC", + "IFTRUE_R", "IFTRUE_C", "IFFALSE_R", "IFFALSE_C", "ADD_RR", "ADD_CR", "ADD_RC", "ADD_CC", + "SUB_RR", "SUB_CR", "SUB_RC", "SUB_CC", "MUL_RR", "MUL_CR", "MUL_RC", "MUL_CC", + + "DIV_RR", "DIV_CR", "DIV_RC", "DIV_CC", "MOD_RR", "MOD_CR", "MOD_RC", "MOD_CC", + "EXP_RR", "EXP_CR", "EXP_RC", "EXP_CC", "BAND_RR", "BAND_CR", "BAND_RC", "BAND_CC", + "BOR_RR", "BOR_CR", "BOR_RC", "BOR_CC", "BXOR_RR", "BXOR_CR", "BXOR_RC", "BXOR_CC", + "BASL_RR", "BASL_CR", "BASL_RC", "BASL_CC", "BLSR_RR", "BLSR_CR", "BLSR_RC", "BLSR_CC", + + "BASR_RR", "BASR_CR", "BASR_RC", "BASR_CC", "INSTOF_RR", "INSTOF_CR", "INSTOF_RC", "INSTOF_CC", + "IN_RR", "IN_CR", "IN_RC", "IN_CC", "GETPROP_RR", "GETPROP_CR", "GETPROP_RC", "GETPROP_CC", + "PUTPROP_RR", "PUTPROP_CR", "PUTPROP_RC", "PUTPROP_CC", "DELPROP_RR", "DELPROP_CR", "DELPROP_RC", "DELPROP_CC", + "PREINCR", "PREDECR", "POSTINCR", "POSTDECR", "PREINCV", "PREDECV", "POSTINCV", "POSTDECV", + + "PREINCP_RR", "PREINCP_CR", "PREINCP_RC", "PREINCP_CC", "PREDECP_RR", "PREDECP_CR", "PREDECP_RC", "PREDECP_CC", + "POSTINCP_RR", "POSTINCP_CR", "POSTINCP_RC", "POSTINCP_CC", "POSTDECP_RR", "POSTDECP_CR", "POSTDECP_RC", "POSTDECP_CC", + "DECLVAR_RR", "DECLVAR_CR", "DECLVAR_RC", "DECLVAR_CC", "REGEXP_RR", "REGEXP_RC", "REGEXP_CR", "REGEXP_CC", + "CLOSURE", "TYPEOF", "TYPEOFID", "PUTVAR", "DELVAR", "RETREG", "RETUNDEF", "RETCONST", + + "RETCONSTN", "LABEL", "ENDLABEL", "BREAK", "CONTINUE", "TRYCATCH", "ENDTRY", "ENDCATCH", + "ENDFIN", "THROW", "INVLHS", "CSREG", "CSVAR_RR", "CSVAR_CR", "CSVAR_RC", "CSVAR_CC", + "CALL0", "CALL1", "CALL2", "CALL3", "CALL4", "CALL5", "CALL6", "CALL7", + "CALL8", "CALL9", "CALL10", "CALL11", "CALL12", "CALL13", "CALL14", "CALL15", + + "NEWOBJ", "NEWARR", "MPUTOBJ", "MPUTOBJI", "INITSET", "INITGET", "MPUTARR", "MPUTARRI", + "SETALEN", "INITENUM", "NEXTENUM", "NEWTARGET", "DEBUGGER", "NOP", "INVALID", "UNUSED207", + "GETPROPC_RR", "GETPROPC_CR", "GETPROPC_RC", "GETPROPC_CC", "UNUSED212", "UNUSED213", "UNUSED214", "UNUSED215", + "UNUSED216", "UNUSED217", "UNUSED218", "UNUSED219", "UNUSED220", "UNUSED221", "UNUSED222", "UNUSED223", + + "UNUSED224", "UNUSED225", "UNUSED226", "UNUSED227", "UNUSED228", "UNUSED229", "UNUSED230", "UNUSED231", + "UNUSED232", "UNUSED233", "UNUSED234", "UNUSED235", "UNUSED236", "UNUSED237", "UNUSED238", "UNUSED239", + "UNUSED240", "UNUSED241", "UNUSED242", "UNUSED243", "UNUSED244", "UNUSED245", "UNUSED246", "UNUSED247", + "UNUSED248", "UNUSED249", "UNUSED250", "UNUSED251", "UNUSED252", "UNUSED253", "UNUSED254", "UNUSED255" +}; + +typedef struct duk__dprint_state duk__dprint_state; +struct duk__dprint_state { + duk_fixedbuffer *fb; + + /* loop_stack_index could be perhaps be replaced by 'depth', but it's nice + * to not couple these two mechanisms unnecessarily. + */ + duk_hobject *loop_stack[DUK__LOOP_STACK_DEPTH]; + duk_int_t loop_stack_index; + duk_int_t loop_stack_limit; + + duk_int_t depth; + duk_int_t depth_limit; + + duk_bool_t pointer; + duk_bool_t heavy; + duk_bool_t binary; + duk_bool_t follow_proto; + duk_bool_t internal; + duk_bool_t hexdump; +}; + +/* helpers */ +DUK_LOCAL_DECL void duk__print_hstring(duk__dprint_state *st, duk_hstring *k, duk_bool_t quotes); +DUK_LOCAL_DECL void duk__print_hobject(duk__dprint_state *st, duk_hobject *h); +DUK_LOCAL_DECL void duk__print_hbuffer(duk__dprint_state *st, duk_hbuffer *h); +DUK_LOCAL_DECL void duk__print_tval(duk__dprint_state *st, duk_tval *tv); +DUK_LOCAL_DECL void duk__print_instr(duk__dprint_state *st, duk_instr_t ins); +DUK_LOCAL_DECL void duk__print_heaphdr(duk__dprint_state *st, duk_heaphdr *h); +DUK_LOCAL_DECL void duk__print_shared_heaphdr(duk__dprint_state *st, duk_heaphdr *h); +DUK_LOCAL_DECL void duk__print_shared_heaphdr_string(duk__dprint_state *st, duk_heaphdr_string *h); + +DUK_LOCAL void duk__print_shared_heaphdr(duk__dprint_state *st, duk_heaphdr *h) { + duk_fixedbuffer *fb = st->fb; + + if (st->heavy) { + duk_fb_sprintf(fb, "(%p)", (void *) h); + } + + if (!h) { + return; + } + + if (st->binary) { + duk_size_t i; + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_LBRACKET); + for (i = 0; i < (duk_size_t) sizeof(*h); i++) { + duk_fb_sprintf(fb, "%02lx", (unsigned long) ((duk_uint8_t *) h)[i]); + } + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_RBRACKET); + } + +#if defined(DUK_USE_REFERENCE_COUNTING) /* currently implicitly also DUK_USE_DOUBLE_LINKED_HEAP */ + if (st->heavy) { + duk_fb_sprintf(fb, + "[h_next=%p,h_prev=%p,h_refcount=%lu,h_flags=%08lx,type=%ld," + "reachable=%ld,temproot=%ld,finalizable=%ld,finalized=%ld]", + (void *) DUK_HEAPHDR_GET_NEXT(NULL, h), + (void *) DUK_HEAPHDR_GET_PREV(NULL, h), + (unsigned long) DUK_HEAPHDR_GET_REFCOUNT(h), + (unsigned long) DUK_HEAPHDR_GET_FLAGS(h), + (long) DUK_HEAPHDR_GET_TYPE(h), + (long) (DUK_HEAPHDR_HAS_REACHABLE(h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_TEMPROOT(h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_FINALIZABLE(h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_FINALIZED(h) ? 1 : 0)); + } +#else + if (st->heavy) { + duk_fb_sprintf(fb, + "[h_next=%p,h_flags=%08lx,type=%ld,reachable=%ld,temproot=%ld,finalizable=%ld,finalized=%ld]", + (void *) DUK_HEAPHDR_GET_NEXT(NULL, h), + (unsigned long) DUK_HEAPHDR_GET_FLAGS(h), + (long) DUK_HEAPHDR_GET_TYPE(h), + (long) (DUK_HEAPHDR_HAS_REACHABLE(h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_TEMPROOT(h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_FINALIZABLE(h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_FINALIZED(h) ? 1 : 0)); + } +#endif +} + +DUK_LOCAL void duk__print_shared_heaphdr_string(duk__dprint_state *st, duk_heaphdr_string *h) { + duk_fixedbuffer *fb = st->fb; + + if (st->heavy) { + duk_fb_sprintf(fb, "(%p)", (void *) h); + } + + if (!h) { + return; + } + + if (st->binary) { + duk_size_t i; + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_LBRACKET); + for (i = 0; i < (duk_size_t) sizeof(*h); i++) { + duk_fb_sprintf(fb, "%02lx", (unsigned long) ((duk_uint8_t *) h)[i]); + } + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_RBRACKET); + } + +#if defined(DUK_USE_REFERENCE_COUNTING) + if (st->heavy) { + duk_fb_sprintf(fb, + "[h_refcount=%lu,h_flags=%08lx,type=%ld,reachable=%ld,temproot=%ld,finalizable=%ld,finalized=%ld]", + (unsigned long) DUK_HEAPHDR_GET_REFCOUNT((duk_heaphdr *) h), + (unsigned long) DUK_HEAPHDR_GET_FLAGS((duk_heaphdr *) h), + (long) DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) h), + (long) (DUK_HEAPHDR_HAS_REACHABLE((duk_heaphdr *) h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_TEMPROOT((duk_heaphdr *) h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_FINALIZABLE((duk_heaphdr *) h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_FINALIZED((duk_heaphdr *) h) ? 1 : 0)); + } +#else + if (st->heavy) { + duk_fb_sprintf(fb, + "[h_flags=%08lx,type=%ld,reachable=%ld,temproot=%ld,finalizable=%ld,finalized=%ld]", + (unsigned long) DUK_HEAPHDR_GET_FLAGS((duk_heaphdr *) h), + (long) DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) h), + (long) (DUK_HEAPHDR_HAS_REACHABLE((duk_heaphdr *) h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_TEMPROOT((duk_heaphdr *) h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_FINALIZABLE((duk_heaphdr *) h) ? 1 : 0), + (long) (DUK_HEAPHDR_HAS_FINALIZED((duk_heaphdr *) h) ? 1 : 0)); + } +#endif +} + +DUK_LOCAL void duk__print_hstring(duk__dprint_state *st, duk_hstring *h, duk_bool_t quotes) { + duk_fixedbuffer *fb = st->fb; + const duk_uint8_t *p; + const duk_uint8_t *p_end; + + /* terminal type: no depth check */ + + if (duk_fb_is_full(fb)) { + return; + } + + duk__print_shared_heaphdr_string(st, &h->hdr); + + if (!h) { + duk_fb_put_cstring(fb, "NULL"); + return; + } + + p = DUK_HSTRING_GET_DATA(h); + p_end = p + DUK_HSTRING_GET_BYTELEN(h); + + if (p_end > p && p[0] == DUK_ASC_UNDERSCORE) { + /* If property key begins with underscore, encode it with + * forced quotes (e.g. "_Foo") to distinguish it from encoded + * internal properties (e.g. \x82Bar -> _Bar). + */ + quotes = 1; + } + + if (quotes) { + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_DOUBLEQUOTE); + } + while (p < p_end) { + duk_uint8_t ch = *p++; + + /* two special escapes: '\' and '"', other printables as is */ + if (ch == '\\') { + duk_fb_sprintf(fb, "\\\\"); + } else if (ch == '"') { + duk_fb_sprintf(fb, "\\\""); + } else if (ch >= 0x20 && ch <= 0x7e) { + duk_fb_put_byte(fb, ch); + } else if (ch == 0x82 && !quotes) { + /* encode \x82Bar as _Bar if no quotes are + * applied, this is for readable internal keys. + */ + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_UNDERSCORE); + } else { + duk_fb_sprintf(fb, "\\x%02lx", (unsigned long) ch); + } + } + if (quotes) { + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_DOUBLEQUOTE); + } +#if defined(DUK_USE_REFERENCE_COUNTING) + /* XXX: limit to quoted strings only, to save keys from being cluttered? */ + duk_fb_sprintf(fb, "/%lu", (unsigned long) DUK_HEAPHDR_GET_REFCOUNT(&h->hdr)); +#endif +} + +#define DUK__COMMA() \ + do { \ + if (first) { \ + first = 0; \ + } else { \ + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_COMMA); \ + } \ + } while (0) + +DUK_LOCAL void duk__print_hobject(duk__dprint_state *st, duk_hobject *h) { + duk_fixedbuffer *fb = st->fb; + duk_uint_fast32_t i; + duk_tval *tv; + duk_hstring *key; + duk_bool_t first = 1; + const char *brace1 = "{"; + const char *brace2 = "}"; + duk_bool_t pushed_loopstack = 0; + + if (duk_fb_is_full(fb)) { + return; + } + + duk__print_shared_heaphdr(st, &h->hdr); + + if (h && DUK_HOBJECT_HAS_ARRAY_PART(h)) { + brace1 = "["; + brace2 = "]"; + } + + if (!h) { + duk_fb_put_cstring(fb, "NULL"); + goto finished; + } + + if (st->depth >= st->depth_limit) { + const char *subtype = "generic"; + + if (DUK_HOBJECT_IS_COMPFUNC(h)) { + subtype = "compfunc"; + } else if (DUK_HOBJECT_IS_NATFUNC(h)) { + subtype = "natfunc"; + } else if (DUK_HOBJECT_IS_THREAD(h)) { + subtype = "thread"; + } else if (DUK_HOBJECT_IS_BUFOBJ(h)) { + subtype = "bufobj"; + } else if (DUK_HOBJECT_IS_ARRAY(h)) { + subtype = "array"; + } + duk_fb_sprintf(fb, "%sobject/%s %p%s", (const char *) brace1, subtype, (void *) h, (const char *) brace2); + return; + } + + for (i = 0; i < (duk_uint_fast32_t) st->loop_stack_index; i++) { + if (st->loop_stack[i] == h) { + duk_fb_sprintf(fb, "%sLOOP:%p%s", (const char *) brace1, (void *) h, (const char *) brace2); + return; + } + } + + /* after this, return paths should 'goto finished' for decrement */ + st->depth++; + + if (st->loop_stack_index >= st->loop_stack_limit) { + duk_fb_sprintf(fb, "%sOUT-OF-LOOP-STACK%s", (const char *) brace1, (const char *) brace2); + goto finished; + } + st->loop_stack[st->loop_stack_index++] = h; + pushed_loopstack = 1; + + /* + * Notation: double underscore used for internal properties which are not + * stored in the property allocation (e.g. '__valstack'). + */ + + duk_fb_put_cstring(fb, brace1); + + if (DUK_HOBJECT_GET_PROPS(NULL, h)) { + duk_uint32_t a_limit; + + a_limit = DUK_HOBJECT_GET_ASIZE(h); + if (st->internal) { + /* dump all allocated entries, unused entries print as 'unused', + * note that these may extend beyond current 'length' and look + * a bit funny. + */ + } else { + /* leave out trailing 'unused' elements */ + while (a_limit > 0) { + tv = DUK_HOBJECT_A_GET_VALUE_PTR(NULL, h, a_limit - 1); + if (!DUK_TVAL_IS_UNUSED(tv)) { + break; + } + a_limit--; + } + } + + for (i = 0; i < a_limit; i++) { + tv = DUK_HOBJECT_A_GET_VALUE_PTR(NULL, h, i); + DUK__COMMA(); + duk__print_tval(st, tv); + } + for (i = 0; i < DUK_HOBJECT_GET_ENEXT(h); i++) { + key = DUK_HOBJECT_E_GET_KEY(NULL, h, i); + if (!key) { + continue; + } + if (!st->internal && DUK_HSTRING_HAS_HIDDEN(key)) { + continue; + } + DUK__COMMA(); + duk__print_hstring(st, key, 0); + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_COLON); + if (DUK_HOBJECT_E_SLOT_IS_ACCESSOR(NULL, h, i)) { + duk_fb_sprintf(fb, + "[get:%p,set:%p]", + (void *) DUK_HOBJECT_E_GET_VALUE(NULL, h, i).a.get, + (void *) DUK_HOBJECT_E_GET_VALUE(NULL, h, i).a.set); + } else { + tv = &DUK_HOBJECT_E_GET_VALUE(NULL, h, i).v; + duk__print_tval(st, tv); + } + if (st->heavy) { + duk_fb_sprintf(fb, "<%02lx>", (unsigned long) DUK_HOBJECT_E_GET_FLAGS(NULL, h, i)); + } + } + } + if (st->internal) { + if (DUK_HOBJECT_IS_ARRAY(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__array:true"); + } + if (DUK_HOBJECT_HAS_EXTENSIBLE(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__extensible:true"); + } + if (DUK_HOBJECT_HAS_CONSTRUCTABLE(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__constructable:true"); + } + if (DUK_HOBJECT_HAS_BOUNDFUNC(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__boundfunc:true"); + } + if (DUK_HOBJECT_HAS_COMPFUNC(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__compfunc:true"); + } + if (DUK_HOBJECT_HAS_NATFUNC(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__natfunc:true"); + } + if (DUK_HOBJECT_HAS_BUFOBJ(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__bufobj:true"); + } + if (DUK_HOBJECT_IS_THREAD(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__thread:true"); + } + if (DUK_HOBJECT_HAS_ARRAY_PART(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__array_part:true"); + } + if (DUK_HOBJECT_HAS_STRICT(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__strict:true"); + } + if (DUK_HOBJECT_HAS_NOTAIL(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__notail:true"); + } + if (DUK_HOBJECT_HAS_NEWENV(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__newenv:true"); + } + if (DUK_HOBJECT_HAS_NAMEBINDING(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__namebinding:true"); + } + if (DUK_HOBJECT_HAS_CREATEARGS(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__createargs:true"); + } + if (DUK_HOBJECT_HAS_EXOTIC_ARRAY(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__exotic_array:true"); + } + if (DUK_HOBJECT_HAS_EXOTIC_STRINGOBJ(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__exotic_stringobj:true"); + } + if (DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__exotic_arguments:true"); + } + if (DUK_HOBJECT_IS_BUFOBJ(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__exotic_bufobj:true"); + } + if (DUK_HOBJECT_HAS_EXOTIC_PROXYOBJ(h)) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__exotic_proxyobj:true"); + } + } + + if (st->internal && DUK_HOBJECT_IS_ARRAY(h)) { + duk_harray *a = (duk_harray *) h; + DUK__COMMA(); + duk_fb_sprintf(fb, "__length:%ld", (long) a->length); + DUK__COMMA(); + duk_fb_sprintf(fb, "__length_nonwritable:%ld", (long) a->length_nonwritable); + } else if (st->internal && DUK_HOBJECT_IS_COMPFUNC(h)) { + duk_hcompfunc *f = (duk_hcompfunc *) h; + DUK__COMMA(); + duk_fb_put_cstring(fb, "__data:"); + duk__print_hbuffer(st, (duk_hbuffer *) DUK_HCOMPFUNC_GET_DATA(NULL, f)); + DUK__COMMA(); + duk_fb_put_cstring(fb, "__lexenv:"); + duk__print_hobject(st, DUK_HCOMPFUNC_GET_LEXENV(NULL, f)); + DUK__COMMA(); + duk_fb_put_cstring(fb, "__varenv:"); + duk__print_hobject(st, DUK_HCOMPFUNC_GET_VARENV(NULL, f)); + DUK__COMMA(); + duk_fb_sprintf(fb, "__nregs:%ld", (long) f->nregs); + DUK__COMMA(); + duk_fb_sprintf(fb, "__nargs:%ld", (long) f->nargs); +#if defined(DUK_USE_DEBUGGER_SUPPORT) + DUK__COMMA(); + duk_fb_sprintf(fb, "__start_line:%ld", (long) f->start_line); + DUK__COMMA(); + duk_fb_sprintf(fb, "__end_line:%ld", (long) f->end_line); +#endif + DUK__COMMA(); + duk_fb_put_cstring(fb, "__data:"); + duk__print_hbuffer(st, (duk_hbuffer *) DUK_HCOMPFUNC_GET_DATA(NULL, f)); + } else if (st->internal && DUK_HOBJECT_IS_NATFUNC(h)) { + duk_hnatfunc *f = (duk_hnatfunc *) h; + DUK__COMMA(); + duk_fb_sprintf(fb, "__func:"); + duk_fb_put_funcptr(fb, (duk_uint8_t *) &f->func, sizeof(f->func)); + DUK__COMMA(); + duk_fb_sprintf(fb, "__nargs:%ld", (long) f->nargs); + DUK__COMMA(); + duk_fb_sprintf(fb, "__magic:%ld", (long) f->magic); + } else if (st->internal && DUK_HOBJECT_IS_DECENV(h)) { + duk_hdecenv *e = (duk_hdecenv *) h; + DUK__COMMA(); + duk_fb_sprintf(fb, "__thread:"); + duk__print_hobject(st, (duk_hobject *) e->thread); + DUK__COMMA(); + duk_fb_sprintf(fb, "__varmap:"); + duk__print_hobject(st, (duk_hobject *) e->varmap); + DUK__COMMA(); + duk_fb_sprintf(fb, "__regbase_byteoff:%ld", (long) e->regbase_byteoff); + } else if (st->internal && DUK_HOBJECT_IS_OBJENV(h)) { + duk_hobjenv *e = (duk_hobjenv *) h; + DUK__COMMA(); + duk_fb_sprintf(fb, "__target:"); + duk__print_hobject(st, (duk_hobject *) e->target); + DUK__COMMA(); + duk_fb_sprintf(fb, "__has_this:%ld", (long) e->has_this); +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + } else if (st->internal && DUK_HOBJECT_IS_BUFOBJ(h)) { + duk_hbufobj *b = (duk_hbufobj *) h; + DUK__COMMA(); + duk_fb_sprintf(fb, "__buf:"); + duk__print_hbuffer(st, (duk_hbuffer *) b->buf); + DUK__COMMA(); + duk_fb_sprintf(fb, "__buf_prop:"); + duk__print_hobject(st, (duk_hobject *) b->buf_prop); + DUK__COMMA(); + duk_fb_sprintf(fb, "__offset:%ld", (long) b->offset); + DUK__COMMA(); + duk_fb_sprintf(fb, "__length:%ld", (long) b->length); + DUK__COMMA(); + duk_fb_sprintf(fb, "__shift:%ld", (long) b->shift); + DUK__COMMA(); + duk_fb_sprintf(fb, "__elemtype:%ld", (long) b->elem_type); +#endif + } else if (st->internal && DUK_HOBJECT_IS_PROXY(h)) { + duk_hproxy *p = (duk_hproxy *) h; + DUK__COMMA(); + duk_fb_sprintf(fb, "__target:"); + duk__print_hobject(st, p->target); + DUK__COMMA(); + duk_fb_sprintf(fb, "__handler:"); + duk__print_hobject(st, p->handler); + } else if (st->internal && DUK_HOBJECT_IS_THREAD(h)) { + duk_hthread *t = (duk_hthread *) h; + DUK__COMMA(); + duk_fb_sprintf(fb, "__ptr_curr_pc:%p", (void *) t->ptr_curr_pc); + DUK__COMMA(); + duk_fb_sprintf(fb, "__heap:%p", (void *) t->heap); + DUK__COMMA(); + duk_fb_sprintf(fb, "__strict:%ld", (long) t->strict); + DUK__COMMA(); + duk_fb_sprintf(fb, "__state:%ld", (long) t->state); + DUK__COMMA(); + duk_fb_sprintf(fb, "__unused1:%ld", (long) t->unused1); + DUK__COMMA(); + duk_fb_sprintf(fb, "__unused2:%ld", (long) t->unused2); + DUK__COMMA(); + duk_fb_sprintf(fb, "__valstack:%p", (void *) t->valstack); + DUK__COMMA(); + duk_fb_sprintf(fb, "__valstack_end:%p/%ld", (void *) t->valstack_end, (long) (t->valstack_end - t->valstack)); + DUK__COMMA(); + duk_fb_sprintf(fb, + "__valstack_alloc_end:%p/%ld", + (void *) t->valstack_alloc_end, + (long) (t->valstack_alloc_end - t->valstack)); + DUK__COMMA(); + duk_fb_sprintf(fb, + "__valstack_bottom:%p/%ld", + (void *) t->valstack_bottom, + (long) (t->valstack_bottom - t->valstack)); + DUK__COMMA(); + duk_fb_sprintf(fb, "__valstack_top:%p/%ld", (void *) t->valstack_top, (long) (t->valstack_top - t->valstack)); + DUK__COMMA(); + duk_fb_sprintf(fb, "__callstack_curr:%p", (void *) t->callstack_curr); + DUK__COMMA(); + duk_fb_sprintf(fb, "__callstack_top:%ld", (long) t->callstack_top); + DUK__COMMA(); + duk_fb_sprintf(fb, "__callstack_preventcount:%ld", (long) t->callstack_preventcount); + DUK__COMMA(); + duk_fb_sprintf(fb, "__resumer:"); + duk__print_hobject(st, (duk_hobject *) t->resumer); + DUK__COMMA(); + duk_fb_sprintf(fb, "__compile_ctx:%p", (void *) t->compile_ctx); +#if defined(DUK_USE_INTERRUPT_COUNTER) + DUK__COMMA(); + duk_fb_sprintf(fb, "__interrupt_counter:%ld", (long) t->interrupt_counter); + DUK__COMMA(); + duk_fb_sprintf(fb, "__interrupt_init:%ld", (long) t->interrupt_init); +#endif + + /* XXX: print built-ins array? */ + } +#if defined(DUK_USE_REFERENCE_COUNTING) + if (st->internal) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__refcount:%lu", (unsigned long) DUK_HEAPHDR_GET_REFCOUNT((duk_heaphdr *) h)); + } +#endif + if (st->internal) { + DUK__COMMA(); + duk_fb_sprintf(fb, "__class:%ld", (long) DUK_HOBJECT_GET_CLASS_NUMBER(h)); + } + + DUK__COMMA(); + duk_fb_sprintf(fb, "__heapptr:%p", (void *) h); /* own pointer */ + + /* prototype should be last, for readability */ + if (DUK_HOBJECT_GET_PROTOTYPE(NULL, h)) { + if (st->follow_proto) { + DUK__COMMA(); + duk_fb_put_cstring(fb, "__prototype:"); + duk__print_hobject(st, DUK_HOBJECT_GET_PROTOTYPE(NULL, h)); + } else { + DUK__COMMA(); + duk_fb_sprintf(fb, "__prototype:%p", (void *) DUK_HOBJECT_GET_PROTOTYPE(NULL, h)); + } + } + + duk_fb_put_cstring(fb, brace2); + +#if defined(DUK_USE_HOBJECT_HASH_PART) + if (st->heavy && DUK_HOBJECT_GET_HSIZE(h) > 0) { + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_LANGLE); + for (i = 0; i < DUK_HOBJECT_GET_HSIZE(h); i++) { + duk_uint_t h_idx = DUK_HOBJECT_H_GET_INDEX(NULL, h, i); + if (i > 0) { + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_COMMA); + } + if (h_idx == DUK_HOBJECT_HASHIDX_UNUSED) { + duk_fb_sprintf(fb, "u"); + } else if (h_idx == DUK_HOBJECT_HASHIDX_DELETED) { + duk_fb_sprintf(fb, "d"); + } else { + duk_fb_sprintf(fb, "%ld", (long) h_idx); + } + } + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_RANGLE); + } +#endif + +finished: + st->depth--; + if (pushed_loopstack) { + st->loop_stack_index--; + st->loop_stack[st->loop_stack_index] = NULL; + } +} + +DUK_LOCAL void duk__print_hbuffer(duk__dprint_state *st, duk_hbuffer *h) { + duk_fixedbuffer *fb = st->fb; + duk_size_t i, n; + duk_uint8_t *p; + + if (duk_fb_is_full(fb)) { + return; + } + + /* terminal type: no depth check */ + + if (!h) { + duk_fb_put_cstring(fb, "NULL"); + return; + } + + if (DUK_HBUFFER_HAS_DYNAMIC(h)) { + if (DUK_HBUFFER_HAS_EXTERNAL(h)) { + duk_hbuffer_external *g = (duk_hbuffer_external *) h; + duk_fb_sprintf(fb, + "buffer:external:%p:%ld", + (void *) DUK_HBUFFER_EXTERNAL_GET_DATA_PTR(NULL, g), + (long) DUK_HBUFFER_EXTERNAL_GET_SIZE(g)); + } else { + duk_hbuffer_dynamic *g = (duk_hbuffer_dynamic *) h; + duk_fb_sprintf(fb, + "buffer:dynamic:%p:%ld", + (void *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(NULL, g), + (long) DUK_HBUFFER_DYNAMIC_GET_SIZE(g)); + } + } else { + duk_fb_sprintf(fb, "buffer:fixed:%ld", (long) DUK_HBUFFER_GET_SIZE(h)); + } + +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_fb_sprintf(fb, "/%lu", (unsigned long) DUK_HEAPHDR_GET_REFCOUNT(&h->hdr)); +#endif + + if (st->hexdump) { + duk_fb_sprintf(fb, "=["); + n = DUK_HBUFFER_GET_SIZE(h); + p = (duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(NULL, h); + for (i = 0; i < n; i++) { + duk_fb_sprintf(fb, "%02lx", (unsigned long) p[i]); + } + duk_fb_sprintf(fb, "]"); + } +} + +DUK_LOCAL void duk__print_heaphdr(duk__dprint_state *st, duk_heaphdr *h) { + duk_fixedbuffer *fb = st->fb; + + if (duk_fb_is_full(fb)) { + return; + } + + if (!h) { + duk_fb_put_cstring(fb, "NULL"); + return; + } + + switch (DUK_HEAPHDR_GET_TYPE(h)) { + case DUK_HTYPE_STRING: + duk__print_hstring(st, (duk_hstring *) h, 1); + break; + case DUK_HTYPE_OBJECT: + duk__print_hobject(st, (duk_hobject *) h); + break; + case DUK_HTYPE_BUFFER: + duk__print_hbuffer(st, (duk_hbuffer *) h); + break; + default: + duk_fb_sprintf(fb, "[unknown htype %ld]", (long) DUK_HEAPHDR_GET_TYPE(h)); + break; + } +} + +DUK_LOCAL void duk__print_tval(duk__dprint_state *st, duk_tval *tv) { + duk_fixedbuffer *fb = st->fb; + + if (duk_fb_is_full(fb)) { + return; + } + + /* depth check is done when printing an actual type */ + + if (st->heavy) { + duk_fb_sprintf(fb, "(%p)", (void *) tv); + } + + if (!tv) { + duk_fb_put_cstring(fb, "NULL"); + return; + } + + if (st->binary) { + duk_size_t i; + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_LBRACKET); + for (i = 0; i < (duk_size_t) sizeof(*tv); i++) { + duk_fb_sprintf(fb, "%02lx", (unsigned long) ((duk_uint8_t *) tv)[i]); + } + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_RBRACKET); + } + + if (st->heavy) { + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_LANGLE); + } + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNDEFINED: { + duk_fb_put_cstring(fb, "undefined"); + break; + } + case DUK_TAG_UNUSED: { + duk_fb_put_cstring(fb, "unused"); + break; + } + case DUK_TAG_NULL: { + duk_fb_put_cstring(fb, "null"); + break; + } + case DUK_TAG_BOOLEAN: { + duk_fb_put_cstring(fb, DUK_TVAL_GET_BOOLEAN(tv) ? "true" : "false"); + break; + } + case DUK_TAG_STRING: { + /* Note: string is a terminal heap object, so no depth check here */ + duk__print_hstring(st, DUK_TVAL_GET_STRING(tv), 1); + break; + } + case DUK_TAG_OBJECT: { + duk__print_hobject(st, DUK_TVAL_GET_OBJECT(tv)); + break; + } + case DUK_TAG_BUFFER: { + duk__print_hbuffer(st, DUK_TVAL_GET_BUFFER(tv)); + break; + } + case DUK_TAG_POINTER: { + duk_fb_sprintf(fb, "pointer:%p", (void *) DUK_TVAL_GET_POINTER(tv)); + break; + } + case DUK_TAG_LIGHTFUNC: { + duk_c_function func; + duk_small_uint_t lf_flags; + + DUK_TVAL_GET_LIGHTFUNC(tv, func, lf_flags); + duk_fb_sprintf(fb, "lightfunc:"); + duk_fb_put_funcptr(fb, (duk_uint8_t *) &func, sizeof(func)); + duk_fb_sprintf(fb, ":%04lx", (long) lf_flags); + break; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + duk_fb_sprintf(fb, "%.18g_F", (double) DUK_TVAL_GET_NUMBER(tv)); + break; +#endif + default: { + /* IEEE double is approximately 16 decimal digits; print a couple extra */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + duk_fb_sprintf(fb, "%.18g", (double) DUK_TVAL_GET_NUMBER(tv)); + break; + } + } + if (st->heavy) { + duk_fb_put_byte(fb, (duk_uint8_t) DUK_ASC_RANGLE); + } +} + +DUK_LOCAL void duk__print_instr(duk__dprint_state *st, duk_instr_t ins) { + duk_fixedbuffer *fb = st->fb; + duk_small_int_t op; + const char *op_name; + + op = (duk_small_int_t) DUK_DEC_OP(ins); + op_name = duk__bc_optab[op]; + + /* XXX: option to fix opcode length so it lines up nicely */ + + if (op == DUK_OP_JUMP) { + duk_int_t diff1 = (duk_int_t) (DUK_DEC_ABC(ins) - DUK_BC_JUMP_BIAS); /* from next pc */ + duk_int_t diff2 = diff1 + 1; /* from curr pc */ + + duk_fb_sprintf(fb, + "%s %ld (to pc%c%ld)", + (const char *) op_name, + (long) diff1, + (int) (diff2 >= 0 ? '+' : '-'), /* char format: use int */ + (long) (diff2 >= 0 ? diff2 : -diff2)); + } else { + duk_fb_sprintf(fb, + "%s %ld, %ld, %ld", + (const char *) op_name, + (long) DUK_DEC_A(ins), + (long) DUK_DEC_B(ins), + (long) DUK_DEC_C(ins)); + } +} + +DUK_LOCAL void duk__print_opcode(duk__dprint_state *st, duk_small_int_t opcode) { + duk_fixedbuffer *fb = st->fb; + + if (opcode < DUK_BC_OP_MIN || opcode > DUK_BC_OP_MAX) { + duk_fb_sprintf(fb, "?(%ld)", (long) opcode); + } else { + duk_fb_sprintf(fb, "%s", (const char *) duk__bc_optab[opcode]); + } +} + +DUK_LOCAL void duk__print_catcher(duk__dprint_state *st, duk_catcher *cat) { + duk_fixedbuffer *fb = st->fb; + + if (duk_fb_is_full(fb)) { + return; + } + + if (!cat) { + duk_fb_put_cstring(fb, "NULL"); + return; + } + + duk_fb_sprintf(fb, + "[catcher ptr=%p parent=%p varname=%p pc_base=%p, idx_base=%ld, flags=0x%08lx]", + (void *) cat, + (void *) cat->parent, + (void *) cat->h_varname, + (void *) cat->pc_base, + (long) cat->idx_base, + (unsigned long) cat->flags); +} + +DUK_LOCAL void duk__print_activation(duk__dprint_state *st, duk_activation *act) { + duk_fixedbuffer *fb = st->fb; + + if (duk_fb_is_full(fb)) { + return; + } + + if (!act) { + duk_fb_put_cstring(fb, "NULL"); + return; + } + + /* prev_caller: conditional, omitted on purpose, it's rarely used. */ + /* prev_line: conditional, omitted on purpose (but would be nice). */ + duk_fb_sprintf(fb, + "[activation ptr=%p tv_func= func=%p parent=%p var_env=%p lex_env=%p cat=%p curr_pc=%p " + "bottom_byteoff=%ld retval_byteoff=%ld reserve_byteoff=%ld flags=%ld]", + (void *) act, + (void *) act->func, + (void *) act->parent, + (void *) act->var_env, + (void *) act->lex_env, + (void *) act->cat, + (void *) act->curr_pc, + (long) act->bottom_byteoff, + (long) act->retval_byteoff, + (long) act->reserve_byteoff, + (long) act->flags); +} + +DUK_INTERNAL duk_int_t duk_debug_vsnprintf(char *str, duk_size_t size, const char *format, va_list ap) { + duk_fixedbuffer fb; + const char *p = format; + const char *p_end = p + DUK_STRLEN(format); + duk_int_t retval; + + duk_memzero(&fb, sizeof(fb)); + fb.buffer = (duk_uint8_t *) str; + fb.length = size; + fb.offset = 0; + fb.truncated = 0; + + while (p < p_end) { + char ch = *p++; + const char *p_begfmt = NULL; + duk_bool_t got_exclamation = 0; + duk_bool_t got_long = 0; /* %lf, %ld etc */ + duk__dprint_state st; + + if (ch != DUK_ASC_PERCENT) { + duk_fb_put_byte(&fb, (duk_uint8_t) ch); + continue; + } + + /* + * Format tag parsing. Since we don't understand all the + * possible format tags allowed, we just scan for a terminating + * specifier and keep track of relevant modifiers that we do + * understand. See man 3 printf. + */ + + duk_memzero(&st, sizeof(st)); + st.fb = &fb; + st.depth = 0; + st.depth_limit = 1; + st.loop_stack_index = 0; + st.loop_stack_limit = DUK__LOOP_STACK_DEPTH; + + p_begfmt = p - 1; + while (p < p_end) { + ch = *p++; + + if (ch == DUK_ASC_STAR) { + /* unsupported: would consume multiple args */ + goto format_error; + } else if (ch == DUK_ASC_PERCENT) { + duk_fb_put_byte(&fb, (duk_uint8_t) DUK_ASC_PERCENT); + break; + } else if (ch == DUK_ASC_EXCLAMATION) { + got_exclamation = 1; + } else if (!got_exclamation && ch == DUK_ASC_LC_L) { + got_long = 1; + } else if (got_exclamation && ch == DUK_ASC_LC_D) { + st.depth_limit = DUK__DEEP_DEPTH_LIMIT; + } else if (got_exclamation && ch == DUK_ASC_LC_P) { + st.follow_proto = 1; + } else if (got_exclamation && ch == DUK_ASC_LC_I) { + st.internal = 1; + } else if (got_exclamation && ch == DUK_ASC_LC_X) { + st.hexdump = 1; + } else if (got_exclamation && ch == DUK_ASC_LC_H) { + st.heavy = 1; + } else if (got_exclamation && ch == DUK_ASC_ATSIGN) { + st.pointer = 1; + } else if (got_exclamation && ch == DUK_ASC_HASH) { + st.binary = 1; + } else if (got_exclamation && ch == DUK_ASC_UC_T) { + duk_tval *t = va_arg(ap, duk_tval *); + if (st.pointer && !st.heavy) { + duk_fb_sprintf(&fb, "(%p)", (void *) t); + } + duk__print_tval(&st, t); + break; + } else if (got_exclamation && ch == DUK_ASC_UC_O) { + duk_heaphdr *t = va_arg(ap, duk_heaphdr *); + if (st.pointer && !st.heavy) { + duk_fb_sprintf(&fb, "(%p)", (void *) t); + } + duk__print_heaphdr(&st, t); + break; + } else if (got_exclamation && ch == DUK_ASC_UC_I) { + duk_instr_t t = va_arg(ap, duk_instr_t); + duk__print_instr(&st, t); + break; + } else if (got_exclamation && ch == DUK_ASC_UC_X) { + long t = va_arg(ap, long); + duk__print_opcode(&st, (duk_small_int_t) t); + break; + } else if (got_exclamation && ch == DUK_ASC_UC_C) { + duk_catcher *t = va_arg(ap, duk_catcher *); + duk__print_catcher(&st, t); + break; + } else if (got_exclamation && ch == DUK_ASC_UC_A) { + duk_activation *t = va_arg(ap, duk_activation *); + duk__print_activation(&st, t); + break; + } else if (!got_exclamation && strchr(DUK__ALLOWED_STANDARD_SPECIFIERS, (int) ch)) { + char fmtbuf[DUK__MAX_FORMAT_TAG_LENGTH]; + duk_size_t fmtlen; + + DUK_ASSERT(p >= p_begfmt); + fmtlen = (duk_size_t) (p - p_begfmt); + if (fmtlen >= sizeof(fmtbuf)) { + /* format is too large, abort */ + goto format_error; + } + duk_memzero(fmtbuf, sizeof(fmtbuf)); + duk_memcpy(fmtbuf, p_begfmt, fmtlen); + + /* assume exactly 1 arg, which is why '*' is forbidden; arg size still + * depends on type though. + */ + + if (ch == DUK_ASC_LC_F || ch == DUK_ASC_LC_G || ch == DUK_ASC_LC_E) { + /* %f and %lf both consume a 'long' */ + double arg = va_arg(ap, double); + duk_fb_sprintf(&fb, fmtbuf, arg); + } else if (ch == DUK_ASC_LC_D && got_long) { + /* %ld */ + long arg = va_arg(ap, long); + duk_fb_sprintf(&fb, fmtbuf, arg); + } else if (ch == DUK_ASC_LC_D) { + /* %d; only 16 bits are guaranteed */ + int arg = va_arg(ap, int); + duk_fb_sprintf(&fb, fmtbuf, arg); + } else if (ch == DUK_ASC_LC_U && got_long) { + /* %lu */ + unsigned long arg = va_arg(ap, unsigned long); + duk_fb_sprintf(&fb, fmtbuf, arg); + } else if (ch == DUK_ASC_LC_U) { + /* %u; only 16 bits are guaranteed */ + unsigned int arg = va_arg(ap, unsigned int); + duk_fb_sprintf(&fb, fmtbuf, arg); + } else if (ch == DUK_ASC_LC_X && got_long) { + /* %lx */ + unsigned long arg = va_arg(ap, unsigned long); + duk_fb_sprintf(&fb, fmtbuf, arg); + } else if (ch == DUK_ASC_LC_X) { + /* %x; only 16 bits are guaranteed */ + unsigned int arg = va_arg(ap, unsigned int); + duk_fb_sprintf(&fb, fmtbuf, arg); + } else if (ch == DUK_ASC_LC_S) { + /* %s */ + const char *arg = va_arg(ap, const char *); + if (arg == NULL) { + /* '%s' and NULL is not portable, so special case + * it for debug printing. + */ + duk_fb_sprintf(&fb, "NULL"); + } else { + duk_fb_sprintf(&fb, fmtbuf, arg); + } + } else if (ch == DUK_ASC_LC_P) { + /* %p */ + void *arg = va_arg(ap, void *); + if (arg == NULL) { + /* '%p' and NULL is portable, but special case it + * anyway to get a standard NULL marker in logs. + */ + duk_fb_sprintf(&fb, "NULL"); + } else { + duk_fb_sprintf(&fb, fmtbuf, arg); + } + } else if (ch == DUK_ASC_LC_C) { + /* '%c', passed concretely as int */ + int arg = va_arg(ap, int); + duk_fb_sprintf(&fb, fmtbuf, arg); + } else { + /* Should not happen. */ + duk_fb_sprintf(&fb, "INVALID-FORMAT(%s)", (const char *) fmtbuf); + } + break; + } else { + /* ignore */ + } + } + } + goto done; + +format_error: + duk_fb_put_cstring(&fb, "FMTERR"); + /* fall through */ + +done: + retval = (duk_int_t) fb.offset; + duk_fb_put_byte(&fb, (duk_uint8_t) 0); + + /* return total chars written excluding terminator */ + return retval; +} + +#if 0 /*unused*/ +DUK_INTERNAL duk_int_t duk_debug_snprintf(char *str, duk_size_t size, const char *format, ...) { + duk_int_t retval; + va_list ap; + va_start(ap, format); + retval = duk_debug_vsnprintf(str, size, format, ap); + va_end(ap); + return retval; +} +#endif + +/* Formatting function pointers is tricky: there is no standard pointer for + * function pointers and the size of a function pointer may depend on the + * specific pointer type. This helper formats a function pointer based on + * its memory layout to get something useful on most platforms. + */ +DUK_INTERNAL void duk_debug_format_funcptr(char *buf, duk_size_t buf_size, duk_uint8_t *fptr, duk_size_t fptr_size) { + duk_size_t i; + duk_uint8_t *p = (duk_uint8_t *) buf; + duk_uint8_t *p_end = (duk_uint8_t *) (buf + buf_size - 1); + + DUK_ASSERT(buf != NULL); + duk_memzero(buf, buf_size); + + for (i = 0; i < fptr_size; i++) { + duk_int_t left = (duk_int_t) (p_end - p); + duk_uint8_t ch; + if (left <= 0) { + break; + } + + /* Quite approximate but should be useful for little and big endian. */ +#if defined(DUK_USE_INTEGER_BE) + ch = fptr[i]; +#else + ch = fptr[fptr_size - 1 - i]; +#endif + p += DUK_SNPRINTF((char *) p, (duk_size_t) left, "%02lx", (unsigned long) ch); + } +} + +#endif /* DUK_USE_DEBUG */ + +/* automatic undefs */ +#undef DUK__ALLOWED_STANDARD_SPECIFIERS +#undef DUK__COMMA +#undef DUK__DEEP_DEPTH_LIMIT +#undef DUK__LOOP_STACK_DEPTH +#undef DUK__MAX_FORMAT_TAG_LENGTH +#line 1 "duk_debugger.c" +/* + * Duktape debugger + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + +/* + * Assert helpers + */ + +#if defined(DUK_USE_ASSERTIONS) +#define DUK__DBG_TPORT_ENTER() \ + do { \ + DUK_ASSERT(heap->dbg_calling_transport == 0); \ + heap->dbg_calling_transport = 1; \ + } while (0) +#define DUK__DBG_TPORT_EXIT() \ + do { \ + DUK_ASSERT(heap->dbg_calling_transport == 1); \ + heap->dbg_calling_transport = 0; \ + } while (0) +#else +#define DUK__DBG_TPORT_ENTER() \ + do { \ + } while (0) +#define DUK__DBG_TPORT_EXIT() \ + do { \ + } while (0) +#endif + +/* + * Helper structs + */ + +typedef union { + void *p; + duk_uint_t b[1]; + /* Use b[] to access the size of the union, which is strictly not + * correct. Can't use fixed size unless there's feature detection + * for pointer byte size. + */ +} duk__ptr_union; + +/* + * Detach handling + */ + +#define DUK__SET_CONN_BROKEN(thr, reason) \ + do { \ + /* For now shared handler is fine. */ \ + duk__debug_do_detach1((thr)->heap, (reason)); \ + } while (0) + +DUK_LOCAL void duk__debug_do_detach1(duk_heap *heap, duk_int_t reason) { + /* Can be called multiple times with no harm. Mark the transport + * bad (dbg_read_cb == NULL) and clear state except for the detached + * callback and the udata field. The detached callback is delayed + * to the message loop so that it can be called between messages; + * this avoids corner cases related to immediate debugger reattach + * inside the detached callback. + */ + + if (heap->dbg_detaching) { + DUK_D(DUK_DPRINT("debugger already detaching, ignore detach1")); + return; + } + + DUK_D(DUK_DPRINT("debugger transport detaching, marking transport broken")); + + heap->dbg_detaching = 1; /* prevent multiple in-progress detaches */ + + if (heap->dbg_write_cb != NULL) { + duk_hthread *thr; + + thr = heap->heap_thread; + DUK_ASSERT(thr != NULL); + + duk_debug_write_notify(thr, DUK_DBG_CMD_DETACHING); + duk_debug_write_int(thr, reason); + duk_debug_write_eom(thr); + } + + heap->dbg_read_cb = NULL; + heap->dbg_write_cb = NULL; + heap->dbg_peek_cb = NULL; + heap->dbg_read_flush_cb = NULL; + heap->dbg_write_flush_cb = NULL; + heap->dbg_request_cb = NULL; + /* heap->dbg_detached_cb: keep */ + /* heap->dbg_udata: keep */ + /* heap->dbg_processing: keep on purpose to avoid debugger re-entry in detaching state */ + heap->dbg_state_dirty = 0; + heap->dbg_force_restart = 0; + heap->dbg_pause_flags = 0; + heap->dbg_pause_act = NULL; + heap->dbg_pause_startline = 0; + heap->dbg_have_next_byte = 0; + duk_debug_clear_paused(heap); /* XXX: some overlap with field inits above */ + heap->dbg_state_dirty = 0; /* XXX: clear_paused sets dirty; rework? */ + + /* Ensure there are no stale active breakpoint pointers. + * Breakpoint list is currently kept - we could empty it + * here but we'd need to handle refcounts correctly, and + * we'd need a 'thr' reference for that. + * + * XXX: clear breakpoint on either attach or detach? + */ + heap->dbg_breakpoints_active[0] = (duk_breakpoint *) NULL; +} + +DUK_LOCAL void duk__debug_do_detach2(duk_heap *heap) { + duk_debug_detached_function detached_cb; + void *detached_udata; + duk_hthread *thr; + + thr = heap->heap_thread; + if (thr == NULL) { + DUK_ASSERT(heap->dbg_detached_cb == NULL); + return; + } + + /* Safe to call multiple times. */ + + detached_cb = heap->dbg_detached_cb; + detached_udata = heap->dbg_udata; + heap->dbg_detached_cb = NULL; + heap->dbg_udata = NULL; + + if (detached_cb) { + /* Careful here: state must be wiped before the call + * so that we can cleanly handle a re-attach from + * inside the callback. + */ + DUK_D(DUK_DPRINT("detached during message loop, delayed call to detached_cb")); + detached_cb(thr, detached_udata); + } + + heap->dbg_detaching = 0; +} + +DUK_INTERNAL void duk_debug_do_detach(duk_heap *heap) { + duk__debug_do_detach1(heap, 0); + duk__debug_do_detach2(heap); +} + +/* Called on a read/write error: NULL all callbacks except the detached + * callback so that we never accidentally call them after a read/write + * error has been indicated. This is especially important for the transport + * I/O callbacks to fulfill guaranteed callback semantics. + */ +DUK_LOCAL void duk__debug_null_most_callbacks(duk_hthread *thr) { + duk_heap *heap; + + DUK_ASSERT(thr != NULL); + + heap = thr->heap; + DUK_D(DUK_DPRINT("transport read/write error, NULL all callbacks expected detached")); + heap->dbg_read_cb = NULL; + heap->dbg_write_cb = NULL; /* this is especially critical to avoid another write call in detach1() */ + heap->dbg_peek_cb = NULL; + heap->dbg_read_flush_cb = NULL; + heap->dbg_write_flush_cb = NULL; + heap->dbg_request_cb = NULL; + /* keep heap->dbg_detached_cb */ +} + +/* + * Pause handling + */ + +DUK_LOCAL void duk__debug_set_pause_state(duk_hthread *thr, duk_heap *heap, duk_small_uint_t pause_flags) { + duk_uint_fast32_t line; + + line = duk_debug_curr_line(thr); + if (line == 0) { + /* No line info for current function. */ + duk_small_uint_t updated_flags; + + updated_flags = pause_flags & ~(DUK_PAUSE_FLAG_LINE_CHANGE); + DUK_D(DUK_DPRINT("no line info for current activation, disable line-based pause flags: 0x%08lx -> 0x%08lx", + (long) pause_flags, + (long) updated_flags)); + pause_flags = updated_flags; + } + + heap->dbg_pause_flags = pause_flags; + heap->dbg_pause_act = thr->callstack_curr; + heap->dbg_pause_startline = (duk_uint32_t) line; + heap->dbg_state_dirty = 1; + + DUK_D(DUK_DPRINT("set state for automatic pause triggers, flags=0x%08lx, act=%p, startline=%ld", + (long) heap->dbg_pause_flags, + (void *) heap->dbg_pause_act, + (long) heap->dbg_pause_startline)); +} + +/* + * Debug connection peek and flush primitives + */ + +DUK_INTERNAL duk_bool_t duk_debug_read_peek(duk_hthread *thr) { + duk_heap *heap; + duk_bool_t ret; + + DUK_ASSERT(thr != NULL); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + + if (heap->dbg_read_cb == NULL) { + DUK_D(DUK_DPRINT("attempt to peek in detached state, return zero (= no data)")); + return 0; + } + if (heap->dbg_peek_cb == NULL) { + DUK_DD(DUK_DDPRINT("no peek callback, return zero (= no data)")); + return 0; + } + + DUK__DBG_TPORT_ENTER(); + ret = (duk_bool_t) (heap->dbg_peek_cb(heap->dbg_udata) > 0); + DUK__DBG_TPORT_EXIT(); + return ret; +} + +DUK_INTERNAL void duk_debug_read_flush(duk_hthread *thr) { + duk_heap *heap; + + DUK_ASSERT(thr != NULL); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + + if (heap->dbg_read_cb == NULL) { + DUK_D(DUK_DPRINT("attempt to read flush in detached state, ignore")); + return; + } + if (heap->dbg_read_flush_cb == NULL) { + DUK_DD(DUK_DDPRINT("no read flush callback, ignore")); + return; + } + + DUK__DBG_TPORT_ENTER(); + heap->dbg_read_flush_cb(heap->dbg_udata); + DUK__DBG_TPORT_EXIT(); +} + +DUK_INTERNAL void duk_debug_write_flush(duk_hthread *thr) { + duk_heap *heap; + + DUK_ASSERT(thr != NULL); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + + if (heap->dbg_read_cb == NULL) { + DUK_D(DUK_DPRINT("attempt to write flush in detached state, ignore")); + return; + } + if (heap->dbg_write_flush_cb == NULL) { + DUK_DD(DUK_DDPRINT("no write flush callback, ignore")); + return; + } + + DUK__DBG_TPORT_ENTER(); + heap->dbg_write_flush_cb(heap->dbg_udata); + DUK__DBG_TPORT_EXIT(); +} + +/* + * Debug connection skip primitives + */ + +/* Skip fully. */ +DUK_INTERNAL void duk_debug_skip_bytes(duk_hthread *thr, duk_size_t length) { + duk_uint8_t dummy[64]; + duk_size_t now; + + DUK_ASSERT(thr != NULL); + + while (length > 0) { + now = (length > sizeof(dummy) ? sizeof(dummy) : length); + duk_debug_read_bytes(thr, dummy, now); + length -= now; + } +} + +DUK_INTERNAL void duk_debug_skip_byte(duk_hthread *thr) { + DUK_ASSERT(thr != NULL); + + (void) duk_debug_read_byte(thr); +} + +/* + * Debug connection read primitives + */ + +/* Peek ahead in the stream one byte. */ +DUK_INTERNAL uint8_t duk_debug_peek_byte(duk_hthread *thr) { + /* It is important not to call this if the last byte read was an EOM. + * Reading ahead in this scenario would cause unnecessary blocking if + * another message is not available. + */ + + duk_uint8_t x; + + x = duk_debug_read_byte(thr); + thr->heap->dbg_have_next_byte = 1; + thr->heap->dbg_next_byte = x; + return x; +} + +/* Read fully. */ +DUK_INTERNAL void duk_debug_read_bytes(duk_hthread *thr, duk_uint8_t *data, duk_size_t length) { + duk_heap *heap; + duk_uint8_t *p; + duk_size_t left; + duk_size_t got; + + DUK_ASSERT(thr != NULL); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + DUK_ASSERT(data != NULL); + + if (heap->dbg_read_cb == NULL) { + DUK_D(DUK_DPRINT("attempt to read %ld bytes in detached state, return zero data", (long) length)); + goto fail; + } + + /* NOTE: length may be zero */ + p = data; + if (length >= 1 && heap->dbg_have_next_byte) { + heap->dbg_have_next_byte = 0; + *p++ = heap->dbg_next_byte; + } + for (;;) { + left = (duk_size_t) ((data + length) - p); + if (left == 0) { + break; + } + DUK_ASSERT(heap->dbg_read_cb != NULL); + DUK_ASSERT(left >= 1); +#if defined(DUK_USE_DEBUGGER_TRANSPORT_TORTURE) + left = 1; +#endif + DUK__DBG_TPORT_ENTER(); + got = heap->dbg_read_cb(heap->dbg_udata, (char *) p, left); + DUK__DBG_TPORT_EXIT(); + + if (got == 0 || got > left) { + DUK_D(DUK_DPRINT("connection error during read, return zero data")); + duk__debug_null_most_callbacks(thr); /* avoid calling write callback in detach1() */ + DUK__SET_CONN_BROKEN(thr, 1); + goto fail; + } + p += got; + } + return; + +fail: + duk_memzero((void *) data, (size_t) length); +} + +DUK_INTERNAL duk_uint8_t duk_debug_read_byte(duk_hthread *thr) { + duk_uint8_t x; + + x = 0; /* just in case callback is broken and won't write 'x' */ + duk_debug_read_bytes(thr, &x, 1); + return x; +} + +DUK_LOCAL duk_uint32_t duk__debug_read_uint32_raw(duk_hthread *thr) { + duk_uint8_t buf[4]; + + DUK_ASSERT(thr != NULL); + + duk_debug_read_bytes(thr, buf, 4); + return ((duk_uint32_t) buf[0] << 24) | ((duk_uint32_t) buf[1] << 16) | ((duk_uint32_t) buf[2] << 8) | (duk_uint32_t) buf[3]; +} + +DUK_LOCAL duk_int32_t duk__debug_read_int32_raw(duk_hthread *thr) { + return (duk_int32_t) duk__debug_read_uint32_raw(thr); +} + +DUK_LOCAL duk_uint16_t duk__debug_read_uint16_raw(duk_hthread *thr) { + duk_uint8_t buf[2]; + + DUK_ASSERT(thr != NULL); + + duk_debug_read_bytes(thr, buf, 2); + return ((duk_uint16_t) buf[0] << 8) | (duk_uint16_t) buf[1]; +} + +DUK_INTERNAL duk_int32_t duk_debug_read_int(duk_hthread *thr) { + duk_small_uint_t x; + duk_small_uint_t t; + + DUK_ASSERT(thr != NULL); + + x = duk_debug_read_byte(thr); + if (x >= 0xc0) { + t = duk_debug_read_byte(thr); + return (duk_int32_t) (((x - 0xc0) << 8) + t); + } else if (x >= 0x80) { + return (duk_int32_t) (x - 0x80); + } else if (x == DUK_DBG_IB_INT4) { + return (duk_int32_t) duk__debug_read_uint32_raw(thr); + } + + DUK_D(DUK_DPRINT("debug connection error: failed to decode int")); + DUK__SET_CONN_BROKEN(thr, 1); + return 0; +} + +DUK_LOCAL duk_hstring *duk__debug_read_hstring_raw(duk_hthread *thr, duk_uint32_t len) { + duk_uint8_t buf[31]; + duk_uint8_t *p; + + if (len <= sizeof(buf)) { + duk_debug_read_bytes(thr, buf, (duk_size_t) len); + duk_push_lstring(thr, (const char *) buf, (duk_size_t) len); + } else { + p = (duk_uint8_t *) duk_push_fixed_buffer(thr, (duk_size_t) len); /* zero for paranoia */ + DUK_ASSERT(p != NULL); + duk_debug_read_bytes(thr, p, (duk_size_t) len); + (void) duk_buffer_to_string(thr, -1); /* Safety relies on debug client, which is OK. */ + } + + return duk_require_hstring(thr, -1); +} + +DUK_INTERNAL duk_hstring *duk_debug_read_hstring(duk_hthread *thr) { + duk_small_uint_t x; + duk_uint32_t len; + + DUK_ASSERT(thr != NULL); + + x = duk_debug_read_byte(thr); + if (x >= 0x60 && x <= 0x7f) { + /* For short strings, use a fixed temp buffer. */ + len = (duk_uint32_t) (x - 0x60); + } else if (x == DUK_DBG_IB_STR2) { + len = (duk_uint32_t) duk__debug_read_uint16_raw(thr); + } else if (x == DUK_DBG_IB_STR4) { + len = (duk_uint32_t) duk__debug_read_uint32_raw(thr); + } else { + goto fail; + } + + return duk__debug_read_hstring_raw(thr, len); + +fail: + DUK_D(DUK_DPRINT("debug connection error: failed to decode int")); + DUK__SET_CONN_BROKEN(thr, 1); + duk_push_hstring_empty(thr); /* always push some string */ + return duk_require_hstring(thr, -1); +} + +DUK_LOCAL duk_hbuffer *duk__debug_read_hbuffer_raw(duk_hthread *thr, duk_uint32_t len) { + duk_uint8_t *p; + + p = (duk_uint8_t *) duk_push_fixed_buffer(thr, (duk_size_t) len); /* zero for paranoia */ + DUK_ASSERT(p != NULL); + duk_debug_read_bytes(thr, p, (duk_size_t) len); + + return duk_require_hbuffer(thr, -1); +} + +DUK_LOCAL void *duk__debug_read_pointer_raw(duk_hthread *thr) { + duk_small_uint_t x; + duk__ptr_union pu; + + DUK_ASSERT(thr != NULL); + + x = duk_debug_read_byte(thr); + if (x != sizeof(pu)) { + goto fail; + } + duk_debug_read_bytes(thr, (duk_uint8_t *) &pu.p, sizeof(pu)); +#if defined(DUK_USE_INTEGER_LE) + duk_byteswap_bytes((duk_uint8_t *) pu.b, sizeof(pu)); +#endif + return (void *) pu.p; + +fail: + DUK_D(DUK_DPRINT("debug connection error: failed to decode pointer")); + DUK__SET_CONN_BROKEN(thr, 1); + return (void *) NULL; +} + +DUK_LOCAL duk_double_t duk__debug_read_double_raw(duk_hthread *thr) { + duk_double_union du; + + DUK_ASSERT(sizeof(du.uc) == 8); + duk_debug_read_bytes(thr, (duk_uint8_t *) du.uc, sizeof(du.uc)); + DUK_DBLUNION_DOUBLE_NTOH(&du); + return du.d; +} + +#if 0 +DUK_INTERNAL duk_heaphdr *duk_debug_read_heapptr(duk_hthread *thr) { + duk_small_uint_t x; + + DUK_ASSERT(thr != NULL); + + x = duk_debug_read_byte(thr); + if (x != DUK_DBG_IB_HEAPPTR) { + goto fail; + } + + return (duk_heaphdr *) duk__debug_read_pointer_raw(thr); + + fail: + DUK_D(DUK_DPRINT("debug connection error: failed to decode heapptr")); + DUK__SET_CONN_BROKEN(thr, 1); + return NULL; +} +#endif + +DUK_INTERNAL duk_heaphdr *duk_debug_read_any_ptr(duk_hthread *thr) { + duk_small_uint_t x; + + DUK_ASSERT(thr != NULL); + + x = duk_debug_read_byte(thr); + switch (x) { + case DUK_DBG_IB_OBJECT: + case DUK_DBG_IB_POINTER: + case DUK_DBG_IB_HEAPPTR: + /* Accept any pointer-like value; for 'object' dvalue, read + * and ignore the class number. + */ + if (x == DUK_DBG_IB_OBJECT) { + duk_debug_skip_byte(thr); + } + break; + default: + goto fail; + } + + return (duk_heaphdr *) duk__debug_read_pointer_raw(thr); + +fail: + DUK_D(DUK_DPRINT("debug connection error: failed to decode any pointer (object, pointer, heapptr)")); + DUK__SET_CONN_BROKEN(thr, 1); + return NULL; +} + +DUK_INTERNAL duk_tval *duk_debug_read_tval(duk_hthread *thr) { + duk_uint8_t x; + duk_uint_t t; + duk_uint32_t len; + + DUK_ASSERT(thr != NULL); + + x = duk_debug_read_byte(thr); + + if (x >= 0xc0) { + t = (duk_uint_t) (x - 0xc0); + t = (t << 8) + duk_debug_read_byte(thr); + duk_push_uint(thr, (duk_uint_t) t); + goto return_ptr; + } + if (x >= 0x80) { + duk_push_uint(thr, (duk_uint_t) (x - 0x80)); + goto return_ptr; + } + if (x >= 0x60) { + len = (duk_uint32_t) (x - 0x60); + duk__debug_read_hstring_raw(thr, len); + goto return_ptr; + } + + switch (x) { + case DUK_DBG_IB_INT4: { + duk_int32_t i = duk__debug_read_int32_raw(thr); + duk_push_i32(thr, i); + break; + } + case DUK_DBG_IB_STR4: { + len = duk__debug_read_uint32_raw(thr); + duk__debug_read_hstring_raw(thr, len); + break; + } + case DUK_DBG_IB_STR2: { + len = duk__debug_read_uint16_raw(thr); + duk__debug_read_hstring_raw(thr, len); + break; + } + case DUK_DBG_IB_BUF4: { + len = duk__debug_read_uint32_raw(thr); + duk__debug_read_hbuffer_raw(thr, len); + break; + } + case DUK_DBG_IB_BUF2: { + len = duk__debug_read_uint16_raw(thr); + duk__debug_read_hbuffer_raw(thr, len); + break; + } + case DUK_DBG_IB_UNDEFINED: { + duk_push_undefined(thr); + break; + } + case DUK_DBG_IB_NULL: { + duk_push_null(thr); + break; + } + case DUK_DBG_IB_TRUE: { + duk_push_true(thr); + break; + } + case DUK_DBG_IB_FALSE: { + duk_push_false(thr); + break; + } + case DUK_DBG_IB_NUMBER: { + duk_double_t d; + d = duk__debug_read_double_raw(thr); + duk_push_number(thr, d); + break; + } + case DUK_DBG_IB_OBJECT: { + duk_heaphdr *h; + duk_debug_skip_byte(thr); + h = (duk_heaphdr *) duk__debug_read_pointer_raw(thr); + duk_push_heapptr(thr, (void *) h); + break; + } + case DUK_DBG_IB_POINTER: { + void *ptr; + ptr = duk__debug_read_pointer_raw(thr); + duk_push_pointer(thr, ptr); + break; + } + case DUK_DBG_IB_LIGHTFUNC: { + /* XXX: Not needed for now, so not implemented. Note that + * function pointers may have different size/layout than + * a void pointer. + */ + DUK_D(DUK_DPRINT("reading lightfunc values unimplemented")); + goto fail; + } + case DUK_DBG_IB_HEAPPTR: { + duk_heaphdr *h; + h = (duk_heaphdr *) duk__debug_read_pointer_raw(thr); + duk_push_heapptr(thr, (void *) h); + break; + } + case DUK_DBG_IB_UNUSED: /* unused: not accepted in inbound messages */ + default: + goto fail; + } + +return_ptr: + return DUK_GET_TVAL_NEGIDX(thr, -1); + +fail: + DUK_D(DUK_DPRINT("debug connection error: failed to decode tval")); + DUK__SET_CONN_BROKEN(thr, 1); + return NULL; +} + +/* + * Debug connection write primitives + */ + +/* Write fully. */ +DUK_INTERNAL void duk_debug_write_bytes(duk_hthread *thr, const duk_uint8_t *data, duk_size_t length) { + duk_heap *heap; + const duk_uint8_t *p; + duk_size_t left; + duk_size_t got; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(length == 0 || data != NULL); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + + if (heap->dbg_write_cb == NULL) { + DUK_D(DUK_DPRINT("attempt to write %ld bytes in detached state, ignore", (long) length)); + return; + } + if (length == 0) { + /* Avoid doing an actual write callback with length == 0, + * because that's reserved for a write flush. + */ + return; + } + DUK_ASSERT(data != NULL); + + p = data; + for (;;) { + left = (duk_size_t) ((data + length) - p); + if (left == 0) { + break; + } + DUK_ASSERT(heap->dbg_write_cb != NULL); + DUK_ASSERT(left >= 1); +#if defined(DUK_USE_DEBUGGER_TRANSPORT_TORTURE) + left = 1; +#endif + DUK__DBG_TPORT_ENTER(); + got = heap->dbg_write_cb(heap->dbg_udata, (const char *) p, left); + DUK__DBG_TPORT_EXIT(); + + if (got == 0 || got > left) { + duk__debug_null_most_callbacks(thr); /* avoid calling write callback in detach1() */ + DUK_D(DUK_DPRINT("connection error during write")); + DUK__SET_CONN_BROKEN(thr, 1); + return; + } + p += got; + } +} + +DUK_INTERNAL void duk_debug_write_byte(duk_hthread *thr, duk_uint8_t x) { + duk_debug_write_bytes(thr, (const duk_uint8_t *) &x, 1); +} + +DUK_INTERNAL void duk_debug_write_unused(duk_hthread *thr) { + duk_debug_write_byte(thr, DUK_DBG_IB_UNUSED); +} + +DUK_INTERNAL void duk_debug_write_undefined(duk_hthread *thr) { + duk_debug_write_byte(thr, DUK_DBG_IB_UNDEFINED); +} + +#if defined(DUK_USE_DEBUGGER_INSPECT) +DUK_INTERNAL void duk_debug_write_null(duk_hthread *thr) { + duk_debug_write_byte(thr, DUK_DBG_IB_NULL); +} +#endif + +DUK_INTERNAL void duk_debug_write_boolean(duk_hthread *thr, duk_uint_t val) { + duk_debug_write_byte(thr, val ? DUK_DBG_IB_TRUE : DUK_DBG_IB_FALSE); +} + +/* Write signed 32-bit integer. */ +DUK_INTERNAL void duk_debug_write_int(duk_hthread *thr, duk_int32_t x) { + duk_uint8_t buf[5]; + duk_size_t len; + + DUK_ASSERT(thr != NULL); + + if (x >= 0 && x <= 0x3fL) { + buf[0] = (duk_uint8_t) (0x80 + x); + len = 1; + } else if (x >= 0 && x <= 0x3fffL) { + buf[0] = (duk_uint8_t) (0xc0 + (x >> 8)); + buf[1] = (duk_uint8_t) (x & 0xff); + len = 2; + } else { + /* Signed integers always map to 4 bytes now. */ + buf[0] = (duk_uint8_t) DUK_DBG_IB_INT4; + buf[1] = (duk_uint8_t) ((x >> 24) & 0xff); + buf[2] = (duk_uint8_t) ((x >> 16) & 0xff); + buf[3] = (duk_uint8_t) ((x >> 8) & 0xff); + buf[4] = (duk_uint8_t) (x & 0xff); + len = 5; + } + duk_debug_write_bytes(thr, buf, len); +} + +/* Write unsigned 32-bit integer. */ +DUK_INTERNAL void duk_debug_write_uint(duk_hthread *thr, duk_uint32_t x) { + /* The debugger protocol doesn't support a plain integer encoding for + * the full 32-bit unsigned range (only 32-bit signed). For now, + * unsigned 32-bit values simply written as signed ones. This is not + * a concrete issue except for 32-bit heaphdr fields. Proper solutions + * would be to (a) write such integers as IEEE doubles or (b) add an + * unsigned 32-bit dvalue. + */ + if (x >= 0x80000000UL) { + DUK_D(DUK_DPRINT("writing unsigned integer 0x%08lx as signed integer", (long) x)); + } + duk_debug_write_int(thr, (duk_int32_t) x); +} + +DUK_INTERNAL void duk_debug_write_strbuf(duk_hthread *thr, const char *data, duk_size_t length, duk_uint8_t marker_base) { + duk_uint8_t buf[5]; + duk_size_t buflen; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(length == 0 || data != NULL); + + if (length <= 0x1fUL && marker_base == DUK_DBG_IB_STR4) { + /* For strings, special form for short lengths. */ + buf[0] = (duk_uint8_t) (0x60 + length); + buflen = 1; + } else if (length <= 0xffffUL) { + buf[0] = (duk_uint8_t) (marker_base + 1); + buf[1] = (duk_uint8_t) (length >> 8); + buf[2] = (duk_uint8_t) (length & 0xff); + buflen = 3; + } else { + buf[0] = (duk_uint8_t) marker_base; + buf[1] = (duk_uint8_t) (length >> 24); + buf[2] = (duk_uint8_t) ((length >> 16) & 0xff); + buf[3] = (duk_uint8_t) ((length >> 8) & 0xff); + buf[4] = (duk_uint8_t) (length & 0xff); + buflen = 5; + } + + duk_debug_write_bytes(thr, (const duk_uint8_t *) buf, buflen); + duk_debug_write_bytes(thr, (const duk_uint8_t *) data, length); +} + +DUK_INTERNAL void duk_debug_write_string(duk_hthread *thr, const char *data, duk_size_t length) { + duk_debug_write_strbuf(thr, data, length, DUK_DBG_IB_STR4); +} + +DUK_INTERNAL void duk_debug_write_cstring(duk_hthread *thr, const char *data) { + DUK_ASSERT(thr != NULL); + + duk_debug_write_string(thr, data, data ? DUK_STRLEN(data) : 0); +} + +DUK_INTERNAL void duk_debug_write_hstring(duk_hthread *thr, duk_hstring *h) { + DUK_ASSERT(thr != NULL); + + /* XXX: differentiate null pointer from empty string? */ + duk_debug_write_string(thr, + (h != NULL ? (const char *) DUK_HSTRING_GET_DATA(h) : NULL), + (h != NULL ? (duk_size_t) DUK_HSTRING_GET_BYTELEN(h) : 0)); +} + +DUK_LOCAL void duk__debug_write_hstring_safe_top(duk_hthread *thr) { + duk_debug_write_hstring(thr, duk_safe_to_hstring(thr, -1)); +} + +DUK_INTERNAL void duk_debug_write_buffer(duk_hthread *thr, const char *data, duk_size_t length) { + duk_debug_write_strbuf(thr, data, length, DUK_DBG_IB_BUF4); +} + +DUK_INTERNAL void duk_debug_write_hbuffer(duk_hthread *thr, duk_hbuffer *h) { + DUK_ASSERT(thr != NULL); + + duk_debug_write_buffer(thr, + (h != NULL ? (const char *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h) : NULL), + (h != NULL ? (duk_size_t) DUK_HBUFFER_GET_SIZE(h) : 0)); +} + +DUK_LOCAL void duk__debug_write_pointer_raw(duk_hthread *thr, void *ptr, duk_uint8_t ibyte) { + duk_uint8_t buf[2]; + duk__ptr_union pu; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(sizeof(ptr) >= 1 && sizeof(ptr) <= 16); + /* ptr may be NULL */ + + buf[0] = ibyte; + buf[1] = sizeof(pu); + duk_debug_write_bytes(thr, buf, 2); + pu.p = (void *) ptr; +#if defined(DUK_USE_INTEGER_LE) + duk_byteswap_bytes((duk_uint8_t *) pu.b, sizeof(pu)); +#endif + duk_debug_write_bytes(thr, (const duk_uint8_t *) &pu.p, (duk_size_t) sizeof(pu)); +} + +DUK_INTERNAL void duk_debug_write_pointer(duk_hthread *thr, void *ptr) { + duk__debug_write_pointer_raw(thr, ptr, DUK_DBG_IB_POINTER); +} + +#if defined(DUK_USE_DEBUGGER_DUMPHEAP) || defined(DUK_USE_DEBUGGER_INSPECT) +DUK_INTERNAL void duk_debug_write_heapptr(duk_hthread *thr, duk_heaphdr *h) { + duk__debug_write_pointer_raw(thr, (void *) h, DUK_DBG_IB_HEAPPTR); +} +#endif /* DUK_USE_DEBUGGER_DUMPHEAP || DUK_USE_DEBUGGER_INSPECT */ + +DUK_INTERNAL void duk_debug_write_hobject(duk_hthread *thr, duk_hobject *obj) { + duk_uint8_t buf[3]; + duk__ptr_union pu; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(sizeof(obj) >= 1 && sizeof(obj) <= 16); + DUK_ASSERT(obj != NULL); + + buf[0] = DUK_DBG_IB_OBJECT; + buf[1] = (duk_uint8_t) DUK_HOBJECT_GET_CLASS_NUMBER(obj); + buf[2] = sizeof(pu); + duk_debug_write_bytes(thr, buf, 3); + pu.p = (void *) obj; +#if defined(DUK_USE_INTEGER_LE) + duk_byteswap_bytes((duk_uint8_t *) pu.b, sizeof(pu)); +#endif + duk_debug_write_bytes(thr, (const duk_uint8_t *) &pu.p, (duk_size_t) sizeof(pu)); +} + +DUK_INTERNAL void duk_debug_write_tval(duk_hthread *thr, duk_tval *tv) { + duk_c_function lf_func; + duk_small_uint_t lf_flags; + duk_uint8_t buf[4]; + duk_double_union du1; + duk_double_union du2; + duk_int32_t i32; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv != NULL); + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNDEFINED: + duk_debug_write_byte(thr, DUK_DBG_IB_UNDEFINED); + break; + case DUK_TAG_UNUSED: + duk_debug_write_byte(thr, DUK_DBG_IB_UNUSED); + break; + case DUK_TAG_NULL: + duk_debug_write_byte(thr, DUK_DBG_IB_NULL); + break; + case DUK_TAG_BOOLEAN: + DUK_ASSERT(DUK_TVAL_GET_BOOLEAN(tv) == 0 || DUK_TVAL_GET_BOOLEAN(tv) == 1); + duk_debug_write_boolean(thr, DUK_TVAL_GET_BOOLEAN(tv)); + break; + case DUK_TAG_POINTER: + duk_debug_write_pointer(thr, (void *) DUK_TVAL_GET_POINTER(tv)); + break; + case DUK_TAG_LIGHTFUNC: + DUK_TVAL_GET_LIGHTFUNC(tv, lf_func, lf_flags); + buf[0] = DUK_DBG_IB_LIGHTFUNC; + buf[1] = (duk_uint8_t) (lf_flags >> 8); + buf[2] = (duk_uint8_t) (lf_flags & 0xff); + buf[3] = sizeof(lf_func); + duk_debug_write_bytes(thr, buf, 4); + duk_debug_write_bytes(thr, (const duk_uint8_t *) &lf_func, sizeof(lf_func)); + break; + case DUK_TAG_STRING: + duk_debug_write_hstring(thr, DUK_TVAL_GET_STRING(tv)); + break; + case DUK_TAG_OBJECT: + duk_debug_write_hobject(thr, DUK_TVAL_GET_OBJECT(tv)); + break; + case DUK_TAG_BUFFER: + duk_debug_write_hbuffer(thr, DUK_TVAL_GET_BUFFER(tv)); + break; +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: + /* Numbers are normalized to big (network) endian. We can + * (but are not required) to use integer dvalues when there's + * no loss of precision. + * + * XXX: share check with other code; this check is slow but + * reliable and doesn't require careful exponent/mantissa + * mask tricks as in the fastint downgrade code. + */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + du1.d = DUK_TVAL_GET_NUMBER(tv); + i32 = (duk_int32_t) du1.d; + du2.d = (duk_double_t) i32; + + DUK_DD(DUK_DDPRINT("i32=%ld du1=%02x%02x%02x%02x%02x%02x%02x%02x " + "du2=%02x%02x%02x%02x%02x%02x%02x%02x", + (long) i32, + (unsigned int) du1.uc[0], + (unsigned int) du1.uc[1], + (unsigned int) du1.uc[2], + (unsigned int) du1.uc[3], + (unsigned int) du1.uc[4], + (unsigned int) du1.uc[5], + (unsigned int) du1.uc[6], + (unsigned int) du1.uc[7], + (unsigned int) du2.uc[0], + (unsigned int) du2.uc[1], + (unsigned int) du2.uc[2], + (unsigned int) du2.uc[3], + (unsigned int) du2.uc[4], + (unsigned int) du2.uc[5], + (unsigned int) du2.uc[6], + (unsigned int) du2.uc[7])); + + if (duk_memcmp((const void *) du1.uc, (const void *) du2.uc, sizeof(du1.uc)) == 0) { + duk_debug_write_int(thr, i32); + } else { + DUK_DBLUNION_DOUBLE_HTON(&du1); + duk_debug_write_byte(thr, DUK_DBG_IB_NUMBER); + duk_debug_write_bytes(thr, (const duk_uint8_t *) du1.uc, sizeof(du1.uc)); + } + } +} + +#if defined(DUK_USE_DEBUGGER_DUMPHEAP) +/* Variant for writing duk_tvals so that any heap allocated values are + * written out as tagged heap pointers. + */ +DUK_LOCAL void duk__debug_write_tval_heapptr(duk_hthread *thr, duk_tval *tv) { + if (DUK_TVAL_IS_HEAP_ALLOCATED(tv)) { + duk_heaphdr *h = DUK_TVAL_GET_HEAPHDR(tv); + duk_debug_write_heapptr(thr, h); + } else { + duk_debug_write_tval(thr, tv); + } +} +#endif /* DUK_USE_DEBUGGER_DUMPHEAP */ + +/* + * Debug connection message write helpers + */ + +#if 0 /* unused */ +DUK_INTERNAL void duk_debug_write_request(duk_hthread *thr, duk_small_uint_t command) { + duk_debug_write_byte(thr, DUK_DBG_IB_REQUEST); + duk_debug_write_int(thr, command); +} +#endif + +DUK_INTERNAL void duk_debug_write_reply(duk_hthread *thr) { + duk_debug_write_byte(thr, DUK_DBG_IB_REPLY); +} + +DUK_INTERNAL void duk_debug_write_error_eom(duk_hthread *thr, duk_small_uint_t err_code, const char *msg) { + /* Allow NULL 'msg' */ + duk_debug_write_byte(thr, DUK_DBG_IB_ERROR); + duk_debug_write_int(thr, (duk_int32_t) err_code); + duk_debug_write_cstring(thr, msg); + duk_debug_write_eom(thr); +} + +DUK_INTERNAL void duk_debug_write_notify(duk_hthread *thr, duk_small_uint_t command) { + duk_debug_write_byte(thr, DUK_DBG_IB_NOTIFY); + duk_debug_write_int(thr, (duk_int32_t) command); +} + +DUK_INTERNAL void duk_debug_write_eom(duk_hthread *thr) { + duk_debug_write_byte(thr, DUK_DBG_IB_EOM); + + /* As an initial implementation, write flush after every EOM (and the + * version identifier). A better implementation would flush only when + * Duktape is finished processing messages so that a flush only happens + * after all outbound messages are finished on that occasion. + */ + duk_debug_write_flush(thr); +} + +/* + * Status message and helpers + */ + +DUK_INTERNAL duk_uint_fast32_t duk_debug_curr_line(duk_hthread *thr) { + duk_activation *act; + duk_uint_fast32_t line; + duk_uint_fast32_t pc; + + act = thr->callstack_curr; + if (act == NULL) { + return 0; + } + + /* We're conceptually between two opcodes; act->pc indicates the next + * instruction to be executed. This is usually the correct pc/line to + * indicate in Status. (For the 'debugger' statement this now reports + * the pc/line after the debugger statement because the debugger opcode + * has already been executed.) + */ + + pc = duk_hthread_get_act_curr_pc(thr, act); + + /* XXX: this should be optimized to be a raw query and avoid valstack + * operations if possible. + */ + duk_push_tval(thr, &act->tv_func); + line = duk_hobject_pc2line_query(thr, -1, pc); + duk_pop(thr); + return line; +} + +DUK_INTERNAL void duk_debug_send_status(duk_hthread *thr) { + duk_activation *act; + + duk_debug_write_notify(thr, DUK_DBG_CMD_STATUS); + duk_debug_write_int(thr, (DUK_HEAP_HAS_DEBUGGER_PAUSED(thr->heap) ? 1 : 0)); + + act = thr->callstack_curr; + if (act == NULL) { + duk_debug_write_undefined(thr); + duk_debug_write_undefined(thr); + duk_debug_write_int(thr, 0); + duk_debug_write_int(thr, 0); + } else { + duk_push_tval(thr, &act->tv_func); + duk_get_prop_literal(thr, -1, "fileName"); + duk__debug_write_hstring_safe_top(thr); + duk_get_prop_literal(thr, -2, "name"); + duk__debug_write_hstring_safe_top(thr); + duk_pop_3(thr); + /* Report next pc/line to be executed. */ + duk_debug_write_uint(thr, (duk_uint32_t) duk_debug_curr_line(thr)); + duk_debug_write_uint(thr, (duk_uint32_t) duk_hthread_get_act_curr_pc(thr, act)); + } + + duk_debug_write_eom(thr); +} + +#if defined(DUK_USE_DEBUGGER_THROW_NOTIFY) +DUK_INTERNAL void duk_debug_send_throw(duk_hthread *thr, duk_bool_t fatal) { + /* + * NFY EOM + */ + + duk_activation *act; + duk_uint32_t pc; + + DUK_ASSERT(thr->valstack_top > thr->valstack); /* At least: ... [err] */ + + duk_debug_write_notify(thr, DUK_DBG_CMD_THROW); + duk_debug_write_int(thr, (duk_int32_t) fatal); + + /* Report thrown value to client coerced to string */ + duk_dup_top(thr); + duk__debug_write_hstring_safe_top(thr); + duk_pop(thr); + + if (duk_is_error(thr, -1)) { + /* Error instance, use augmented error data directly */ + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_FILE_NAME); + duk__debug_write_hstring_safe_top(thr); + duk_get_prop_stridx_short(thr, -2, DUK_STRIDX_LINE_NUMBER); + duk_debug_write_uint(thr, duk_get_uint(thr, -1)); + duk_pop_2(thr); + } else { + /* For anything other than an Error instance, we calculate the + * error location directly from the current activation if one + * exists. + */ + act = thr->callstack_curr; + if (act != NULL) { + duk_push_tval(thr, &act->tv_func); + duk_get_prop_literal(thr, -1, "fileName"); + duk__debug_write_hstring_safe_top(thr); + pc = (duk_uint32_t) duk_hthread_get_act_prev_pc(thr, act); + duk_debug_write_uint(thr, (duk_uint32_t) duk_hobject_pc2line_query(thr, -2, pc)); + duk_pop_2(thr); + } else { + /* Can happen if duk_throw() is called on an empty + * callstack. + */ + duk_debug_write_cstring(thr, ""); + duk_debug_write_uint(thr, 0); + } + } + + duk_debug_write_eom(thr); +} +#endif /* DUK_USE_DEBUGGER_THROW_NOTIFY */ + +/* + * Debug message processing + */ + +/* Skip dvalue. */ +DUK_LOCAL duk_bool_t duk__debug_skip_dvalue(duk_hthread *thr) { + duk_uint8_t x; + duk_uint32_t len; + + x = duk_debug_read_byte(thr); + + if (x >= 0xc0) { + duk_debug_skip_byte(thr); + return 0; + } + if (x >= 0x80) { + return 0; + } + if (x >= 0x60) { + duk_debug_skip_bytes(thr, (duk_size_t) (x - 0x60)); + return 0; + } + switch (x) { + case DUK_DBG_IB_EOM: + return 1; /* Return 1: got EOM */ + case DUK_DBG_IB_REQUEST: + case DUK_DBG_IB_REPLY: + case DUK_DBG_IB_ERROR: + case DUK_DBG_IB_NOTIFY: + break; + case DUK_DBG_IB_INT4: + (void) duk__debug_read_uint32_raw(thr); + break; + case DUK_DBG_IB_STR4: + case DUK_DBG_IB_BUF4: + len = duk__debug_read_uint32_raw(thr); + duk_debug_skip_bytes(thr, len); + break; + case DUK_DBG_IB_STR2: + case DUK_DBG_IB_BUF2: + len = duk__debug_read_uint16_raw(thr); + duk_debug_skip_bytes(thr, len); + break; + case DUK_DBG_IB_UNUSED: + case DUK_DBG_IB_UNDEFINED: + case DUK_DBG_IB_NULL: + case DUK_DBG_IB_TRUE: + case DUK_DBG_IB_FALSE: + break; + case DUK_DBG_IB_NUMBER: + duk_debug_skip_bytes(thr, 8); + break; + case DUK_DBG_IB_OBJECT: + duk_debug_skip_byte(thr); + len = duk_debug_read_byte(thr); + duk_debug_skip_bytes(thr, len); + break; + case DUK_DBG_IB_POINTER: + case DUK_DBG_IB_HEAPPTR: + len = duk_debug_read_byte(thr); + duk_debug_skip_bytes(thr, len); + break; + case DUK_DBG_IB_LIGHTFUNC: + duk_debug_skip_bytes(thr, 2); + len = duk_debug_read_byte(thr); + duk_debug_skip_bytes(thr, len); + break; + default: + goto fail; + } + + return 0; + +fail: + DUK__SET_CONN_BROKEN(thr, 1); + return 1; /* Pretend like we got EOM */ +} + +/* Skip dvalues to EOM. */ +DUK_LOCAL void duk__debug_skip_to_eom(duk_hthread *thr) { + for (;;) { + if (duk__debug_skip_dvalue(thr)) { + break; + } + } +} + +/* Read and validate a call stack index. If index is invalid, write out an + * error message and return zero. + */ +DUK_LOCAL duk_int32_t duk__debug_read_validate_csindex(duk_hthread *thr) { + duk_int32_t level; + level = duk_debug_read_int(thr); + if (level >= 0 || -level > (duk_int32_t) thr->callstack_top) { + duk_debug_write_error_eom(thr, DUK_DBG_ERR_NOTFOUND, "invalid callstack index"); + return 0; /* zero indicates failure */ + } + return level; +} + +/* Read a call stack index and lookup the corresponding duk_activation. + * If index is invalid, write out an error message and return NULL. + */ +DUK_LOCAL duk_activation *duk__debug_read_level_get_activation(duk_hthread *thr) { + duk_activation *act; + duk_int32_t level; + + level = duk_debug_read_int(thr); + act = duk_hthread_get_activation_for_level(thr, level); + if (act == NULL) { + duk_debug_write_error_eom(thr, DUK_DBG_ERR_NOTFOUND, "invalid callstack index"); + } + return act; +} + +/* + * Simple commands + */ + +DUK_LOCAL void duk__debug_handle_basic_info(duk_hthread *thr, duk_heap *heap) { + DUK_UNREF(heap); + DUK_D(DUK_DPRINT("debug command Version")); + + duk_debug_write_reply(thr); + duk_debug_write_int(thr, DUK_VERSION); + duk_debug_write_cstring(thr, DUK_GIT_DESCRIBE); + duk_debug_write_cstring(thr, DUK_USE_TARGET_INFO); +#if defined(DUK_USE_DOUBLE_LE) + duk_debug_write_int(thr, 1); +#elif defined(DUK_USE_DOUBLE_ME) + duk_debug_write_int(thr, 2); +#elif defined(DUK_USE_DOUBLE_BE) + duk_debug_write_int(thr, 3); +#else + duk_debug_write_int(thr, 0); +#endif + duk_debug_write_int(thr, (duk_int_t) sizeof(void *)); + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_trigger_status(duk_hthread *thr, duk_heap *heap) { + DUK_UNREF(heap); + DUK_D(DUK_DPRINT("debug command TriggerStatus")); + + duk_debug_write_reply(thr); + duk_debug_write_eom(thr); + heap->dbg_state_dirty = 1; +} + +DUK_LOCAL void duk__debug_handle_pause(duk_hthread *thr, duk_heap *heap) { + DUK_D(DUK_DPRINT("debug command Pause")); + duk_debug_set_paused(heap); + duk_debug_write_reply(thr); + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_resume(duk_hthread *thr, duk_heap *heap) { + duk_small_uint_t pause_flags; + + DUK_D(DUK_DPRINT("debug command Resume")); + + duk_debug_clear_paused(heap); + + pause_flags = 0; +#if 0 /* manual testing */ + pause_flags |= DUK_PAUSE_FLAG_ONE_OPCODE; + pause_flags |= DUK_PAUSE_FLAG_CAUGHT_ERROR; + pause_flags |= DUK_PAUSE_FLAG_UNCAUGHT_ERROR; +#endif +#if defined(DUK_USE_DEBUGGER_PAUSE_UNCAUGHT) + pause_flags |= DUK_PAUSE_FLAG_UNCAUGHT_ERROR; +#endif + + duk__debug_set_pause_state(thr, heap, pause_flags); + + duk_debug_write_reply(thr); + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_step(duk_hthread *thr, duk_heap *heap, duk_int32_t cmd) { + duk_small_uint_t pause_flags; + + DUK_D(DUK_DPRINT("debug command StepInto/StepOver/StepOut: %d", (int) cmd)); + + if (cmd == DUK_DBG_CMD_STEPINTO) { + pause_flags = DUK_PAUSE_FLAG_LINE_CHANGE | DUK_PAUSE_FLAG_FUNC_ENTRY | DUK_PAUSE_FLAG_FUNC_EXIT; + } else if (cmd == DUK_DBG_CMD_STEPOVER) { + pause_flags = DUK_PAUSE_FLAG_LINE_CHANGE | DUK_PAUSE_FLAG_FUNC_EXIT; + } else { + DUK_ASSERT(cmd == DUK_DBG_CMD_STEPOUT); + pause_flags = DUK_PAUSE_FLAG_FUNC_EXIT; + } +#if defined(DUK_USE_DEBUGGER_PAUSE_UNCAUGHT) + pause_flags |= DUK_PAUSE_FLAG_UNCAUGHT_ERROR; +#endif + + /* If current activation doesn't have line information, line-based + * pause flags are automatically disabled. As a result, e.g. + * StepInto will then pause on (native) function entry or exit. + */ + duk_debug_clear_paused(heap); + duk__debug_set_pause_state(thr, heap, pause_flags); + + duk_debug_write_reply(thr); + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_list_break(duk_hthread *thr, duk_heap *heap) { + duk_small_int_t i; + + DUK_D(DUK_DPRINT("debug command ListBreak")); + duk_debug_write_reply(thr); + for (i = 0; i < (duk_small_int_t) heap->dbg_breakpoint_count; i++) { + duk_debug_write_hstring(thr, heap->dbg_breakpoints[i].filename); + duk_debug_write_uint(thr, (duk_uint32_t) heap->dbg_breakpoints[i].line); + } + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_add_break(duk_hthread *thr, duk_heap *heap) { + duk_hstring *filename; + duk_uint32_t linenumber; + duk_small_int_t idx; + + DUK_UNREF(heap); + + filename = duk_debug_read_hstring(thr); + linenumber = (duk_uint32_t) duk_debug_read_int(thr); + DUK_D(DUK_DPRINT("debug command AddBreak: %!O:%ld", (duk_hobject *) filename, (long) linenumber)); + idx = duk_debug_add_breakpoint(thr, filename, linenumber); + if (idx >= 0) { + duk_debug_write_reply(thr); + duk_debug_write_int(thr, (duk_int32_t) idx); + duk_debug_write_eom(thr); + } else { + duk_debug_write_error_eom(thr, DUK_DBG_ERR_TOOMANY, "no space for breakpoint"); + } +} + +DUK_LOCAL void duk__debug_handle_del_break(duk_hthread *thr, duk_heap *heap) { + duk_small_uint_t idx; + + DUK_UNREF(heap); + + DUK_D(DUK_DPRINT("debug command DelBreak")); + idx = (duk_small_uint_t) duk_debug_read_int(thr); + if (duk_debug_remove_breakpoint(thr, idx)) { + duk_debug_write_reply(thr); + duk_debug_write_eom(thr); + } else { + duk_debug_write_error_eom(thr, DUK_DBG_ERR_NOTFOUND, "invalid breakpoint index"); + } +} + +DUK_LOCAL void duk__debug_handle_get_var(duk_hthread *thr, duk_heap *heap) { + duk_activation *act; + duk_hstring *str; + duk_bool_t rc; + + DUK_UNREF(heap); + DUK_D(DUK_DPRINT("debug command GetVar")); + + act = duk__debug_read_level_get_activation(thr); + if (act == NULL) { + return; + } + str = duk_debug_read_hstring(thr); /* push to stack */ + DUK_ASSERT(str != NULL); + + rc = duk_js_getvar_activation(thr, act, str, 0); + + duk_debug_write_reply(thr); + if (rc) { + duk_debug_write_int(thr, 1); + DUK_ASSERT(duk_get_tval(thr, -2) != NULL); + duk_debug_write_tval(thr, duk_get_tval(thr, -2)); + } else { + duk_debug_write_int(thr, 0); + duk_debug_write_unused(thr); + } + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_put_var(duk_hthread *thr, duk_heap *heap) { + duk_activation *act; + duk_hstring *str; + duk_tval *tv; + + DUK_UNREF(heap); + DUK_D(DUK_DPRINT("debug command PutVar")); + + act = duk__debug_read_level_get_activation(thr); + if (act == NULL) { + return; + } + str = duk_debug_read_hstring(thr); /* push to stack */ + DUK_ASSERT(str != NULL); + tv = duk_debug_read_tval(thr); + if (tv == NULL) { + /* detached */ + return; + } + + duk_js_putvar_activation(thr, act, str, tv, 0); + + /* XXX: Current putvar implementation doesn't have a success flag, + * add one and send to debug client? + */ + duk_debug_write_reply(thr); + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_get_call_stack(duk_hthread *thr, duk_heap *heap) { + duk_hthread *curr_thr = thr; + duk_activation *curr_act; + duk_uint_fast32_t pc; + duk_uint_fast32_t line; + + DUK_ASSERT(thr != NULL); + DUK_UNREF(heap); + + duk_debug_write_reply(thr); + while (curr_thr != NULL) { + for (curr_act = curr_thr->callstack_curr; curr_act != NULL; curr_act = curr_act->parent) { + /* PC/line semantics here are: + * - For callstack top we're conceptually between two + * opcodes and current PC indicates next line to + * execute, so report that (matches Status). + * - For other activations we're conceptually still + * executing the instruction at PC-1, so report that + * (matches error stacktrace behavior). + * - See: https://github.com/svaarala/duktape/issues/281 + */ + + /* XXX: optimize to use direct reads, i.e. avoid + * value stack operations. + */ + duk_push_tval(thr, &curr_act->tv_func); + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_FILE_NAME); + duk__debug_write_hstring_safe_top(thr); + duk_get_prop_stridx_short(thr, -2, DUK_STRIDX_NAME); + duk__debug_write_hstring_safe_top(thr); + pc = duk_hthread_get_act_curr_pc(thr, curr_act); + if (curr_act != curr_thr->callstack_curr && pc > 0) { + pc--; + } + line = duk_hobject_pc2line_query(thr, -3, pc); + duk_debug_write_uint(thr, (duk_uint32_t) line); + duk_debug_write_uint(thr, (duk_uint32_t) pc); + duk_pop_3(thr); + } + curr_thr = curr_thr->resumer; + } + /* SCANBUILD: warning about 'thr' potentially being NULL here, + * warning is incorrect because thr != NULL always here. + */ + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_get_locals(duk_hthread *thr, duk_heap *heap) { + duk_activation *act; + duk_hstring *varname; + + DUK_UNREF(heap); + + act = duk__debug_read_level_get_activation(thr); + if (act == NULL) { + return; + } + + duk_debug_write_reply(thr); + + /* XXX: several nice-to-have improvements here: + * - Use direct reads avoiding value stack operations + * - Avoid triggering getters, indicate getter values to debug client + * - If side effects are possible, add error catching + */ + + if (DUK_TVAL_IS_OBJECT(&act->tv_func)) { + duk_hobject *h_func = DUK_TVAL_GET_OBJECT(&act->tv_func); + duk_hobject *h_varmap; + + h_varmap = duk_hobject_get_varmap(thr, h_func); + if (h_varmap != NULL) { + duk_push_hobject(thr, h_varmap); + duk_enum(thr, -1, 0 /*enum_flags*/); + while (duk_next(thr, -1 /*enum_index*/, 0 /*get_value*/)) { + varname = duk_known_hstring(thr, -1); + + duk_js_getvar_activation(thr, act, varname, 0 /*throw_flag*/); + /* [ ... func varmap enum key value this ] */ + duk_debug_write_hstring(thr, duk_get_hstring(thr, -3)); + duk_debug_write_tval(thr, duk_get_tval(thr, -2)); + duk_pop_3(thr); /* -> [ ... func varmap enum ] */ + } + } else { + DUK_D(DUK_DPRINT("varmap missing in GetLocals, ignore")); + } + } else { + DUK_D(DUK_DPRINT("varmap is not an object in GetLocals, ignore")); + } + + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_eval(duk_hthread *thr, duk_heap *heap) { + duk_small_uint_t call_flags; + duk_int_t call_ret; + duk_small_int_t eval_err; + duk_bool_t direct_eval; + duk_int32_t level; + duk_idx_t idx_func; + + DUK_UNREF(heap); + + DUK_D(DUK_DPRINT("debug command Eval")); + + /* The eval code is executed within the lexical environment of a specified + * activation. For now, use global object eval() function, with the eval + * considered a 'direct call to eval'. + * + * Callstack index for debug commands only affects scope -- the callstack + * as seen by, e.g. Duktape.act() will be the same regardless. + */ + + /* nargs == 2 so we can pass a callstack index to eval(). */ + idx_func = duk_get_top(thr); + duk_push_c_function(thr, duk_bi_global_object_eval, 2 /*nargs*/); + duk_push_undefined(thr); /* 'this' binding shouldn't matter here */ + + /* Read callstack index, if non-null. */ + if (duk_debug_peek_byte(thr) == DUK_DBG_IB_NULL) { + direct_eval = 0; + level = -1; /* Not needed, but silences warning. */ + (void) duk_debug_read_byte(thr); + } else { + direct_eval = 1; + level = duk__debug_read_validate_csindex(thr); + if (level == 0) { + return; + } + } + + DUK_ASSERT(!direct_eval || (level < 0 && -level <= (duk_int32_t) thr->callstack_top)); + + (void) duk_debug_read_hstring(thr); + if (direct_eval) { + duk_push_int(thr, level - 1); /* compensate for eval() call */ + } + + /* [ ... eval "eval" eval_input level? ] */ + + call_flags = 0; + if (direct_eval) { + duk_activation *act; + duk_hobject *fun; + + act = duk_hthread_get_activation_for_level(thr, level); + if (act != NULL) { + fun = DUK_ACT_GET_FUNC(act); + if (fun != NULL && DUK_HOBJECT_IS_COMPFUNC(fun)) { + /* Direct eval requires that there's a current + * activation and it is an ECMAScript function. + * When Eval is executed from e.g. cooperate API + * call we'll need to do an indirect eval instead. + */ + call_flags |= DUK_CALL_FLAG_DIRECT_EVAL; + } + } + } + + call_ret = duk_pcall_method_flags(thr, duk_get_top(thr) - (idx_func + 2), call_flags); + + if (call_ret == DUK_EXEC_SUCCESS) { + eval_err = 0; + /* Use result value as is. */ + } else { + /* For errors a string coerced result is most informative + * right now, as the debug client doesn't have the capability + * to traverse the error object. + */ + eval_err = 1; + duk_safe_to_string(thr, -1); + } + + /* [ ... result ] */ + + duk_debug_write_reply(thr); + duk_debug_write_int(thr, (duk_int32_t) eval_err); + DUK_ASSERT(duk_get_tval(thr, -1) != NULL); + duk_debug_write_tval(thr, duk_get_tval(thr, -1)); + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_detach(duk_hthread *thr, duk_heap *heap) { + DUK_UNREF(heap); + DUK_D(DUK_DPRINT("debug command Detach")); + + duk_debug_write_reply(thr); + duk_debug_write_eom(thr); + + DUK_D(DUK_DPRINT("debug connection detached, mark broken")); + DUK__SET_CONN_BROKEN(thr, 0); /* not an error */ +} + +DUK_LOCAL void duk__debug_handle_apprequest(duk_hthread *thr, duk_heap *heap) { + duk_idx_t old_top; + + DUK_D(DUK_DPRINT("debug command AppRequest")); + + old_top = duk_get_top(thr); /* save stack top */ + + if (heap->dbg_request_cb != NULL) { + duk_idx_t nrets; + duk_idx_t nvalues = 0; + duk_idx_t top, idx; + + /* Read tvals from the message and push them onto the valstack, + * then call the request callback to process the request. + */ + while (duk_debug_peek_byte(thr) != DUK_DBG_IB_EOM) { + duk_tval *tv; + if (!duk_check_stack(thr, 1)) { + DUK_D(DUK_DPRINT("failed to allocate space for request dvalue(s)")); + goto fail; + } + tv = duk_debug_read_tval(thr); /* push to stack */ + if (tv == NULL) { + /* detached */ + return; + } + nvalues++; + } + DUK_ASSERT(duk_get_top(thr) == old_top + nvalues); + + /* Request callback should push values for reply to client onto valstack */ + DUK_D(DUK_DPRINT("calling into AppRequest request_cb with nvalues=%ld, old_top=%ld, top=%ld", + (long) nvalues, + (long) old_top, + (long) duk_get_top(thr))); + nrets = heap->dbg_request_cb(thr, heap->dbg_udata, nvalues); + DUK_D(DUK_DPRINT("returned from AppRequest request_cb; nvalues=%ld -> nrets=%ld, old_top=%ld, top=%ld", + (long) nvalues, + (long) nrets, + (long) old_top, + (long) duk_get_top(thr))); + if (nrets >= 0) { + DUK_ASSERT(duk_get_top(thr) >= old_top + nrets); + if (duk_get_top(thr) < old_top + nrets) { + DUK_D(DUK_DPRINT("AppRequest callback doesn't match value stack configuration, " + "top=%ld < old_top=%ld + nrets=%ld; " + "this might mean it's unsafe to continue!", + (long) duk_get_top(thr), + (long) old_top, + (long) nrets)); + goto fail; + } + + /* Reply with tvals pushed by request callback */ + duk_debug_write_byte(thr, DUK_DBG_IB_REPLY); + top = duk_get_top(thr); + for (idx = top - nrets; idx < top; idx++) { + duk_debug_write_tval(thr, DUK_GET_TVAL_POSIDX(thr, idx)); + } + duk_debug_write_eom(thr); + } else { + DUK_ASSERT(duk_get_top(thr) >= old_top + 1); + if (duk_get_top(thr) < old_top + 1) { + DUK_D(DUK_DPRINT("request callback return value doesn't match value stack configuration")); + goto fail; + } + duk_debug_write_error_eom(thr, DUK_DBG_ERR_APPLICATION, duk_get_string(thr, -1)); + } + + duk_set_top(thr, old_top); /* restore stack top */ + } else { + DUK_D(DUK_DPRINT("no request callback, treat AppRequest as unsupported")); + duk_debug_write_error_eom(thr, DUK_DBG_ERR_UNSUPPORTED, "AppRequest unsupported by target"); + } + + return; + +fail: + duk_set_top(thr, old_top); /* restore stack top */ + DUK__SET_CONN_BROKEN(thr, 1); +} + +/* + * DumpHeap command + */ + +#if defined(DUK_USE_DEBUGGER_DUMPHEAP) +/* XXX: this has some overlap with object inspection; remove this and make + * DumpHeap return lists of heapptrs instead? + */ +DUK_LOCAL void duk__debug_dump_heaphdr(duk_hthread *thr, duk_heap *heap, duk_heaphdr *hdr) { + DUK_UNREF(heap); + + duk_debug_write_heapptr(thr, hdr); + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HEAPHDR_GET_TYPE(hdr)); + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HEAPHDR_GET_FLAGS_RAW(hdr)); +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HEAPHDR_GET_REFCOUNT(hdr)); +#else + duk_debug_write_int(thr, (duk_int32_t) -1); +#endif + + switch (DUK_HEAPHDR_GET_TYPE(hdr)) { + case DUK_HTYPE_STRING: { + duk_hstring *h = (duk_hstring *) hdr; + + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HSTRING_GET_BYTELEN(h)); + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HSTRING_GET_CHARLEN(h)); + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HSTRING_GET_HASH(h)); + duk_debug_write_hstring(thr, h); + break; + } + case DUK_HTYPE_OBJECT: { + duk_hobject *h = (duk_hobject *) hdr; + duk_hstring *k; + duk_uint_fast32_t i; + + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HOBJECT_GET_CLASS_NUMBER(h)); + duk_debug_write_heapptr(thr, (duk_heaphdr *) DUK_HOBJECT_GET_PROTOTYPE(heap, h)); + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HOBJECT_GET_ESIZE(h)); + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HOBJECT_GET_ENEXT(h)); + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HOBJECT_GET_ASIZE(h)); + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HOBJECT_GET_HSIZE(h)); + + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ENEXT(h); i++) { + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HOBJECT_E_GET_FLAGS(heap, h, i)); + k = DUK_HOBJECT_E_GET_KEY(heap, h, i); + duk_debug_write_heapptr(thr, (duk_heaphdr *) k); + if (k == NULL) { + duk_debug_write_int(thr, 0); /* isAccessor */ + duk_debug_write_unused(thr); + continue; + } + if (DUK_HOBJECT_E_SLOT_IS_ACCESSOR(heap, h, i)) { + duk_debug_write_int(thr, 1); /* isAccessor */ + duk_debug_write_heapptr(thr, (duk_heaphdr *) DUK_HOBJECT_E_GET_VALUE_PTR(heap, h, i)->a.get); + duk_debug_write_heapptr(thr, (duk_heaphdr *) DUK_HOBJECT_E_GET_VALUE_PTR(heap, h, i)->a.set); + } else { + duk_debug_write_int(thr, 0); /* isAccessor */ + + duk__debug_write_tval_heapptr(thr, &DUK_HOBJECT_E_GET_VALUE_PTR(heap, h, i)->v); + } + } + + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ASIZE(h); i++) { + /* Note: array dump will include elements beyond + * 'length'. + */ + duk__debug_write_tval_heapptr(thr, DUK_HOBJECT_A_GET_VALUE_PTR(heap, h, i)); + } + break; + } + case DUK_HTYPE_BUFFER: { + duk_hbuffer *h = (duk_hbuffer *) hdr; + + duk_debug_write_uint(thr, (duk_uint32_t) DUK_HBUFFER_GET_SIZE(h)); + duk_debug_write_buffer(thr, (const char *) DUK_HBUFFER_GET_DATA_PTR(heap, h), (duk_size_t) DUK_HBUFFER_GET_SIZE(h)); + break; + } + default: { + DUK_D(DUK_DPRINT("invalid htype: %d", (int) DUK_HEAPHDR_GET_TYPE(hdr))); + } + } +} + +DUK_LOCAL void duk__debug_dump_heap_allocated(duk_hthread *thr, duk_heap *heap) { + duk_heaphdr *hdr; + + hdr = heap->heap_allocated; + while (hdr != NULL) { + duk__debug_dump_heaphdr(thr, heap, hdr); + hdr = DUK_HEAPHDR_GET_NEXT(heap, hdr); + } +} + +DUK_LOCAL void duk__debug_dump_strtab(duk_hthread *thr, duk_heap *heap) { + duk_uint32_t i; + duk_hstring *h; + + for (i = 0; i < heap->st_size; i++) { +#if defined(DUK_USE_STRTAB_PTRCOMP) + h = DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, heap->strtable16[i]); +#else + h = heap->strtable[i]; +#endif + while (h != NULL) { + duk__debug_dump_heaphdr(thr, heap, (duk_heaphdr *) h); + h = h->hdr.h_next; + } + } +} + +DUK_LOCAL void duk__debug_handle_dump_heap(duk_hthread *thr, duk_heap *heap) { + DUK_D(DUK_DPRINT("debug command DumpHeap")); + + duk_debug_write_reply(thr); + duk__debug_dump_heap_allocated(thr, heap); + duk__debug_dump_strtab(thr, heap); + duk_debug_write_eom(thr); +} +#endif /* DUK_USE_DEBUGGER_DUMPHEAP */ + +DUK_LOCAL void duk__debug_handle_get_bytecode(duk_hthread *thr, duk_heap *heap) { + duk_activation *act; + duk_hcompfunc *fun = NULL; + duk_size_t i, n; + duk_tval *tv; + duk_hobject **fn; + duk_int32_t level = -1; + duk_uint8_t ibyte; + + DUK_UNREF(heap); + + DUK_D(DUK_DPRINT("debug command GetBytecode")); + + ibyte = duk_debug_peek_byte(thr); + if (ibyte != DUK_DBG_IB_EOM) { + tv = duk_debug_read_tval(thr); + if (tv == NULL) { + /* detached */ + return; + } + if (DUK_TVAL_IS_OBJECT(tv)) { + /* tentative, checked later */ + fun = (duk_hcompfunc *) DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(fun != NULL); + } else if (DUK_TVAL_IS_NUMBER(tv)) { + level = (duk_int32_t) DUK_TVAL_GET_NUMBER(tv); + } else { + DUK_D(DUK_DPRINT("invalid argument to GetBytecode: %!T", tv)); + goto fail_args; + } + } + + if (fun == NULL) { + act = duk_hthread_get_activation_for_level(thr, level); + if (act == NULL) { + goto fail_index; + } + fun = (duk_hcompfunc *) DUK_ACT_GET_FUNC(act); + } + + if (fun == NULL || !DUK_HOBJECT_IS_COMPFUNC((duk_hobject *) fun)) { + DUK_D(DUK_DPRINT("invalid argument to GetBytecode: %!O", fun)); + goto fail_args; + } + DUK_ASSERT(fun != NULL && DUK_HOBJECT_IS_COMPFUNC((duk_hobject *) fun)); + + duk_debug_write_reply(thr); + n = DUK_HCOMPFUNC_GET_CONSTS_COUNT(heap, fun); + duk_debug_write_int(thr, (duk_int32_t) n); + tv = DUK_HCOMPFUNC_GET_CONSTS_BASE(heap, fun); + for (i = 0; i < n; i++) { + duk_debug_write_tval(thr, tv); + tv++; + } + n = DUK_HCOMPFUNC_GET_FUNCS_COUNT(heap, fun); + duk_debug_write_int(thr, (duk_int32_t) n); + fn = DUK_HCOMPFUNC_GET_FUNCS_BASE(heap, fun); + for (i = 0; i < n; i++) { + duk_debug_write_hobject(thr, *fn); + fn++; + } + duk_debug_write_string(thr, + (const char *) DUK_HCOMPFUNC_GET_CODE_BASE(heap, fun), + (duk_size_t) DUK_HCOMPFUNC_GET_CODE_SIZE(heap, fun)); + duk_debug_write_eom(thr); + return; + +fail_args: + duk_debug_write_error_eom(thr, DUK_DBG_ERR_UNKNOWN, "invalid argument"); + return; + +fail_index: + duk_debug_write_error_eom(thr, DUK_DBG_ERR_NOTFOUND, "invalid callstack index"); + return; +} + +/* + * Object inspection commands: GetHeapObjInfo, GetObjPropDesc, + * GetObjPropDescRange + */ + +#if defined(DUK_USE_DEBUGGER_INSPECT) + +#if 0 /* pruned */ +DUK_LOCAL const char * const duk__debug_getinfo_heaphdr_keys[] = { + "reachable", + "temproot", + "finalizable", + "finalized", + "readonly" + /* NULL not needed here */ +}; +DUK_LOCAL duk_uint_t duk__debug_getinfo_heaphdr_masks[] = { + DUK_HEAPHDR_FLAG_REACHABLE, + DUK_HEAPHDR_FLAG_TEMPROOT, + DUK_HEAPHDR_FLAG_FINALIZABLE, + DUK_HEAPHDR_FLAG_FINALIZED, + DUK_HEAPHDR_FLAG_READONLY, + 0 /* terminator */ +}; +#endif +DUK_LOCAL const char * const duk__debug_getinfo_hstring_keys[] = { +#if 0 + "arridx", + "symbol", + "hidden", + "reserved_word", + "strict_reserved_word", + "eval_or_arguments", +#endif + "extdata" + /* NULL not needed here */ +}; +DUK_LOCAL duk_uint_t duk__debug_getinfo_hstring_masks[] = { +#if 0 + DUK_HSTRING_FLAG_ARRIDX, + DUK_HSTRING_FLAG_SYMBOL, + DUK_HSTRING_FLAG_HIDDEN, + DUK_HSTRING_FLAG_RESERVED_WORD, + DUK_HSTRING_FLAG_STRICT_RESERVED_WORD, + DUK_HSTRING_FLAG_EVAL_OR_ARGUMENTS, +#endif + DUK_HSTRING_FLAG_EXTDATA, + 0 /* terminator */ +}; +DUK_LOCAL const char * const duk__debug_getinfo_hobject_keys[] = { + "extensible", "constructable", "callable", "boundfunc", "compfunc", "natfunc", "bufobj", + "fastrefs", "array_part", "strict", "notail", "newenv", "namebinding", "createargs", + "have_finalizer", "exotic_array", "exotic_stringobj", "exotic_arguments", "exotic_proxyobj", "special_call" + /* NULL not needed here */ +}; +DUK_LOCAL duk_uint_t duk__debug_getinfo_hobject_masks[] = { + DUK_HOBJECT_FLAG_EXTENSIBLE, DUK_HOBJECT_FLAG_CONSTRUCTABLE, DUK_HOBJECT_FLAG_CALLABLE, + DUK_HOBJECT_FLAG_BOUNDFUNC, DUK_HOBJECT_FLAG_COMPFUNC, DUK_HOBJECT_FLAG_NATFUNC, + DUK_HOBJECT_FLAG_BUFOBJ, DUK_HOBJECT_FLAG_FASTREFS, DUK_HOBJECT_FLAG_ARRAY_PART, + DUK_HOBJECT_FLAG_STRICT, DUK_HOBJECT_FLAG_NOTAIL, DUK_HOBJECT_FLAG_NEWENV, + DUK_HOBJECT_FLAG_NAMEBINDING, DUK_HOBJECT_FLAG_CREATEARGS, DUK_HOBJECT_FLAG_HAVE_FINALIZER, + DUK_HOBJECT_FLAG_EXOTIC_ARRAY, DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ, DUK_HOBJECT_FLAG_EXOTIC_ARGUMENTS, + DUK_HOBJECT_FLAG_EXOTIC_PROXYOBJ, DUK_HOBJECT_FLAG_SPECIAL_CALL, 0 /* terminator */ +}; +DUK_LOCAL const char * const duk__debug_getinfo_hbuffer_keys[] = { + "dynamic", + "external" + /* NULL not needed here */ +}; +DUK_LOCAL duk_uint_t duk__debug_getinfo_hbuffer_masks[] = { + DUK_HBUFFER_FLAG_DYNAMIC, + DUK_HBUFFER_FLAG_EXTERNAL, + 0 /* terminator */ +}; + +DUK_LOCAL void duk__debug_getinfo_flags_key(duk_hthread *thr, const char *key) { + duk_debug_write_uint(thr, 0); + duk_debug_write_cstring(thr, key); +} + +DUK_LOCAL void duk__debug_getinfo_prop_uint(duk_hthread *thr, const char *key, duk_uint_t val) { + duk_debug_write_uint(thr, 0); + duk_debug_write_cstring(thr, key); + duk_debug_write_uint(thr, val); +} + +DUK_LOCAL void duk__debug_getinfo_prop_int(duk_hthread *thr, const char *key, duk_int_t val) { + duk_debug_write_uint(thr, 0); + duk_debug_write_cstring(thr, key); + duk_debug_write_int(thr, val); +} + +DUK_LOCAL void duk__debug_getinfo_prop_bool(duk_hthread *thr, const char *key, duk_bool_t val) { + duk_debug_write_uint(thr, 0); + duk_debug_write_cstring(thr, key); + duk_debug_write_boolean(thr, val); +} + +DUK_LOCAL void duk__debug_getinfo_bitmask(duk_hthread *thr, const char * const *keys, duk_uint_t *masks, duk_uint_t flags) { + const char *key; + duk_uint_t mask; + + for (;;) { + mask = *masks++; + if (mask == 0) { + break; + } + key = *keys++; + DUK_ASSERT(key != NULL); + + DUK_DD(DUK_DDPRINT("inspect bitmask: key=%s, mask=0x%08lx, flags=0x%08lx", + key, + (unsigned long) mask, + (unsigned long) flags)); + duk__debug_getinfo_prop_bool(thr, key, flags & mask); + } +} + +/* Inspect a property using a virtual index into a conceptual property list + * consisting of (1) all array part items from [0,a_size[ (even when above + * .length) and (2) all entry part items from [0,e_next[. Unused slots are + * indicated using dvalue 'unused'. + */ +DUK_LOCAL duk_bool_t duk__debug_getprop_index(duk_hthread *thr, duk_heap *heap, duk_hobject *h_obj, duk_uint_t idx) { + duk_uint_t a_size; + duk_tval *tv; + duk_hstring *h_key; + duk_hobject *h_getset; + duk_uint_t flags; + + DUK_UNREF(heap); + + a_size = DUK_HOBJECT_GET_ASIZE(h_obj); + if (idx < a_size) { + duk_debug_write_uint(thr, DUK_PROPDESC_FLAGS_WEC); + duk_debug_write_uint(thr, idx); + tv = DUK_HOBJECT_A_GET_VALUE_PTR(heap, h_obj, idx); + duk_debug_write_tval(thr, tv); + return 1; + } + + idx -= a_size; + if (idx >= DUK_HOBJECT_GET_ENEXT(h_obj)) { + return 0; + } + + h_key = DUK_HOBJECT_E_GET_KEY(heap, h_obj, idx); + if (h_key == NULL) { + duk_debug_write_uint(thr, 0); + duk_debug_write_null(thr); + duk_debug_write_unused(thr); + return 1; + } + + flags = DUK_HOBJECT_E_GET_FLAGS(heap, h_obj, idx); + if (DUK_HSTRING_HAS_SYMBOL(h_key)) { + flags |= DUK_DBG_PROPFLAG_SYMBOL; + } + if (DUK_HSTRING_HAS_HIDDEN(h_key)) { + flags |= DUK_DBG_PROPFLAG_HIDDEN; + } + duk_debug_write_uint(thr, flags); + duk_debug_write_hstring(thr, h_key); + if (flags & DUK_PROPDESC_FLAG_ACCESSOR) { + h_getset = DUK_HOBJECT_E_GET_VALUE_GETTER(heap, h_obj, idx); + if (h_getset) { + duk_debug_write_hobject(thr, h_getset); + } else { + duk_debug_write_null(thr); + } + h_getset = DUK_HOBJECT_E_GET_VALUE_SETTER(heap, h_obj, idx); + if (h_getset) { + duk_debug_write_hobject(thr, h_getset); + } else { + duk_debug_write_null(thr); + } + } else { + tv = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(heap, h_obj, idx); + duk_debug_write_tval(thr, tv); + } + return 1; +} + +DUK_LOCAL void duk__debug_handle_get_heap_obj_info(duk_hthread *thr, duk_heap *heap) { + duk_heaphdr *h; + + DUK_D(DUK_DPRINT("debug command GetHeapObjInfo")); + DUK_UNREF(heap); + + DUK_ASSERT(sizeof(duk__debug_getinfo_hstring_keys) / sizeof(const char *) == + sizeof(duk__debug_getinfo_hstring_masks) / sizeof(duk_uint_t) - 1); + DUK_ASSERT(sizeof(duk__debug_getinfo_hobject_keys) / sizeof(const char *) == + sizeof(duk__debug_getinfo_hobject_masks) / sizeof(duk_uint_t) - 1); + DUK_ASSERT(sizeof(duk__debug_getinfo_hbuffer_keys) / sizeof(const char *) == + sizeof(duk__debug_getinfo_hbuffer_masks) / sizeof(duk_uint_t) - 1); + + h = duk_debug_read_any_ptr(thr); + if (!h) { + duk_debug_write_error_eom(thr, DUK_DBG_ERR_UNKNOWN, "invalid target"); + return; + } + + duk_debug_write_reply(thr); + + /* As with all inspection code, we rely on the debug client providing + * a valid, non-stale pointer: there's no portable way to safely + * validate the pointer here. + */ + + duk__debug_getinfo_flags_key(thr, "heapptr"); + duk_debug_write_heapptr(thr, h); + + /* XXX: comes out as signed now */ + duk__debug_getinfo_prop_uint(thr, "heaphdr_flags", (duk_uint_t) DUK_HEAPHDR_GET_FLAGS(h)); + duk__debug_getinfo_prop_uint(thr, "heaphdr_type", (duk_uint_t) DUK_HEAPHDR_GET_TYPE(h)); +#if defined(DUK_USE_REFERENCE_COUNTING) + duk__debug_getinfo_prop_uint(thr, "refcount", (duk_uint_t) DUK_HEAPHDR_GET_REFCOUNT(h)); +#endif +#if 0 /* pruned */ + duk__debug_getinfo_bitmask(thr, + duk__debug_getinfo_heaphdr_keys, + duk__debug_getinfo_heaphdr_masks, + DUK_HEAPHDR_GET_FLAGS_RAW(h)); +#endif + + switch (DUK_HEAPHDR_GET_TYPE(h)) { + case DUK_HTYPE_STRING: { + duk_hstring *h_str; + + h_str = (duk_hstring *) h; + duk__debug_getinfo_bitmask(thr, + duk__debug_getinfo_hstring_keys, + duk__debug_getinfo_hstring_masks, + DUK_HEAPHDR_GET_FLAGS_RAW(h)); + duk__debug_getinfo_prop_uint(thr, "bytelen", (duk_uint_t) DUK_HSTRING_GET_BYTELEN(h_str)); + duk__debug_getinfo_prop_uint(thr, "charlen", (duk_uint_t) DUK_HSTRING_GET_CHARLEN(h_str)); + duk__debug_getinfo_prop_uint(thr, "hash", (duk_uint_t) DUK_HSTRING_GET_HASH(h_str)); + duk__debug_getinfo_flags_key(thr, "data"); + duk_debug_write_hstring(thr, h_str); + break; + } + case DUK_HTYPE_OBJECT: { + duk_hobject *h_obj; + duk_hobject *h_proto; + + h_obj = (duk_hobject *) h; + h_proto = DUK_HOBJECT_GET_PROTOTYPE(heap, h_obj); + + /* duk_hobject specific fields. */ + duk__debug_getinfo_bitmask(thr, + duk__debug_getinfo_hobject_keys, + duk__debug_getinfo_hobject_masks, + DUK_HEAPHDR_GET_FLAGS_RAW(h)); + duk__debug_getinfo_prop_uint(thr, "class_number", DUK_HOBJECT_GET_CLASS_NUMBER(h_obj)); + duk__debug_getinfo_flags_key(thr, "class_name"); + duk_debug_write_hstring(thr, DUK_HOBJECT_GET_CLASS_STRING(heap, h_obj)); + duk__debug_getinfo_flags_key(thr, "prototype"); + if (h_proto != NULL) { + duk_debug_write_hobject(thr, h_proto); + } else { + duk_debug_write_null(thr); + } + duk__debug_getinfo_flags_key(thr, "props"); + duk_debug_write_pointer(thr, (void *) DUK_HOBJECT_GET_PROPS(heap, h_obj)); + duk__debug_getinfo_prop_uint(thr, "e_size", (duk_uint_t) DUK_HOBJECT_GET_ESIZE(h_obj)); + duk__debug_getinfo_prop_uint(thr, "e_next", (duk_uint_t) DUK_HOBJECT_GET_ENEXT(h_obj)); + duk__debug_getinfo_prop_uint(thr, "a_size", (duk_uint_t) DUK_HOBJECT_GET_ASIZE(h_obj)); + duk__debug_getinfo_prop_uint(thr, "h_size", (duk_uint_t) DUK_HOBJECT_GET_HSIZE(h_obj)); + + if (DUK_HOBJECT_IS_ARRAY(h_obj)) { + duk_harray *h_arr; + h_arr = (duk_harray *) h_obj; + + duk__debug_getinfo_prop_uint(thr, "length", (duk_uint_t) h_arr->length); + duk__debug_getinfo_prop_bool(thr, "length_nonwritable", h_arr->length_nonwritable); + } + + if (DUK_HOBJECT_IS_NATFUNC(h_obj)) { + duk_hnatfunc *h_fun; + h_fun = (duk_hnatfunc *) h_obj; + + duk__debug_getinfo_prop_int(thr, "nargs", h_fun->nargs); + duk__debug_getinfo_prop_int(thr, "magic", h_fun->magic); + duk__debug_getinfo_prop_bool(thr, "varargs", h_fun->magic == DUK_HNATFUNC_NARGS_VARARGS); + /* Native function pointer may be different from a void pointer, + * and we serialize it from memory directly now (no byte swapping etc). + */ + duk__debug_getinfo_flags_key(thr, "funcptr"); + duk_debug_write_buffer(thr, (const char *) &h_fun->func, sizeof(h_fun->func)); + } + + if (DUK_HOBJECT_IS_COMPFUNC(h_obj)) { + duk_hcompfunc *h_fun; + duk_hbuffer *h_buf; + duk_hobject *h_lexenv; + duk_hobject *h_varenv; + h_fun = (duk_hcompfunc *) h_obj; + + duk__debug_getinfo_prop_int(thr, "nregs", h_fun->nregs); + duk__debug_getinfo_prop_int(thr, "nargs", h_fun->nargs); + + duk__debug_getinfo_flags_key(thr, "lex_env"); + h_lexenv = DUK_HCOMPFUNC_GET_LEXENV(thr->heap, h_fun); + if (h_lexenv != NULL) { + duk_debug_write_hobject(thr, h_lexenv); + } else { + duk_debug_write_null(thr); + } + duk__debug_getinfo_flags_key(thr, "var_env"); + h_varenv = DUK_HCOMPFUNC_GET_VARENV(thr->heap, h_fun); + if (h_varenv != NULL) { + duk_debug_write_hobject(thr, h_varenv); + } else { + duk_debug_write_null(thr); + } + + duk__debug_getinfo_prop_uint(thr, "start_line", h_fun->start_line); + duk__debug_getinfo_prop_uint(thr, "end_line", h_fun->end_line); + h_buf = (duk_hbuffer *) DUK_HCOMPFUNC_GET_DATA(thr->heap, h_fun); + if (h_buf != NULL) { + duk__debug_getinfo_flags_key(thr, "data"); + duk_debug_write_heapptr(thr, (duk_heaphdr *) h_buf); + } + } + + if (DUK_HOBJECT_IS_BOUNDFUNC(h_obj)) { + duk_hboundfunc *h_bfun; + h_bfun = (duk_hboundfunc *) (void *) h_obj; + + duk__debug_getinfo_flags_key(thr, "target"); + duk_debug_write_tval(thr, &h_bfun->target); + duk__debug_getinfo_flags_key(thr, "this_binding"); + duk_debug_write_tval(thr, &h_bfun->this_binding); + duk__debug_getinfo_flags_key(thr, "nargs"); + duk_debug_write_int(thr, h_bfun->nargs); + /* h_bfun->args not exposed now */ + } + + if (DUK_HOBJECT_IS_THREAD(h_obj)) { + /* XXX: Currently no inspection of threads, e.g. value stack, call + * stack, catch stack, etc. + */ + duk_hthread *h_thr; + h_thr = (duk_hthread *) h_obj; + DUK_UNREF(h_thr); + } + + if (DUK_HOBJECT_IS_DECENV(h_obj)) { + duk_hdecenv *h_env; + h_env = (duk_hdecenv *) h_obj; + + duk__debug_getinfo_flags_key(thr, "thread"); + duk_debug_write_heapptr(thr, (duk_heaphdr *) (h_env->thread)); + duk__debug_getinfo_flags_key(thr, "varmap"); + duk_debug_write_heapptr(thr, (duk_heaphdr *) (h_env->varmap)); + duk__debug_getinfo_prop_uint(thr, "regbase", (duk_uint_t) h_env->regbase_byteoff); + } + + if (DUK_HOBJECT_IS_OBJENV(h_obj)) { + duk_hobjenv *h_env; + h_env = (duk_hobjenv *) h_obj; + + duk__debug_getinfo_flags_key(thr, "target"); + duk_debug_write_heapptr(thr, (duk_heaphdr *) (h_env->target)); + duk__debug_getinfo_prop_bool(thr, "has_this", h_env->has_this); + } + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + if (DUK_HOBJECT_IS_BUFOBJ(h_obj)) { + duk_hbufobj *h_bufobj; + h_bufobj = (duk_hbufobj *) h_obj; + + duk__debug_getinfo_prop_uint(thr, "slice_offset", h_bufobj->offset); + duk__debug_getinfo_prop_uint(thr, "slice_length", h_bufobj->length); + duk__debug_getinfo_prop_uint(thr, "elem_shift", (duk_uint_t) h_bufobj->shift); + duk__debug_getinfo_prop_uint(thr, "elem_type", (duk_uint_t) h_bufobj->elem_type); + duk__debug_getinfo_prop_bool(thr, "is_typedarray", (duk_uint_t) h_bufobj->is_typedarray); + if (h_bufobj->buf != NULL) { + duk__debug_getinfo_flags_key(thr, "buffer"); + duk_debug_write_heapptr(thr, (duk_heaphdr *) h_bufobj->buf); + } + } +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + break; + } + case DUK_HTYPE_BUFFER: { + duk_hbuffer *h_buf; + + h_buf = (duk_hbuffer *) h; + duk__debug_getinfo_bitmask(thr, + duk__debug_getinfo_hbuffer_keys, + duk__debug_getinfo_hbuffer_masks, + DUK_HEAPHDR_GET_FLAGS_RAW(h)); + duk__debug_getinfo_prop_uint(thr, "size", (duk_uint_t) DUK_HBUFFER_GET_SIZE(h_buf)); + duk__debug_getinfo_flags_key(thr, "dataptr"); + duk_debug_write_pointer(thr, (void *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_buf)); + duk__debug_getinfo_flags_key(thr, "data"); + duk_debug_write_hbuffer(thr, h_buf); /* tolerates NULL h_buf */ + break; + } + default: { + /* Since we already started writing the reply, just emit nothing. */ + DUK_D(DUK_DPRINT("inspect target pointer has invalid heaphdr type")); + } + } + + duk_debug_write_eom(thr); +} + +DUK_LOCAL void duk__debug_handle_get_obj_prop_desc(duk_hthread *thr, duk_heap *heap) { + duk_heaphdr *h; + duk_hobject *h_obj; + duk_hstring *h_key; + duk_propdesc desc; + + DUK_D(DUK_DPRINT("debug command GetObjPropDesc")); + DUK_UNREF(heap); + + h = duk_debug_read_any_ptr(thr); + if (!h) { + duk_debug_write_error_eom(thr, DUK_DBG_ERR_UNKNOWN, "invalid target"); + return; + } + h_key = duk_debug_read_hstring(thr); + if (h == NULL || DUK_HEAPHDR_GET_TYPE(h) != DUK_HTYPE_OBJECT || h_key == NULL) { + goto fail_args; + } + h_obj = (duk_hobject *) h; + + if (duk_hobject_get_own_propdesc(thr, h_obj, h_key, &desc, 0 /*flags*/)) { + duk_int_t virtual_idx; + duk_bool_t rc; + + /* To use the shared helper need the virtual index. */ + DUK_ASSERT(desc.e_idx >= 0 || desc.a_idx >= 0); + virtual_idx = (desc.a_idx >= 0 ? desc.a_idx : (duk_int_t) DUK_HOBJECT_GET_ASIZE(h_obj) + desc.e_idx); + + duk_debug_write_reply(thr); + rc = duk__debug_getprop_index(thr, heap, h_obj, (duk_uint_t) virtual_idx); + DUK_ASSERT(rc == 1); + DUK_UNREF(rc); + duk_debug_write_eom(thr); + } else { + duk_debug_write_error_eom(thr, DUK_DBG_ERR_NOTFOUND, "not found"); + } + return; + +fail_args: + duk_debug_write_error_eom(thr, DUK_DBG_ERR_UNKNOWN, "invalid args"); +} + +DUK_LOCAL void duk__debug_handle_get_obj_prop_desc_range(duk_hthread *thr, duk_heap *heap) { + duk_heaphdr *h; + duk_hobject *h_obj; + duk_uint_t idx, idx_start, idx_end; + + DUK_D(DUK_DPRINT("debug command GetObjPropDescRange")); + DUK_UNREF(heap); + + h = duk_debug_read_any_ptr(thr); + idx_start = (duk_uint_t) duk_debug_read_int(thr); + idx_end = (duk_uint_t) duk_debug_read_int(thr); + if (h == NULL || DUK_HEAPHDR_GET_TYPE(h) != DUK_HTYPE_OBJECT) { + goto fail_args; + } + h_obj = (duk_hobject *) h; + + /* The index range space is conceptually the array part followed by the + * entry part. Unlike normal enumeration all slots are exposed here as + * is and return 'unused' if the slots are not in active use. In particular + * the array part is included for the full a_size regardless of what the + * array .length is. + */ + + duk_debug_write_reply(thr); + for (idx = idx_start; idx < idx_end; idx++) { + if (!duk__debug_getprop_index(thr, heap, h_obj, idx)) { + break; + } + } + duk_debug_write_eom(thr); + return; + +fail_args: + duk_debug_write_error_eom(thr, DUK_DBG_ERR_UNKNOWN, "invalid args"); +} + +#endif /* DUK_USE_DEBUGGER_INSPECT */ + +/* + * Process incoming debug requests + * + * Individual request handlers can push temporaries on the value stack and + * rely on duk__debug_process_message() to restore the value stack top + * automatically. + */ + +/* Process one debug message. Automatically restore value stack top to its + * entry value, so that individual message handlers don't need exact value + * stack handling which is convenient. + */ +DUK_LOCAL void duk__debug_process_message(duk_hthread *thr) { + duk_heap *heap; + duk_uint8_t x; + duk_int32_t cmd; + duk_idx_t entry_top; + + DUK_ASSERT(thr != NULL); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + + entry_top = duk_get_top(thr); + + x = duk_debug_read_byte(thr); + switch (x) { + case DUK_DBG_IB_REQUEST: { + cmd = duk_debug_read_int(thr); + switch (cmd) { + case DUK_DBG_CMD_BASICINFO: { + duk__debug_handle_basic_info(thr, heap); + break; + } + case DUK_DBG_CMD_TRIGGERSTATUS: { + duk__debug_handle_trigger_status(thr, heap); + break; + } + case DUK_DBG_CMD_PAUSE: { + duk__debug_handle_pause(thr, heap); + break; + } + case DUK_DBG_CMD_RESUME: { + duk__debug_handle_resume(thr, heap); + break; + } + case DUK_DBG_CMD_STEPINTO: + case DUK_DBG_CMD_STEPOVER: + case DUK_DBG_CMD_STEPOUT: { + duk__debug_handle_step(thr, heap, cmd); + break; + } + case DUK_DBG_CMD_LISTBREAK: { + duk__debug_handle_list_break(thr, heap); + break; + } + case DUK_DBG_CMD_ADDBREAK: { + duk__debug_handle_add_break(thr, heap); + break; + } + case DUK_DBG_CMD_DELBREAK: { + duk__debug_handle_del_break(thr, heap); + break; + } + case DUK_DBG_CMD_GETVAR: { + duk__debug_handle_get_var(thr, heap); + break; + } + case DUK_DBG_CMD_PUTVAR: { + duk__debug_handle_put_var(thr, heap); + break; + } + case DUK_DBG_CMD_GETCALLSTACK: { + duk__debug_handle_get_call_stack(thr, heap); + break; + } + case DUK_DBG_CMD_GETLOCALS: { + duk__debug_handle_get_locals(thr, heap); + break; + } + case DUK_DBG_CMD_EVAL: { + duk__debug_handle_eval(thr, heap); + break; + } + case DUK_DBG_CMD_DETACH: { + /* The actual detached_cb call is postponed to message loop so + * we don't need any special precautions here (just skip to EOM + * on the already closed connection). + */ + duk__debug_handle_detach(thr, heap); + break; + } +#if defined(DUK_USE_DEBUGGER_DUMPHEAP) + case DUK_DBG_CMD_DUMPHEAP: { + duk__debug_handle_dump_heap(thr, heap); + break; + } +#endif /* DUK_USE_DEBUGGER_DUMPHEAP */ + case DUK_DBG_CMD_GETBYTECODE: { + duk__debug_handle_get_bytecode(thr, heap); + break; + } + case DUK_DBG_CMD_APPREQUEST: { + duk__debug_handle_apprequest(thr, heap); + break; + } +#if defined(DUK_USE_DEBUGGER_INSPECT) + case DUK_DBG_CMD_GETHEAPOBJINFO: { + duk__debug_handle_get_heap_obj_info(thr, heap); + break; + } + case DUK_DBG_CMD_GETOBJPROPDESC: { + duk__debug_handle_get_obj_prop_desc(thr, heap); + break; + } + case DUK_DBG_CMD_GETOBJPROPDESCRANGE: { + duk__debug_handle_get_obj_prop_desc_range(thr, heap); + break; + } +#endif /* DUK_USE_DEBUGGER_INSPECT */ + default: { + DUK_D(DUK_DPRINT("debug command unsupported: %d", (int) cmd)); + duk_debug_write_error_eom(thr, DUK_DBG_ERR_UNSUPPORTED, "unsupported command"); + } + } /* switch cmd */ + break; + } + case DUK_DBG_IB_REPLY: { + DUK_D(DUK_DPRINT("debug reply, skipping")); + break; + } + case DUK_DBG_IB_ERROR: { + DUK_D(DUK_DPRINT("debug error, skipping")); + break; + } + case DUK_DBG_IB_NOTIFY: { + DUK_D(DUK_DPRINT("debug notify, skipping")); + break; + } + default: { + DUK_D(DUK_DPRINT("invalid initial byte, drop connection: %d", (int) x)); + goto fail; + } + } /* switch initial byte */ + + DUK_ASSERT(duk_get_top(thr) >= entry_top); + duk_set_top(thr, entry_top); + duk__debug_skip_to_eom(thr); + return; + +fail: + DUK_ASSERT(duk_get_top(thr) >= entry_top); + duk_set_top(thr, entry_top); + DUK__SET_CONN_BROKEN(thr, 1); + return; +} + +DUK_LOCAL void duk__check_resend_status(duk_hthread *thr) { + if (thr->heap->dbg_read_cb != NULL && thr->heap->dbg_state_dirty) { + duk_debug_send_status(thr); + thr->heap->dbg_state_dirty = 0; + } +} + +DUK_INTERNAL duk_bool_t duk_debug_process_messages(duk_hthread *thr, duk_bool_t no_block) { +#if defined(DUK_USE_ASSERTIONS) + duk_idx_t entry_top; +#endif + duk_bool_t retval = 0; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); +#if defined(DUK_USE_ASSERTIONS) + entry_top = duk_get_top(thr); +#endif + + DUK_D(DUK_DPRINT("process debug messages: read_cb=%s, no_block=%ld, detaching=%ld, processing=%ld", + thr->heap->dbg_read_cb ? "not NULL" : "NULL", + (long) no_block, + (long) thr->heap->dbg_detaching, + (long) thr->heap->dbg_processing)); + DUK_DD(DUK_DDPRINT("top at entry: %ld", (long) duk_get_top(thr))); + + /* thr->heap->dbg_detaching may be != 0 if a debugger write outside + * the message loop caused a transport error and detach1() to run. + */ + DUK_ASSERT(thr->heap->dbg_detaching == 0 || thr->heap->dbg_detaching == 1); + DUK_ASSERT(thr->heap->dbg_processing == 0); + thr->heap->dbg_processing = 1; + + /* Ensure dirty state causes a Status even if never process any + * messages. This is expected by the bytecode executor when in + * the running state. + */ + duk__check_resend_status(thr); + + for (;;) { + /* Process messages until we're no longer paused or we peek + * and see there's nothing to read right now. + */ + DUK_DD(DUK_DDPRINT("top at loop top: %ld", (long) duk_get_top(thr))); + DUK_ASSERT(thr->heap->dbg_processing == 1); + + while (thr->heap->dbg_read_cb == NULL && thr->heap->dbg_detaching) { + /* Detach is pending; can be triggered from outside the + * debugger loop (e.g. Status notify write error) or by + * previous message handling. Call detached callback + * here, in a controlled state, to ensure a possible + * reattach inside the detached_cb is handled correctly. + * + * Recheck for detach in a while loop: an immediate + * reattach involves a call to duk_debugger_attach() + * which writes a debugger handshake line immediately + * inside the API call. If the transport write fails + * for that handshake, we can immediately end up in a + * "transport broken, detaching" case several times here. + * Loop back until we're either cleanly attached or + * fully detached. + * + * NOTE: Reset dbg_processing = 1 forcibly, in case we + * re-attached; duk_debugger_attach() sets dbg_processing + * to 0 at the moment. + */ + + DUK_D(DUK_DPRINT("detach pending (dbg_read_cb == NULL, dbg_detaching != 0), call detach2")); + + duk__debug_do_detach2(thr->heap); + thr->heap->dbg_processing = 1; /* may be set to 0 by duk_debugger_attach() inside callback */ + + DUK_D(DUK_DPRINT("after detach2 (and possible reattach): dbg_read_cb=%s, dbg_detaching=%ld", + thr->heap->dbg_read_cb ? "not NULL" : "NULL", + (long) thr->heap->dbg_detaching)); + } + DUK_ASSERT(thr->heap->dbg_detaching == 0); /* true even with reattach */ + DUK_ASSERT(thr->heap->dbg_processing == 1); /* even after a detach and possible reattach */ + + if (thr->heap->dbg_read_cb == NULL) { + DUK_D(DUK_DPRINT("debug connection broken (and not detaching), stop processing messages")); + break; + } + + if (!DUK_HEAP_HAS_DEBUGGER_PAUSED(thr->heap) || no_block) { + if (!duk_debug_read_peek(thr)) { + /* Note: peek cannot currently trigger a detach + * so the dbg_detaching == 0 assert outside the + * loop is correct. + */ + DUK_D(DUK_DPRINT("processing debug message, peek indicated no data, stop processing messages")); + break; + } + DUK_D(DUK_DPRINT("processing debug message, peek indicated there is data, handle it")); + } else { + DUK_D(DUK_DPRINT("paused, process debug message, blocking if necessary")); + } + + duk__check_resend_status(thr); + duk__debug_process_message(thr); + duk__check_resend_status(thr); + + retval = 1; /* processed one or more messages */ + } + + DUK_ASSERT(thr->heap->dbg_detaching == 0); + DUK_ASSERT(thr->heap->dbg_processing == 1); + thr->heap->dbg_processing = 0; + + /* As an initial implementation, read flush after exiting the message + * loop. If transport is broken, this is a no-op (with debug logs). + */ + duk_debug_read_flush(thr); /* this cannot initiate a detach */ + DUK_ASSERT(thr->heap->dbg_detaching == 0); + + DUK_DD(DUK_DDPRINT("top at exit: %ld", (long) duk_get_top(thr))); + +#if defined(DUK_USE_ASSERTIONS) + /* Easy to get wrong, so assert for it. */ + DUK_ASSERT(entry_top == duk_get_top(thr)); +#endif + + return retval; +} + +/* + * Halt execution helper + */ + +/* Halt execution and enter a debugger message loop until execution is resumed + * by the client. PC for the current activation may be temporarily decremented + * so that the "current" instruction will be shown by the client. This helper + * is callable from anywhere, also outside bytecode executor. + */ + +DUK_INTERNAL void duk_debug_halt_execution(duk_hthread *thr, duk_bool_t use_prev_pc) { + duk_activation *act; + duk_hcompfunc *fun; + duk_instr_t *old_pc = NULL; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(duk_debug_is_attached(thr->heap)); + DUK_ASSERT(thr->heap->dbg_processing == 0); + DUK_ASSERT(!duk_debug_is_paused(thr->heap)); + + duk_debug_set_paused(thr->heap); + + act = thr->callstack_curr; + + /* NOTE: act may be NULL if an error is thrown outside of any activation, + * which may happen in the case of, e.g. syntax errors. + */ + + /* Decrement PC if that was requested, this requires a PC sync. */ + if (act != NULL) { + duk_hthread_sync_currpc(thr); + old_pc = act->curr_pc; + fun = (duk_hcompfunc *) DUK_ACT_GET_FUNC(act); + + /* Short circuit if is safe: if act->curr_pc != NULL, 'fun' is + * guaranteed to be a non-NULL ECMAScript function. + */ + DUK_ASSERT(act->curr_pc == NULL || (fun != NULL && DUK_HOBJECT_IS_COMPFUNC((duk_hobject *) fun))); + if (use_prev_pc && act->curr_pc != NULL && act->curr_pc > DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, fun)) { + act->curr_pc--; + } + } + + /* Process debug messages until we are no longer paused. */ + + /* NOTE: This is a bit fragile. It's important to ensure that + * duk_debug_process_messages() never throws an error or + * act->curr_pc will never be reset. + */ + + thr->heap->dbg_state_dirty = 1; + while (DUK_HEAP_HAS_DEBUGGER_PAUSED(thr->heap)) { + DUK_ASSERT(duk_debug_is_attached(thr->heap)); + DUK_ASSERT(thr->heap->dbg_processing == 0); + duk_debug_process_messages(thr, 0 /*no_block*/); + } + + /* XXX: Decrementing and restoring act->curr_pc works now, but if the + * debugger message loop gains the ability to adjust the current PC + * (e.g. a forced jump) restoring the PC here will break. Another + * approach would be to use a state flag for the "decrement 1 from + * topmost activation's PC" and take it into account whenever dealing + * with PC values. + */ + if (act != NULL) { + act->curr_pc = old_pc; /* restore PC */ + } +} + +/* + * Breakpoint management + */ + +DUK_INTERNAL duk_small_int_t duk_debug_add_breakpoint(duk_hthread *thr, duk_hstring *filename, duk_uint32_t line) { + duk_heap *heap; + duk_breakpoint *b; + + /* Caller must trigger recomputation of active breakpoint list. To + * ensure stale values are not used if that doesn't happen, clear the + * active breakpoint list here. + */ + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(filename != NULL); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + + if (heap->dbg_breakpoint_count >= DUK_HEAP_MAX_BREAKPOINTS) { + DUK_D(DUK_DPRINT("failed to add breakpoint for %O:%ld, all breakpoint slots used", + (duk_heaphdr *) filename, + (long) line)); + return -1; + } + heap->dbg_breakpoints_active[0] = (duk_breakpoint *) NULL; + b = heap->dbg_breakpoints + (heap->dbg_breakpoint_count++); + b->filename = filename; + b->line = line; + DUK_HSTRING_INCREF(thr, filename); + + return (duk_small_int_t) (heap->dbg_breakpoint_count - 1); /* index */ +} + +DUK_INTERNAL duk_bool_t duk_debug_remove_breakpoint(duk_hthread *thr, duk_small_uint_t breakpoint_index) { + duk_heap *heap; + duk_hstring *h; + duk_breakpoint *b; + duk_size_t move_size; + + /* Caller must trigger recomputation of active breakpoint list. To + * ensure stale values are not used if that doesn't happen, clear the + * active breakpoint list here. + */ + + DUK_ASSERT(thr != NULL); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + DUK_ASSERT(duk_debug_is_attached(thr->heap)); + DUK_ASSERT_DISABLE(breakpoint_index >= 0); /* unsigned */ + + if (breakpoint_index >= heap->dbg_breakpoint_count) { + DUK_D(DUK_DPRINT("invalid breakpoint index: %ld", (long) breakpoint_index)); + return 0; + } + b = heap->dbg_breakpoints + breakpoint_index; + + h = b->filename; + DUK_ASSERT(h != NULL); + + move_size = sizeof(duk_breakpoint) * (heap->dbg_breakpoint_count - breakpoint_index - 1); + duk_memmove((void *) b, (const void *) (b + 1), (size_t) move_size); + + heap->dbg_breakpoint_count--; + heap->dbg_breakpoints_active[0] = (duk_breakpoint *) NULL; + + DUK_HSTRING_DECREF(thr, h); /* side effects */ + DUK_UNREF(h); /* w/o refcounting */ + + /* Breakpoint entries above the used area are left as garbage. */ + + return 1; +} + +/* + * Misc state management + */ + +DUK_INTERNAL duk_bool_t duk_debug_is_attached(duk_heap *heap) { + return (heap->dbg_read_cb != NULL); +} + +DUK_INTERNAL duk_bool_t duk_debug_is_paused(duk_heap *heap) { + return (DUK_HEAP_HAS_DEBUGGER_PAUSED(heap) != 0); +} + +DUK_INTERNAL void duk_debug_set_paused(duk_heap *heap) { + if (duk_debug_is_paused(heap)) { + DUK_D(DUK_DPRINT("trying to set paused state when already paused, ignoring")); + } else { + DUK_HEAP_SET_DEBUGGER_PAUSED(heap); + heap->dbg_state_dirty = 1; + duk_debug_clear_pause_state(heap); + DUK_ASSERT(heap->ms_running == 0); /* debugger can't be triggered within mark-and-sweep */ + heap->ms_running = 2; /* prevent mark-and-sweep, prevent refzero queueing */ + heap->ms_prevent_count++; + DUK_ASSERT(heap->ms_prevent_count != 0); /* Wrap. */ + DUK_ASSERT(heap->heap_thread != NULL); + } +} + +DUK_INTERNAL void duk_debug_clear_paused(duk_heap *heap) { + if (duk_debug_is_paused(heap)) { + DUK_HEAP_CLEAR_DEBUGGER_PAUSED(heap); + heap->dbg_state_dirty = 1; + duk_debug_clear_pause_state(heap); + DUK_ASSERT(heap->ms_running == 2); + DUK_ASSERT(heap->ms_prevent_count > 0); + heap->ms_prevent_count--; + heap->ms_running = 0; + DUK_ASSERT(heap->heap_thread != NULL); + } else { + DUK_D(DUK_DPRINT("trying to clear paused state when not paused, ignoring")); + } +} + +DUK_INTERNAL void duk_debug_clear_pause_state(duk_heap *heap) { + heap->dbg_pause_flags = 0; + heap->dbg_pause_act = NULL; + heap->dbg_pause_startline = 0; +} + +#else /* DUK_USE_DEBUGGER_SUPPORT */ + +/* No debugger support. */ + +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + +/* automatic undefs */ +#undef DUK__DBG_TPORT_ENTER +#undef DUK__DBG_TPORT_EXIT +#undef DUK__SET_CONN_BROKEN +#line 1 "duk_error_augment.c" +/* + * Augmenting errors at their creation site and their throw site. + * + * When errors are created, traceback data is added by built-in code + * and a user error handler (if defined) can process or replace the + * error. Similarly, when errors are thrown, a user error handler + * (if defined) can process or replace the error. + * + * Augmentation and other processing at error creation time is nice + * because an error is only created once, but it may be thrown and + * rethrown multiple times. User error handler registered for processing + * an error at its throw site must be careful to handle rethrowing in + * a useful manner. + * + * Error augmentation may throw an internal error (e.g. alloc error). + * + * ECMAScript allows throwing any values, so all values cannot be + * augmented. Currently, the built-in augmentation at error creation + * only augments error values which are Error instances (= have the + * built-in Error.prototype in their prototype chain) and are also + * extensible. User error handlers have no limitations in this respect. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Helper for calling a user error handler. + * + * 'thr' must be the currently active thread; the error handler is called + * in its context. The valstack of 'thr' must have the error value on + * top, and will be replaced by another error value based on the return + * value of the error handler. + * + * The helper calls duk_handle_call() recursively in protected mode. + * Before that call happens, no longjmps should happen; as a consequence, + * we must assume that the valstack contains enough temporary space for + * arguments and such. + * + * While the error handler runs, any errors thrown will not trigger a + * recursive error handler call (this is implemented using a heap level + * flag which will "follow" through any coroutines resumed inside the + * error handler). If the error handler is not callable or throws an + * error, the resulting error replaces the original error (for Duktape + * internal errors, duk_error_throw.c further substitutes this error with + * a DoubleError which is not ideal). This would be easy to change and + * even signal to the caller. + * + * The user error handler is stored in 'Duktape.errCreate' or + * 'Duktape.errThrow' depending on whether we're augmenting the error at + * creation or throw time. There are several alternatives to this approach, + * see doc/error-objects.rst for discussion. + * + * Note: since further longjmp()s may occur while calling the error handler + * (for many reasons, e.g. a labeled 'break' inside the handler), the + * caller can make no assumptions on the thr->heap->lj state after the + * call (this affects especially duk_error_throw.c). This is not an issue + * as long as the caller writes to the lj state only after the error handler + * finishes. + */ + +#if defined(DUK_USE_ERRTHROW) || defined(DUK_USE_ERRCREATE) +DUK_LOCAL void duk__err_augment_user(duk_hthread *thr, duk_small_uint_t stridx_cb) { + duk_tval *tv_hnd; + duk_int_t rc; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT_STRIDX_VALID(stridx_cb); + + if (thr->heap->augmenting_error) { + DUK_D(DUK_DPRINT("recursive call to error augmentation, ignore")); + return; + } + + /* + * Check whether or not we have an error handler. + * + * We must be careful of not triggering an error when looking up the + * property. For instance, if the property is a getter, we don't want + * to call it, only plain values are allowed. The value, if it exists, + * is not checked. If the value is not a function, a TypeError happens + * when it is called and that error replaces the original one. + */ + + DUK_ASSERT_VALSTACK_SPACE(thr, 4); /* 3 entries actually needed below */ + + /* [ ... errval ] */ + + if (thr->builtins[DUK_BIDX_DUKTAPE] == NULL) { + /* When creating built-ins, some of the built-ins may not be set + * and we want to tolerate that when throwing errors. + */ + DUK_DD(DUK_DDPRINT("error occurred when DUK_BIDX_DUKTAPE is NULL, ignoring")); + return; + } + tv_hnd = duk_hobject_find_entry_tval_ptr_stridx(thr->heap, thr->builtins[DUK_BIDX_DUKTAPE], stridx_cb); + if (tv_hnd == NULL) { + DUK_DD(DUK_DDPRINT("error handler does not exist or is not a plain value: %!T", (duk_tval *) tv_hnd)); + return; + } + DUK_DDD(DUK_DDDPRINT("error handler dump (callability not checked): %!T", (duk_tval *) tv_hnd)); + duk_push_tval(thr, tv_hnd); + + /* [ ... errval errhandler ] */ + + duk_insert(thr, -2); /* -> [ ... errhandler errval ] */ + duk_push_undefined(thr); + duk_insert(thr, -2); /* -> [ ... errhandler undefined(= this) errval ] */ + + /* [ ... errhandler undefined errval ] */ + + /* + * heap->augmenting_error prevents recursive re-entry and also causes + * call handling to use a larger (but not unbounded) call stack limit + * for the duration of error augmentation. + * + * We ignore errors now: a success return and an error value both + * replace the original error value. (This would be easy to change.) + */ + + DUK_ASSERT(thr->heap->augmenting_error == 0); + thr->heap->augmenting_error = 1; + + rc = duk_pcall_method(thr, 1); + DUK_UNREF(rc); /* no need to check now: both success and error are OK */ + + DUK_ASSERT(thr->heap->augmenting_error == 1); + thr->heap->augmenting_error = 0; + + /* [ ... errval ] */ +} +#endif /* DUK_USE_ERRTHROW || DUK_USE_ERRCREATE */ + +/* + * Add ._Tracedata to an error on the stack top. + */ + +#if defined(DUK_USE_TRACEBACKS) +DUK_LOCAL void duk__add_traceback(duk_hthread *thr, + duk_hthread *thr_callstack, + const char *c_filename, + duk_int_t c_line, + duk_small_uint_t flags) { + duk_activation *act; + duk_int_t depth; + duk_int_t arr_size; + duk_tval *tv; + duk_hstring *s; + duk_uint32_t u32; + duk_double_t d; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr_callstack != NULL); + + /* [ ... error ] */ + + /* + * The traceback format is pretty arcane in an attempt to keep it compact + * and cheap to create. It may change arbitrarily from version to version. + * It should be decoded/accessed through version specific accessors only. + * + * See doc/error-objects.rst. + */ + + DUK_DDD(DUK_DDDPRINT("adding traceback to object: %!T", (duk_tval *) duk_get_tval(thr, -1))); + + /* Preallocate array to correct size, so that we can just write out + * the _Tracedata values into the array part. + */ + act = thr->callstack_curr; + depth = DUK_USE_TRACEBACK_DEPTH; + DUK_ASSERT(thr_callstack->callstack_top <= DUK_INT_MAX); /* callstack limits */ + if (depth > (duk_int_t) thr_callstack->callstack_top) { + depth = (duk_int_t) thr_callstack->callstack_top; + } + if (depth > 0) { + if (flags & DUK_AUGMENT_FLAG_SKIP_ONE) { + DUK_ASSERT(act != NULL); + act = act->parent; + depth--; + } + } + arr_size = depth * 2; + if (thr->compile_ctx != NULL && thr->compile_ctx->h_filename != NULL) { + arr_size += 2; + } + if (c_filename) { + /* We need the C filename to be interned before getting the + * array part pointer to avoid any GC interference while the + * array part is populated. + */ + duk_push_string(thr, c_filename); + arr_size += 2; + } + + /* XXX: Uninitialized would be OK. Maybe add internal primitive to + * push bare duk_harray with size? + */ + DUK_D(DUK_DPRINT("preallocated _Tracedata to %ld items", (long) arr_size)); + tv = duk_push_harray_with_size_outptr(thr, (duk_uint32_t) arr_size); + duk_clear_prototype(thr, -1); + DUK_ASSERT(duk_is_bare_object(thr, -1)); + DUK_ASSERT(arr_size == 0 || tv != NULL); + + /* Compiler SyntaxErrors (and other errors) come first, and are + * blamed by default (not flagged "noblame"). + */ + if (thr->compile_ctx != NULL && thr->compile_ctx->h_filename != NULL) { + s = thr->compile_ctx->h_filename; + DUK_TVAL_SET_STRING(tv, s); + DUK_HSTRING_INCREF(thr, s); + tv++; + + u32 = (duk_uint32_t) thr->compile_ctx->curr_token.start_line; /* (flags<<32) + (line), flags = 0 */ + DUK_TVAL_SET_U32(tv, u32); + tv++; + } + + /* Filename/line from C macros (__FILE__, __LINE__) are added as an + * entry with a special format: (string, number). The number contains + * the line and flags. + */ + + /* [ ... error c_filename? arr ] */ + + if (c_filename) { + DUK_ASSERT(DUK_TVAL_IS_STRING(thr->valstack_top - 2)); + s = DUK_TVAL_GET_STRING(thr->valstack_top - 2); /* interned c_filename */ + DUK_ASSERT(s != NULL); + DUK_TVAL_SET_STRING(tv, s); + DUK_HSTRING_INCREF(thr, s); + tv++; + + d = ((flags & DUK_AUGMENT_FLAG_NOBLAME_FILELINE) ? + ((duk_double_t) DUK_TB_FLAG_NOBLAME_FILELINE) * DUK_DOUBLE_2TO32 : + 0.0) + + (duk_double_t) c_line; + DUK_TVAL_SET_DOUBLE(tv, d); + tv++; + } + + /* Traceback depth doesn't take into account the filename/line + * special handling above (intentional). + */ + for (; depth-- > 0; act = act->parent) { + duk_uint32_t pc; + duk_tval *tv_src; + + /* [... arr] */ + + DUK_ASSERT(act != NULL); /* depth check above, assumes book-keeping is correct */ + DUK_ASSERT_DISABLE(act->pc >= 0); /* unsigned */ + + /* Add function object. */ + tv_src = &act->tv_func; /* object (function) or lightfunc */ + DUK_ASSERT(DUK_TVAL_IS_OBJECT(tv_src) || DUK_TVAL_IS_LIGHTFUNC(tv_src)); + DUK_TVAL_SET_TVAL(tv, tv_src); + DUK_TVAL_INCREF(thr, tv); + tv++; + + /* Add a number containing: pc, activation flags. + * + * PC points to next instruction, find offending PC. Note that + * PC == 0 for native code. + */ + pc = (duk_uint32_t) duk_hthread_get_act_prev_pc(thr_callstack, act); + DUK_ASSERT_DISABLE(pc >= 0); /* unsigned */ + DUK_ASSERT((duk_double_t) pc < DUK_DOUBLE_2TO32); /* assume PC is at most 32 bits and non-negative */ + d = ((duk_double_t) act->flags) * DUK_DOUBLE_2TO32 + (duk_double_t) pc; + DUK_TVAL_SET_DOUBLE(tv, d); + tv++; + } + +#if defined(DUK_USE_ASSERTIONS) + { + duk_harray *a; + a = (duk_harray *) duk_known_hobject(thr, -1); + DUK_ASSERT(a != NULL); + DUK_ASSERT((duk_uint32_t) (tv - DUK_HOBJECT_A_GET_BASE(thr->heap, (duk_hobject *) a)) == a->length); + DUK_ASSERT(a->length == (duk_uint32_t) arr_size); + DUK_ASSERT(duk_is_bare_object(thr, -1)); + } +#endif + + /* [ ... error c_filename? arr ] */ + + if (c_filename) { + duk_remove_m2(thr); + } + + /* [ ... error arr ] */ + + duk_xdef_prop_stridx_short_wec(thr, -2, DUK_STRIDX_INT_TRACEDATA); /* -> [ ... error ] */ +} +#endif /* DUK_USE_TRACEBACKS */ + +/* + * Add .fileName and .lineNumber to an error on the stack top. + */ + +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) && !defined(DUK_USE_TRACEBACKS) +DUK_LOCAL void duk__add_fileline(duk_hthread *thr, + duk_hthread *thr_callstack, + const char *c_filename, + duk_int_t c_line, + duk_small_uint_t flags) { +#if defined(DUK_USE_ASSERTIONS) + duk_int_t entry_top; +#endif + +#if defined(DUK_USE_ASSERTIONS) + entry_top = duk_get_top(thr); +#endif + + /* + * If tracebacks are disabled, 'fileName' and 'lineNumber' are added + * as plain own properties. Since Error.prototype has accessors of + * the same name, we need to define own properties directly (cannot + * just use e.g. duk_put_prop_stridx). Existing properties are not + * overwritten in case they already exist. + */ + + if (thr->compile_ctx != NULL && thr->compile_ctx->h_filename != NULL) { + /* Compiler SyntaxError (or other error) gets the primary blame. + * Currently no flag to prevent blaming. + */ + duk_push_uint(thr, (duk_uint_t) thr->compile_ctx->curr_token.start_line); + duk_push_hstring(thr, thr->compile_ctx->h_filename); + } else if (c_filename && (flags & DUK_AUGMENT_FLAG_NOBLAME_FILELINE) == 0) { + /* C call site gets blamed next, unless flagged not to do so. + * XXX: file/line is disabled in minimal builds, so disable this + * too when appropriate. + */ + duk_push_int(thr, c_line); + duk_push_string(thr, c_filename); + } else { + /* Finally, blame the innermost callstack entry which has a + * .fileName property. + */ + duk_small_uint_t depth; + duk_uint32_t ecma_line; + duk_activation *act; + + DUK_ASSERT(thr_callstack->callstack_top <= DUK_INT_MAX); /* callstack limits */ + depth = DUK_USE_TRACEBACK_DEPTH; + if (depth > thr_callstack->callstack_top) { + depth = thr_callstack->callstack_top; + } + for (act = thr_callstack->callstack_curr; depth-- > 0; act = act->parent) { + duk_hobject *func; + duk_uint32_t pc; + + DUK_ASSERT(act != NULL); + func = DUK_ACT_GET_FUNC(act); + if (func == NULL) { + /* Lightfunc, not blamed now. */ + continue; + } + + /* PC points to next instruction, find offending PC, + * PC == 0 for native code. + */ + pc = duk_hthread_get_act_prev_pc( + thr, + act); /* thr argument only used for thr->heap, so specific thread doesn't matter */ + DUK_UNREF(pc); + DUK_ASSERT_DISABLE(pc >= 0); /* unsigned */ + DUK_ASSERT((duk_double_t) pc < DUK_DOUBLE_2TO32); /* assume PC is at most 32 bits and non-negative */ + + duk_push_hobject(thr, func); + + /* [ ... error func ] */ + + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_FILE_NAME); + if (!duk_is_string_notsymbol(thr, -1)) { + duk_pop_2(thr); + continue; + } + + /* [ ... error func fileName ] */ + + ecma_line = 0; +#if defined(DUK_USE_PC2LINE) + if (DUK_HOBJECT_IS_COMPFUNC(func)) { + ecma_line = duk_hobject_pc2line_query(thr, -2, (duk_uint_fast32_t) pc); + } else { + /* Native function, no relevant lineNumber. */ + } +#endif /* DUK_USE_PC2LINE */ + duk_push_u32(thr, ecma_line); + + /* [ ... error func fileName lineNumber ] */ + + duk_replace(thr, -3); + + /* [ ... error lineNumber fileName ] */ + goto define_props; + } + + /* No activation matches, use undefined for both .fileName and + * .lineNumber (matches what we do with a _Tracedata based + * no-match lookup. + */ + duk_push_undefined(thr); + duk_push_undefined(thr); + } + +define_props: + /* [ ... error lineNumber fileName ] */ +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(duk_get_top(thr) == entry_top + 2); +#endif + duk_xdef_prop_stridx_short(thr, -3, DUK_STRIDX_FILE_NAME, DUK_PROPDESC_FLAGS_C | DUK_PROPDESC_FLAG_NO_OVERWRITE); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LINE_NUMBER, DUK_PROPDESC_FLAGS_C | DUK_PROPDESC_FLAG_NO_OVERWRITE); +} +#endif /* DUK_USE_AUGMENT_ERROR_CREATE && !DUK_USE_TRACEBACKS */ + +/* + * Add line number to a compiler error. + */ + +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) +DUK_LOCAL void duk__add_compiler_error_line(duk_hthread *thr) { + /* Append a "(line NNN)" to the "message" property of any error + * thrown during compilation. Usually compilation errors are + * SyntaxErrors but they can also be out-of-memory errors and + * the like. + */ + + /* [ ... error ] */ + + DUK_ASSERT(duk_is_object(thr, -1)); + + if (!(thr->compile_ctx != NULL && thr->compile_ctx->h_filename != NULL)) { + return; + } + + DUK_DDD(DUK_DDDPRINT("compile error, before adding line info: %!T", (duk_tval *) duk_get_tval(thr, -1))); + + if (duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_MESSAGE)) { + duk_bool_t at_end; + + /* Best guesstimate that error occurred at end of input, token + * truncated by end of input, etc. + */ +#if 0 + at_end = (thr->compile_ctx->curr_token.start_offset + 1 >= thr->compile_ctx->lex.input_length); + at_end = (thr->compile_ctx->lex.window[0].codepoint < 0 || thr->compile_ctx->lex.window[1].codepoint < 0); +#endif + at_end = (thr->compile_ctx->lex.window[0].codepoint < 0); + + DUK_D(DUK_DPRINT("syntax error, determined at_end=%ld; curr_token.start_offset=%ld, " + "lex.input_length=%ld, window[0].codepoint=%ld, window[1].codepoint=%ld", + (long) at_end, + (long) thr->compile_ctx->curr_token.start_offset, + (long) thr->compile_ctx->lex.input_length, + (long) thr->compile_ctx->lex.window[0].codepoint, + (long) thr->compile_ctx->lex.window[1].codepoint)); + + duk_push_sprintf(thr, + " (line %ld%s)", + (long) thr->compile_ctx->curr_token.start_line, + at_end ? ", end of input" : ""); + duk_concat(thr, 2); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_MESSAGE); + } else { + duk_pop(thr); + } + + DUK_DDD(DUK_DDDPRINT("compile error, after adding line info: %!T", (duk_tval *) duk_get_tval(thr, -1))); +} +#endif /* DUK_USE_AUGMENT_ERROR_CREATE */ + +/* + * Augment an error being created using Duktape specific properties + * like _Tracedata or .fileName/.lineNumber. + */ + +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) +DUK_LOCAL void duk__err_augment_builtin_create(duk_hthread *thr, + duk_hthread *thr_callstack, + const char *c_filename, + duk_int_t c_line, + duk_hobject *obj, + duk_small_uint_t flags) { +#if defined(DUK_USE_ASSERTIONS) + duk_int_t entry_top; +#endif + +#if defined(DUK_USE_ASSERTIONS) + entry_top = duk_get_top(thr); +#endif + DUK_ASSERT(obj != NULL); + + DUK_UNREF(obj); /* unreferenced w/o tracebacks */ + + duk__add_compiler_error_line(thr); + +#if defined(DUK_USE_TRACEBACKS) + /* If tracebacks are enabled, the '_Tracedata' property is the only + * thing we need: 'fileName' and 'lineNumber' are virtual properties + * which use '_Tracedata'. (Check _Tracedata only as own property.) + */ + if (duk_hobject_find_entry_tval_ptr_stridx(thr->heap, obj, DUK_STRIDX_INT_TRACEDATA) != NULL) { + DUK_DDD(DUK_DDDPRINT("error value already has a '_Tracedata' property, not modifying it")); + } else { + duk__add_traceback(thr, thr_callstack, c_filename, c_line, flags); + } +#else + /* Without tracebacks the concrete .fileName and .lineNumber need + * to be added directly. + */ + duk__add_fileline(thr, thr_callstack, c_filename, c_line, flags); +#endif + +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(duk_get_top(thr) == entry_top); +#endif +} +#endif /* DUK_USE_AUGMENT_ERROR_CREATE */ + +/* + * Augment an error at creation time with _Tracedata/fileName/lineNumber + * and allow a user error handler (if defined) to process/replace the error. + * The error to be augmented is at the stack top. + * + * thr: thread containing the error value + * thr_callstack: thread which should be used for generating callstack etc. + * c_filename: C __FILE__ related to the error + * c_line: C __LINE__ related to the error + * flags & DUK_AUGMENT_FLAG_NOBLAME_FILELINE: + * if true, don't fileName/line as error source, otherwise use traceback + * (needed because user code filename/line are reported but internal ones + * are not) + */ + +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) +DUK_INTERNAL void duk_err_augment_error_create(duk_hthread *thr, + duk_hthread *thr_callstack, + const char *c_filename, + duk_int_t c_line, + duk_small_uint_t flags) { + duk_hobject *obj; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr_callstack != NULL); + + /* [ ... error ] */ + + /* + * Criteria for augmenting: + * + * - augmentation enabled in build (naturally) + * - error value internal prototype chain contains the built-in + * Error prototype object (i.e. 'val instanceof Error') + * + * Additional criteria for built-in augmenting: + * + * - error value is an extensible object + */ + + obj = duk_get_hobject(thr, -1); + if (!obj) { + DUK_DDD(DUK_DDDPRINT("value is not an object, skip both built-in and user augment")); + return; + } + if (!duk_hobject_prototype_chain_contains(thr, obj, thr->builtins[DUK_BIDX_ERROR_PROTOTYPE], 1 /*ignore_loop*/)) { + /* If the value has a prototype loop, it's critical not to + * throw here. Instead, assume the value is not to be + * augmented. + */ + DUK_DDD(DUK_DDDPRINT("value is not an error instance, skip both built-in and user augment")); + return; + } + if (DUK_HOBJECT_HAS_EXTENSIBLE(obj)) { + DUK_DDD(DUK_DDDPRINT("error meets criteria, built-in augment")); + duk__err_augment_builtin_create(thr, thr_callstack, c_filename, c_line, obj, flags); + } else { + DUK_DDD(DUK_DDDPRINT("error does not meet criteria, no built-in augment")); + } + + /* [ ... error ] */ + +#if defined(DUK_USE_ERRCREATE) + duk__err_augment_user(thr, DUK_STRIDX_ERR_CREATE); +#endif +} +#endif /* DUK_USE_AUGMENT_ERROR_CREATE */ + +/* + * Augment an error at throw time; allow a user error handler (if defined) + * to process/replace the error. The error to be augmented is at the + * stack top. + */ + +#if defined(DUK_USE_AUGMENT_ERROR_THROW) +DUK_INTERNAL void duk_err_augment_error_throw(duk_hthread *thr) { +#if defined(DUK_USE_ERRTHROW) + duk__err_augment_user(thr, DUK_STRIDX_ERR_THROW); +#endif /* DUK_USE_ERRTHROW */ +} +#endif /* DUK_USE_AUGMENT_ERROR_THROW */ +#line 1 "duk_error_longjmp.c" +/* + * Do a longjmp call, calling the fatal error handler if no + * catchpoint exists. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_PREFER_SIZE) +DUK_NORETURN(DUK_LOCAL_DECL void duk__uncaught_minimal(duk_hthread *thr)); +DUK_LOCAL void duk__uncaught_minimal(duk_hthread *thr) { + (void) duk_fatal(thr, "uncaught error"); + DUK_WO_NORETURN(return;); +} +#endif + +#if 0 +DUK_NORETURN(DUK_LOCAL_DECL void duk__uncaught_readable(duk_hthread *thr)); +DUK_LOCAL void duk__uncaught_readable(duk_hthread *thr) { + const char *summary; + char buf[DUK_USE_FATAL_MAXLEN]; + + summary = duk_push_string_tval_readable(thr, &thr->heap->lj.value1); + DUK_SNPRINTF(buf, sizeof(buf), "uncaught: %s", summary); + buf[sizeof(buf) - 1] = (char) 0; + (void) duk_fatal(thr, (const char *) buf); + DUK_WO_NORETURN(return;); +} +#endif + +#if !defined(DUK_USE_PREFER_SIZE) +DUK_NORETURN(DUK_LOCAL_DECL void duk__uncaught_error_aware(duk_hthread *thr)); +DUK_LOCAL void duk__uncaught_error_aware(duk_hthread *thr) { + const char *summary; + char buf[DUK_USE_FATAL_MAXLEN]; + + summary = duk_push_string_tval_readable_error(thr, &thr->heap->lj.value1); + DUK_ASSERT(summary != NULL); + DUK_SNPRINTF(buf, sizeof(buf), "uncaught: %s", summary); + buf[sizeof(buf) - 1] = (char) 0; + (void) duk_fatal(thr, (const char *) buf); + DUK_WO_NORETURN(return;); +} +#endif + +DUK_INTERNAL void duk_err_longjmp(duk_hthread *thr) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + + DUK_DD(DUK_DDPRINT("longjmp error: type=%d iserror=%d value1=%!T value2=%!T", + (int) thr->heap->lj.type, + (int) thr->heap->lj.iserror, + &thr->heap->lj.value1, + &thr->heap->lj.value2)); + + /* Prevent finalizer execution during error handling. All error + * handling sites will process pending finalizers once error handling + * is complete and we're ready for the side effects. Does not prevent + * refzero freeing or mark-and-sweep during error handling. + * + * NOTE: when we come here some calling code may have used DECREF + * NORZ macros without an explicit DUK_REFZERO_CHECK_xxx() call. + * We don't want to do it here because it would just check for + * pending finalizers and we prevent that explicitly. Instead, + * the error catcher will run the finalizers once error handling + * is complete. + */ + + DUK_ASSERT_LJSTATE_SET(thr->heap); + + thr->heap->pf_prevent_count++; + DUK_ASSERT(thr->heap->pf_prevent_count != 0); /* Wrap. */ + +#if defined(DUK_USE_ASSERTIONS) + /* XXX: set this immediately when longjmp state is set */ + DUK_ASSERT(thr->heap->error_not_allowed == 0); /* Detect error within critical section. */ + thr->heap->error_not_allowed = 1; +#endif + + DUK_DD(DUK_DDPRINT("about to longjmp, pf_prevent_count=%ld", (long) thr->heap->pf_prevent_count)); + + /* If we don't have a jmpbuf_ptr, there is little we can do except + * cause a fatal error. The caller's expectation is that we never + * return. + */ + if (!thr->heap->lj.jmpbuf_ptr) { + DUK_D(DUK_DPRINT("uncaught error: type=%d iserror=%d value1=%!T value2=%!T", + (int) thr->heap->lj.type, + (int) thr->heap->lj.iserror, + &thr->heap->lj.value1, + &thr->heap->lj.value2)); + +#if defined(DUK_USE_PREFER_SIZE) + duk__uncaught_minimal(thr); +#else + duk__uncaught_error_aware(thr); +#endif + DUK_UNREACHABLE(); + } + +#if defined(DUK_USE_CPP_EXCEPTIONS) + throw duk_internal_exception(); /* dummy */ +#else + DUK_LONGJMP(thr->heap->lj.jmpbuf_ptr->jb); +#endif + + DUK_UNREACHABLE(); +} +#line 1 "duk_error_misc.c" +/* + * Error helpers + */ + +/* #include duk_internal.h -> already included */ + +/* + * Helper to walk the thread chain and see if there is an active error + * catcher. Protected calls or finally blocks aren't considered catching. + */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) +DUK_LOCAL duk_bool_t duk__have_active_catcher(duk_hthread *thr) { + /* As noted above, a protected API call won't be counted as a + * catcher. This is usually convenient, e.g. in the case of a top- + * level duk_pcall(), but may not always be desirable. Perhaps add + * an argument to treat them as catchers? + */ + + duk_activation *act; + duk_catcher *cat; + + DUK_ASSERT(thr != NULL); + + for (; thr != NULL; thr = thr->resumer) { + for (act = thr->callstack_curr; act != NULL; act = act->parent) { + for (cat = act->cat; cat != NULL; cat = cat->parent) { + if (DUK_CAT_HAS_CATCH_ENABLED(cat)) { + return 1; /* all we need to know */ + } + } + } + } + return 0; +} +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + +/* + * Get prototype object for an integer error code. + */ + +DUK_INTERNAL duk_hobject *duk_error_prototype_from_code(duk_hthread *thr, duk_errcode_t code) { + switch (code) { + case DUK_ERR_EVAL_ERROR: + return thr->builtins[DUK_BIDX_EVAL_ERROR_PROTOTYPE]; + case DUK_ERR_RANGE_ERROR: + return thr->builtins[DUK_BIDX_RANGE_ERROR_PROTOTYPE]; + case DUK_ERR_REFERENCE_ERROR: + return thr->builtins[DUK_BIDX_REFERENCE_ERROR_PROTOTYPE]; + case DUK_ERR_SYNTAX_ERROR: + return thr->builtins[DUK_BIDX_SYNTAX_ERROR_PROTOTYPE]; + case DUK_ERR_TYPE_ERROR: + return thr->builtins[DUK_BIDX_TYPE_ERROR_PROTOTYPE]; + case DUK_ERR_URI_ERROR: + return thr->builtins[DUK_BIDX_URI_ERROR_PROTOTYPE]; + case DUK_ERR_ERROR: + default: + return thr->builtins[DUK_BIDX_ERROR_PROTOTYPE]; + } +} + +/* + * Helper for debugger throw notify and pause-on-uncaught integration. + */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) +DUK_INTERNAL void duk_err_check_debugger_integration(duk_hthread *thr) { + duk_bool_t uncaught; + duk_tval *tv_obj; + + /* If something is thrown with the debugger attached and nobody will + * catch it, execution is paused before the longjmp, turning over + * control to the debug client. This allows local state to be examined + * before the stack is unwound. Errors are not intercepted when debug + * message loop is active (e.g. for Eval). + */ + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + + /* XXX: Allow customizing the pause and notify behavior at runtime + * using debugger runtime flags. For now the behavior is fixed using + * config options. + */ + + if (!duk_debug_is_attached(thr->heap) || thr->heap->dbg_processing || thr->heap->lj.type != DUK_LJ_TYPE_THROW || + thr->heap->creating_error) { + DUK_D(DUK_DPRINT("skip debugger error integration; not attached, debugger processing, not THROW, or error thrown " + "while creating error")); + return; + } + + /* Don't intercept a DoubleError, we may have caused the initial double + * fault and attempting to intercept it will cause us to be called + * recursively and exhaust the C stack. (This should no longer happen + * for the initial throw because DoubleError path doesn't do a debugger + * integration check, but it might happen for rethrows.) + */ + tv_obj = &thr->heap->lj.value1; + if (DUK_TVAL_IS_OBJECT(tv_obj) && DUK_TVAL_GET_OBJECT(tv_obj) == thr->builtins[DUK_BIDX_DOUBLE_ERROR]) { + DUK_D(DUK_DPRINT("built-in DoubleError instance (re)thrown, not intercepting")); + return; + } + + uncaught = !duk__have_active_catcher(thr); + + /* Debugger code expects the value at stack top. This also serves + * as a backup: we need to store/restore the longjmp state because + * when the debugger is paused Eval commands may be executed and + * they can arbitrarily clobber the longjmp state. + */ + duk_push_tval(thr, tv_obj); + + /* Store and reset longjmp state. */ + DUK_ASSERT_LJSTATE_SET(thr->heap); + DUK_TVAL_DECREF_NORZ(thr, tv_obj); + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(&thr->heap->lj.value2)); /* Always for THROW type. */ + DUK_TVAL_SET_UNDEFINED(tv_obj); + thr->heap->lj.type = DUK_LJ_TYPE_UNKNOWN; + DUK_ASSERT_LJSTATE_UNSET(thr->heap); + +#if defined(DUK_USE_DEBUGGER_THROW_NOTIFY) + /* Report it to the debug client */ + DUK_D(DUK_DPRINT("throw with debugger attached, report to client")); + duk_debug_send_throw(thr, uncaught); +#endif + + if (uncaught) { + if (thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_UNCAUGHT_ERROR) { + DUK_D(DUK_DPRINT("PAUSE TRIGGERED by uncaught error")); + duk_debug_halt_execution(thr, 1 /*use_prev_pc*/); + } + } else { + if (thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_CAUGHT_ERROR) { + DUK_D(DUK_DPRINT("PAUSE TRIGGERED by caught error")); + duk_debug_halt_execution(thr, 1 /*use_prev_pc*/); + } + } + + /* Restore longjmp state. */ + DUK_ASSERT_LJSTATE_UNSET(thr->heap); + thr->heap->lj.type = DUK_LJ_TYPE_THROW; + tv_obj = DUK_GET_TVAL_NEGIDX(thr, -1); + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(&thr->heap->lj.value1)); + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(&thr->heap->lj.value2)); + DUK_TVAL_SET_TVAL(&thr->heap->lj.value1, tv_obj); + DUK_TVAL_INCREF(thr, tv_obj); + DUK_ASSERT_LJSTATE_SET(thr->heap); + + duk_pop(thr); +} +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + +/* + * Helpers for setting up heap longjmp state. + */ + +DUK_INTERNAL void duk_err_setup_ljstate1(duk_hthread *thr, duk_small_uint_t lj_type, duk_tval *tv_val) { + duk_heap *heap; + + DUK_ASSERT(thr != NULL); + heap = thr->heap; + DUK_ASSERT(heap != NULL); + DUK_ASSERT(tv_val != NULL); + + DUK_ASSERT_LJSTATE_UNSET(heap); + + heap->lj.type = lj_type; + DUK_TVAL_SET_TVAL(&heap->lj.value1, tv_val); + DUK_TVAL_INCREF(thr, tv_val); + + DUK_ASSERT_LJSTATE_SET(heap); +} +#line 1 "duk_error_throw.c" +/* + * Create and throw an ECMAScript error object based on a code and a message. + * + * Used when we throw errors internally. ECMAScript generated error objects + * are created by ECMAScript code, and the throwing is handled by the bytecode + * executor. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Create and throw an error (originating from Duktape internally) + * + * Push an error object on top of the stack, possibly throw augmenting + * the error, and finally longjmp. + * + * If an error occurs while we're dealing with the current error, we might + * enter an infinite recursion loop. This is prevented by detecting a + * "double fault" through the heap->creating_error flag; the recursion + * then stops at the second level. + */ + +#if defined(DUK_USE_VERBOSE_ERRORS) +DUK_INTERNAL void duk_err_create_and_throw(duk_hthread *thr, + duk_errcode_t code, + const char *msg, + const char *filename, + duk_int_t line) { +#else +DUK_INTERNAL void duk_err_create_and_throw(duk_hthread *thr, duk_errcode_t code) { +#endif +#if defined(DUK_USE_VERBOSE_ERRORS) + DUK_DD(DUK_DDPRINT("duk_err_create_and_throw(): code=%ld, msg=%s, filename=%s, line=%ld", + (long) code, + (const char *) msg, + (const char *) filename, + (long) line)); +#else + DUK_DD(DUK_DDPRINT("duk_err_create_and_throw(): code=%ld", (long) code)); +#endif + + DUK_ASSERT(thr != NULL); + + /* Even though nested call is possible because we throw an error when + * trying to create an error, the potential errors must happen before + * the longjmp state is configured. + */ + DUK_ASSERT_LJSTATE_UNSET(thr->heap); + + /* Sync so that augmentation sees up-to-date activations, NULL + * thr->ptr_curr_pc so that it's not used if side effects occur + * in augmentation or longjmp handling. + */ + duk_hthread_sync_and_null_currpc(thr); + + /* + * Create and push an error object onto the top of stack. + * The error is potentially augmented before throwing. + * + * If a "double error" occurs, use a fixed error instance + * to avoid further trouble. + */ + + if (thr->heap->creating_error) { + duk_tval tv_val; + duk_hobject *h_err; + + thr->heap->creating_error = 0; + + h_err = thr->builtins[DUK_BIDX_DOUBLE_ERROR]; + if (h_err != NULL) { + DUK_D(DUK_DPRINT("double fault detected -> use built-in fixed 'double error' instance")); + DUK_TVAL_SET_OBJECT(&tv_val, h_err); + } else { + DUK_D(DUK_DPRINT("double fault detected; there is no built-in fixed 'double error' instance " + "-> use the error code as a number")); + DUK_TVAL_SET_I32(&tv_val, (duk_int32_t) code); + } + + duk_err_setup_ljstate1(thr, DUK_LJ_TYPE_THROW, &tv_val); + + /* No augmentation to avoid any allocations or side effects. */ + } else { + /* Prevent infinite recursion. Extra call stack and C + * recursion headroom (see GH-191) is added for augmentation. + * That is now signalled by heap->augmenting error and taken + * into account in call handling without an explicit limit bump. + */ + thr->heap->creating_error = 1; + + duk_require_stack(thr, 1); + + /* XXX: usually unnecessary '%s' formatting here, but cannot + * use 'msg' as a format string directly. + */ +#if defined(DUK_USE_VERBOSE_ERRORS) + duk_push_error_object_raw(thr, code | DUK_ERRCODE_FLAG_NOBLAME_FILELINE, filename, line, "%s", (const char *) msg); +#else + duk_push_error_object_raw(thr, code | DUK_ERRCODE_FLAG_NOBLAME_FILELINE, NULL, 0, NULL); +#endif + + /* Note that an alloc error may happen during error augmentation. + * This may happen both when the original error is an alloc error + * and when it's something else. Because any error in augmentation + * must be handled correctly anyway, there's no special check for + * avoiding it for alloc errors (this differs from Duktape 1.x). + */ +#if defined(DUK_USE_AUGMENT_ERROR_THROW) + DUK_DDD(DUK_DDDPRINT("THROW ERROR (INTERNAL): %!iT (before throw augment)", (duk_tval *) duk_get_tval(thr, -1))); + duk_err_augment_error_throw(thr); +#endif + + duk_err_setup_ljstate1(thr, DUK_LJ_TYPE_THROW, DUK_GET_TVAL_NEGIDX(thr, -1)); + thr->heap->creating_error = 0; + + /* Error is now created and we assume no errors can occur any + * more. Check for debugger Throw integration only when the + * error is complete. If we enter debugger message loop, + * creating_error must be 0 so that errors can be thrown in + * the paused state, e.g. in Eval commands. + */ +#if defined(DUK_USE_DEBUGGER_SUPPORT) + duk_err_check_debugger_integration(thr); +#endif + } + + /* + * Finally, longjmp + */ + + DUK_DDD(DUK_DDDPRINT("THROW ERROR (INTERNAL): %!iT, %!iT (after throw augment)", + (duk_tval *) &thr->heap->lj.value1, + (duk_tval *) &thr->heap->lj.value2)); + + duk_err_longjmp(thr); + DUK_UNREACHABLE(); +} + +/* + * Helper for C function call negative return values. + */ + +DUK_INTERNAL void duk_error_throw_from_negative_rc(duk_hthread *thr, duk_ret_t rc) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(rc < 0); + + /* + * The __FILE__ and __LINE__ information is intentionally not used in the + * creation of the error object, as it isn't useful in the tracedata. The + * tracedata still contains the function which returned the negative return + * code, and having the file/line of this function isn't very useful. + * + * The error messages for DUK_RET_xxx shorthand are intentionally very + * minimal: they're only really useful for low memory targets. + */ + + duk_error_raw(thr, -rc, NULL, 0, "error (rc %ld)", (long) rc); + DUK_WO_NORETURN(return;); +} +#line 1 "duk_hbuffer_alloc.c" +/* + * duk_hbuffer allocation and freeing. + */ + +/* #include duk_internal.h -> already included */ + +/* Allocate a new duk_hbuffer of a certain type and return a pointer to it + * (NULL on error). Write buffer data pointer to 'out_bufdata' (only if + * allocation successful). + */ +DUK_INTERNAL duk_hbuffer *duk_hbuffer_alloc(duk_heap *heap, duk_size_t size, duk_small_uint_t flags, void **out_bufdata) { + duk_hbuffer *res = NULL; + duk_size_t header_size; + duk_size_t alloc_size; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(out_bufdata != NULL); + + DUK_DDD(DUK_DDDPRINT("allocate hbuffer")); + + /* Size sanity check. Should not be necessary because caller is + * required to check this, but we don't want to cause a segfault + * if the size wraps either in duk_size_t computation or when + * storing the size in a 16-bit field. + */ + if (size > DUK_HBUFFER_MAX_BYTELEN) { + DUK_D(DUK_DPRINT("hbuffer alloc failed: size too large: %ld", (long) size)); + return NULL; /* no need to write 'out_bufdata' */ + } + + if (flags & DUK_BUF_FLAG_EXTERNAL) { + header_size = sizeof(duk_hbuffer_external); + alloc_size = sizeof(duk_hbuffer_external); + } else if (flags & DUK_BUF_FLAG_DYNAMIC) { + header_size = sizeof(duk_hbuffer_dynamic); + alloc_size = sizeof(duk_hbuffer_dynamic); + } else { + header_size = sizeof(duk_hbuffer_fixed); + alloc_size = sizeof(duk_hbuffer_fixed) + size; + DUK_ASSERT(alloc_size >= sizeof(duk_hbuffer_fixed)); /* no wrapping */ + } + + res = (duk_hbuffer *) DUK_ALLOC(heap, alloc_size); + if (DUK_UNLIKELY(res == NULL)) { + goto alloc_error; + } + + /* zero everything unless requested not to do so */ +#if defined(DUK_USE_ZERO_BUFFER_DATA) + duk_memzero((void *) res, (flags & DUK_BUF_FLAG_NOZERO) ? header_size : alloc_size); +#else + duk_memzero((void *) res, header_size); +#endif + + if (flags & DUK_BUF_FLAG_EXTERNAL) { + duk_hbuffer_external *h; + h = (duk_hbuffer_external *) res; + DUK_UNREF(h); + *out_bufdata = NULL; +#if defined(DUK_USE_EXPLICIT_NULL_INIT) +#if defined(DUK_USE_HEAPPTR16) +/* the compressed pointer is zeroed which maps to NULL, so nothing to do. */ +#else + DUK_HBUFFER_EXTERNAL_SET_DATA_PTR(heap, h, NULL); +#endif +#endif + DUK_ASSERT(DUK_HBUFFER_EXTERNAL_GET_DATA_PTR(heap, h) == NULL); + } else if (flags & DUK_BUF_FLAG_DYNAMIC) { + duk_hbuffer_dynamic *h = (duk_hbuffer_dynamic *) res; + void *ptr; + + if (size > 0) { + DUK_ASSERT(!(flags & DUK_BUF_FLAG_EXTERNAL)); /* alloc external with size zero */ + DUK_DDD(DUK_DDDPRINT("dynamic buffer with nonzero size, alloc actual buffer")); +#if defined(DUK_USE_ZERO_BUFFER_DATA) + ptr = DUK_ALLOC_ZEROED(heap, size); +#else + ptr = DUK_ALLOC(heap, size); +#endif + if (DUK_UNLIKELY(ptr == NULL)) { + /* Because size > 0, NULL check is correct */ + goto alloc_error; + } + *out_bufdata = ptr; + + DUK_HBUFFER_DYNAMIC_SET_DATA_PTR(heap, h, ptr); + } else { + *out_bufdata = NULL; +#if defined(DUK_USE_EXPLICIT_NULL_INIT) +#if defined(DUK_USE_HEAPPTR16) +/* the compressed pointer is zeroed which maps to NULL, so nothing to do. */ +#else + DUK_HBUFFER_DYNAMIC_SET_DATA_PTR(heap, h, NULL); +#endif +#endif + DUK_ASSERT(DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(heap, h) == NULL); + } + } else { + *out_bufdata = (void *) ((duk_hbuffer_fixed *) (void *) res + 1); + } + + DUK_HBUFFER_SET_SIZE(res, size); + + DUK_HEAPHDR_SET_TYPE(&res->hdr, DUK_HTYPE_BUFFER); + if (flags & DUK_BUF_FLAG_DYNAMIC) { + DUK_HBUFFER_SET_DYNAMIC(res); + if (flags & DUK_BUF_FLAG_EXTERNAL) { + DUK_HBUFFER_SET_EXTERNAL(res); + } + } else { + DUK_ASSERT(!(flags & DUK_BUF_FLAG_EXTERNAL)); + } + DUK_HEAP_INSERT_INTO_HEAP_ALLOCATED(heap, &res->hdr); + + DUK_DDD(DUK_DDDPRINT("allocated hbuffer: %p", (void *) res)); + return res; + +alloc_error: + DUK_DD(DUK_DDPRINT("hbuffer allocation failed")); + + DUK_FREE(heap, res); + return NULL; /* no need to write 'out_bufdata' */ +} + +/* For indirect allocs. */ + +DUK_INTERNAL void *duk_hbuffer_get_dynalloc_ptr(duk_heap *heap, void *ud) { + duk_hbuffer_dynamic *buf = (duk_hbuffer_dynamic *) ud; + DUK_UNREF(heap); + return (void *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(heap, buf); +} +#line 1 "duk_hbuffer_assert.c" +/* + * duk_hbuffer assertion helpers + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_ASSERTIONS) + +DUK_INTERNAL void duk_hbuffer_assert_valid(duk_hbuffer *h) { + DUK_ASSERT(h != NULL); +} + +#endif /* DUK_USE_ASSERTIONS */ +#line 1 "duk_hbuffer_ops.c" +/* + * duk_hbuffer operations such as resizing and inserting/appending data to + * a dynamic buffer. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Resizing + */ + +DUK_INTERNAL void duk_hbuffer_resize(duk_hthread *thr, duk_hbuffer_dynamic *buf, duk_size_t new_size) { + void *res; + duk_size_t prev_size; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(buf != NULL); + DUK_ASSERT(DUK_HBUFFER_HAS_DYNAMIC(buf)); + DUK_ASSERT(!DUK_HBUFFER_HAS_EXTERNAL(buf)); + + /* + * Maximum size check + */ + + if (new_size > DUK_HBUFFER_MAX_BYTELEN) { + DUK_ERROR_RANGE(thr, "buffer too long"); + DUK_WO_NORETURN(return;); + } + + /* + * Note: use indirect realloc variant just in case mark-and-sweep + * (finalizers) might resize this same buffer during garbage + * collection. + */ + + res = DUK_REALLOC_INDIRECT(thr->heap, duk_hbuffer_get_dynalloc_ptr, (void *) buf, new_size); + if (DUK_LIKELY(res != NULL || new_size == 0)) { + /* 'res' may be NULL if new allocation size is 0. */ + + DUK_DDD(DUK_DDDPRINT("resized dynamic buffer %p:%ld -> %p:%ld", + (void *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(thr->heap, buf), + (long) DUK_HBUFFER_DYNAMIC_GET_SIZE(buf), + (void *) res, + (long) new_size)); + + /* + * The entire allocated buffer area, regardless of actual used + * size, is kept zeroed in resizes for simplicity. If the buffer + * is grown, zero the new part. + */ + + prev_size = DUK_HBUFFER_DYNAMIC_GET_SIZE(buf); + if (new_size > prev_size) { + DUK_ASSERT(new_size - prev_size > 0); +#if defined(DUK_USE_ZERO_BUFFER_DATA) + duk_memzero((void *) ((char *) res + prev_size), (duk_size_t) (new_size - prev_size)); +#endif + } + + DUK_HBUFFER_DYNAMIC_SET_SIZE(buf, new_size); + DUK_HBUFFER_DYNAMIC_SET_DATA_PTR(thr->heap, buf, res); + } else { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return;); + } + + DUK_ASSERT(res != NULL || new_size == 0); +} + +DUK_INTERNAL void duk_hbuffer_reset(duk_hthread *thr, duk_hbuffer_dynamic *buf) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(buf != NULL); + DUK_ASSERT(DUK_HBUFFER_HAS_DYNAMIC(buf)); + DUK_ASSERT(!DUK_HBUFFER_HAS_EXTERNAL(buf)); + + duk_hbuffer_resize(thr, buf, 0); +} +/* #include duk_internal.h -> already included */ +#line 2 "duk_hbufobj_misc.c" + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_uint_t duk_hbufobj_clamp_bytelength(duk_hbufobj *h_bufobj, duk_uint_t len) { + duk_uint_t buf_size; + duk_uint_t buf_avail; + + DUK_ASSERT(h_bufobj != NULL); + DUK_ASSERT(h_bufobj->buf != NULL); + + buf_size = (duk_uint_t) DUK_HBUFFER_GET_SIZE(h_bufobj->buf); + if (h_bufobj->offset > buf_size) { + /* Slice starting point is beyond current length. */ + return 0; + } + buf_avail = buf_size - h_bufobj->offset; + + return buf_avail >= len ? len : buf_avail; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ +#line 1 "duk_heap_alloc.c" +/* + * duk_heap allocation and freeing. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_ROM_STRINGS) +/* Fixed seed value used with ROM strings. */ +#define DUK__FIXED_HASH_SEED 0xabcd1234 +#endif + +/* + * Free a heap object. + * + * Free heap object and its internal (non-heap) pointers. Assumes that + * caller has removed the object from heap allocated list or the string + * intern table, and any weak references (which strings may have) have + * been already dealt with. + */ + +DUK_INTERNAL void duk_free_hobject(duk_heap *heap, duk_hobject *h) { + DUK_ASSERT(heap != NULL); + DUK_ASSERT(h != NULL); + + DUK_FREE(heap, DUK_HOBJECT_GET_PROPS(heap, h)); + + if (DUK_HOBJECT_IS_COMPFUNC(h)) { + duk_hcompfunc *f = (duk_hcompfunc *) h; + DUK_UNREF(f); + /* Currently nothing to free; 'data' is a heap object */ + } else if (DUK_HOBJECT_IS_NATFUNC(h)) { + duk_hnatfunc *f = (duk_hnatfunc *) h; + DUK_UNREF(f); + /* Currently nothing to free */ + } else if (DUK_HOBJECT_IS_THREAD(h)) { + duk_hthread *t = (duk_hthread *) h; + duk_activation *act; + + DUK_FREE(heap, t->valstack); + + /* Don't free h->resumer because it exists in the heap. + * Callstack entries also contain function pointers which + * are not freed for the same reason. They are decref + * finalized and the targets are freed if necessary based + * on their refcount (or reachability). + */ + for (act = t->callstack_curr; act != NULL;) { + duk_activation *act_next; + duk_catcher *cat; + + for (cat = act->cat; cat != NULL;) { + duk_catcher *cat_next; + + cat_next = cat->parent; + DUK_FREE(heap, (void *) cat); + cat = cat_next; + } + + act_next = act->parent; + DUK_FREE(heap, (void *) act); + act = act_next; + } + + /* XXX: with 'caller' property the callstack would need + * to be unwound to update the 'caller' properties of + * functions in the callstack. + */ + } else if (DUK_HOBJECT_IS_BOUNDFUNC(h)) { + duk_hboundfunc *f = (duk_hboundfunc *) (void *) h; + + DUK_FREE(heap, f->args); + } + + DUK_FREE(heap, (void *) h); +} + +DUK_INTERNAL void duk_free_hbuffer(duk_heap *heap, duk_hbuffer *h) { + DUK_ASSERT(heap != NULL); + DUK_ASSERT(h != NULL); + + if (DUK_HBUFFER_HAS_DYNAMIC(h) && !DUK_HBUFFER_HAS_EXTERNAL(h)) { + duk_hbuffer_dynamic *g = (duk_hbuffer_dynamic *) h; + DUK_DDD(DUK_DDDPRINT("free dynamic buffer %p", (void *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(heap, g))); + DUK_FREE(heap, DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(heap, g)); + } + DUK_FREE(heap, (void *) h); +} + +DUK_INTERNAL void duk_free_hstring(duk_heap *heap, duk_hstring *h) { + DUK_ASSERT(heap != NULL); + DUK_ASSERT(h != NULL); + + DUK_UNREF(heap); + DUK_UNREF(h); + +#if defined(DUK_USE_HSTRING_EXTDATA) && defined(DUK_USE_EXTSTR_FREE) + if (DUK_HSTRING_HAS_EXTDATA(h)) { + DUK_DDD( + DUK_DDDPRINT("free extstr: hstring %!O, extdata: %p", h, DUK_HSTRING_GET_EXTDATA((duk_hstring_external *) h))); + DUK_USE_EXTSTR_FREE(heap->heap_udata, (const void *) DUK_HSTRING_GET_EXTDATA((duk_hstring_external *) h)); + } +#endif + DUK_FREE(heap, (void *) h); +} + +DUK_INTERNAL void duk_heap_free_heaphdr_raw(duk_heap *heap, duk_heaphdr *hdr) { + DUK_ASSERT(heap); + DUK_ASSERT(hdr); + + DUK_DDD(DUK_DDDPRINT("free heaphdr %p, htype %ld", (void *) hdr, (long) DUK_HEAPHDR_GET_TYPE(hdr))); + + switch (DUK_HEAPHDR_GET_TYPE(hdr)) { + case DUK_HTYPE_STRING: + duk_free_hstring(heap, (duk_hstring *) hdr); + break; + case DUK_HTYPE_OBJECT: + duk_free_hobject(heap, (duk_hobject *) hdr); + break; + default: + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(hdr) == DUK_HTYPE_BUFFER); + duk_free_hbuffer(heap, (duk_hbuffer *) hdr); + } +} + +/* + * Free the heap. + * + * Frees heap-related non-heap-tracked allocations such as the + * string intern table; then frees the heap allocated objects; + * and finally frees the heap structure itself. Reference counts + * and GC markers are ignored (and not updated) in this process, + * and finalizers won't be called. + * + * The heap pointer and heap object pointers must not be used + * after this call. + */ + +#if defined(DUK_USE_CACHE_ACTIVATION) +DUK_LOCAL duk_size_t duk__heap_free_activation_freelist(duk_heap *heap) { + duk_activation *act; + duk_activation *act_next; + duk_size_t count_act = 0; + + for (act = heap->activation_free; act != NULL;) { + act_next = act->parent; + DUK_FREE(heap, (void *) act); + act = act_next; +#if defined(DUK_USE_DEBUG) + count_act++; +#endif + } + heap->activation_free = NULL; /* needed when called from mark-and-sweep */ + return count_act; +} +#endif /* DUK_USE_CACHE_ACTIVATION */ + +#if defined(DUK_USE_CACHE_CATCHER) +DUK_LOCAL duk_size_t duk__heap_free_catcher_freelist(duk_heap *heap) { + duk_catcher *cat; + duk_catcher *cat_next; + duk_size_t count_cat = 0; + + for (cat = heap->catcher_free; cat != NULL;) { + cat_next = cat->parent; + DUK_FREE(heap, (void *) cat); + cat = cat_next; +#if defined(DUK_USE_DEBUG) + count_cat++; +#endif + } + heap->catcher_free = NULL; /* needed when called from mark-and-sweep */ + + return count_cat; +} +#endif /* DUK_USE_CACHE_CATCHER */ + +DUK_INTERNAL void duk_heap_free_freelists(duk_heap *heap) { + duk_size_t count_act = 0; + duk_size_t count_cat = 0; + +#if defined(DUK_USE_CACHE_ACTIVATION) + count_act = duk__heap_free_activation_freelist(heap); +#endif +#if defined(DUK_USE_CACHE_CATCHER) + count_cat = duk__heap_free_catcher_freelist(heap); +#endif + DUK_UNREF(heap); + DUK_UNREF(count_act); + DUK_UNREF(count_cat); + + DUK_D( + DUK_DPRINT("freed %ld activation freelist entries, %ld catcher freelist entries", (long) count_act, (long) count_cat)); +} + +DUK_LOCAL void duk__free_allocated(duk_heap *heap) { + duk_heaphdr *curr; + duk_heaphdr *next; + + curr = heap->heap_allocated; + while (curr) { + /* We don't log or warn about freeing zero refcount objects + * because they may happen with finalizer processing. + */ + + DUK_DDD(DUK_DDDPRINT("FINALFREE (allocated): %!iO", (duk_heaphdr *) curr)); + next = DUK_HEAPHDR_GET_NEXT(heap, curr); + duk_heap_free_heaphdr_raw(heap, curr); + curr = next; + } +} + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_LOCAL void duk__free_finalize_list(duk_heap *heap) { + duk_heaphdr *curr; + duk_heaphdr *next; + + curr = heap->finalize_list; + while (curr) { + DUK_DDD(DUK_DDDPRINT("FINALFREE (finalize_list): %!iO", (duk_heaphdr *) curr)); + next = DUK_HEAPHDR_GET_NEXT(heap, curr); + duk_heap_free_heaphdr_raw(heap, curr); + curr = next; + } +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +DUK_LOCAL void duk__free_stringtable(duk_heap *heap) { + /* strings are only tracked by stringtable */ + duk_heap_strtable_free(heap); +} + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_LOCAL void duk__free_run_finalizers(duk_heap *heap) { + duk_heaphdr *curr; + duk_uint_t round_no; + duk_size_t count_all; + duk_size_t count_finalized; + duk_size_t curr_limit; + + DUK_ASSERT(heap != NULL); + +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(heap->refzero_list == NULL); /* refzero not running -> must be empty */ +#endif + DUK_ASSERT(heap->finalize_list == NULL); /* mark-and-sweep last pass */ + + if (heap->heap_thread == NULL) { + /* May happen when heap allocation fails right off. There + * cannot be any finalizable objects in this case. + */ + DUK_D(DUK_DPRINT("no heap_thread in heap destruct, assume no finalizable objects")); + return; + } + + /* Prevent finalize_list processing and mark-and-sweep entirely. + * Setting ms_running != 0 also prevents refzero handling from moving + * objects away from the heap_allocated list. The flag name is a bit + * misleading here. + * + * Use a distinct value for ms_running here (== 2) so that assertions + * can detect this situation separate from the normal runtime + * mark-and-sweep case. This allows better assertions (GH-2030). + */ + DUK_ASSERT(heap->pf_prevent_count == 0); + DUK_ASSERT(heap->ms_running == 0); + DUK_ASSERT(heap->ms_prevent_count == 0); + heap->pf_prevent_count = 1; + heap->ms_running = 2; /* Use distinguishable value. */ + heap->ms_prevent_count = 1; /* Bump, because mark-and-sweep assumes it's bumped when ms_running is set. */ + + curr_limit = 0; /* suppress warning, not used */ + for (round_no = 0;; round_no++) { + curr = heap->heap_allocated; + count_all = 0; + count_finalized = 0; + while (curr) { + count_all++; + if (DUK_HEAPHDR_IS_OBJECT(curr)) { + /* Only objects in heap_allocated may have finalizers. Check that + * the object itself has a _Finalizer property (own or inherited) + * so that we don't execute finalizers for e.g. Proxy objects. + */ + DUK_ASSERT(curr != NULL); + + if (DUK_HOBJECT_HAS_FINALIZER_FAST(heap, (duk_hobject *) curr)) { + if (!DUK_HEAPHDR_HAS_FINALIZED((duk_heaphdr *) curr)) { + DUK_ASSERT( + DUK_HEAP_HAS_FINALIZER_NORESCUE(heap)); /* maps to finalizer 2nd argument */ + duk_heap_run_finalizer(heap, (duk_hobject *) curr); + count_finalized++; + } + } + } + curr = DUK_HEAPHDR_GET_NEXT(heap, curr); + } + + /* Each round of finalizer execution may spawn new finalizable objects + * which is normal behavior for some applications. Allow multiple + * rounds of finalization, but use a shrinking limit based on the + * first round to detect the case where a runaway finalizer creates + * an unbounded amount of new finalizable objects. Finalizer rescue + * is not supported: the semantics are unclear because most of the + * objects being finalized here are already reachable. The finalizer + * is given a boolean to indicate that rescue is not possible. + * + * See discussion in: https://github.com/svaarala/duktape/pull/473 + */ + + if (round_no == 0) { + /* Cannot wrap: each object is at least 8 bytes so count is + * at most 1/8 of that. + */ + curr_limit = count_all * 2; + } else { + curr_limit = (curr_limit * 3) / 4; /* Decrease by 25% every round */ + } + DUK_D(DUK_DPRINT("finalizer round %ld complete, %ld objects, tried to execute %ld finalizers, current limit is %ld", + (long) round_no, + (long) count_all, + (long) count_finalized, + (long) curr_limit)); + + if (count_finalized == 0) { + DUK_D(DUK_DPRINT("no more finalizable objects, forced finalization finished")); + break; + } + if (count_finalized >= curr_limit) { + DUK_D(DUK_DPRINT("finalizer count above limit, potentially runaway finalizer; skip remaining finalizers")); + break; + } + } + + DUK_ASSERT(heap->ms_running == 2); + DUK_ASSERT(heap->pf_prevent_count == 1); + heap->ms_running = 0; + heap->pf_prevent_count = 0; +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +DUK_INTERNAL void duk_heap_free(duk_heap *heap) { + DUK_D(DUK_DPRINT("free heap: %p", (void *) heap)); + +#if defined(DUK_USE_DEBUG) + duk_heap_strtable_dump(heap); +#endif + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + /* Detach a debugger if attached (can be called multiple times) + * safely. + */ + /* XXX: Add a flag to reject an attempt to re-attach? Otherwise + * the detached callback may immediately reattach. + */ + duk_debug_do_detach(heap); +#endif + + /* Execute finalizers before freeing the heap, even for reachable + * objects. This gives finalizers the chance to free any native + * resources like file handles, allocations made outside Duktape, + * etc. This is quite tricky to get right, so that all finalizer + * guarantees are honored. + * + * Run mark-and-sweep a few times just in case (unreachable object + * finalizers run already here). The last round must rescue objects + * from the previous round without running any more finalizers. This + * ensures rescued objects get their FINALIZED flag cleared so that + * their finalizer is called once more in forced finalization to + * satisfy finalizer guarantees. However, we don't want to run any + * more finalizers because that'd required one more loop, and so on. + * + * XXX: this perhaps requires an execution time limit. + */ + DUK_D(DUK_DPRINT("execute finalizers before freeing heap")); + DUK_ASSERT(heap->pf_skip_finalizers == 0); + DUK_D(DUK_DPRINT("forced gc #1 in heap destruction")); + duk_heap_mark_and_sweep(heap, 0); + DUK_D(DUK_DPRINT("forced gc #2 in heap destruction")); + duk_heap_mark_and_sweep(heap, 0); + DUK_D(DUK_DPRINT("forced gc #3 in heap destruction (don't run finalizers)")); + heap->pf_skip_finalizers = 1; + duk_heap_mark_and_sweep(heap, 0); /* Skip finalizers; queue finalizable objects to heap_allocated. */ + + /* There are never objects in refzero_list at this point, or at any + * point beyond a DECREF (even a DECREF_NORZ). Since Duktape 2.1 + * refzero_list processing is side effect free, so it is always + * processed to completion by a DECREF initially triggering a zero + * refcount. + */ +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(heap->refzero_list == NULL); /* Always processed to completion inline. */ +#endif +#if defined(DUK_USE_FINALIZER_SUPPORT) + DUK_ASSERT(heap->finalize_list == NULL); /* Last mark-and-sweep with skip_finalizers. */ +#endif + +#if defined(DUK_USE_FINALIZER_SUPPORT) + DUK_D(DUK_DPRINT("run finalizers for remaining finalizable objects")); + DUK_HEAP_SET_FINALIZER_NORESCUE(heap); /* Rescue no longer supported. */ + duk__free_run_finalizers(heap); +#endif /* DUK_USE_FINALIZER_SUPPORT */ + + /* Note: heap->heap_thread, heap->curr_thread, and heap->heap_object + * are on the heap allocated list. + */ + + DUK_D(DUK_DPRINT("freeing temporary freelists")); + duk_heap_free_freelists(heap); + + DUK_D(DUK_DPRINT("freeing heap_allocated of heap: %p", (void *) heap)); + duk__free_allocated(heap); + +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(heap->refzero_list == NULL); /* Always processed to completion inline. */ +#endif + +#if defined(DUK_USE_FINALIZER_SUPPORT) + DUK_D(DUK_DPRINT("freeing finalize_list of heap: %p", (void *) heap)); + duk__free_finalize_list(heap); +#endif + + DUK_D(DUK_DPRINT("freeing string table of heap: %p", (void *) heap)); + duk__free_stringtable(heap); + + DUK_D(DUK_DPRINT("freeing heap structure: %p", (void *) heap)); + heap->free_func(heap->heap_udata, heap); +} + +/* + * Allocate a heap. + * + * String table is initialized with built-in strings from genbuiltins.py, + * either by dynamically creating the strings or by referring to ROM strings. + */ + +#if defined(DUK_USE_ROM_STRINGS) +DUK_LOCAL duk_bool_t duk__init_heap_strings(duk_heap *heap) { +#if defined(DUK_USE_ASSERTIONS) + duk_small_uint_t i; +#endif + + DUK_UNREF(heap); + + /* With ROM-based strings, heap->strs[] and thr->strs[] are omitted + * so nothing to initialize for strs[]. + */ + +#if defined(DUK_USE_ASSERTIONS) + for (i = 0; i < sizeof(duk_rom_strings_lookup) / sizeof(const duk_hstring *); i++) { + const duk_hstring *h; + duk_uint32_t hash; + + h = duk_rom_strings_lookup[i]; + while (h != NULL) { + hash = duk_heap_hashstring(heap, (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h), DUK_HSTRING_GET_BYTELEN(h)); + DUK_DD(DUK_DDPRINT("duk_rom_strings_lookup[%d] -> hash 0x%08lx, computed 0x%08lx", + (int) i, + (unsigned long) DUK_HSTRING_GET_HASH(h), + (unsigned long) hash)); + DUK_ASSERT(hash == (duk_uint32_t) DUK_HSTRING_GET_HASH(h)); + + h = (const duk_hstring *) h->hdr.h_next; + } + } +#endif + return 1; +} +#else /* DUK_USE_ROM_STRINGS */ + +DUK_LOCAL duk_bool_t duk__init_heap_strings(duk_heap *heap) { + duk_bitdecoder_ctx bd_ctx; + duk_bitdecoder_ctx *bd = &bd_ctx; /* convenience */ + duk_small_uint_t i; + + duk_memzero(&bd_ctx, sizeof(bd_ctx)); + bd->data = (const duk_uint8_t *) duk_strings_data; + bd->length = (duk_size_t) DUK_STRDATA_DATA_LENGTH; + + for (i = 0; i < DUK_HEAP_NUM_STRINGS; i++) { + duk_uint8_t tmp[DUK_STRDATA_MAX_STRLEN]; + duk_small_uint_t len; + duk_hstring *h; + + len = duk_bd_decode_bitpacked_string(bd, tmp); + + /* No need to length check string: it will never exceed even + * the 16-bit length maximum. + */ + DUK_ASSERT(len <= 0xffffUL); + DUK_DDD(DUK_DDDPRINT("intern built-in string %ld", (long) i)); + h = duk_heap_strtable_intern(heap, tmp, len); + if (!h) { + goto failed; + } + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) h)); + + /* Special flags checks. Since these strings are always + * reachable and a string cannot appear twice in the string + * table, there's no need to check/set these flags elsewhere. + * The 'internal' flag is set by string intern code. + */ + if (i == DUK_STRIDX_EVAL || i == DUK_STRIDX_LC_ARGUMENTS) { + DUK_HSTRING_SET_EVAL_OR_ARGUMENTS(h); + } + if (i >= DUK_STRIDX_START_RESERVED && i < DUK_STRIDX_END_RESERVED) { + DUK_HSTRING_SET_RESERVED_WORD(h); + if (i >= DUK_STRIDX_START_STRICT_RESERVED) { + DUK_HSTRING_SET_STRICT_RESERVED_WORD(h); + } + } + + DUK_DDD(DUK_DDDPRINT("interned: %!O", (duk_heaphdr *) h)); + + /* XXX: The incref macro takes a thread pointer but doesn't + * use it right now. + */ + DUK_HSTRING_INCREF(_never_referenced_, h); + +#if defined(DUK_USE_HEAPPTR16) + heap->strs16[i] = DUK_USE_HEAPPTR_ENC16(heap->heap_udata, (void *) h); +#else + heap->strs[i] = h; +#endif + } + + return 1; + +failed: + return 0; +} +#endif /* DUK_USE_ROM_STRINGS */ + +DUK_LOCAL duk_bool_t duk__init_heap_thread(duk_heap *heap) { + duk_hthread *thr; + + DUK_D(DUK_DPRINT("heap init: alloc heap thread")); + thr = duk_hthread_alloc_unchecked(heap, DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_THREAD)); + if (thr == NULL) { + DUK_D(DUK_DPRINT("failed to alloc heap_thread")); + return 0; + } + thr->state = DUK_HTHREAD_STATE_INACTIVE; +#if defined(DUK_USE_ROM_STRINGS) + /* No strs[] pointer. */ +#else /* DUK_USE_ROM_STRINGS */ +#if defined(DUK_USE_HEAPPTR16) + thr->strs16 = heap->strs16; +#else + thr->strs = heap->strs; +#endif +#endif /* DUK_USE_ROM_STRINGS */ + + heap->heap_thread = thr; + DUK_HTHREAD_INCREF(thr, thr); /* Note: first argument not really used */ + + /* 'thr' is now reachable */ + + DUK_D(DUK_DPRINT("heap init: init heap thread stacks")); + if (!duk_hthread_init_stacks(heap, thr)) { + return 0; + } + + /* XXX: this may now fail, and is not handled correctly */ + duk_hthread_create_builtin_objects(thr); + + /* default prototype */ + DUK_HOBJECT_SET_PROTOTYPE_INIT_INCREF(thr, (duk_hobject *) thr, thr->builtins[DUK_BIDX_THREAD_PROTOTYPE]); + + return 1; +} + +#if defined(DUK_USE_DEBUG) +#define DUK__DUMPSZ(t) \ + do { \ + DUK_D(DUK_DPRINT("" #t "=%ld", (long) sizeof(t))); \ + } while (0) + +/* These is not 100% because format would need to be non-portable "long long". + * Also print out as doubles to catch cases where the "long" type is not wide + * enough; the limits will then not be printed accurately but the magnitude + * will be correct. + */ +#define DUK__DUMPLM_SIGNED_RAW(t, a, b) \ + do { \ + DUK_D(DUK_DPRINT(t "=[%ld,%ld]=[%lf,%lf]", (long) (a), (long) (b), (double) (a), (double) (b))); \ + } while (0) +#define DUK__DUMPLM_UNSIGNED_RAW(t, a, b) \ + do { \ + DUK_D(DUK_DPRINT(t "=[%lu,%lu]=[%lf,%lf]", (unsigned long) (a), (unsigned long) (b), (double) (a), (double) (b))); \ + } while (0) +#define DUK__DUMPLM_SIGNED(t) \ + do { \ + DUK__DUMPLM_SIGNED_RAW("DUK_" #t "_{MIN,MAX}", DUK_##t##_MIN, DUK_##t##_MAX); \ + } while (0) +#define DUK__DUMPLM_UNSIGNED(t) \ + do { \ + DUK__DUMPLM_UNSIGNED_RAW("DUK_" #t "_{MIN,MAX}", DUK_##t##_MIN, DUK_##t##_MAX); \ + } while (0) + +DUK_LOCAL void duk__dump_type_sizes(void) { + DUK_D(DUK_DPRINT("sizeof()")); + + /* basic platform types */ + DUK__DUMPSZ(char); + DUK__DUMPSZ(short); + DUK__DUMPSZ(int); + DUK__DUMPSZ(long); + DUK__DUMPSZ(double); + DUK__DUMPSZ(void *); + DUK__DUMPSZ(size_t); + + /* basic types from duk_features.h */ + DUK__DUMPSZ(duk_uint8_t); + DUK__DUMPSZ(duk_int8_t); + DUK__DUMPSZ(duk_uint16_t); + DUK__DUMPSZ(duk_int16_t); + DUK__DUMPSZ(duk_uint32_t); + DUK__DUMPSZ(duk_int32_t); + DUK__DUMPSZ(duk_uint64_t); + DUK__DUMPSZ(duk_int64_t); + DUK__DUMPSZ(duk_uint_least8_t); + DUK__DUMPSZ(duk_int_least8_t); + DUK__DUMPSZ(duk_uint_least16_t); + DUK__DUMPSZ(duk_int_least16_t); + DUK__DUMPSZ(duk_uint_least32_t); + DUK__DUMPSZ(duk_int_least32_t); +#if defined(DUK_USE_64BIT_OPS) + DUK__DUMPSZ(duk_uint_least64_t); + DUK__DUMPSZ(duk_int_least64_t); +#endif + DUK__DUMPSZ(duk_uint_fast8_t); + DUK__DUMPSZ(duk_int_fast8_t); + DUK__DUMPSZ(duk_uint_fast16_t); + DUK__DUMPSZ(duk_int_fast16_t); + DUK__DUMPSZ(duk_uint_fast32_t); + DUK__DUMPSZ(duk_int_fast32_t); +#if defined(DUK_USE_64BIT_OPS) + DUK__DUMPSZ(duk_uint_fast64_t); + DUK__DUMPSZ(duk_int_fast64_t); +#endif + DUK__DUMPSZ(duk_uintptr_t); + DUK__DUMPSZ(duk_intptr_t); + DUK__DUMPSZ(duk_uintmax_t); + DUK__DUMPSZ(duk_intmax_t); + DUK__DUMPSZ(duk_double_t); + + /* important chosen base types */ + DUK__DUMPSZ(duk_int_t); + DUK__DUMPSZ(duk_uint_t); + DUK__DUMPSZ(duk_int_fast_t); + DUK__DUMPSZ(duk_uint_fast_t); + DUK__DUMPSZ(duk_small_int_t); + DUK__DUMPSZ(duk_small_uint_t); + DUK__DUMPSZ(duk_small_int_fast_t); + DUK__DUMPSZ(duk_small_uint_fast_t); + + /* some derived types */ + DUK__DUMPSZ(duk_codepoint_t); + DUK__DUMPSZ(duk_ucodepoint_t); + DUK__DUMPSZ(duk_idx_t); + DUK__DUMPSZ(duk_errcode_t); + DUK__DUMPSZ(duk_uarridx_t); + + /* tval */ + DUK__DUMPSZ(duk_double_union); + DUK__DUMPSZ(duk_tval); + + /* structs from duk_forwdecl.h */ + DUK__DUMPSZ(duk_jmpbuf); /* just one 'int' for C++ exceptions */ + DUK__DUMPSZ(duk_heaphdr); + DUK__DUMPSZ(duk_heaphdr_string); + DUK__DUMPSZ(duk_hstring); + DUK__DUMPSZ(duk_hstring_external); + DUK__DUMPSZ(duk_hobject); + DUK__DUMPSZ(duk_harray); + DUK__DUMPSZ(duk_hcompfunc); + DUK__DUMPSZ(duk_hnatfunc); + DUK__DUMPSZ(duk_hdecenv); + DUK__DUMPSZ(duk_hobjenv); + DUK__DUMPSZ(duk_hthread); +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + DUK__DUMPSZ(duk_hbufobj); +#endif + DUK__DUMPSZ(duk_hproxy); + DUK__DUMPSZ(duk_hbuffer); + DUK__DUMPSZ(duk_hbuffer_fixed); + DUK__DUMPSZ(duk_hbuffer_dynamic); + DUK__DUMPSZ(duk_hbuffer_external); + DUK__DUMPSZ(duk_propaccessor); + DUK__DUMPSZ(duk_propvalue); + DUK__DUMPSZ(duk_propdesc); + DUK__DUMPSZ(duk_heap); + DUK__DUMPSZ(duk_activation); + DUK__DUMPSZ(duk_catcher); + DUK__DUMPSZ(duk_strcache_entry); + DUK__DUMPSZ(duk_litcache_entry); + DUK__DUMPSZ(duk_ljstate); + DUK__DUMPSZ(duk_fixedbuffer); + DUK__DUMPSZ(duk_bitdecoder_ctx); + DUK__DUMPSZ(duk_bitencoder_ctx); + DUK__DUMPSZ(duk_token); + DUK__DUMPSZ(duk_re_token); + DUK__DUMPSZ(duk_lexer_point); + DUK__DUMPSZ(duk_lexer_ctx); + DUK__DUMPSZ(duk_compiler_instr); + DUK__DUMPSZ(duk_compiler_func); + DUK__DUMPSZ(duk_compiler_ctx); + DUK__DUMPSZ(duk_re_matcher_ctx); + DUK__DUMPSZ(duk_re_compiler_ctx); +} +DUK_LOCAL void duk__dump_type_limits(void) { + DUK_D(DUK_DPRINT("limits")); + + /* basic types */ + DUK__DUMPLM_SIGNED(INT8); + DUK__DUMPLM_UNSIGNED(UINT8); + DUK__DUMPLM_SIGNED(INT_FAST8); + DUK__DUMPLM_UNSIGNED(UINT_FAST8); + DUK__DUMPLM_SIGNED(INT_LEAST8); + DUK__DUMPLM_UNSIGNED(UINT_LEAST8); + DUK__DUMPLM_SIGNED(INT16); + DUK__DUMPLM_UNSIGNED(UINT16); + DUK__DUMPLM_SIGNED(INT_FAST16); + DUK__DUMPLM_UNSIGNED(UINT_FAST16); + DUK__DUMPLM_SIGNED(INT_LEAST16); + DUK__DUMPLM_UNSIGNED(UINT_LEAST16); + DUK__DUMPLM_SIGNED(INT32); + DUK__DUMPLM_UNSIGNED(UINT32); + DUK__DUMPLM_SIGNED(INT_FAST32); + DUK__DUMPLM_UNSIGNED(UINT_FAST32); + DUK__DUMPLM_SIGNED(INT_LEAST32); + DUK__DUMPLM_UNSIGNED(UINT_LEAST32); +#if defined(DUK_USE_64BIT_OPS) + DUK__DUMPLM_SIGNED(INT64); + DUK__DUMPLM_UNSIGNED(UINT64); + DUK__DUMPLM_SIGNED(INT_FAST64); + DUK__DUMPLM_UNSIGNED(UINT_FAST64); + DUK__DUMPLM_SIGNED(INT_LEAST64); + DUK__DUMPLM_UNSIGNED(UINT_LEAST64); +#endif + DUK__DUMPLM_SIGNED(INTPTR); + DUK__DUMPLM_UNSIGNED(UINTPTR); + DUK__DUMPLM_SIGNED(INTMAX); + DUK__DUMPLM_UNSIGNED(UINTMAX); + + /* derived types */ + DUK__DUMPLM_SIGNED(INT); + DUK__DUMPLM_UNSIGNED(UINT); + DUK__DUMPLM_SIGNED(INT_FAST); + DUK__DUMPLM_UNSIGNED(UINT_FAST); + DUK__DUMPLM_SIGNED(SMALL_INT); + DUK__DUMPLM_UNSIGNED(SMALL_UINT); + DUK__DUMPLM_SIGNED(SMALL_INT_FAST); + DUK__DUMPLM_UNSIGNED(SMALL_UINT_FAST); +} + +DUK_LOCAL void duk__dump_misc_options(void) { + DUK_D(DUK_DPRINT("DUK_VERSION: %ld", (long) DUK_VERSION)); + DUK_D(DUK_DPRINT("DUK_GIT_DESCRIBE: %s", DUK_GIT_DESCRIBE)); + DUK_D(DUK_DPRINT("OS string: %s", DUK_USE_OS_STRING)); + DUK_D(DUK_DPRINT("architecture string: %s", DUK_USE_ARCH_STRING)); + DUK_D(DUK_DPRINT("compiler string: %s", DUK_USE_COMPILER_STRING)); + DUK_D(DUK_DPRINT("debug level: %ld", (long) DUK_USE_DEBUG_LEVEL)); +#if defined(DUK_USE_PACKED_TVAL) + DUK_D(DUK_DPRINT("DUK_USE_PACKED_TVAL: yes")); +#else + DUK_D(DUK_DPRINT("DUK_USE_PACKED_TVAL: no")); +#endif +#if defined(DUK_USE_VARIADIC_MACROS) + DUK_D(DUK_DPRINT("DUK_USE_VARIADIC_MACROS: yes")); +#else + DUK_D(DUK_DPRINT("DUK_USE_VARIADIC_MACROS: no")); +#endif +#if defined(DUK_USE_INTEGER_LE) + DUK_D(DUK_DPRINT("integer endianness: little")); +#elif defined(DUK_USE_INTEGER_ME) + DUK_D(DUK_DPRINT("integer endianness: mixed")); +#elif defined(DUK_USE_INTEGER_BE) + DUK_D(DUK_DPRINT("integer endianness: big")); +#else + DUK_D(DUK_DPRINT("integer endianness: ???")); +#endif +#if defined(DUK_USE_DOUBLE_LE) + DUK_D(DUK_DPRINT("IEEE double endianness: little")); +#elif defined(DUK_USE_DOUBLE_ME) + DUK_D(DUK_DPRINT("IEEE double endianness: mixed")); +#elif defined(DUK_USE_DOUBLE_BE) + DUK_D(DUK_DPRINT("IEEE double endianness: big")); +#else + DUK_D(DUK_DPRINT("IEEE double endianness: ???")); +#endif +} +#endif /* DUK_USE_DEBUG */ + +DUK_INTERNAL +duk_heap *duk_heap_alloc(duk_alloc_function alloc_func, + duk_realloc_function realloc_func, + duk_free_function free_func, + void *heap_udata, + duk_fatal_function fatal_func) { + duk_heap *res = NULL; + duk_uint32_t st_initsize; + + DUK_D(DUK_DPRINT("allocate heap")); + + /* + * Random config sanity asserts + */ + + DUK_ASSERT(DUK_USE_STRTAB_MINSIZE >= 64); + + DUK_ASSERT((DUK_HTYPE_STRING & 0x01U) == 0); + DUK_ASSERT((DUK_HTYPE_BUFFER & 0x01U) == 0); + DUK_ASSERT((DUK_HTYPE_OBJECT & 0x01U) == 1); /* DUK_HEAPHDR_IS_OBJECT() relies ont his. */ + + /* + * Debug dump type sizes + */ + +#if defined(DUK_USE_DEBUG) + duk__dump_misc_options(); + duk__dump_type_sizes(); + duk__dump_type_limits(); +#endif + + /* + * If selftests enabled, run them as early as possible. + */ + +#if defined(DUK_USE_SELF_TESTS) + DUK_D(DUK_DPRINT("run self tests")); + if (duk_selftest_run_tests(alloc_func, realloc_func, free_func, heap_udata) > 0) { + fatal_func(heap_udata, "self test(s) failed"); + } + DUK_D(DUK_DPRINT("self tests passed")); +#endif + + /* + * Important assert-like checks that should be enabled even + * when assertions are otherwise not enabled. + */ + +#if defined(DUK_USE_EXEC_REGCONST_OPTIMIZE) + /* Can't check sizeof() using preprocessor so explicit check. + * This will be optimized away in practice; unfortunately a + * warning is generated on some compilers as a result. + */ +#if defined(DUK_USE_PACKED_TVAL) + if (sizeof(duk_tval) != 8) { +#else + if (sizeof(duk_tval) != 16) { +#endif + fatal_func(heap_udata, "sizeof(duk_tval) not 8 or 16, cannot use DUK_USE_EXEC_REGCONST_OPTIMIZE option"); + } +#endif /* DUK_USE_EXEC_REGCONST_OPTIMIZE */ + + /* + * Computed values (e.g. INFINITY) + */ + +#if defined(DUK_USE_COMPUTED_NAN) + do { + /* Workaround for some exotic platforms where NAN is missing + * and the expression (0.0 / 0.0) does NOT result in a NaN. + * Such platforms use the global 'duk_computed_nan' which must + * be initialized at runtime. Use 'volatile' to ensure that + * the compiler will actually do the computation and not try + * to do constant folding which might result in the original + * problem. + */ + volatile double dbl1 = 0.0; + volatile double dbl2 = 0.0; + duk_computed_nan = dbl1 / dbl2; + } while (0); +#endif + +#if defined(DUK_USE_COMPUTED_INFINITY) + do { + /* Similar workaround for INFINITY. */ + volatile double dbl1 = 1.0; + volatile double dbl2 = 0.0; + duk_computed_infinity = dbl1 / dbl2; + } while (0); +#endif + + /* + * Allocate heap struct + * + * Use a raw call, all macros expect the heap to be initialized + */ + +#if defined(DUK_USE_INJECT_HEAP_ALLOC_ERROR) && (DUK_USE_INJECT_HEAP_ALLOC_ERROR == 1) + goto failed; +#endif + DUK_D(DUK_DPRINT("alloc duk_heap object")); + res = (duk_heap *) alloc_func(heap_udata, sizeof(duk_heap)); + if (!res) { + goto failed; + } + + /* + * Zero the struct, and start initializing roughly in order + */ + + duk_memzero(res, sizeof(*res)); +#if defined(DUK_USE_ASSERTIONS) + res->heap_initializing = 1; +#endif + + /* explicit NULL inits */ +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + res->heap_udata = NULL; + res->heap_allocated = NULL; +#if defined(DUK_USE_REFERENCE_COUNTING) + res->refzero_list = NULL; +#endif +#if defined(DUK_USE_FINALIZER_SUPPORT) + res->finalize_list = NULL; +#if defined(DUK_USE_ASSERTIONS) + res->currently_finalizing = NULL; +#endif +#endif +#if defined(DUK_USE_CACHE_ACTIVATION) + res->activation_free = NULL; +#endif +#if defined(DUK_USE_CACHE_CATCHER) + res->catcher_free = NULL; +#endif + res->heap_thread = NULL; + res->curr_thread = NULL; + res->heap_object = NULL; +#if defined(DUK_USE_STRTAB_PTRCOMP) + res->strtable16 = NULL; +#else + res->strtable = NULL; +#endif +#if defined(DUK_USE_ROM_STRINGS) + /* no res->strs[] */ +#else /* DUK_USE_ROM_STRINGS */ +#if defined(DUK_USE_HEAPPTR16) + /* res->strs16[] is zeroed and zero decodes to NULL, so no NULL inits. */ +#else + { + duk_small_uint_t i; + for (i = 0; i < DUK_HEAP_NUM_STRINGS; i++) { + res->strs[i] = NULL; + } + } +#endif +#endif /* DUK_USE_ROM_STRINGS */ +#if defined(DUK_USE_DEBUGGER_SUPPORT) + res->dbg_read_cb = NULL; + res->dbg_write_cb = NULL; + res->dbg_peek_cb = NULL; + res->dbg_read_flush_cb = NULL; + res->dbg_write_flush_cb = NULL; + res->dbg_request_cb = NULL; + res->dbg_udata = NULL; + res->dbg_pause_act = NULL; +#endif +#endif /* DUK_USE_EXPLICIT_NULL_INIT */ + + res->alloc_func = alloc_func; + res->realloc_func = realloc_func; + res->free_func = free_func; + res->heap_udata = heap_udata; + res->fatal_func = fatal_func; + + /* XXX: for now there's a pointer packing zero assumption, i.e. + * NULL <=> compressed pointer 0. If this is removed, may need + * to precompute e.g. null16 here. + */ + + /* res->ms_trigger_counter == 0 -> now causes immediate GC; which is OK */ + + /* Prevent mark-and-sweep and finalizer execution until heap is completely + * initialized. + */ + DUK_ASSERT(res->ms_prevent_count == 0); + DUK_ASSERT(res->pf_prevent_count == 0); + res->ms_prevent_count = 1; + res->pf_prevent_count = 1; + DUK_ASSERT(res->ms_running == 0); + + res->call_recursion_depth = 0; + res->call_recursion_limit = DUK_USE_NATIVE_CALL_RECLIMIT; + + /* XXX: use the pointer as a seed for now: mix in time at least */ + + /* The casts through duk_uintptr_t is to avoid the following GCC warning: + * + * warning: cast from pointer to integer of different size [-Wpointer-to-int-cast] + * + * This still generates a /Wp64 warning on VS2010 when compiling for x86. + */ +#if defined(DUK_USE_ROM_STRINGS) + /* XXX: make a common DUK_USE_ option, and allow custom fixed seed? */ + DUK_D(DUK_DPRINT("using rom strings, force heap hash_seed to fixed value 0x%08lx", (long) DUK__FIXED_HASH_SEED)); + res->hash_seed = (duk_uint32_t) DUK__FIXED_HASH_SEED; +#else /* DUK_USE_ROM_STRINGS */ + res->hash_seed = (duk_uint32_t) (duk_uintptr_t) res; +#if !defined(DUK_USE_STRHASH_DENSE) + res->hash_seed ^= 5381; /* Bernstein hash init value is normally 5381; XOR it in in case pointer low bits are 0 */ +#endif +#endif /* DUK_USE_ROM_STRINGS */ + +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + res->lj.jmpbuf_ptr = NULL; +#endif + DUK_ASSERT(res->lj.type == DUK_LJ_TYPE_UNKNOWN); /* zero */ + DUK_ASSERT(res->lj.iserror == 0); + DUK_TVAL_SET_UNDEFINED(&res->lj.value1); + DUK_TVAL_SET_UNDEFINED(&res->lj.value2); + + DUK_ASSERT_LJSTATE_UNSET(res); + + /* + * Init stringtable: fixed variant + */ + + st_initsize = DUK_USE_STRTAB_MINSIZE; +#if defined(DUK_USE_STRTAB_PTRCOMP) + res->strtable16 = (duk_uint16_t *) alloc_func(heap_udata, sizeof(duk_uint16_t) * st_initsize); + if (res->strtable16 == NULL) { + goto failed; + } +#else + res->strtable = (duk_hstring **) alloc_func(heap_udata, sizeof(duk_hstring *) * st_initsize); + if (res->strtable == NULL) { + goto failed; + } +#endif + res->st_size = st_initsize; + res->st_mask = st_initsize - 1; +#if (DUK_USE_STRTAB_MINSIZE != DUK_USE_STRTAB_MAXSIZE) + DUK_ASSERT(res->st_count == 0); +#endif + +#if defined(DUK_USE_STRTAB_PTRCOMP) + /* zero assumption */ + duk_memzero(res->strtable16, sizeof(duk_uint16_t) * st_initsize); +#else +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + { + duk_uint32_t i; + for (i = 0; i < st_initsize; i++) { + res->strtable[i] = NULL; + } + } +#else + duk_memzero(res->strtable, sizeof(duk_hstring *) * st_initsize); +#endif /* DUK_USE_EXPLICIT_NULL_INIT */ +#endif /* DUK_USE_STRTAB_PTRCOMP */ + + /* + * Init stringcache + */ + +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + { + duk_uint_t i; + for (i = 0; i < DUK_HEAP_STRCACHE_SIZE; i++) { + res->strcache[i].h = NULL; + } + } +#endif + + /* + * Init litcache + */ +#if defined(DUK_USE_LITCACHE_SIZE) + DUK_ASSERT(DUK_USE_LITCACHE_SIZE > 0); + DUK_ASSERT(DUK_IS_POWER_OF_TWO((duk_uint_t) DUK_USE_LITCACHE_SIZE)); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + { + duk_uint_t i; + for (i = 0; i < DUK_USE_LITCACHE_SIZE; i++) { + res->litcache[i].addr = NULL; + res->litcache[i].h = NULL; + } + } +#endif +#endif /* DUK_USE_LITCACHE_SIZE */ + + /* XXX: error handling is incomplete. It would be cleanest if + * there was a setjmp catchpoint, so that all init code could + * freely throw errors. If that were the case, the return code + * passing here could be removed. + */ + + /* + * Init built-in strings + */ + +#if defined(DUK_USE_INJECT_HEAP_ALLOC_ERROR) && (DUK_USE_INJECT_HEAP_ALLOC_ERROR == 2) + goto failed; +#endif + DUK_D(DUK_DPRINT("heap init: initialize heap strings")); + if (!duk__init_heap_strings(res)) { + goto failed; + } + + /* + * Init the heap thread + */ + +#if defined(DUK_USE_INJECT_HEAP_ALLOC_ERROR) && (DUK_USE_INJECT_HEAP_ALLOC_ERROR == 3) + goto failed; +#endif + DUK_D(DUK_DPRINT("heap init: initialize heap thread")); + if (!duk__init_heap_thread(res)) { + goto failed; + } + + /* + * Init the heap object + */ + +#if defined(DUK_USE_INJECT_HEAP_ALLOC_ERROR) && (DUK_USE_INJECT_HEAP_ALLOC_ERROR == 4) + goto failed; +#endif + DUK_D(DUK_DPRINT("heap init: initialize heap object")); + DUK_ASSERT(res->heap_thread != NULL); + res->heap_object = duk_hobject_alloc_unchecked(res, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJECT)); + if (res->heap_object == NULL) { + goto failed; + } + DUK_HOBJECT_INCREF(res->heap_thread, res->heap_object); + + /* + * Odds and ends depending on the heap thread + */ + +#if !defined(DUK_USE_GET_RANDOM_DOUBLE) +#if defined(DUK_USE_PREFER_SIZE) || !defined(DUK_USE_64BIT_OPS) + res->rnd_state = (duk_uint32_t) duk_time_get_ecmascript_time(res->heap_thread); + duk_util_tinyrandom_prepare_seed(res->heap_thread); +#else + res->rnd_state[0] = (duk_uint64_t) duk_time_get_ecmascript_time(res->heap_thread); + DUK_ASSERT(res->rnd_state[1] == 0); /* Not filled here, filled in by seed preparation. */ +#if 0 /* Manual test values matching misc/xoroshiro128plus_test.c. */ + res->rnd_state[0] = DUK_U64_CONSTANT(0xdeadbeef12345678); + res->rnd_state[1] = DUK_U64_CONSTANT(0xcafed00d12345678); +#endif + duk_util_tinyrandom_prepare_seed(res->heap_thread); + /* Mix in heap pointer: this ensures that if two Duktape heaps are + * created on the same millisecond, they get a different PRNG + * sequence (unless e.g. virtual memory addresses cause also the + * heap object pointer to be the same). + */ + { + duk_uint64_t tmp_u64; + tmp_u64 = 0; + duk_memcpy((void *) &tmp_u64, + (const void *) &res, + (size_t) (sizeof(void *) >= sizeof(duk_uint64_t) ? sizeof(duk_uint64_t) : sizeof(void *))); + res->rnd_state[1] ^= tmp_u64; + } + do { + duk_small_uint_t i; + for (i = 0; i < 10; i++) { + /* Throw away a few initial random numbers just in + * case. Probably unnecessary due to SplitMix64 + * preparation. + */ + (void) duk_util_tinyrandom_get_double(res->heap_thread); + } + } while (0); +#endif +#endif + + /* + * Allow finalizer and mark-and-sweep processing. + */ + + DUK_D(DUK_DPRINT("heap init: allow finalizer/mark-and-sweep processing")); + DUK_ASSERT(res->ms_prevent_count == 1); + DUK_ASSERT(res->pf_prevent_count == 1); + res->ms_prevent_count = 0; + res->pf_prevent_count = 0; + DUK_ASSERT(res->ms_running == 0); +#if defined(DUK_USE_ASSERTIONS) + res->heap_initializing = 0; +#endif + + /* + * All done. + */ + + DUK_D(DUK_DPRINT("allocated heap: %p", (void *) res)); + return res; + +failed: + DUK_D(DUK_DPRINT("heap allocation failed")); + + if (res != NULL) { + /* Assumes that allocated pointers and alloc funcs are valid + * if res exists. + */ + DUK_ASSERT(res->ms_prevent_count == 1); + DUK_ASSERT(res->pf_prevent_count == 1); + DUK_ASSERT(res->ms_running == 0); + if (res->heap_thread != NULL) { + res->ms_prevent_count = 0; + res->pf_prevent_count = 0; + } +#if defined(DUK_USE_ASSERTIONS) + res->heap_initializing = 0; +#endif + + DUK_ASSERT(res->alloc_func != NULL); + DUK_ASSERT(res->realloc_func != NULL); + DUK_ASSERT(res->free_func != NULL); + duk_heap_free(res); + } + + return NULL; +} + +/* automatic undefs */ +#undef DUK__DUMPLM_SIGNED +#undef DUK__DUMPLM_SIGNED_RAW +#undef DUK__DUMPLM_UNSIGNED +#undef DUK__DUMPLM_UNSIGNED_RAW +#undef DUK__DUMPSZ +#undef DUK__FIXED_HASH_SEED +#line 1 "duk_heap_finalize.c" +/* + * Finalizer handling. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) + +/* + * Fake torture finalizer. + */ + +#if defined(DUK_USE_FINALIZER_TORTURE) +DUK_LOCAL duk_ret_t duk__fake_global_finalizer(duk_hthread *thr) { + DUK_DD(DUK_DDPRINT("fake global torture finalizer executed")); + + /* Require a lot of stack to force a value stack grow/shrink. */ + duk_require_stack(thr, 100000); + + /* Force a reallocation with pointer change for value stack + * to maximize side effects. + */ + duk_hthread_valstack_torture_realloc(thr); + + /* Inner function call, error throw. */ + duk_eval_string_noresult(thr, + "(function dummy() {\n" + " dummy.prototype = null; /* break reference loop */\n" + " try {\n" + " throw 'fake-finalizer-dummy-error';\n" + " } catch (e) {\n" + " void e;\n" + " }\n" + "})()"); + + /* The above creates garbage (e.g. a function instance). Because + * the function/prototype reference loop is broken, it gets collected + * immediately by DECREF. If Function.prototype has a _Finalizer + * property (happens in some test cases), the garbage gets queued to + * finalize_list. This still won't cause an infinite loop because + * the torture finalizer is called once per finalize_list run and + * the garbage gets handled in the same run. (If the garbage needs + * mark-and-sweep collection, an infinite loop might ensue.) + */ + return 0; +} + +DUK_LOCAL void duk__run_global_torture_finalizer(duk_hthread *thr) { + DUK_ASSERT(thr != NULL); + + /* Avoid fake finalization when callstack limit is near. Otherwise + * a callstack limit error will be created, then refzero'ed. The + * +5 headroom is conservative. + */ + if (thr->heap->call_recursion_depth + 5 >= thr->heap->call_recursion_limit || + thr->callstack_top + 5 >= DUK_USE_CALLSTACK_LIMIT) { + DUK_D(DUK_DPRINT("skip global torture finalizer, too little headroom for call recursion or call stack size")); + return; + } + + /* Run fake finalizer. Avoid creating unnecessary garbage. */ + duk_push_c_function(thr, duk__fake_global_finalizer, 0 /*nargs*/); + (void) duk_pcall(thr, 0 /*nargs*/); + duk_pop(thr); +} +#endif /* DUK_USE_FINALIZER_TORTURE */ + +/* + * Process the finalize_list to completion. + * + * An object may be placed on finalize_list by either refcounting or + * mark-and-sweep. The refcount of objects placed by refcounting will be + * zero; the refcount of objects placed by mark-and-sweep is > 0. In both + * cases the refcount is bumped by 1 artificially so that a REFZERO event + * can never happen while an object is waiting for finalization. Without + * this bump a REFZERO could now happen because user code may call + * duk_push_heapptr() and then pop a value even when it's on finalize_list. + * + * List processing assumes refcounts are kept up-to-date at all times, so + * that once the finalizer returns, a zero refcount is a reliable reason to + * free the object immediately rather than place it back to the heap. This + * is the case because we run outside of refzero_list processing so that + * DECREF cascades are handled fully inline. + * + * For mark-and-sweep queued objects (had_zero_refcount false) the object + * may be freed immediately if its refcount is zero after the finalizer call + * (i.e. finalizer removed the reference loop for the object). If not, the + * next mark-and-sweep will collect the object unless it has become reachable + * (i.e. rescued) by that time and its refcount hasn't fallen to zero before + * that. Mark-and-sweep detects these objects because their FINALIZED flag + * is set. + * + * There's an inherent limitation for mark-and-sweep finalizer rescuing: an + * object won't get refinalized if (1) it's rescued, but (2) becomes + * unreachable before mark-and-sweep has had time to notice it. The next + * mark-and-sweep round simply doesn't have any information of whether the + * object has been unreachable the whole time or not (the only way to get + * that information would be a mark-and-sweep pass for *every finalized + * object*). This is awkward for the application because the mark-and-sweep + * round is not generally visible or under full application control. + * + * For refcount queued objects (had_zero_refcount true) the object is either + * immediately freed or rescued, and waiting for a mark-and-sweep round is not + * necessary (or desirable); FINALIZED is cleared when a rescued object is + * queued back to heap_allocated. The object is eligible for finalization + * again (either via refcounting or mark-and-sweep) immediately after being + * rescued. If a refcount finalized object is placed into an unreachable + * reference loop by its finalizer, it will get collected by mark-and-sweep + * and currently the finalizer will execute again. + * + * There's a special case where: + * + * - Mark-and-sweep queues an object to finalize_list for finalization. + * - The finalizer is executed, FINALIZED is set, and object is queued + * back to heap_allocated, waiting for a new mark-and-sweep round. + * - The object's refcount drops to zero before mark-and-sweep has a + * chance to run another round and make a rescue/free decision. + * + * This is now handled by refzero code: if an object has a finalizer but + * FINALIZED is already set, the object is freed without finalizer processing. + * The outcome is the same as if mark-and-sweep was executed at that point; + * mark-and-sweep would also free the object without another finalizer run. + * This could also be changed so that the refzero-triggered finalizer *IS* + * executed: being refzero collected implies someone has operated on the + * object so it hasn't been totally unreachable the whole time. This would + * risk a finalizer loop however. + */ + +DUK_INTERNAL void duk_heap_process_finalize_list(duk_heap *heap) { + duk_heaphdr *curr; +#if defined(DUK_USE_DEBUG) + duk_size_t count = 0; +#endif + + DUK_DDD(DUK_DDDPRINT("duk_heap_process_finalize_list: %p", (void *) heap)); + + if (heap->pf_prevent_count != 0) { + DUK_DDD(DUK_DDDPRINT("skip finalize_list processing: pf_prevent_count != 0")); + return; + } + + /* Heap alloc prevents mark-and-sweep before heap_thread is ready. */ + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->heap_thread != NULL); + DUK_ASSERT(heap->heap_thread->valstack != NULL); +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(heap->refzero_list == NULL); +#endif + + DUK_ASSERT(heap->pf_prevent_count == 0); + heap->pf_prevent_count = 1; + + /* Mark-and-sweep no longer needs to be prevented when running + * finalizers: mark-and-sweep skips any rescue decisions if there + * are any objects in finalize_list when mark-and-sweep is entered. + * This protects finalized objects from incorrect rescue decisions + * caused by finalize_list being a reachability root and only + * partially processed. Freeing decisions are not postponed. + */ + + /* When finalizer torture is enabled, make a fake finalizer call with + * maximum side effects regardless of whether finalize_list is empty. + */ +#if defined(DUK_USE_FINALIZER_TORTURE) + duk__run_global_torture_finalizer(heap->heap_thread); +#endif + + /* Process finalize_list until it becomes empty. There's currently no + * protection against a finalizer always creating more garbage. + */ + while ((curr = heap->finalize_list) != NULL) { +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_bool_t queue_back; +#endif + + DUK_DD(DUK_DDPRINT("processing finalize_list entry: %p -> %!iO", (void *) curr, curr)); + + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(curr) == DUK_HTYPE_OBJECT); /* Only objects have finalizers. */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_REACHABLE(curr)); + DUK_ASSERT(!DUK_HEAPHDR_HAS_TEMPROOT(curr)); + DUK_ASSERT(DUK_HEAPHDR_HAS_FINALIZABLE( + curr)); /* All objects on finalize_list will have this flag (except object being finalized right now). */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_FINALIZED(curr)); /* Queueing code ensures. */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY(curr)); /* ROM objects never get freed (or finalized). */ + +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(heap->currently_finalizing == NULL); + heap->currently_finalizing = curr; +#endif + + /* Clear FINALIZABLE for object being finalized, so that + * duk_push_heapptr() can properly ignore the object. + */ + DUK_HEAPHDR_CLEAR_FINALIZABLE(curr); + + if (DUK_LIKELY(!heap->pf_skip_finalizers)) { + /* Run the finalizer, duk_heap_run_finalizer() sets + * and checks for FINALIZED to prevent the finalizer + * from executing multiple times per finalization cycle. + * (This safeguard shouldn't be actually needed anymore). + */ + +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_bool_t had_zero_refcount; +#endif + + /* The object's refcount is >0 throughout so it won't be + * refzero processed prematurely. + */ +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(curr) >= 1); + had_zero_refcount = (DUK_HEAPHDR_GET_REFCOUNT(curr) == 1); /* Preincremented on finalize_list insert. */ +#endif + + DUK_ASSERT(!DUK_HEAPHDR_HAS_FINALIZED(curr)); + duk_heap_run_finalizer(heap, (duk_hobject *) curr); /* must never longjmp */ + DUK_ASSERT(DUK_HEAPHDR_HAS_FINALIZED(curr)); + /* XXX: assert that object is still in finalize_list + * when duk_push_heapptr() allows automatic rescue. + */ + +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_DD(DUK_DDPRINT("refcount after finalizer (includes bump): %ld", (long) DUK_HEAPHDR_GET_REFCOUNT(curr))); + if (DUK_HEAPHDR_GET_REFCOUNT(curr) == 1) { /* Only artificial bump in refcount? */ +#if defined(DUK_USE_DEBUG) + if (had_zero_refcount) { + DUK_DD(DUK_DDPRINT( + "finalized object's refcount is zero -> free immediately (refcount queued)")); + } else { + DUK_DD(DUK_DDPRINT( + "finalized object's refcount is zero -> free immediately (mark-and-sweep queued)")); + } +#endif + queue_back = 0; + } else +#endif + { +#if defined(DUK_USE_REFERENCE_COUNTING) + queue_back = 1; + if (had_zero_refcount) { + /* When finalization is triggered + * by refzero and we queue the object + * back, clear FINALIZED right away + * so that the object can be refinalized + * immediately if necessary. + */ + DUK_HEAPHDR_CLEAR_FINALIZED(curr); + } +#endif + } + } else { + /* Used during heap destruction: don't actually run finalizers + * because we're heading into forced finalization. Instead, + * queue finalizable objects back to the heap_allocated list. + */ + DUK_D(DUK_DPRINT("skip finalizers flag set, queue object to heap_allocated without finalizing")); + DUK_ASSERT(!DUK_HEAPHDR_HAS_FINALIZED(curr)); +#if defined(DUK_USE_REFERENCE_COUNTING) + queue_back = 1; +#endif + } + + /* Dequeue object from finalize_list. Note that 'curr' may no + * longer be finalize_list head because new objects may have + * been queued to the list. As a result we can't optimize for + * the single-linked heap case and must scan the list for + * removal, typically the scan is very short however. + */ + DUK_HEAP_REMOVE_FROM_FINALIZE_LIST(heap, curr); + + /* Queue back to heap_allocated or free immediately. */ +#if defined(DUK_USE_REFERENCE_COUNTING) + if (queue_back) { + /* FINALIZED is only cleared if object originally + * queued for finalization by refcounting. For + * mark-and-sweep FINALIZED is left set, so that + * next mark-and-sweep round can make a rescue/free + * decision. + */ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(curr) >= 1); + DUK_HEAPHDR_PREDEC_REFCOUNT(curr); /* Remove artificial refcount bump. */ + DUK_HEAPHDR_CLEAR_FINALIZABLE(curr); + DUK_HEAP_INSERT_INTO_HEAP_ALLOCATED(heap, curr); + } else { + /* No need to remove the refcount bump here. */ + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(curr) == DUK_HTYPE_OBJECT); /* currently, always the case */ + DUK_DD(DUK_DDPRINT("refcount finalize after finalizer call: %!O", curr)); + duk_hobject_refcount_finalize_norz(heap, (duk_hobject *) curr); + duk_free_hobject(heap, (duk_hobject *) curr); + DUK_DD(DUK_DDPRINT("freed hobject after finalization: %p", (void *) curr)); + } +#else /* DUK_USE_REFERENCE_COUNTING */ + DUK_HEAPHDR_CLEAR_FINALIZABLE(curr); + DUK_HEAP_INSERT_INTO_HEAP_ALLOCATED(heap, curr); +#endif /* DUK_USE_REFERENCE_COUNTING */ + +#if defined(DUK_USE_DEBUG) + count++; +#endif + +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(heap->currently_finalizing != NULL); + heap->currently_finalizing = NULL; +#endif + } + + /* finalize_list will always be processed completely. */ + DUK_ASSERT(heap->finalize_list == NULL); + +#if 0 + /* While NORZ macros are used above, this is unnecessary because the + * only pending side effects are now finalizers, and finalize_list is + * empty. + */ + DUK_REFZERO_CHECK_SLOW(heap->heap_thread); +#endif + + /* Prevent count may be bumped while finalizers run, but should always + * be reliably unbumped by the time we get here. + */ + DUK_ASSERT(heap->pf_prevent_count == 1); + heap->pf_prevent_count = 0; + +#if defined(DUK_USE_DEBUG) + DUK_DD(DUK_DDPRINT("duk_heap_process_finalize_list: %ld finalizers called", (long) count)); +#endif +} + +/* + * Run an duk_hobject finalizer. Must never throw an uncaught error + * (but may throw caught errors). + * + * There is no return value. Any return value or error thrown by + * the finalizer is ignored (although errors are debug logged). + * + * Notes: + * + * - The finalizer thread 'top' assertions are there because it is + * critical that strict stack policy is observed (i.e. no cruft + * left on the finalizer stack). + */ + +DUK_LOCAL duk_ret_t duk__finalize_helper(duk_hthread *thr, void *udata) { + DUK_ASSERT(thr != NULL); + DUK_UNREF(udata); + + DUK_DDD(DUK_DDDPRINT("protected finalization helper running")); + + /* [... obj] */ + + /* _Finalizer property is read without checking if the value is + * callable or even exists. This is intentional, and handled + * by throwing an error which is caught by the safe call wrapper. + * + * XXX: Finalizer lookup should traverse the prototype chain (to allow + * inherited finalizers) but should not invoke accessors or proxy object + * behavior. At the moment this lookup will invoke proxy behavior, so + * caller must ensure that this function is not called if the target is + * a Proxy. + */ + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_INT_FINALIZER); /* -> [... obj finalizer] */ + duk_dup_m2(thr); + duk_push_boolean(thr, DUK_HEAP_HAS_FINALIZER_NORESCUE(thr->heap)); + DUK_DDD(DUK_DDDPRINT("calling finalizer")); + duk_call(thr, 2); /* [ ... obj finalizer obj heapDestruct ] -> [ ... obj retval ] */ + DUK_DDD(DUK_DDDPRINT("finalizer returned successfully")); + return 0; + + /* Note: we rely on duk_safe_call() to fix up the stack for the caller, + * so we don't need to pop stuff here. There is no return value; + * caller determines rescued status based on object refcount. + */ +} + +DUK_INTERNAL void duk_heap_run_finalizer(duk_heap *heap, duk_hobject *obj) { + duk_hthread *thr; + duk_ret_t rc; +#if defined(DUK_USE_ASSERTIONS) + duk_idx_t entry_top; +#endif + + DUK_DD(DUK_DDPRINT("running duk_hobject finalizer for object: %p", (void *) obj)); + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->heap_thread != NULL); + thr = heap->heap_thread; + DUK_ASSERT(obj != NULL); + DUK_ASSERT_VALSTACK_SPACE(heap->heap_thread, 1); + +#if defined(DUK_USE_ASSERTIONS) + entry_top = duk_get_top(thr); +#endif + /* + * Get and call the finalizer. All of this must be wrapped + * in a protected call, because even getting the finalizer + * may trigger an error (getter may throw one, for instance). + */ + + /* ROM objects could inherit a finalizer, but they are never deemed + * unreachable by mark-and-sweep, and their refcount never falls to 0. + */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)); + + /* Duktape 2.1: finalize_list never contains objects with FINALIZED + * set, so no need to check here. + */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_FINALIZED((duk_heaphdr *) obj)); +#if 0 + if (DUK_HEAPHDR_HAS_FINALIZED((duk_heaphdr *) obj)) { + DUK_D(DUK_DPRINT("object already finalized, avoid running finalizer twice: %!O", obj)); + return; + } +#endif + DUK_HEAPHDR_SET_FINALIZED((duk_heaphdr *) obj); /* ensure never re-entered until rescue cycle complete */ + +#if defined(DUK_USE_ES6_PROXY) + if (DUK_HOBJECT_IS_PROXY(obj)) { + /* This may happen if duk_set_finalizer() or Duktape.fin() is + * called for a Proxy object. In such cases the fast finalizer + * flag will be set on the Proxy, not the target, and neither + * will be finalized. + */ + DUK_D(DUK_DPRINT("object is a Proxy, skip finalizer call")); + return; + } +#endif /* DUK_USE_ES6_PROXY */ + + duk_push_hobject(thr, obj); /* this also increases refcount by one */ + rc = duk_safe_call(thr, duk__finalize_helper, NULL /*udata*/, 0 /*nargs*/, 1 /*nrets*/); /* -> [... obj retval/error] */ + DUK_ASSERT_TOP(thr, entry_top + 2); /* duk_safe_call discipline */ + + if (rc != DUK_EXEC_SUCCESS) { + /* Note: we ask for one return value from duk_safe_call to get this + * error debugging here. + */ + DUK_D(DUK_DPRINT("wrapped finalizer call failed for object %p (ignored); error: %!T", + (void *) obj, + (duk_tval *) duk_get_tval(thr, -1))); + } + duk_pop_2(thr); /* -> [...] */ + + DUK_ASSERT_TOP(thr, entry_top); +} + +#else /* DUK_USE_FINALIZER_SUPPORT */ + +/* nothing */ + +#endif /* DUK_USE_FINALIZER_SUPPORT */ +#line 1 "duk_heap_hashstring.c" +/* + * String hash computation (interning). + * + * String hashing is performance critical because a string hash is computed + * for all new strings which are candidates to be added to the string table. + * However, strings actually added to the string table go through a codepoint + * length calculation which dominates performance because it goes through + * every byte of the input string (but only for strings added). + * + * The string hash algorithm should be fast, but on the other hand provide + * good enough hashes to ensure both string table and object property table + * hash tables work reasonably well (i.e., there aren't too many collisions + * with real world inputs). Unless the hash is cryptographic, it's always + * possible to craft inputs with maximal hash collisions. + * + * NOTE: The hash algorithms must match tools/dukutil.py:duk_heap_hashstring() + * for ROM string support! + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_STRHASH_DENSE) +/* Constants for duk_hashstring(). */ +#define DUK__STRHASH_SHORTSTRING 4096L +#define DUK__STRHASH_MEDIUMSTRING (256L * 1024L) +#define DUK__STRHASH_BLOCKSIZE 256L + +DUK_INTERNAL duk_uint32_t duk_heap_hashstring(duk_heap *heap, const duk_uint8_t *str, duk_size_t len) { + duk_uint32_t hash; + + /* Use Murmurhash2 directly for short strings, and use "block skipping" + * for long strings: hash an initial part and then sample the rest of + * the string with reasonably sized chunks. An initial offset for the + * sampling is computed based on a hash of the initial part of the string; + * this is done to (usually) avoid the case where all long strings have + * certain offset ranges which are never sampled. + * + * Skip should depend on length and bound the total time to roughly + * logarithmic. With current values: + * + * 1M string => 256 * 241 = 61696 bytes (0.06M) of hashing + * 1G string => 256 * 16321 = 4178176 bytes (3.98M) of hashing + * + * XXX: It would be better to compute the skip offset more "smoothly" + * instead of having a few boundary values. + */ + + /* note: mixing len into seed improves hashing when skipping */ + duk_uint32_t str_seed = heap->hash_seed ^ ((duk_uint32_t) len); + + if (len <= DUK__STRHASH_SHORTSTRING) { + hash = duk_util_hashbytes(str, len, str_seed); + } else { + duk_size_t off; + duk_size_t skip; + + if (len <= DUK__STRHASH_MEDIUMSTRING) { + skip = (duk_size_t) (16 * DUK__STRHASH_BLOCKSIZE + DUK__STRHASH_BLOCKSIZE); + } else { + skip = (duk_size_t) (256 * DUK__STRHASH_BLOCKSIZE + DUK__STRHASH_BLOCKSIZE); + } + + hash = duk_util_hashbytes(str, (duk_size_t) DUK__STRHASH_SHORTSTRING, str_seed); + off = DUK__STRHASH_SHORTSTRING + (skip * (hash % 256)) / 256; + + /* XXX: inefficient loop */ + while (off < len) { + duk_size_t left = len - off; + duk_size_t now = (duk_size_t) (left > DUK__STRHASH_BLOCKSIZE ? DUK__STRHASH_BLOCKSIZE : left); + hash ^= duk_util_hashbytes(str + off, now, str_seed); + off += skip; + } + } + +#if defined(DUK_USE_STRHASH16) + /* Truncate to 16 bits here, so that a computed hash can be compared + * against a hash stored in a 16-bit field. + */ + hash &= 0x0000ffffUL; +#endif + return hash; +} +#else /* DUK_USE_STRHASH_DENSE */ +DUK_INTERNAL duk_uint32_t duk_heap_hashstring(duk_heap *heap, const duk_uint8_t *str, duk_size_t len) { + duk_uint32_t hash; + duk_size_t step; + duk_size_t off; + + /* Slightly modified "Bernstein hash" from: + * + * http://eternallyconfuzzled.com/tuts/algorithms/jsw_tut_hashing.aspx + * + * Modifications: string skipping and reverse direction similar to + * Lua 5.1.5, and different hash initializer. + * + * The reverse direction ensures last byte it always included in the + * hash which is a good default as changing parts of the string are + * more often in the suffix than in the prefix. + */ + + hash = heap->hash_seed ^ ((duk_uint32_t) len); /* Bernstein hash init value is normally 5381 */ + step = (len >> DUK_USE_STRHASH_SKIP_SHIFT) + 1; + for (off = len; off >= step; off -= step) { + DUK_ASSERT(off >= 1); /* off >= step, and step >= 1 */ + hash = (hash * 33) + str[off - 1]; + } + +#if defined(DUK_USE_STRHASH16) + /* Truncate to 16 bits here, so that a computed hash can be compared + * against a hash stored in a 16-bit field. + */ + hash &= 0x0000ffffUL; +#endif + return hash; +} +#endif /* DUK_USE_STRHASH_DENSE */ + +/* automatic undefs */ +#undef DUK__STRHASH_BLOCKSIZE +#undef DUK__STRHASH_MEDIUMSTRING +#undef DUK__STRHASH_SHORTSTRING +#line 1 "duk_heap_markandsweep.c" +/* + * Mark-and-sweep garbage collection. + */ + +/* #include duk_internal.h -> already included */ + +DUK_LOCAL_DECL void duk__mark_heaphdr(duk_heap *heap, duk_heaphdr *h); +DUK_LOCAL_DECL void duk__mark_heaphdr_nonnull(duk_heap *heap, duk_heaphdr *h); +DUK_LOCAL_DECL void duk__mark_tval(duk_heap *heap, duk_tval *tv); +DUK_LOCAL_DECL void duk__mark_tvals(duk_heap *heap, duk_tval *tv, duk_idx_t count); + +/* + * Marking functions for heap types: mark children recursively. + */ + +DUK_LOCAL void duk__mark_hstring(duk_heap *heap, duk_hstring *h) { + DUK_UNREF(heap); + DUK_UNREF(h); + + DUK_DDD(DUK_DDDPRINT("duk__mark_hstring: %p", (void *) h)); + DUK_ASSERT(h); + DUK_HSTRING_ASSERT_VALID(h); + + /* nothing to process */ +} + +DUK_LOCAL void duk__mark_hobject(duk_heap *heap, duk_hobject *h) { + duk_uint_fast32_t i; + + DUK_DDD(DUK_DDDPRINT("duk__mark_hobject: %p", (void *) h)); + + DUK_ASSERT(h); + DUK_HOBJECT_ASSERT_VALID(h); + + /* XXX: use advancing pointers instead of index macros -> faster and smaller? */ + + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ENEXT(h); i++) { + duk_hstring *key = DUK_HOBJECT_E_GET_KEY(heap, h, i); + if (key == NULL) { + continue; + } + duk__mark_heaphdr_nonnull(heap, (duk_heaphdr *) key); + if (DUK_HOBJECT_E_SLOT_IS_ACCESSOR(heap, h, i)) { + duk__mark_heaphdr(heap, (duk_heaphdr *) DUK_HOBJECT_E_GET_VALUE_PTR(heap, h, i)->a.get); + duk__mark_heaphdr(heap, (duk_heaphdr *) DUK_HOBJECT_E_GET_VALUE_PTR(heap, h, i)->a.set); + } else { + duk__mark_tval(heap, &DUK_HOBJECT_E_GET_VALUE_PTR(heap, h, i)->v); + } + } + + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ASIZE(h); i++) { + duk__mark_tval(heap, DUK_HOBJECT_A_GET_VALUE_PTR(heap, h, i)); + } + + /* Hash part is a 'weak reference' and does not contribute. */ + + duk__mark_heaphdr(heap, (duk_heaphdr *) DUK_HOBJECT_GET_PROTOTYPE(heap, h)); + + /* Fast path for objects which don't have a subclass struct, or have a + * subclass struct but nothing that needs marking in the subclass struct. + */ + if (DUK_HOBJECT_HAS_FASTREFS(h)) { + DUK_ASSERT(DUK_HOBJECT_ALLOWS_FASTREFS(h)); + return; + } + DUK_ASSERT(DUK_HOBJECT_PROHIBITS_FASTREFS(h)); + + /* XXX: reorg, more common first */ + if (DUK_HOBJECT_IS_COMPFUNC(h)) { + duk_hcompfunc *f = (duk_hcompfunc *) h; + duk_tval *tv, *tv_end; + duk_hobject **fn, **fn_end; + + DUK_HCOMPFUNC_ASSERT_VALID(f); + + /* 'data' is reachable through every compiled function which + * contains a reference. + */ + + duk__mark_heaphdr(heap, (duk_heaphdr *) DUK_HCOMPFUNC_GET_DATA(heap, f)); + duk__mark_heaphdr(heap, (duk_heaphdr *) DUK_HCOMPFUNC_GET_LEXENV(heap, f)); + duk__mark_heaphdr(heap, (duk_heaphdr *) DUK_HCOMPFUNC_GET_VARENV(heap, f)); + + if (DUK_HCOMPFUNC_GET_DATA(heap, f) != NULL) { + tv = DUK_HCOMPFUNC_GET_CONSTS_BASE(heap, f); + tv_end = DUK_HCOMPFUNC_GET_CONSTS_END(heap, f); + while (tv < tv_end) { + duk__mark_tval(heap, tv); + tv++; + } + + fn = DUK_HCOMPFUNC_GET_FUNCS_BASE(heap, f); + fn_end = DUK_HCOMPFUNC_GET_FUNCS_END(heap, f); + while (fn < fn_end) { + duk__mark_heaphdr_nonnull(heap, (duk_heaphdr *) *fn); + fn++; + } + } else { + /* May happen in some out-of-memory corner cases. */ + DUK_D(DUK_DPRINT("duk_hcompfunc 'data' is NULL, skipping marking")); + } + } else if (DUK_HOBJECT_IS_DECENV(h)) { + duk_hdecenv *e = (duk_hdecenv *) h; + DUK_HDECENV_ASSERT_VALID(e); + duk__mark_heaphdr(heap, (duk_heaphdr *) e->thread); + duk__mark_heaphdr(heap, (duk_heaphdr *) e->varmap); + } else if (DUK_HOBJECT_IS_OBJENV(h)) { + duk_hobjenv *e = (duk_hobjenv *) h; + DUK_HOBJENV_ASSERT_VALID(e); + duk__mark_heaphdr_nonnull(heap, (duk_heaphdr *) e->target); +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + } else if (DUK_HOBJECT_IS_BUFOBJ(h)) { + duk_hbufobj *b = (duk_hbufobj *) h; + DUK_HBUFOBJ_ASSERT_VALID(b); + duk__mark_heaphdr(heap, (duk_heaphdr *) b->buf); + duk__mark_heaphdr(heap, (duk_heaphdr *) b->buf_prop); +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + } else if (DUK_HOBJECT_IS_BOUNDFUNC(h)) { + duk_hboundfunc *f = (duk_hboundfunc *) (void *) h; + DUK_HBOUNDFUNC_ASSERT_VALID(f); + duk__mark_tval(heap, &f->target); + duk__mark_tval(heap, &f->this_binding); + duk__mark_tvals(heap, f->args, f->nargs); +#if defined(DUK_USE_ES6_PROXY) + } else if (DUK_HOBJECT_IS_PROXY(h)) { + duk_hproxy *p = (duk_hproxy *) h; + DUK_HPROXY_ASSERT_VALID(p); + duk__mark_heaphdr_nonnull(heap, (duk_heaphdr *) p->target); + duk__mark_heaphdr_nonnull(heap, (duk_heaphdr *) p->handler); +#endif /* DUK_USE_ES6_PROXY */ + } else if (DUK_HOBJECT_IS_THREAD(h)) { + duk_hthread *t = (duk_hthread *) h; + duk_activation *act; + duk_tval *tv; + + DUK_HTHREAD_ASSERT_VALID(t); + + tv = t->valstack; + while (tv < t->valstack_top) { + duk__mark_tval(heap, tv); + tv++; + } + + for (act = t->callstack_curr; act != NULL; act = act->parent) { + duk__mark_heaphdr(heap, (duk_heaphdr *) DUK_ACT_GET_FUNC(act)); + duk__mark_heaphdr(heap, (duk_heaphdr *) act->var_env); + duk__mark_heaphdr(heap, (duk_heaphdr *) act->lex_env); +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) + duk__mark_heaphdr(heap, (duk_heaphdr *) act->prev_caller); +#endif +#if 0 /* nothing now */ + for (cat = act->cat; cat != NULL; cat = cat->parent) { + } +#endif + } + + duk__mark_heaphdr(heap, (duk_heaphdr *) t->resumer); + + for (i = 0; i < DUK_NUM_BUILTINS; i++) { + duk__mark_heaphdr(heap, (duk_heaphdr *) t->builtins[i]); + } + } else { + /* We may come here if the object should have a FASTREFS flag + * but it's missing for some reason. Assert for never getting + * here; however, other than performance, this is harmless. + */ + DUK_D(DUK_DPRINT("missing FASTREFS flag for: %!iO", h)); + DUK_ASSERT(0); + } +} + +/* Mark any duk_heaphdr type. Recursion tracking happens only here. */ +DUK_LOCAL void duk__mark_heaphdr(duk_heap *heap, duk_heaphdr *h) { + DUK_DDD( + DUK_DDDPRINT("duk__mark_heaphdr %p, type %ld", (void *) h, (h != NULL ? (long) DUK_HEAPHDR_GET_TYPE(h) : (long) -1))); + + /* XXX: add non-null variant? */ + if (h == NULL) { + return; + } + + DUK_HEAPHDR_ASSERT_VALID(h); + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY(h) || DUK_HEAPHDR_HAS_REACHABLE(h)); + +#if defined(DUK_USE_ASSERTIONS) && defined(DUK_USE_REFERENCE_COUNTING) + if (!DUK_HEAPHDR_HAS_READONLY(h)) { + h->h_assert_refcount++; /* Comparison refcount: bump even if already reachable. */ + } +#endif + if (DUK_HEAPHDR_HAS_REACHABLE(h)) { + DUK_DDD(DUK_DDDPRINT("already marked reachable, skip")); + return; + } +#if defined(DUK_USE_ROM_OBJECTS) + /* READONLY objects always have REACHABLE set, so the check above + * will prevent READONLY objects from being marked here. + */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY(h)); +#endif + + DUK_HEAPHDR_SET_REACHABLE(h); + + if (heap->ms_recursion_depth >= DUK_USE_MARK_AND_SWEEP_RECLIMIT) { + DUK_D(DUK_DPRINT("mark-and-sweep recursion limit reached, marking as temproot: %p", (void *) h)); + DUK_HEAP_SET_MARKANDSWEEP_RECLIMIT_REACHED(heap); + DUK_HEAPHDR_SET_TEMPROOT(h); + return; + } + + heap->ms_recursion_depth++; + DUK_ASSERT(heap->ms_recursion_depth != 0); /* Wrap. */ + + switch (DUK_HEAPHDR_GET_TYPE(h)) { + case DUK_HTYPE_STRING: + duk__mark_hstring(heap, (duk_hstring *) h); + break; + case DUK_HTYPE_OBJECT: + duk__mark_hobject(heap, (duk_hobject *) h); + break; + case DUK_HTYPE_BUFFER: + /* nothing to mark */ + break; + default: + DUK_D(DUK_DPRINT("attempt to mark heaphdr %p with invalid htype %ld", (void *) h, (long) DUK_HEAPHDR_GET_TYPE(h))); + DUK_UNREACHABLE(); + } + + DUK_ASSERT(heap->ms_recursion_depth > 0); + heap->ms_recursion_depth--; +} + +DUK_LOCAL void duk__mark_tval(duk_heap *heap, duk_tval *tv) { + DUK_DDD(DUK_DDDPRINT("duk__mark_tval %p", (void *) tv)); + if (tv == NULL) { + return; + } + DUK_TVAL_ASSERT_VALID(tv); + if (DUK_TVAL_IS_HEAP_ALLOCATED(tv)) { + duk_heaphdr *h; + h = DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(h != NULL); + duk__mark_heaphdr_nonnull(heap, h); + } +} + +DUK_LOCAL void duk__mark_tvals(duk_heap *heap, duk_tval *tv, duk_idx_t count) { + DUK_ASSERT(count == 0 || tv != NULL); + + while (count-- > 0) { + DUK_TVAL_ASSERT_VALID(tv); + if (DUK_TVAL_IS_HEAP_ALLOCATED(tv)) { + duk_heaphdr *h; + h = DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(h != NULL); + duk__mark_heaphdr_nonnull(heap, h); + } + tv++; + } +} + +/* Mark any duk_heaphdr type, caller guarantees a non-NULL pointer. */ +DUK_LOCAL void duk__mark_heaphdr_nonnull(duk_heap *heap, duk_heaphdr *h) { + /* For now, just call the generic handler. Change when call sites + * are changed too. + */ + duk__mark_heaphdr(heap, h); +} + +/* + * Mark the heap. + */ + +DUK_LOCAL void duk__mark_roots_heap(duk_heap *heap) { + duk_small_uint_t i; + + DUK_DD(DUK_DDPRINT("duk__mark_roots_heap: %p", (void *) heap)); + + duk__mark_heaphdr(heap, (duk_heaphdr *) heap->heap_thread); + duk__mark_heaphdr(heap, (duk_heaphdr *) heap->heap_object); + + for (i = 0; i < DUK_HEAP_NUM_STRINGS; i++) { + duk_hstring *h = DUK_HEAP_GET_STRING(heap, i); + duk__mark_heaphdr(heap, (duk_heaphdr *) h); + } + + duk__mark_tval(heap, &heap->lj.value1); + duk__mark_tval(heap, &heap->lj.value2); + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + for (i = 0; i < heap->dbg_breakpoint_count; i++) { + duk__mark_heaphdr(heap, (duk_heaphdr *) heap->dbg_breakpoints[i].filename); + } +#endif +} + +/* + * Mark unreachable, finalizable objects. + * + * Such objects will be moved aside and their finalizers run later. They + * have to be treated as reachability roots for their properties etc to + * remain allocated. This marking is only done for unreachable values which + * would be swept later. + * + * Objects are first marked FINALIZABLE and only then marked as reachability + * roots; otherwise circular references might be handled inconsistently. + */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_LOCAL void duk__mark_finalizable(duk_heap *heap) { + duk_heaphdr *hdr; + duk_size_t count_finalizable = 0; + + DUK_DD(DUK_DDPRINT("duk__mark_finalizable: %p", (void *) heap)); + + DUK_ASSERT(heap->heap_thread != NULL); + + hdr = heap->heap_allocated; + while (hdr != NULL) { + /* A finalizer is looked up from the object and up its + * prototype chain (which allows inherited finalizers). + * The finalizer is checked for using a duk_hobject flag + * which is kept in sync with the presence and callability + * of a _Finalizer hidden symbol. + */ + + if (!DUK_HEAPHDR_HAS_REACHABLE(hdr) && DUK_HEAPHDR_IS_OBJECT(hdr) && !DUK_HEAPHDR_HAS_FINALIZED(hdr) && + DUK_HOBJECT_HAS_FINALIZER_FAST(heap, (duk_hobject *) hdr)) { + /* heaphdr: + * - is not reachable + * - is an object + * - is not a finalized object waiting for rescue/keep decision + * - has a finalizer + */ + + DUK_DD(DUK_DDPRINT("unreachable heap object will be " + "finalized -> mark as finalizable " + "and treat as a reachability root: %p", + (void *) hdr)); + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY(hdr)); + DUK_HEAPHDR_SET_FINALIZABLE(hdr); + count_finalizable++; + } + + hdr = DUK_HEAPHDR_GET_NEXT(heap, hdr); + } + + if (count_finalizable == 0) { + return; + } + + DUK_DD(DUK_DDPRINT("marked %ld heap objects as finalizable, now mark them reachable", (long) count_finalizable)); + + hdr = heap->heap_allocated; + while (hdr != NULL) { + if (DUK_HEAPHDR_HAS_FINALIZABLE(hdr)) { + duk__mark_heaphdr_nonnull(heap, hdr); + } + + hdr = DUK_HEAPHDR_GET_NEXT(heap, hdr); + } + + /* Caller will finish the marking process if we hit a recursion limit. */ +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +/* + * Mark objects on finalize_list. + */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_LOCAL void duk__mark_finalize_list(duk_heap *heap) { + duk_heaphdr *hdr; +#if defined(DUK_USE_DEBUG) + duk_size_t count_finalize_list = 0; +#endif + + DUK_DD(DUK_DDPRINT("duk__mark_finalize_list: %p", (void *) heap)); + + hdr = heap->finalize_list; + while (hdr != NULL) { + duk__mark_heaphdr_nonnull(heap, hdr); + hdr = DUK_HEAPHDR_GET_NEXT(heap, hdr); +#if defined(DUK_USE_DEBUG) + count_finalize_list++; +#endif + } + +#if defined(DUK_USE_DEBUG) + if (count_finalize_list > 0) { + DUK_D(DUK_DPRINT("marked %ld objects on the finalize_list as reachable (previous finalizer run skipped)", + (long) count_finalize_list)); + } +#endif +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +/* + * Fallback marking handler if recursion limit is reached. + * + * Iterates 'temproots' until recursion limit is no longer hit. Temproots + * can be in heap_allocated or finalize_list; refzero_list is now always + * empty for mark-and-sweep. A temproot may occur in finalize_list now if + * there are objects on the finalize_list and user code creates a reference + * from an object in heap_allocated to the object in finalize_list (which is + * now allowed), and it happened to coincide with the recursion depth limit. + * + * This is a slow scan, but guarantees that we finish with a bounded C stack. + * + * Note that nodes may have been marked as temproots before this scan begun, + * OR they may have been marked during the scan (as we process nodes + * recursively also during the scan). This is intended behavior. + */ + +#if defined(DUK_USE_DEBUG) +DUK_LOCAL void duk__handle_temproot(duk_heap *heap, duk_heaphdr *hdr, duk_size_t *count) { +#else +DUK_LOCAL void duk__handle_temproot(duk_heap *heap, duk_heaphdr *hdr) { +#endif + DUK_ASSERT(hdr != NULL); + + if (!DUK_HEAPHDR_HAS_TEMPROOT(hdr)) { + DUK_DDD(DUK_DDDPRINT("not a temp root: %p", (void *) hdr)); + return; + } + + DUK_DDD(DUK_DDDPRINT("found a temp root: %p", (void *) hdr)); + DUK_HEAPHDR_CLEAR_TEMPROOT(hdr); + DUK_HEAPHDR_CLEAR_REACHABLE(hdr); /* Done so that duk__mark_heaphdr() works correctly. */ +#if defined(DUK_USE_ASSERTIONS) && defined(DUK_USE_REFERENCE_COUNTING) + hdr->h_assert_refcount--; /* Same node visited twice. */ +#endif + duk__mark_heaphdr_nonnull(heap, hdr); + +#if defined(DUK_USE_DEBUG) + (*count)++; +#endif +} + +DUK_LOCAL void duk__mark_temproots_by_heap_scan(duk_heap *heap) { + duk_heaphdr *hdr; +#if defined(DUK_USE_DEBUG) + duk_size_t count; +#endif + + DUK_DD(DUK_DDPRINT("duk__mark_temproots_by_heap_scan: %p", (void *) heap)); + + while (DUK_HEAP_HAS_MARKANDSWEEP_RECLIMIT_REACHED(heap)) { + DUK_DD(DUK_DDPRINT("recursion limit reached, doing heap scan to continue from temproots")); + +#if defined(DUK_USE_DEBUG) + count = 0; +#endif + DUK_HEAP_CLEAR_MARKANDSWEEP_RECLIMIT_REACHED(heap); + + hdr = heap->heap_allocated; + while (hdr) { +#if defined(DUK_USE_DEBUG) + duk__handle_temproot(heap, hdr, &count); +#else + duk__handle_temproot(heap, hdr); +#endif + hdr = DUK_HEAPHDR_GET_NEXT(heap, hdr); + } + +#if defined(DUK_USE_FINALIZER_SUPPORT) + hdr = heap->finalize_list; + while (hdr) { +#if defined(DUK_USE_DEBUG) + duk__handle_temproot(heap, hdr, &count); +#else + duk__handle_temproot(heap, hdr); +#endif + hdr = DUK_HEAPHDR_GET_NEXT(heap, hdr); + } +#endif + +#if defined(DUK_USE_DEBUG) + DUK_DD(DUK_DDPRINT("temproot mark heap scan processed %ld temp roots", (long) count)); +#endif + } +} + +/* + * Finalize refcounts for heap elements just about to be freed. + * This must be done for all objects before freeing to avoid any + * stale pointer dereferences. + * + * Note that this must deduce the set of objects to be freed + * identically to duk__sweep_heap(). + */ + +#if defined(DUK_USE_REFERENCE_COUNTING) +DUK_LOCAL void duk__finalize_refcounts(duk_heap *heap) { + duk_heaphdr *hdr; + + DUK_ASSERT(heap->heap_thread != NULL); + + DUK_DD(DUK_DDPRINT("duk__finalize_refcounts: heap=%p", (void *) heap)); + + hdr = heap->heap_allocated; + while (hdr) { + if (!DUK_HEAPHDR_HAS_REACHABLE(hdr)) { + /* + * Unreachable object about to be swept. Finalize target refcounts + * (objects which the unreachable object points to) without doing + * refzero processing. Recursive decrefs are also prevented when + * refzero processing is disabled. + * + * Value cannot be a finalizable object, as they have been made + * temporarily reachable for this round. + */ + + DUK_DDD(DUK_DDDPRINT("unreachable object, refcount finalize before sweeping: %p", (void *) hdr)); + + /* Finalize using heap->heap_thread; DECREF has a + * suppress check for mark-and-sweep which is based + * on heap->ms_running. + */ + duk_heaphdr_refcount_finalize_norz(heap, hdr); + } + + hdr = DUK_HEAPHDR_GET_NEXT(heap, hdr); + } +} +#endif /* DUK_USE_REFERENCE_COUNTING */ + +/* + * Clear (reachable) flags of finalize_list. + * + * We could mostly do in the sweep phase when we move objects from the + * heap into the finalize_list. However, if a finalizer run is skipped + * during a mark-and-sweep, the objects on the finalize_list will be marked + * reachable during the next mark-and-sweep. Since they're already on the + * finalize_list, no-one will be clearing their REACHABLE flag so we do it + * here. (This now overlaps with the sweep handling in a harmless way.) + */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_LOCAL void duk__clear_finalize_list_flags(duk_heap *heap) { + duk_heaphdr *hdr; + + DUK_DD(DUK_DDPRINT("duk__clear_finalize_list_flags: %p", (void *) heap)); + + hdr = heap->finalize_list; + while (hdr) { + DUK_HEAPHDR_CLEAR_REACHABLE(hdr); +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(DUK_HEAPHDR_HAS_FINALIZABLE(hdr) || (heap->currently_finalizing == hdr)); +#endif + /* DUK_HEAPHDR_FLAG_FINALIZED may be set. */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_TEMPROOT(hdr)); + hdr = DUK_HEAPHDR_GET_NEXT(heap, hdr); + } +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +/* + * Sweep stringtable. + */ + +DUK_LOCAL void duk__sweep_stringtable(duk_heap *heap, duk_size_t *out_count_keep) { + duk_hstring *h; + duk_hstring *prev; + duk_uint32_t i; +#if defined(DUK_USE_DEBUG) + duk_size_t count_free = 0; +#endif + duk_size_t count_keep = 0; + + DUK_DD(DUK_DDPRINT("duk__sweep_stringtable: %p", (void *) heap)); + +#if defined(DUK_USE_STRTAB_PTRCOMP) + if (heap->strtable16 == NULL) { +#else + if (heap->strtable == NULL) { +#endif + goto done; + } + + for (i = 0; i < heap->st_size; i++) { +#if defined(DUK_USE_STRTAB_PTRCOMP) + h = DUK_USE_HEAPPTR_DEC16(heap->heap_udata, heap->strtable16[i]); +#else + h = heap->strtable[i]; +#endif + prev = NULL; + while (h != NULL) { + duk_hstring *next; + next = h->hdr.h_next; + + if (DUK_HEAPHDR_HAS_REACHABLE((duk_heaphdr *) h)) { + DUK_HEAPHDR_CLEAR_REACHABLE((duk_heaphdr *) h); + count_keep++; + prev = h; + } else { +#if defined(DUK_USE_DEBUG) + count_free++; +#endif + + /* For pinned strings the refcount has been + * bumped. We could unbump it here before + * freeing, but that's actually not necessary + * except for assertions. + */ +#if 0 + if (DUK_HSTRING_HAS_PINNED_LITERAL(h)) { + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT((duk_heaphdr *) h) > 0U); + DUK_HSTRING_DECREF_NORZ(heap->heap_thread, h); + DUK_HSTRING_CLEAR_PINNED_LITERAL(h); + } +#endif +#if defined(DUK_USE_REFERENCE_COUNTING) + /* Non-zero refcounts should not happen for unreachable strings, + * because we refcount finalize all unreachable objects which + * should have decreased unreachable string refcounts to zero + * (even for cycles). However, pinned strings have a +1 bump. + */ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT((duk_heaphdr *) h) == DUK_HSTRING_HAS_PINNED_LITERAL(h) ? 1U : + 0U); +#endif + + /* Deal with weak references first. */ + duk_heap_strcache_string_remove(heap, (duk_hstring *) h); + + /* Remove the string from the string table. */ + duk_heap_strtable_unlink_prev(heap, (duk_hstring *) h, (duk_hstring *) prev); + + /* Free inner references (these exist e.g. when external + * strings are enabled) and the struct itself. + */ + duk_free_hstring(heap, (duk_hstring *) h); + + /* Don't update 'prev'; it should be last string kept. */ + } + + h = next; + } + } + +done: +#if defined(DUK_USE_DEBUG) + DUK_D(DUK_DPRINT("mark-and-sweep sweep stringtable: %ld freed, %ld kept", (long) count_free, (long) count_keep)); +#endif + *out_count_keep = count_keep; +} + +/* + * Sweep heap. + */ + +DUK_LOCAL void duk__sweep_heap(duk_heap *heap, duk_small_uint_t flags, duk_size_t *out_count_keep) { + duk_heaphdr *prev; /* last element that was left in the heap */ + duk_heaphdr *curr; + duk_heaphdr *next; +#if defined(DUK_USE_DEBUG) + duk_size_t count_free = 0; + duk_size_t count_finalize = 0; + duk_size_t count_rescue = 0; +#endif + duk_size_t count_keep = 0; + + DUK_DD(DUK_DDPRINT("duk__sweep_heap: %p", (void *) heap)); + + prev = NULL; + curr = heap->heap_allocated; + heap->heap_allocated = NULL; + while (curr) { + /* Strings and ROM objects are never placed on the heap allocated list. */ + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(curr) != DUK_HTYPE_STRING); + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY(curr)); + + next = DUK_HEAPHDR_GET_NEXT(heap, curr); + + if (DUK_HEAPHDR_HAS_REACHABLE(curr)) { + /* + * Reachable object: + * - If FINALIZABLE -> actually unreachable (but marked + * artificially reachable), queue to finalize_list. + * - If !FINALIZABLE but FINALIZED -> rescued after + * finalizer execution. + * - Otherwise just a normal, reachable object. + * + * Objects which are kept are queued to heap_allocated + * tail (we're essentially filtering heap_allocated in + * practice). + */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) + if (DUK_UNLIKELY(DUK_HEAPHDR_HAS_FINALIZABLE(curr))) { + DUK_ASSERT(!DUK_HEAPHDR_HAS_FINALIZED(curr)); + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(curr) == DUK_HTYPE_OBJECT); + DUK_DD(DUK_DDPRINT("sweep; reachable, finalizable --> move to finalize_list: %p", (void *) curr)); + +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_HEAPHDR_PREINC_REFCOUNT( + curr); /* Bump refcount so that refzero never occurs when pending a finalizer call. */ +#endif + DUK_HEAP_INSERT_INTO_FINALIZE_LIST(heap, curr); +#if defined(DUK_USE_DEBUG) + count_finalize++; +#endif + } else +#endif /* DUK_USE_FINALIZER_SUPPORT */ + { + if (DUK_UNLIKELY(DUK_HEAPHDR_HAS_FINALIZED(curr))) { + DUK_ASSERT(!DUK_HEAPHDR_HAS_FINALIZABLE(curr)); + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(curr) == DUK_HTYPE_OBJECT); + + if (flags & DUK_MS_FLAG_POSTPONE_RESCUE) { + DUK_DD(DUK_DDPRINT("sweep; reachable, finalized, but postponing rescue decisions " + "--> keep object (with FINALIZED set): %!iO", + curr)); + count_keep++; + } else { + DUK_DD(DUK_DDPRINT("sweep; reachable, finalized --> rescued after finalization: %p", + (void *) curr)); +#if defined(DUK_USE_FINALIZER_SUPPORT) + DUK_HEAPHDR_CLEAR_FINALIZED(curr); +#endif +#if defined(DUK_USE_DEBUG) + count_rescue++; +#endif + } + } else { + DUK_DD(DUK_DDPRINT("sweep; reachable --> keep: %!iO", curr)); + count_keep++; + } + + if (prev != NULL) { + DUK_ASSERT(heap->heap_allocated != NULL); + DUK_HEAPHDR_SET_NEXT(heap, prev, curr); + } else { + DUK_ASSERT(heap->heap_allocated == NULL); + heap->heap_allocated = curr; + } +#if defined(DUK_USE_DOUBLE_LINKED_HEAP) + DUK_HEAPHDR_SET_PREV(heap, curr, prev); +#endif + DUK_HEAPHDR_ASSERT_LINKS(heap, prev); + DUK_HEAPHDR_ASSERT_LINKS(heap, curr); + prev = curr; + } + + /* + * Shrink check for value stacks here. We're inside + * ms_prevent_count protection which prevents recursive + * mark-and-sweep and refzero finalizers, so there are + * no side effects that would affect the heap lists. + */ + if (DUK_HEAPHDR_IS_OBJECT(curr) && DUK_HOBJECT_IS_THREAD((duk_hobject *) curr)) { + duk_hthread *thr_curr = (duk_hthread *) curr; + DUK_DD(DUK_DDPRINT("value stack shrink check for thread: %!O", curr)); + duk_valstack_shrink_check_nothrow(thr_curr, flags & DUK_MS_FLAG_EMERGENCY /*snug*/); + } + + DUK_HEAPHDR_CLEAR_REACHABLE(curr); + /* Keep FINALIZED if set, used if rescue decisions are postponed. */ + /* Keep FINALIZABLE for objects on finalize_list. */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_REACHABLE(curr)); + } else { + /* + * Unreachable object: + * - If FINALIZED, object was finalized but not + * rescued. This doesn't affect freeing. + * - Otherwise normal unreachable object. + * + * There's no guard preventing a FINALIZED object + * from being freed while finalizers execute: the + * artificial finalize_list reachability roots can't + * cause an incorrect free decision (but can cause + * an incorrect rescue decision). + */ + +#if defined(DUK_USE_REFERENCE_COUNTING) + /* Non-zero refcounts should not happen because we refcount + * finalize all unreachable objects which should cancel out + * refcounts (even for cycles). + */ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(curr) == 0); +#endif + DUK_ASSERT(!DUK_HEAPHDR_HAS_FINALIZABLE(curr)); + +#if defined(DUK_USE_DEBUG) + if (DUK_HEAPHDR_HAS_FINALIZED(curr)) { + DUK_DD(DUK_DDPRINT("sweep; unreachable, finalized --> finalized object not rescued: %p", + (void *) curr)); + } else { + DUK_DD(DUK_DDPRINT("sweep; not reachable --> free: %p", (void *) curr)); + } + +#endif + + /* Note: object cannot be a finalizable unreachable object, as + * they have been marked temporarily reachable for this round, + * and are handled above. + */ + +#if defined(DUK_USE_DEBUG) + count_free++; +#endif + + /* Weak refs should be handled here, but no weak refs for + * any non-string objects exist right now. + */ + + /* Free object and all auxiliary (non-heap) allocs. */ + duk_heap_free_heaphdr_raw(heap, curr); + } + + curr = next; + } + + if (prev != NULL) { + DUK_HEAPHDR_SET_NEXT(heap, prev, NULL); + } + DUK_HEAPHDR_ASSERT_LINKS(heap, prev); + +#if defined(DUK_USE_DEBUG) + DUK_D(DUK_DPRINT("mark-and-sweep sweep objects (non-string): %ld freed, %ld kept, %ld rescued, %ld queued for finalization", + (long) count_free, + (long) count_keep, + (long) count_rescue, + (long) count_finalize)); +#endif + *out_count_keep = count_keep; +} + +/* + * Litcache helpers. + */ + +#if defined(DUK_USE_LITCACHE_SIZE) +DUK_LOCAL void duk__wipe_litcache(duk_heap *heap) { + duk_uint_t i; + duk_litcache_entry *e; + + e = heap->litcache; + for (i = 0; i < DUK_USE_LITCACHE_SIZE; i++) { + e->addr = NULL; + /* e->h does not need to be invalidated: when e->addr is + * NULL, e->h is considered garbage. + */ + e++; + } +} +#endif /* DUK_USE_LITCACHE_SIZE */ + +/* + * Object compaction. + * + * Compaction is assumed to never throw an error. + */ + +DUK_LOCAL int duk__protected_compact_object(duk_hthread *thr, void *udata) { + duk_hobject *obj; + /* XXX: for threads, compact stacks? */ + + DUK_UNREF(udata); + obj = duk_known_hobject(thr, -1); + duk_hobject_compact_props(thr, obj); + return 0; +} + +#if defined(DUK_USE_DEBUG) +DUK_LOCAL void duk__compact_object_list(duk_heap *heap, + duk_hthread *thr, + duk_heaphdr *start, + duk_size_t *p_count_check, + duk_size_t *p_count_compact, + duk_size_t *p_count_bytes_saved) { +#else +DUK_LOCAL void duk__compact_object_list(duk_heap *heap, duk_hthread *thr, duk_heaphdr *start) { +#endif + duk_heaphdr *curr; +#if defined(DUK_USE_DEBUG) + duk_size_t old_size, new_size; +#endif + duk_hobject *obj; + + DUK_UNREF(heap); + + curr = start; + while (curr) { + DUK_DDD(DUK_DDDPRINT("mark-and-sweep compact: %p", (void *) curr)); + + if (DUK_HEAPHDR_GET_TYPE(curr) != DUK_HTYPE_OBJECT) { + goto next; + } + obj = (duk_hobject *) curr; + +#if defined(DUK_USE_DEBUG) + old_size = + DUK_HOBJECT_P_COMPUTE_SIZE(DUK_HOBJECT_GET_ESIZE(obj), DUK_HOBJECT_GET_ASIZE(obj), DUK_HOBJECT_GET_HSIZE(obj)); +#endif + + DUK_DD(DUK_DDPRINT("compact object: %p", (void *) obj)); + duk_push_hobject(thr, obj); + /* XXX: disable error handlers for duration of compaction? */ + duk_safe_call(thr, duk__protected_compact_object, NULL, 1, 0); + +#if defined(DUK_USE_DEBUG) + new_size = + DUK_HOBJECT_P_COMPUTE_SIZE(DUK_HOBJECT_GET_ESIZE(obj), DUK_HOBJECT_GET_ASIZE(obj), DUK_HOBJECT_GET_HSIZE(obj)); +#endif + +#if defined(DUK_USE_DEBUG) + (*p_count_compact)++; + (*p_count_bytes_saved) += (duk_size_t) (old_size - new_size); +#endif + + next: + curr = DUK_HEAPHDR_GET_NEXT(heap, curr); +#if defined(DUK_USE_DEBUG) + (*p_count_check)++; +#endif + } +} + +DUK_LOCAL void duk__compact_objects(duk_heap *heap) { + /* XXX: which lists should participate? to be finalized? */ +#if defined(DUK_USE_DEBUG) + duk_size_t count_check = 0; + duk_size_t count_compact = 0; + duk_size_t count_bytes_saved = 0; +#endif + + DUK_DD(DUK_DDPRINT("duk__compact_objects: %p", (void *) heap)); + + DUK_ASSERT(heap->heap_thread != NULL); + +#if defined(DUK_USE_DEBUG) + duk__compact_object_list(heap, heap->heap_thread, heap->heap_allocated, &count_check, &count_compact, &count_bytes_saved); +#if defined(DUK_USE_FINALIZER_SUPPORT) + duk__compact_object_list(heap, heap->heap_thread, heap->finalize_list, &count_check, &count_compact, &count_bytes_saved); +#endif +#else + duk__compact_object_list(heap, heap->heap_thread, heap->heap_allocated); +#if defined(DUK_USE_FINALIZER_SUPPORT) + duk__compact_object_list(heap, heap->heap_thread, heap->finalize_list); +#endif +#endif +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(heap->refzero_list == NULL); /* Always handled to completion inline in DECREF. */ +#endif + +#if defined(DUK_USE_DEBUG) + DUK_D(DUK_DPRINT("mark-and-sweep compact objects: %ld checked, %ld compaction attempts, %ld bytes saved by compaction", + (long) count_check, + (long) count_compact, + (long) count_bytes_saved)); +#endif +} + +/* + * Assertion helpers. + */ + +#if defined(DUK_USE_ASSERTIONS) +typedef void (*duk__gc_heaphdr_assert)(duk_heap *heap, duk_heaphdr *h); +typedef void (*duk__gc_hstring_assert)(duk_heap *heap, duk_hstring *h); + +DUK_LOCAL void duk__assert_walk_list(duk_heap *heap, duk_heaphdr *start, duk__gc_heaphdr_assert func) { + duk_heaphdr *curr; + for (curr = start; curr != NULL; curr = DUK_HEAPHDR_GET_NEXT(heap, curr)) { + func(heap, curr); + } +} + +DUK_LOCAL void duk__assert_walk_strtable(duk_heap *heap, duk__gc_hstring_assert func) { + duk_uint32_t i; + + for (i = 0; i < heap->st_size; i++) { + duk_hstring *h; + +#if defined(DUK_USE_STRTAB_PTRCOMP) + h = DUK_USE_HEAPPTR_DEC16(heap->heap_udata, heap->strtable16[i]); +#else + h = heap->strtable[i]; +#endif + while (h != NULL) { + func(heap, h); + h = h->hdr.h_next; + } + } +} + +DUK_LOCAL void duk__assert_heaphdr_flags_cb(duk_heap *heap, duk_heaphdr *h) { + DUK_UNREF(heap); + DUK_ASSERT(!DUK_HEAPHDR_HAS_REACHABLE(h)); + DUK_ASSERT(!DUK_HEAPHDR_HAS_TEMPROOT(h)); + DUK_ASSERT(!DUK_HEAPHDR_HAS_FINALIZABLE(h)); + /* may have FINALIZED */ +} +DUK_LOCAL void duk__assert_heaphdr_flags(duk_heap *heap) { + duk__assert_walk_list(heap, heap->heap_allocated, duk__assert_heaphdr_flags_cb); +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(heap->refzero_list == NULL); /* Always handled to completion inline in DECREF. */ +#endif + /* XXX: Assertions for finalize_list? */ +} + +DUK_LOCAL void duk__assert_validity_cb1(duk_heap *heap, duk_heaphdr *h) { + DUK_UNREF(heap); + DUK_ASSERT(DUK_HEAPHDR_IS_OBJECT(h) || DUK_HEAPHDR_IS_BUFFER(h)); + duk_heaphdr_assert_valid_subclassed(h); +} +DUK_LOCAL void duk__assert_validity_cb2(duk_heap *heap, duk_hstring *h) { + DUK_UNREF(heap); + DUK_ASSERT(DUK_HEAPHDR_IS_STRING((duk_heaphdr *) h)); + duk_heaphdr_assert_valid_subclassed((duk_heaphdr *) h); +} +DUK_LOCAL void duk__assert_validity(duk_heap *heap) { + duk__assert_walk_list(heap, heap->heap_allocated, duk__assert_validity_cb1); +#if defined(DUK_USE_FINALIZER_SUPPORT) + duk__assert_walk_list(heap, heap->finalize_list, duk__assert_validity_cb1); +#endif +#if defined(DUK_USE_REFERENCE_COUNTING) + duk__assert_walk_list(heap, heap->refzero_list, duk__assert_validity_cb1); +#endif + duk__assert_walk_strtable(heap, duk__assert_validity_cb2); +} + +#if defined(DUK_USE_REFERENCE_COUNTING) +DUK_LOCAL void duk__assert_valid_refcounts_cb(duk_heap *heap, duk_heaphdr *h) { + /* Cannot really assert much w.r.t. refcounts now. */ + + DUK_UNREF(heap); + if (DUK_HEAPHDR_GET_REFCOUNT(h) == 0 && DUK_HEAPHDR_HAS_FINALIZED(h)) { + /* An object may be in heap_allocated list with a zero + * refcount if it has just been finalized and is waiting + * to be collected by the next cycle. + * (This doesn't currently happen however.) + */ + } else if (DUK_HEAPHDR_GET_REFCOUNT(h) == 0) { + /* An object may be in heap_allocated list with a zero + * refcount also if it is a temporary object created + * during debugger paused state. It will get collected + * by mark-and-sweep based on its reachability status + * (presumably not reachable because refcount is 0). + */ + } + DUK_ASSERT_DISABLE(DUK_HEAPHDR_GET_REFCOUNT(h) >= 0); /* Unsigned. */ +} +DUK_LOCAL void duk__assert_valid_refcounts(duk_heap *heap) { + duk__assert_walk_list(heap, heap->heap_allocated, duk__assert_valid_refcounts_cb); +} + +DUK_LOCAL void duk__clear_assert_refcounts_cb1(duk_heap *heap, duk_heaphdr *h) { + DUK_UNREF(heap); + h->h_assert_refcount = 0; +} +DUK_LOCAL void duk__clear_assert_refcounts_cb2(duk_heap *heap, duk_hstring *h) { + DUK_UNREF(heap); + ((duk_heaphdr *) h)->h_assert_refcount = 0; +} +DUK_LOCAL void duk__clear_assert_refcounts(duk_heap *heap) { + duk__assert_walk_list(heap, heap->heap_allocated, duk__clear_assert_refcounts_cb1); +#if defined(DUK_USE_FINALIZER_SUPPORT) + duk__assert_walk_list(heap, heap->finalize_list, duk__clear_assert_refcounts_cb1); +#endif +#if defined(DUK_USE_REFERENCE_COUNTING) + duk__assert_walk_list(heap, heap->refzero_list, duk__clear_assert_refcounts_cb1); +#endif + duk__assert_walk_strtable(heap, duk__clear_assert_refcounts_cb2); +} + +DUK_LOCAL void duk__check_refcount_heaphdr(duk_heaphdr *hdr) { + duk_bool_t count_ok; + duk_size_t expect_refc; + + /* The refcount check only makes sense for reachable objects on + * heap_allocated or string table, after the sweep phase. Prior to + * sweep phase refcounts will include references that are not visible + * via reachability roots. + * + * Because we're called after the sweep phase, all heap objects on + * heap_allocated are reachable. REACHABLE flags have already been + * cleared so we can't check them. + */ + + /* ROM objects have intentionally incorrect refcount (1), but we won't + * check them. + */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY(hdr)); + + expect_refc = hdr->h_assert_refcount; + if (DUK_HEAPHDR_IS_STRING(hdr) && DUK_HSTRING_HAS_PINNED_LITERAL((duk_hstring *) hdr)) { + expect_refc++; + } + count_ok = ((duk_size_t) DUK_HEAPHDR_GET_REFCOUNT(hdr) == expect_refc); + if (!count_ok) { + DUK_D(DUK_DPRINT("refcount mismatch for: %p: header=%ld counted=%ld --> %!iO", + (void *) hdr, + (long) DUK_HEAPHDR_GET_REFCOUNT(hdr), + (long) hdr->h_assert_refcount, + hdr)); + DUK_ASSERT(0); + } +} + +DUK_LOCAL void duk__check_assert_refcounts_cb1(duk_heap *heap, duk_heaphdr *h) { + DUK_UNREF(heap); + duk__check_refcount_heaphdr(h); +} +DUK_LOCAL void duk__check_assert_refcounts_cb2(duk_heap *heap, duk_hstring *h) { + DUK_UNREF(heap); + duk__check_refcount_heaphdr((duk_heaphdr *) h); +} +DUK_LOCAL void duk__check_assert_refcounts(duk_heap *heap) { + duk__assert_walk_list(heap, heap->heap_allocated, duk__check_assert_refcounts_cb1); +#if defined(DUK_USE_FINALIZER_SUPPORT) + duk__assert_walk_list(heap, heap->finalize_list, duk__check_assert_refcounts_cb1); +#endif + /* XXX: Assert anything for refzero_list? */ + duk__assert_walk_strtable(heap, duk__check_assert_refcounts_cb2); +} +#endif /* DUK_USE_REFERENCE_COUNTING */ + +#if defined(DUK_USE_LITCACHE_SIZE) +DUK_LOCAL void duk__assert_litcache_nulls(duk_heap *heap) { + duk_uint_t i; + duk_litcache_entry *e; + + e = heap->litcache; + for (i = 0; i < DUK_USE_LITCACHE_SIZE; i++) { + /* Entry addresses were NULLed before mark-and-sweep, check + * that they're still NULL afterwards to ensure no pointers + * were recorded through any side effects. + */ + DUK_ASSERT(e->addr == NULL); + } +} +#endif /* DUK_USE_LITCACHE_SIZE */ +#endif /* DUK_USE_ASSERTIONS */ + +/* + * Stats dump. + */ + +#if defined(DUK_USE_DEBUG) +DUK_LOCAL void duk__dump_stats(duk_heap *heap) { + DUK_D(DUK_DPRINT("stats executor: opcodes=%ld, interrupt=%ld, throw=%ld", + (long) heap->stats_exec_opcodes, + (long) heap->stats_exec_interrupt, + (long) heap->stats_exec_throw)); + DUK_D(DUK_DPRINT("stats call: all=%ld, tailcall=%ld, ecmatoecma=%ld", + (long) heap->stats_call_all, + (long) heap->stats_call_tailcall, + (long) heap->stats_call_ecmatoecma)); + DUK_D(DUK_DPRINT("stats safecall: all=%ld, nothrow=%ld, throw=%ld", + (long) heap->stats_safecall_all, + (long) heap->stats_safecall_nothrow, + (long) heap->stats_safecall_throw)); + DUK_D(DUK_DPRINT("stats mark-and-sweep: try_count=%ld, skip_count=%ld, emergency_count=%ld", + (long) heap->stats_ms_try_count, + (long) heap->stats_ms_skip_count, + (long) heap->stats_ms_emergency_count)); + DUK_D(DUK_DPRINT("stats stringtable: intern_hit=%ld, intern_miss=%ld, " + "resize_check=%ld, resize_grow=%ld, resize_shrink=%ld, " + "litcache_hit=%ld, litcache_miss=%ld, litcache_pin=%ld", + (long) heap->stats_strtab_intern_hit, + (long) heap->stats_strtab_intern_miss, + (long) heap->stats_strtab_resize_check, + (long) heap->stats_strtab_resize_grow, + (long) heap->stats_strtab_resize_shrink, + (long) heap->stats_strtab_litcache_hit, + (long) heap->stats_strtab_litcache_miss, + (long) heap->stats_strtab_litcache_pin)); + DUK_D(DUK_DPRINT("stats object: realloc_props=%ld, abandon_array=%ld", + (long) heap->stats_object_realloc_props, + (long) heap->stats_object_abandon_array)); + DUK_D(DUK_DPRINT("stats getownpropdesc: count=%ld, hit=%ld, miss=%ld", + (long) heap->stats_getownpropdesc_count, + (long) heap->stats_getownpropdesc_hit, + (long) heap->stats_getownpropdesc_miss)); + DUK_D(DUK_DPRINT("stats getpropdesc: count=%ld, hit=%ld, miss=%ld", + (long) heap->stats_getpropdesc_count, + (long) heap->stats_getpropdesc_hit, + (long) heap->stats_getpropdesc_miss)); + DUK_D(DUK_DPRINT("stats getprop: all=%ld, arrayidx=%ld, bufobjidx=%ld, " + "bufferidx=%ld, bufferlen=%ld, stringidx=%ld, stringlen=%ld, " + "proxy=%ld, arguments=%ld", + (long) heap->stats_getprop_all, + (long) heap->stats_getprop_arrayidx, + (long) heap->stats_getprop_bufobjidx, + (long) heap->stats_getprop_bufferidx, + (long) heap->stats_getprop_bufferlen, + (long) heap->stats_getprop_stringidx, + (long) heap->stats_getprop_stringlen, + (long) heap->stats_getprop_proxy, + (long) heap->stats_getprop_arguments)); + DUK_D(DUK_DPRINT("stats putprop: all=%ld, arrayidx=%ld, bufobjidx=%ld, " + "bufferidx=%ld, proxy=%ld", + (long) heap->stats_putprop_all, + (long) heap->stats_putprop_arrayidx, + (long) heap->stats_putprop_bufobjidx, + (long) heap->stats_putprop_bufferidx, + (long) heap->stats_putprop_proxy)); + DUK_D(DUK_DPRINT("stats getvar: all=%ld", (long) heap->stats_getvar_all)); + DUK_D(DUK_DPRINT("stats putvar: all=%ld", (long) heap->stats_putvar_all)); + DUK_D(DUK_DPRINT("stats envrec: delayedcreate=%ld, create=%ld, newenv=%ld, oldenv=%ld, pushclosure=%ld", + (long) heap->stats_envrec_delayedcreate, + (long) heap->stats_envrec_create, + (long) heap->stats_envrec_newenv, + (long) heap->stats_envrec_oldenv, + (long) heap->stats_envrec_pushclosure)); +} +#endif /* DUK_USE_DEBUG */ + +/* + * Main mark-and-sweep function. + * + * 'flags' represents the features requested by the caller. The current + * heap->ms_base_flags is ORed automatically into the flags; the base flags + * mask typically prevents certain mark-and-sweep operation to avoid trouble. + */ + +DUK_INTERNAL void duk_heap_mark_and_sweep(duk_heap *heap, duk_small_uint_t flags) { + duk_size_t count_keep_obj; + duk_size_t count_keep_str; +#if defined(DUK_USE_VOLUNTARY_GC) + duk_size_t tmp; +#endif + duk_bool_t entry_creating_error; + + DUK_STATS_INC(heap, stats_ms_try_count); +#if defined(DUK_USE_DEBUG) + if (flags & DUK_MS_FLAG_EMERGENCY) { + DUK_STATS_INC(heap, stats_ms_emergency_count); + } +#endif + + /* If debugger is paused, garbage collection is disabled by default. + * This is achieved by bumping ms_prevent_count when becoming paused. + */ + DUK_ASSERT(!DUK_HEAP_HAS_DEBUGGER_PAUSED(heap) || heap->ms_prevent_count > 0); + + /* Prevention/recursion check as soon as possible because we may + * be called a number of times when voluntary mark-and-sweep is + * pending. + */ + if (heap->ms_prevent_count != 0) { + DUK_DD(DUK_DDPRINT("reject recursive mark-and-sweep")); + DUK_STATS_INC(heap, stats_ms_skip_count); + return; + } + DUK_ASSERT(heap->ms_running == 0); /* ms_prevent_count is bumped when ms_running is set */ + + /* Heap_thread is used during mark-and-sweep for refcount finalization + * (it's also used for finalizer execution once mark-and-sweep is + * complete). Heap allocation code ensures heap_thread is set and + * properly initialized before setting ms_prevent_count to 0. + */ + DUK_ASSERT(heap->heap_thread != NULL); + DUK_ASSERT(heap->heap_thread->valstack != NULL); + + DUK_D(DUK_DPRINT("garbage collect (mark-and-sweep) starting, requested flags: 0x%08lx, effective flags: 0x%08lx", + (unsigned long) flags, + (unsigned long) (flags | heap->ms_base_flags))); + + flags |= heap->ms_base_flags; +#if defined(DUK_USE_FINALIZER_SUPPORT) + if (heap->finalize_list != NULL) { + flags |= DUK_MS_FLAG_POSTPONE_RESCUE; + } +#endif + + /* + * Assertions before + */ + +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(heap->ms_prevent_count == 0); + DUK_ASSERT(heap->ms_running == 0); + DUK_ASSERT(!DUK_HEAP_HAS_DEBUGGER_PAUSED(heap)); + DUK_ASSERT(!DUK_HEAP_HAS_MARKANDSWEEP_RECLIMIT_REACHED(heap)); + DUK_ASSERT(heap->ms_recursion_depth == 0); + duk__assert_heaphdr_flags(heap); + duk__assert_validity(heap); +#if defined(DUK_USE_REFERENCE_COUNTING) + /* Note: heap->refzero_free_running may be true; a refcount + * finalizer may trigger a mark-and-sweep. + */ + duk__assert_valid_refcounts(heap); +#endif /* DUK_USE_REFERENCE_COUNTING */ +#endif /* DUK_USE_ASSERTIONS */ + + /* + * Begin + */ + + DUK_ASSERT(heap->ms_prevent_count == 0); + DUK_ASSERT(heap->ms_running == 0); + heap->ms_prevent_count = 1; + heap->ms_running = 1; + entry_creating_error = heap->creating_error; + heap->creating_error = 0; + + /* + * Free activation/catcher freelists on every mark-and-sweep for now. + * This is an initial rough draft; ideally we'd keep count of the + * freelist size and free only excess entries. + */ + + DUK_D(DUK_DPRINT("freeing temporary freelists")); + duk_heap_free_freelists(heap); + + /* + * Mark roots, hoping that recursion limit is not normally hit. + * If recursion limit is hit, run additional reachability rounds + * starting from "temproots" until marking is complete. + * + * Marking happens in two phases: first we mark actual reachability + * roots (and run "temproots" to complete the process). Then we + * check which objects are unreachable and are finalizable; such + * objects are marked as FINALIZABLE and marked as reachability + * (and "temproots" is run again to complete the process). + * + * The heap finalize_list must also be marked as a reachability root. + * There may be objects on the list from a previous round if the + * previous run had finalizer skip flag. + */ + +#if defined(DUK_USE_ASSERTIONS) && defined(DUK_USE_REFERENCE_COUNTING) + duk__clear_assert_refcounts(heap); +#endif +#if defined(DUK_USE_LITCACHE_SIZE) + duk__wipe_litcache(heap); +#endif + duk__mark_roots_heap(heap); /* Mark main reachability roots. */ +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(heap->refzero_list == NULL); /* Always handled to completion inline in DECREF. */ +#endif + duk__mark_temproots_by_heap_scan(heap); /* Temproots. */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) + duk__mark_finalizable(heap); /* Mark finalizable as reachability roots. */ + duk__mark_finalize_list(heap); /* Mark finalizer work list as reachability roots. */ +#endif + duk__mark_temproots_by_heap_scan(heap); /* Temproots. */ + + /* + * Sweep garbage and remove marking flags, and move objects with + * finalizers to the finalizer work list. + * + * Objects to be swept need to get their refcounts finalized before + * they are swept. In other words, their target object refcounts + * need to be decreased. This has to be done before freeing any + * objects to avoid decref'ing dangling pointers (which may happen + * even without bugs, e.g. with reference loops) + * + * Because strings don't point to other heap objects, similar + * finalization is not necessary for strings. + */ + + /* XXX: more emergency behavior, e.g. find smaller hash sizes etc */ + +#if defined(DUK_USE_REFERENCE_COUNTING) + duk__finalize_refcounts(heap); +#endif + duk__sweep_heap(heap, flags, &count_keep_obj); + duk__sweep_stringtable(heap, &count_keep_str); +#if defined(DUK_USE_ASSERTIONS) && defined(DUK_USE_REFERENCE_COUNTING) + duk__check_assert_refcounts(heap); +#endif +#if defined(DUK_USE_REFERENCE_COUNTING) + DUK_ASSERT(heap->refzero_list == NULL); /* Always handled to completion inline in DECREF. */ +#endif +#if defined(DUK_USE_FINALIZER_SUPPORT) + duk__clear_finalize_list_flags(heap); +#endif + + /* + * Object compaction (emergency only). + * + * Object compaction is a separate step after sweeping, as there is + * more free memory for it to work with. Also, currently compaction + * may insert new objects into the heap allocated list and the string + * table which we don't want to do during a sweep (the reachability + * flags of such objects would be incorrect). The objects inserted + * are currently: + * + * - a temporary duk_hbuffer for a new properties allocation + * - if array part is abandoned, string keys are interned + * + * The object insertions go to the front of the list, so they do not + * cause an infinite loop (they are not compacted). + * + * At present compaction is not allowed when mark-and-sweep runs + * during error handling because it involves a duk_safe_call() + * interfering with error state. + */ + + if ((flags & DUK_MS_FLAG_EMERGENCY) && !(flags & DUK_MS_FLAG_NO_OBJECT_COMPACTION)) { + if (heap->lj.type != DUK_LJ_TYPE_UNKNOWN) { + DUK_D(DUK_DPRINT("lj.type (%ld) not DUK_LJ_TYPE_UNKNOWN, skip object compaction", (long) heap->lj.type)); + } else { + DUK_D(DUK_DPRINT("object compaction")); + duk__compact_objects(heap); + } + } + + /* + * String table resize check. + * + * This is mainly useful in emergency GC: if the string table load + * factor is really low for some reason, we can shrink the string + * table to a smaller size and free some memory in the process. + * Only execute in emergency GC. String table has internal flags + * to protect against recursive resizing if this mark-and-sweep pass + * was triggered by a string table resize. + */ + + if (flags & DUK_MS_FLAG_EMERGENCY) { + DUK_D(DUK_DPRINT("stringtable resize check in emergency gc")); + duk_heap_strtable_force_resize(heap); + } + + /* + * Finish + */ + + DUK_ASSERT(heap->ms_prevent_count == 1); + DUK_ASSERT(heap->ms_running == 1); + heap->ms_prevent_count = 0; + heap->ms_running = 0; + heap->creating_error = entry_creating_error; /* for nested error handling, see GH-2278 */ + + /* + * Assertions after + */ + +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(heap->ms_prevent_count == 0); + DUK_ASSERT(!DUK_HEAP_HAS_MARKANDSWEEP_RECLIMIT_REACHED(heap)); + DUK_ASSERT(heap->ms_recursion_depth == 0); + duk__assert_heaphdr_flags(heap); + duk__assert_validity(heap); +#if defined(DUK_USE_REFERENCE_COUNTING) + /* Note: heap->refzero_free_running may be true; a refcount + * finalizer may trigger a mark-and-sweep. + */ + duk__assert_valid_refcounts(heap); +#endif /* DUK_USE_REFERENCE_COUNTING */ +#if defined(DUK_USE_LITCACHE_SIZE) + duk__assert_litcache_nulls(heap); +#endif /* DUK_USE_LITCACHE_SIZE */ +#endif /* DUK_USE_ASSERTIONS */ + + /* + * Reset trigger counter + */ + +#if defined(DUK_USE_VOLUNTARY_GC) + tmp = (count_keep_obj + count_keep_str) / 256; + heap->ms_trigger_counter = (duk_int_t) ((tmp * DUK_HEAP_MARK_AND_SWEEP_TRIGGER_MULT) + DUK_HEAP_MARK_AND_SWEEP_TRIGGER_ADD); + DUK_D(DUK_DPRINT("garbage collect (mark-and-sweep) finished: %ld objects kept, %ld strings kept, trigger reset to %ld", + (long) count_keep_obj, + (long) count_keep_str, + (long) heap->ms_trigger_counter)); +#else + DUK_D(DUK_DPRINT("garbage collect (mark-and-sweep) finished: %ld objects kept, %ld strings kept, no voluntary trigger", + (long) count_keep_obj, + (long) count_keep_str)); +#endif + + /* + * Stats dump + */ + +#if defined(DUK_USE_DEBUG) + duk__dump_stats(heap); +#endif + + /* + * Finalize objects in the finalization work list. Finalized + * objects are queued back to heap_allocated with FINALIZED set. + * + * Since finalizers may cause arbitrary side effects, they are + * prevented e.g. during string table and object property allocation + * resizing using heap->pf_prevent_count. In this case the objects + * remain in the finalization work list after mark-and-sweep exits + * and they may be finalized on the next pass or any DECREF checking + * for finalize_list. + * + * As of Duktape 2.1 finalization happens outside mark-and-sweep + * protection. Mark-and-sweep is allowed while the finalize_list + * is being processed, but no rescue decisions are done while the + * process is on-going. This avoids incorrect rescue decisions + * if an object is considered reachable (and thus rescued) because + * of a reference via finalize_list (which is considered a reachability + * root). When finalize_list is being processed, reachable objects + * with FINALIZED set will just keep their FINALIZED flag for later + * mark-and-sweep processing. + * + * This could also be handled (a bit better) by having a more refined + * notion of reachability for rescue/free decisions. + * + * XXX: avoid finalizer execution when doing emergency GC? + */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) + /* Attempt to process finalize_list, pf_prevent_count check + * is inside the target. + */ + duk_heap_process_finalize_list(heap); +#endif /* DUK_USE_FINALIZER_SUPPORT */ +} +#line 1 "duk_heap_memory.c" +/* + * Memory allocation handling. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Allocate memory with garbage collection. + */ + +/* Slow path: voluntary GC triggered, first alloc attempt failed, or zero size. */ +DUK_LOCAL DUK_NOINLINE_PERF DUK_COLD void *duk__heap_mem_alloc_slowpath(duk_heap *heap, duk_size_t size) { + void *res; + duk_small_int_t i; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->alloc_func != NULL); + DUK_ASSERT_DISABLE(size >= 0); + + if (size == 0) { + DUK_D(DUK_DPRINT("zero size alloc in slow path, return NULL")); + return NULL; + } + + DUK_D(DUK_DPRINT("first alloc attempt failed or voluntary GC limit reached, attempt to gc and retry")); + +#if 0 + /* + * If GC is already running there is no point in attempting a GC + * because it will be skipped. This could be checked for explicitly, + * but it isn't actually needed: the loop below will eventually + * fail resulting in a NULL. + */ + + if (heap->ms_prevent_count != 0) { + DUK_D(DUK_DPRINT("duk_heap_mem_alloc() failed, gc in progress (gc skipped), alloc size %ld", (long) size)); + return NULL; + } +#endif + + /* + * Retry with several GC attempts. Initial attempts are made without + * emergency mode; later attempts use emergency mode which minimizes + * memory allocations forcibly. + */ + + for (i = 0; i < DUK_HEAP_ALLOC_FAIL_MARKANDSWEEP_LIMIT; i++) { + duk_small_uint_t flags; + + flags = 0; + if (i >= DUK_HEAP_ALLOC_FAIL_MARKANDSWEEP_EMERGENCY_LIMIT - 1) { + flags |= DUK_MS_FLAG_EMERGENCY; + } + + duk_heap_mark_and_sweep(heap, flags); + + DUK_ASSERT(size > 0); + res = heap->alloc_func(heap->heap_udata, size); + if (res != NULL) { + DUK_D(DUK_DPRINT("duk_heap_mem_alloc() succeeded after gc (pass %ld), alloc size %ld", + (long) (i + 1), + (long) size)); + return res; + } + } + + DUK_D(DUK_DPRINT("duk_heap_mem_alloc() failed even after gc, alloc size %ld", (long) size)); + return NULL; +} + +DUK_INTERNAL DUK_INLINE_PERF DUK_HOT void *duk_heap_mem_alloc(duk_heap *heap, duk_size_t size) { + void *res; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->alloc_func != NULL); + DUK_ASSERT_DISABLE(size >= 0); + +#if defined(DUK_USE_VOLUNTARY_GC) + /* Voluntary periodic GC (if enabled). */ + if (DUK_UNLIKELY(--(heap)->ms_trigger_counter < 0)) { + goto slowpath; + } +#endif + +#if defined(DUK_USE_GC_TORTURE) + /* Simulate alloc failure on every alloc, except when mark-and-sweep + * is running. + */ + if (heap->ms_prevent_count == 0) { + DUK_DDD(DUK_DDDPRINT("gc torture enabled, pretend that first alloc attempt fails")); + res = NULL; + DUK_UNREF(res); + goto slowpath; + } +#endif + + /* Zero-size allocation should happen very rarely (if at all), so + * don't check zero size on NULL; handle it in the slow path + * instead. This reduces size of inlined code. + */ + res = heap->alloc_func(heap->heap_udata, size); + if (DUK_LIKELY(res != NULL)) { + return res; + } + +slowpath: + + if (size == 0) { + DUK_D(DUK_DPRINT("first alloc attempt returned NULL for zero size alloc, use slow path to deal with it")); + } else { + DUK_D(DUK_DPRINT("first alloc attempt failed, attempt to gc and retry")); + } + return duk__heap_mem_alloc_slowpath(heap, size); +} + +DUK_INTERNAL DUK_INLINE_PERF DUK_HOT void *duk_heap_mem_alloc_zeroed(duk_heap *heap, duk_size_t size) { + void *res; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->alloc_func != NULL); + DUK_ASSERT_DISABLE(size >= 0); + + res = DUK_ALLOC(heap, size); + if (DUK_LIKELY(res != NULL)) { + duk_memzero(res, size); + } + return res; +} + +DUK_INTERNAL DUK_INLINE_PERF DUK_HOT void *duk_heap_mem_alloc_checked(duk_hthread *thr, duk_size_t size) { + void *res; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(thr->heap->alloc_func != NULL); + + res = duk_heap_mem_alloc(thr->heap, size); + if (DUK_LIKELY(res != NULL)) { + return res; + } else if (size == 0) { + DUK_ASSERT(res == NULL); + return res; + } + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return NULL;); +} + +DUK_INTERNAL DUK_INLINE_PERF DUK_HOT void *duk_heap_mem_alloc_checked_zeroed(duk_hthread *thr, duk_size_t size) { + void *res; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(thr->heap->alloc_func != NULL); + + res = duk_heap_mem_alloc(thr->heap, size); + if (DUK_LIKELY(res != NULL)) { + duk_memzero(res, size); + return res; + } else if (size == 0) { + DUK_ASSERT(res == NULL); + return res; + } + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return NULL;); +} + +/* + * Reallocate memory with garbage collection. + */ + +/* Slow path: voluntary GC triggered, first realloc attempt failed, or zero size. */ +DUK_LOCAL DUK_NOINLINE_PERF DUK_COLD void *duk__heap_mem_realloc_slowpath(duk_heap *heap, void *ptr, duk_size_t newsize) { + void *res; + duk_small_int_t i; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->realloc_func != NULL); + /* ptr may be NULL */ + DUK_ASSERT_DISABLE(newsize >= 0); + + /* Unlike for malloc(), zero size NULL result check happens at the call site. */ + + DUK_D(DUK_DPRINT("first realloc attempt failed, attempt to gc and retry")); + +#if 0 + /* + * Avoid a GC if GC is already running. See duk_heap_mem_alloc(). + */ + + if (heap->ms_prevent_count != 0) { + DUK_D(DUK_DPRINT("duk_heap_mem_realloc() failed, gc in progress (gc skipped), alloc size %ld", (long) newsize)); + return NULL; + } +#endif + + /* + * Retry with several GC attempts. Initial attempts are made without + * emergency mode; later attempts use emergency mode which minimizes + * memory allocations forcibly. + */ + + for (i = 0; i < DUK_HEAP_ALLOC_FAIL_MARKANDSWEEP_LIMIT; i++) { + duk_small_uint_t flags; + + flags = 0; + if (i >= DUK_HEAP_ALLOC_FAIL_MARKANDSWEEP_EMERGENCY_LIMIT - 1) { + flags |= DUK_MS_FLAG_EMERGENCY; + } + + duk_heap_mark_and_sweep(heap, flags); + + res = heap->realloc_func(heap->heap_udata, ptr, newsize); + if (res != NULL || newsize == 0) { + DUK_D(DUK_DPRINT("duk_heap_mem_realloc() succeeded after gc (pass %ld), alloc size %ld", + (long) (i + 1), + (long) newsize)); + return res; + } + } + + DUK_D(DUK_DPRINT("duk_heap_mem_realloc() failed even after gc, alloc size %ld", (long) newsize)); + return NULL; +} + +DUK_INTERNAL DUK_INLINE_PERF DUK_HOT void *duk_heap_mem_realloc(duk_heap *heap, void *ptr, duk_size_t newsize) { + void *res; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->realloc_func != NULL); + /* ptr may be NULL */ + DUK_ASSERT_DISABLE(newsize >= 0); + +#if defined(DUK_USE_VOLUNTARY_GC) + /* Voluntary periodic GC (if enabled). */ + if (DUK_UNLIKELY(--(heap)->ms_trigger_counter < 0)) { + goto gc_retry; + } +#endif + +#if defined(DUK_USE_GC_TORTURE) + /* Simulate alloc failure on every realloc, except when mark-and-sweep + * is running. + */ + if (heap->ms_prevent_count == 0) { + DUK_DDD(DUK_DDDPRINT("gc torture enabled, pretend that first realloc attempt fails")); + res = NULL; + DUK_UNREF(res); + goto gc_retry; + } +#endif + + res = heap->realloc_func(heap->heap_udata, ptr, newsize); + if (DUK_LIKELY(res != NULL) || newsize == 0) { + if (res != NULL && newsize == 0) { + DUK_DD(DUK_DDPRINT("first realloc attempt returned NULL for zero size realloc, accept and return NULL")); + } + return res; + } else { + goto gc_retry; + } + /* Never here. */ + +gc_retry: + return duk__heap_mem_realloc_slowpath(heap, ptr, newsize); +} + +/* + * Reallocate memory with garbage collection, using a callback to provide + * the current allocated pointer. This variant is used when a mark-and-sweep + * (e.g. finalizers) might change the original pointer. + */ + +/* Slow path: voluntary GC triggered, first realloc attempt failed, or zero size. */ +DUK_LOCAL DUK_NOINLINE_PERF DUK_COLD void *duk__heap_mem_realloc_indirect_slowpath(duk_heap *heap, + duk_mem_getptr cb, + void *ud, + duk_size_t newsize) { + void *res; + duk_small_int_t i; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->realloc_func != NULL); + DUK_ASSERT_DISABLE(newsize >= 0); + + /* Unlike for malloc(), zero size NULL result check happens at the call site. */ + + DUK_D(DUK_DPRINT("first indirect realloc attempt failed, attempt to gc and retry")); + +#if 0 + /* + * Avoid a GC if GC is already running. See duk_heap_mem_alloc(). + */ + + if (heap->ms_prevent_count != 0) { + DUK_D(DUK_DPRINT("duk_heap_mem_realloc_indirect() failed, gc in progress (gc skipped), alloc size %ld", (long) newsize)); + return NULL; + } +#endif + + /* + * Retry with several GC attempts. Initial attempts are made without + * emergency mode; later attempts use emergency mode which minimizes + * memory allocations forcibly. + */ + + for (i = 0; i < DUK_HEAP_ALLOC_FAIL_MARKANDSWEEP_LIMIT; i++) { + duk_small_uint_t flags; + +#if defined(DUK_USE_DEBUG) + void *ptr_pre; + void *ptr_post; +#endif + +#if defined(DUK_USE_DEBUG) + ptr_pre = cb(heap, ud); +#endif + flags = 0; + if (i >= DUK_HEAP_ALLOC_FAIL_MARKANDSWEEP_EMERGENCY_LIMIT - 1) { + flags |= DUK_MS_FLAG_EMERGENCY; + } + + duk_heap_mark_and_sweep(heap, flags); +#if defined(DUK_USE_DEBUG) + ptr_post = cb(heap, ud); + if (ptr_pre != ptr_post) { + DUK_DD(DUK_DDPRINT("realloc base pointer changed by mark-and-sweep: %p -> %p", + (void *) ptr_pre, + (void *) ptr_post)); + } +#endif + + /* Note: key issue here is to re-lookup the base pointer on every attempt. + * The pointer being reallocated may change after every mark-and-sweep. + */ + + res = heap->realloc_func(heap->heap_udata, cb(heap, ud), newsize); + if (res != NULL || newsize == 0) { + DUK_D(DUK_DPRINT("duk_heap_mem_realloc_indirect() succeeded after gc (pass %ld), alloc size %ld", + (long) (i + 1), + (long) newsize)); + return res; + } + } + + DUK_D(DUK_DPRINT("duk_heap_mem_realloc_indirect() failed even after gc, alloc size %ld", (long) newsize)); + return NULL; +} + +DUK_INTERNAL DUK_INLINE_PERF DUK_HOT void *duk_heap_mem_realloc_indirect(duk_heap *heap, + duk_mem_getptr cb, + void *ud, + duk_size_t newsize) { + void *res; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->realloc_func != NULL); + DUK_ASSERT_DISABLE(newsize >= 0); + +#if defined(DUK_USE_VOLUNTARY_GC) + /* Voluntary periodic GC (if enabled). */ + if (DUK_UNLIKELY(--(heap)->ms_trigger_counter < 0)) { + goto gc_retry; + } +#endif + +#if defined(DUK_USE_GC_TORTURE) + /* Simulate alloc failure on every realloc, except when mark-and-sweep + * is running. + */ + if (heap->ms_prevent_count == 0) { + DUK_DDD(DUK_DDDPRINT("gc torture enabled, pretend that first indirect realloc attempt fails")); + res = NULL; + DUK_UNREF(res); + goto gc_retry; + } +#endif + + res = heap->realloc_func(heap->heap_udata, cb(heap, ud), newsize); + if (DUK_LIKELY(res != NULL) || newsize == 0) { + if (res != NULL && newsize == 0) { + DUK_DD(DUK_DDPRINT( + "first indirect realloc attempt returned NULL for zero size realloc, accept and return NULL")); + } + return res; + } else { + goto gc_retry; + } + /* Never here. */ + +gc_retry: + return duk__heap_mem_realloc_indirect_slowpath(heap, cb, ud, newsize); +} + +/* + * Free memory + */ + +DUK_INTERNAL DUK_INLINE_PERF DUK_HOT void duk_heap_mem_free(duk_heap *heap, void *ptr) { + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->free_func != NULL); + /* ptr may be NULL */ + + /* Must behave like a no-op with NULL and any pointer returned from + * malloc/realloc with zero size. + */ + heap->free_func(heap->heap_udata, ptr); + + /* Never perform a GC (even voluntary) in a memory free, otherwise + * all call sites doing frees would need to deal with the side effects. + * No need to update voluntary GC counter either. + */ +} +#line 1 "duk_heap_misc.c" +/* + * Support functions for duk_heap. + */ + +/* #include duk_internal.h -> already included */ + +DUK_INTERNAL void duk_heap_insert_into_heap_allocated(duk_heap *heap, duk_heaphdr *hdr) { + duk_heaphdr *root; + + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(hdr) != DUK_HTYPE_STRING); + + root = heap->heap_allocated; +#if defined(DUK_USE_DOUBLE_LINKED_HEAP) + if (root != NULL) { + DUK_ASSERT(DUK_HEAPHDR_GET_PREV(heap, root) == NULL); + DUK_HEAPHDR_SET_PREV(heap, root, hdr); + } + DUK_HEAPHDR_SET_PREV(heap, hdr, NULL); +#endif + DUK_HEAPHDR_SET_NEXT(heap, hdr, root); + DUK_HEAPHDR_ASSERT_LINKS(heap, hdr); + DUK_HEAPHDR_ASSERT_LINKS(heap, root); + heap->heap_allocated = hdr; +} + +#if defined(DUK_USE_REFERENCE_COUNTING) +DUK_INTERNAL void duk_heap_remove_from_heap_allocated(duk_heap *heap, duk_heaphdr *hdr) { + duk_heaphdr *prev; + duk_heaphdr *next; + + /* Strings are in string table. */ + DUK_ASSERT(hdr != NULL); + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(hdr) != DUK_HTYPE_STRING); + + /* Target 'hdr' must be in heap_allocated (not e.g. finalize_list). + * If not, heap lists will become corrupted so assert early for it. + */ +#if defined(DUK_USE_ASSERTIONS) + { + duk_heaphdr *tmp; + for (tmp = heap->heap_allocated; tmp != NULL; tmp = DUK_HEAPHDR_GET_NEXT(heap, tmp)) { + if (tmp == hdr) { + break; + } + } + DUK_ASSERT(tmp == hdr); + } +#endif + + /* Read/write only once to minimize pointer compression calls. */ + prev = DUK_HEAPHDR_GET_PREV(heap, hdr); + next = DUK_HEAPHDR_GET_NEXT(heap, hdr); + + if (prev != NULL) { + DUK_ASSERT(heap->heap_allocated != hdr); + DUK_HEAPHDR_SET_NEXT(heap, prev, next); + } else { + DUK_ASSERT(heap->heap_allocated == hdr); + heap->heap_allocated = next; + } + if (next != NULL) { + DUK_HEAPHDR_SET_PREV(heap, next, prev); + } else { + ; + } +} +#endif /* DUK_USE_REFERENCE_COUNTING */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_INTERNAL void duk_heap_insert_into_finalize_list(duk_heap *heap, duk_heaphdr *hdr) { + duk_heaphdr *root; + + root = heap->finalize_list; +#if defined(DUK_USE_DOUBLE_LINKED_HEAP) + DUK_HEAPHDR_SET_PREV(heap, hdr, NULL); + if (root != NULL) { + DUK_ASSERT(DUK_HEAPHDR_GET_PREV(heap, root) == NULL); + DUK_HEAPHDR_SET_PREV(heap, root, hdr); + } +#endif + DUK_HEAPHDR_SET_NEXT(heap, hdr, root); + DUK_HEAPHDR_ASSERT_LINKS(heap, hdr); + DUK_HEAPHDR_ASSERT_LINKS(heap, root); + heap->finalize_list = hdr; +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_INTERNAL void duk_heap_remove_from_finalize_list(duk_heap *heap, duk_heaphdr *hdr) { +#if defined(DUK_USE_DOUBLE_LINKED_HEAP) + duk_heaphdr *next; + duk_heaphdr *prev; + + next = DUK_HEAPHDR_GET_NEXT(heap, hdr); + prev = DUK_HEAPHDR_GET_PREV(heap, hdr); + if (next != NULL) { + DUK_ASSERT(DUK_HEAPHDR_GET_PREV(heap, next) == hdr); + DUK_HEAPHDR_SET_PREV(heap, next, prev); + } + if (prev == NULL) { + DUK_ASSERT(hdr == heap->finalize_list); + heap->finalize_list = next; + } else { + DUK_ASSERT(hdr != heap->finalize_list); + DUK_HEAPHDR_SET_NEXT(heap, prev, next); + } +#else + duk_heaphdr *next; + duk_heaphdr *curr; + + /* Random removal is expensive: we need to locate the previous element + * because we don't have a 'prev' pointer. + */ + curr = heap->finalize_list; + if (curr == hdr) { + heap->finalize_list = DUK_HEAPHDR_GET_NEXT(heap, curr); + } else { + DUK_ASSERT(hdr != heap->finalize_list); + for (;;) { + DUK_ASSERT(curr != NULL); /* Caller responsibility. */ + + next = DUK_HEAPHDR_GET_NEXT(heap, curr); + if (next == hdr) { + next = DUK_HEAPHDR_GET_NEXT(heap, hdr); + DUK_HEAPHDR_SET_NEXT(heap, curr, next); + break; + } + } + } +#endif +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL duk_bool_t duk_heap_in_heap_allocated(duk_heap *heap, duk_heaphdr *ptr) { + duk_heaphdr *curr; + DUK_ASSERT(heap != NULL); + + for (curr = heap->heap_allocated; curr != NULL; curr = DUK_HEAPHDR_GET_NEXT(heap, curr)) { + if (curr == ptr) { + return 1; + } + } + return 0; +} +#endif /* DUK_USE_ASSERTIONS */ + +#if defined(DUK_USE_INTERRUPT_COUNTER) +DUK_INTERNAL void duk_heap_switch_thread(duk_heap *heap, duk_hthread *new_thr) { + duk_hthread *curr_thr; + + DUK_ASSERT(heap != NULL); + + if (new_thr != NULL) { + curr_thr = heap->curr_thread; + if (curr_thr == NULL) { + /* For initial entry use default value; zero forces an + * interrupt before executing the first insturction. + */ + DUK_DD(DUK_DDPRINT("switch thread, initial entry, init default interrupt counter")); + new_thr->interrupt_counter = 0; + new_thr->interrupt_init = 0; + } else { + /* Copy interrupt counter/init value state to new thread (if any). + * It's OK for new_thr to be the same as curr_thr. + */ +#if defined(DUK_USE_DEBUG) + if (new_thr != curr_thr) { + DUK_DD(DUK_DDPRINT("switch thread, not initial entry, copy interrupt counter")); + } +#endif + new_thr->interrupt_counter = curr_thr->interrupt_counter; + new_thr->interrupt_init = curr_thr->interrupt_init; + } + } else { + DUK_DD(DUK_DDPRINT("switch thread, new thread is NULL, no interrupt counter changes")); + } + + heap->curr_thread = new_thr; /* may be NULL */ +} +#endif /* DUK_USE_INTERRUPT_COUNTER */ + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL void duk_heap_assert_valid(duk_heap *heap) { + DUK_ASSERT(heap != NULL); +} +#endif +#line 1 "duk_heap_refcount.c" +/* + * Reference counting implementation. + * + * INCREF/DECREF, finalization and freeing of objects whose refcount reaches + * zero (refzero). These operations are very performance sensitive, so + * various small tricks are used in an attempt to maximize speed. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_REFERENCE_COUNTING) + +#if !defined(DUK_USE_DOUBLE_LINKED_HEAP) +#error internal error, reference counting requires a double linked heap +#endif + +/* + * Heap object refcount finalization. + * + * When an object is about to be freed, all other objects it refers to must + * be decref'd. Refcount finalization does NOT free the object or its inner + * allocations (mark-and-sweep shares these helpers), it just manipulates + * the refcounts. + * + * Note that any of the DECREFs may cause a refcount to drop to zero. If so, + * the object won't be refzero processed inline, but will just be queued to + * refzero_list and processed by an earlier caller working on refzero_list, + * eliminating C recursion from even long refzero cascades. If refzero + * finalization is triggered by mark-and-sweep, refzero conditions are ignored + * (objects are not even queued to refzero_list) because mark-and-sweep deals + * with them; refcounts are still updated so that they remain in sync with + * actual references. + */ + +DUK_LOCAL void duk__decref_tvals_norz(duk_hthread *thr, duk_tval *tv, duk_idx_t count) { + DUK_ASSERT(count == 0 || tv != NULL); + + while (count-- > 0) { + DUK_TVAL_DECREF_NORZ(thr, tv); + tv++; + } +} + +DUK_INTERNAL void duk_hobject_refcount_finalize_norz(duk_heap *heap, duk_hobject *h) { + duk_hthread *thr; + duk_uint_fast32_t i; + duk_uint_fast32_t n; + duk_propvalue *p_val; + duk_tval *p_tv; + duk_hstring **p_key; + duk_uint8_t *p_flag; + duk_hobject *h_proto; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->heap_thread != NULL); + DUK_ASSERT(h); + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) h) == DUK_HTYPE_OBJECT); + + thr = heap->heap_thread; + DUK_ASSERT(thr != NULL); + + p_key = DUK_HOBJECT_E_GET_KEY_BASE(heap, h); + p_val = DUK_HOBJECT_E_GET_VALUE_BASE(heap, h); + p_flag = DUK_HOBJECT_E_GET_FLAGS_BASE(heap, h); + n = DUK_HOBJECT_GET_ENEXT(h); + while (n-- > 0) { + duk_hstring *key; + + key = p_key[n]; + if (DUK_UNLIKELY(key == NULL)) { + continue; + } + DUK_HSTRING_DECREF_NORZ(thr, key); + if (DUK_UNLIKELY(p_flag[n] & DUK_PROPDESC_FLAG_ACCESSOR)) { + duk_hobject *h_getset; + h_getset = p_val[n].a.get; + DUK_ASSERT(h_getset == NULL || DUK_HEAPHDR_IS_OBJECT((duk_heaphdr *) h_getset)); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, h_getset); + h_getset = p_val[n].a.set; + DUK_ASSERT(h_getset == NULL || DUK_HEAPHDR_IS_OBJECT((duk_heaphdr *) h_getset)); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, h_getset); + } else { + duk_tval *tv_val; + tv_val = &p_val[n].v; + DUK_TVAL_DECREF_NORZ(thr, tv_val); + } + } + + p_tv = DUK_HOBJECT_A_GET_BASE(heap, h); + n = DUK_HOBJECT_GET_ASIZE(h); + while (n-- > 0) { + duk_tval *tv_val; + tv_val = p_tv + n; + DUK_TVAL_DECREF_NORZ(thr, tv_val); + } + + /* Hash part is a 'weak reference' and doesn't contribute to refcounts. */ + + h_proto = (duk_hobject *) DUK_HOBJECT_GET_PROTOTYPE(heap, h); + DUK_ASSERT(h_proto == NULL || DUK_HEAPHDR_IS_OBJECT((duk_heaphdr *) h_proto)); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, h_proto); + + /* XXX: Object subclass tests are quite awkward at present, ideally + * we should be able to switch-case here with a dense index (subtype + * number or something). For now, fast path plain objects and arrays + * and bit test the rest individually. + */ + + if (DUK_HOBJECT_HAS_FASTREFS(h)) { + /* Plain object or array, nothing more to do. While a + * duk_harray has additional fields, none of them need + * DECREF updates. + */ + DUK_ASSERT(DUK_HOBJECT_ALLOWS_FASTREFS(h)); + return; + } + DUK_ASSERT(DUK_HOBJECT_PROHIBITS_FASTREFS(h)); + + /* Slow path: special object, start bit checks from most likely. */ + + /* XXX: reorg, more common first */ + if (DUK_HOBJECT_IS_COMPFUNC(h)) { + duk_hcompfunc *f = (duk_hcompfunc *) h; + duk_tval *tv, *tv_end; + duk_hobject **funcs, **funcs_end; + + DUK_HCOMPFUNC_ASSERT_VALID(f); + + if (DUK_LIKELY(DUK_HCOMPFUNC_GET_DATA(heap, f) != NULL)) { + tv = DUK_HCOMPFUNC_GET_CONSTS_BASE(heap, f); + tv_end = DUK_HCOMPFUNC_GET_CONSTS_END(heap, f); + while (tv < tv_end) { + DUK_TVAL_DECREF_NORZ(thr, tv); + tv++; + } + + funcs = DUK_HCOMPFUNC_GET_FUNCS_BASE(heap, f); + funcs_end = DUK_HCOMPFUNC_GET_FUNCS_END(heap, f); + while (funcs < funcs_end) { + duk_hobject *h_func; + h_func = *funcs; + DUK_ASSERT(h_func != NULL); + DUK_ASSERT(DUK_HEAPHDR_IS_OBJECT((duk_heaphdr *) h_func)); + DUK_HCOMPFUNC_DECREF_NORZ(thr, (duk_hcompfunc *) h_func); + funcs++; + } + } else { + /* May happen in some out-of-memory corner cases. */ + DUK_D(DUK_DPRINT("duk_hcompfunc 'data' is NULL, skipping decref")); + } + + DUK_HEAPHDR_DECREF_ALLOWNULL(thr, (duk_heaphdr *) DUK_HCOMPFUNC_GET_LEXENV(heap, f)); + DUK_HEAPHDR_DECREF_ALLOWNULL(thr, (duk_heaphdr *) DUK_HCOMPFUNC_GET_VARENV(heap, f)); + DUK_HEAPHDR_DECREF_ALLOWNULL(thr, (duk_hbuffer *) DUK_HCOMPFUNC_GET_DATA(heap, f)); + } else if (DUK_HOBJECT_IS_DECENV(h)) { + duk_hdecenv *e = (duk_hdecenv *) h; + DUK_HDECENV_ASSERT_VALID(e); + DUK_HTHREAD_DECREF_NORZ_ALLOWNULL(thr, e->thread); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, e->varmap); + } else if (DUK_HOBJECT_IS_OBJENV(h)) { + duk_hobjenv *e = (duk_hobjenv *) h; + DUK_HOBJENV_ASSERT_VALID(e); + DUK_ASSERT(e->target != NULL); /* Required for object environments. */ + DUK_HOBJECT_DECREF_NORZ(thr, e->target); +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + } else if (DUK_HOBJECT_IS_BUFOBJ(h)) { + duk_hbufobj *b = (duk_hbufobj *) h; + DUK_HBUFOBJ_ASSERT_VALID(b); + DUK_HBUFFER_DECREF_NORZ_ALLOWNULL(thr, (duk_hbuffer *) b->buf); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, (duk_hobject *) b->buf_prop); +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + } else if (DUK_HOBJECT_IS_BOUNDFUNC(h)) { + duk_hboundfunc *f = (duk_hboundfunc *) (void *) h; + DUK_HBOUNDFUNC_ASSERT_VALID(f); + DUK_TVAL_DECREF_NORZ(thr, &f->target); + DUK_TVAL_DECREF_NORZ(thr, &f->this_binding); + duk__decref_tvals_norz(thr, f->args, f->nargs); +#if defined(DUK_USE_ES6_PROXY) + } else if (DUK_HOBJECT_IS_PROXY(h)) { + duk_hproxy *p = (duk_hproxy *) h; + DUK_HPROXY_ASSERT_VALID(p); + DUK_HOBJECT_DECREF_NORZ(thr, p->target); + DUK_HOBJECT_DECREF_NORZ(thr, p->handler); +#endif /* DUK_USE_ES6_PROXY */ + } else if (DUK_HOBJECT_IS_THREAD(h)) { + duk_hthread *t = (duk_hthread *) h; + duk_activation *act; + duk_tval *tv; + + DUK_HTHREAD_ASSERT_VALID(t); + + tv = t->valstack; + while (tv < t->valstack_top) { + DUK_TVAL_DECREF_NORZ(thr, tv); + tv++; + } + + for (act = t->callstack_curr; act != NULL; act = act->parent) { + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, (duk_hobject *) DUK_ACT_GET_FUNC(act)); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, (duk_hobject *) act->var_env); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, (duk_hobject *) act->lex_env); +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, (duk_hobject *) act->prev_caller); +#endif +#if 0 /* nothing now */ + for (cat = act->cat; cat != NULL; cat = cat->parent) { + } +#endif + } + + for (i = 0; i < DUK_NUM_BUILTINS; i++) { + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, (duk_hobject *) t->builtins[i]); + } + + DUK_HTHREAD_DECREF_NORZ_ALLOWNULL(thr, (duk_hthread *) t->resumer); + } else { + /* We may come here if the object should have a FASTREFS flag + * but it's missing for some reason. Assert for never getting + * here; however, other than performance, this is harmless. + */ + DUK_D(DUK_DPRINT("missing FASTREFS flag for: %!iO", h)); + DUK_ASSERT(0); + } +} + +DUK_INTERNAL void duk_heaphdr_refcount_finalize_norz(duk_heap *heap, duk_heaphdr *hdr) { + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->heap_thread != NULL); + DUK_ASSERT(hdr != NULL); + + if (DUK_HEAPHDR_IS_OBJECT(hdr)) { + duk_hobject_refcount_finalize_norz(heap, (duk_hobject *) hdr); + } + /* DUK_HTYPE_BUFFER: nothing to finalize */ + /* DUK_HTYPE_STRING: nothing to finalize */ +} + +/* + * Refzero processing for duk_hobject: queue a refzero'ed object to either + * finalize_list or refzero_list and process the relevent list(s) if + * necessary. + * + * Refzero_list is single linked, with only 'prev' pointers set and valid. + * All 'next' pointers are intentionally left as garbage. This doesn't + * matter because refzero_list is processed to completion before any other + * code (like mark-and-sweep) might walk the list. + * + * In more detail: + * + * - On first insert refzero_list is NULL and the new object becomes the + * first and only element on the list; duk__refcount_free_pending() is + * called and it starts processing the list from the initial element, + * i.e. the list tail. + * + * - As each object is refcount finalized, new objects may be queued to + * refzero_list head. Their 'next' pointers are left as garbage, but + * 'prev' points are set correctly, with the element at refzero_list + * having a NULL 'prev' pointer. The fact that refzero_list is non-NULL + * is used to reject (1) recursive duk__refcount_free_pending() and + * (2) finalize_list processing calls. + * + * - When we're done with the current object, read its 'prev' pointer and + * free the object. If 'prev' is NULL, we've reached head of list and are + * done: set refzero_list to NULL and process pending finalizers. Otherwise + * continue processing the list. + * + * A refzero cascade is free of side effects because it only involves + * queueing more objects and freeing memory; finalizer execution is blocked + * in the code path queueing objects to finalize_list. As a result the + * initial refzero call (which triggers duk__refcount_free_pending()) must + * check finalize_list so that finalizers are executed snappily. + * + * If finalize_list processing starts first, refzero may occur while we're + * processing finalizers. That's fine: that particular refzero cascade is + * handled to completion without side effects. Once the cascade is complete, + * we'll run pending finalizers but notice that we're already doing that and + * return. + * + * This could be expanded to allow incremental freeing: just bail out + * early and resume at a future alloc/decref/refzero. However, if that + * were done, the list structure would need to be kept consistent at all + * times, mark-and-sweep would need to handle refzero_list, etc. + */ + +DUK_LOCAL void duk__refcount_free_pending(duk_heap *heap) { + duk_heaphdr *curr; +#if defined(DUK_USE_DEBUG) + duk_int_t count = 0; +#endif + + DUK_ASSERT(heap != NULL); + + curr = heap->refzero_list; + DUK_ASSERT(curr != NULL); + DUK_ASSERT(DUK_HEAPHDR_GET_PREV(heap, curr) == NULL); /* We're called on initial insert only. */ + /* curr->next is GARBAGE. */ + + do { + duk_heaphdr *prev; + + DUK_DDD(DUK_DDDPRINT("refzero processing %p: %!O", (void *) curr, (duk_heaphdr *) curr)); + +#if defined(DUK_USE_DEBUG) + count++; +#endif + + DUK_ASSERT(curr != NULL); + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(curr) == DUK_HTYPE_OBJECT); /* currently, always the case */ + /* FINALIZED may be set; don't care about flags here. */ + + /* Refcount finalize 'curr'. Refzero_list must be non-NULL + * here to prevent recursive entry to duk__refcount_free_pending(). + */ + DUK_ASSERT(heap->refzero_list != NULL); + duk_hobject_refcount_finalize_norz(heap, (duk_hobject *) curr); + + prev = DUK_HEAPHDR_GET_PREV(heap, curr); + DUK_ASSERT((prev == NULL && heap->refzero_list == curr) || (prev != NULL && heap->refzero_list != curr)); + /* prev->next is intentionally not updated and is garbage. */ + + duk_free_hobject(heap, (duk_hobject *) curr); /* Invalidates 'curr'. */ + + curr = prev; + } while (curr != NULL); + + heap->refzero_list = NULL; + + DUK_DD(DUK_DDPRINT("refzero processed %ld objects", (long) count)); +} + +DUK_LOCAL DUK_INLINE void duk__refcount_refzero_hobject(duk_heap *heap, duk_hobject *obj, duk_bool_t skip_free_pending) { + duk_heaphdr *hdr; + duk_heaphdr *root; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->heap_thread != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) obj) == DUK_HTYPE_OBJECT); + + hdr = (duk_heaphdr *) obj; + + /* Refzero'd objects must be in heap_allocated. They can't be in + * finalize_list because all objects on finalize_list have an + * artificial +1 refcount bump. + */ +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(duk_heap_in_heap_allocated(heap, (duk_heaphdr *) obj)); +#endif + + DUK_HEAP_REMOVE_FROM_HEAP_ALLOCATED(heap, hdr); + +#if defined(DUK_USE_FINALIZER_SUPPORT) + /* This finalizer check MUST BE side effect free. It should also be + * as fast as possible because it's applied to every object freed. + */ + if (DUK_UNLIKELY(DUK_HOBJECT_HAS_FINALIZER_FAST(heap, (duk_hobject *) hdr) != 0U)) { + /* Special case: FINALIZED may be set if mark-and-sweep queued + * object for finalization, the finalizer was executed (and + * FINALIZED set), mark-and-sweep hasn't yet processed the + * object again, but its refcount drops to zero. Free without + * running the finalizer again. + */ + if (DUK_HEAPHDR_HAS_FINALIZED(hdr)) { + DUK_D(DUK_DPRINT("refzero'd object has finalizer and FINALIZED is set -> free")); + } else { + /* Set FINALIZABLE flag so that all objects on finalize_list + * will have it set and are thus detectable based on the + * flag alone. + */ + DUK_HEAPHDR_SET_FINALIZABLE(hdr); + DUK_ASSERT(!DUK_HEAPHDR_HAS_FINALIZED(hdr)); + +#if defined(DUK_USE_REFERENCE_COUNTING) + /* Bump refcount on finalize_list insert so that a + * refzero can never occur when an object is waiting + * for its finalizer call. Refzero might otherwise + * now happen because we allow duk_push_heapptr() for + * objects pending finalization. + */ + DUK_HEAPHDR_PREINC_REFCOUNT(hdr); +#endif + DUK_HEAP_INSERT_INTO_FINALIZE_LIST(heap, hdr); + + /* Process finalizers unless skipping is explicitly + * requested (NORZ) or refzero_list is being processed + * (avoids side effects during a refzero cascade). + * If refzero_list is processed, the initial refzero + * call will run pending finalizers when refzero_list + * is done. + */ + if (!skip_free_pending && heap->refzero_list == NULL) { + duk_heap_process_finalize_list(heap); + } + return; + } + } +#endif /* DUK_USE_FINALIZER_SUPPORT */ + + /* No need to finalize, free object via refzero_list. */ + + root = heap->refzero_list; + + DUK_HEAPHDR_SET_PREV(heap, hdr, NULL); + /* 'next' is left as GARBAGE. */ + heap->refzero_list = hdr; + + if (root == NULL) { + /* Object is now queued. Refzero_list was NULL so + * no-one is currently processing it; do it here. + * With refzero processing just doing a cascade of + * free calls, we can process it directly even when + * NORZ macros are used: there are no side effects. + */ + duk__refcount_free_pending(heap); + DUK_ASSERT(heap->refzero_list == NULL); + + /* Process finalizers only after the entire cascade + * is finished. In most cases there's nothing to + * finalize, so fast path check to avoid a call. + */ +#if defined(DUK_USE_FINALIZER_SUPPORT) + if (!skip_free_pending && DUK_UNLIKELY(heap->finalize_list != NULL)) { + duk_heap_process_finalize_list(heap); + } +#endif + } else { + DUK_ASSERT(DUK_HEAPHDR_GET_PREV(heap, root) == NULL); + DUK_HEAPHDR_SET_PREV(heap, root, hdr); + + /* Object is now queued. Because refzero_list was + * non-NULL, it's already being processed by someone + * in the C call stack, so we're done. + */ + } +} + +#if defined(DUK_USE_FINALIZER_SUPPORT) +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_refzero_check_fast(duk_hthread *thr) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(thr->heap->refzero_list == NULL); /* Processed to completion inline. */ + + if (DUK_UNLIKELY(thr->heap->finalize_list != NULL)) { + duk_heap_process_finalize_list(thr->heap); + } +} + +DUK_INTERNAL void duk_refzero_check_slow(duk_hthread *thr) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(thr->heap->refzero_list == NULL); /* Processed to completion inline. */ + + if (DUK_UNLIKELY(thr->heap->finalize_list != NULL)) { + duk_heap_process_finalize_list(thr->heap); + } +} +#endif /* DUK_USE_FINALIZER_SUPPORT */ + +/* + * Refzero processing for duk_hstring. + */ + +DUK_LOCAL DUK_INLINE void duk__refcount_refzero_hstring(duk_heap *heap, duk_hstring *str) { + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->heap_thread != NULL); + DUK_ASSERT(str != NULL); + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) str) == DUK_HTYPE_STRING); + + duk_heap_strcache_string_remove(heap, str); + duk_heap_strtable_unlink(heap, str); + duk_free_hstring(heap, str); +} + +/* + * Refzero processing for duk_hbuffer. + */ + +DUK_LOCAL DUK_INLINE void duk__refcount_refzero_hbuffer(duk_heap *heap, duk_hbuffer *buf) { + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->heap_thread != NULL); + DUK_ASSERT(buf != NULL); + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) buf) == DUK_HTYPE_BUFFER); + + DUK_HEAP_REMOVE_FROM_HEAP_ALLOCATED(heap, (duk_heaphdr *) buf); + duk_free_hbuffer(heap, buf); +} + +/* + * Incref and decref functions. + * + * Decref may trigger immediate refzero handling, which may free and finalize + * an arbitrary number of objects (a "DECREF cascade"). + * + * Refzero handling is skipped entirely if (1) mark-and-sweep is running or + * (2) execution is paused in the debugger. The objects are left in the heap, + * and will be freed by mark-and-sweep or eventual heap destruction. + * + * This is necessary during mark-and-sweep because refcounts are also updated + * during the sweep phase (otherwise objects referenced by a swept object + * would have incorrect refcounts) which then calls here. This could be + * avoided by using separate decref macros in mark-and-sweep; however, + * mark-and-sweep also calls finalizers which would use the ordinary decref + * macros anyway. + * + * We can't process refzeros (= free objects) when the debugger is running + * as the debugger might make an object unreachable but still continue + * inspecting it (or even cause it to be pushed back). So we must rely on + * mark-and-sweep to collect them. + * + * The DUK__RZ_SUPPRESS_CHECK() condition is also used in heap destruction + * when running finalizers for remaining objects: the flag prevents objects + * from being moved around in heap linked lists while that's being done. + * + * The suppress condition is important to performance. + */ + +#define DUK__RZ_SUPPRESS_ASSERT1() \ + do { \ + DUK_ASSERT(thr != NULL); \ + DUK_ASSERT(thr->heap != NULL); \ + /* When mark-and-sweep runs, heap_thread must exist. */ \ + DUK_ASSERT(thr->heap->ms_running == 0 || thr->heap->heap_thread != NULL); \ + /* In normal operation finalizers are executed with ms_running == 0 \ + * so we should never see ms_running == 1 and thr != heap_thread. \ + * In heap destruction finalizers are executed with ms_running != 0 \ + * to e.g. prevent refzero; a special value ms_running == 2 is used \ + * in that case so it can be distinguished from the normal runtime \ + * case, and allows a stronger assertion here (GH-2030). \ + */ \ + DUK_ASSERT(!(thr->heap->ms_running == 1 && thr != thr->heap->heap_thread)); \ + /* We may be called when the heap is initializing and we process \ + * refzeros normally, but mark-and-sweep and finalizers are prevented \ + * if that's the case. \ + */ \ + DUK_ASSERT(thr->heap->heap_initializing == 0 || thr->heap->ms_prevent_count > 0); \ + DUK_ASSERT(thr->heap->heap_initializing == 0 || thr->heap->pf_prevent_count > 0); \ + } while (0) + +#if defined(DUK_USE_DEBUGGER_SUPPORT) +#define DUK__RZ_SUPPRESS_ASSERT2() \ + do { \ + /* When debugger is paused, ms_running is set. */ \ + DUK_ASSERT(!DUK_HEAP_HAS_DEBUGGER_PAUSED(thr->heap) || thr->heap->ms_running != 0); \ + } while (0) +#define DUK__RZ_SUPPRESS_COND() (heap->ms_running != 0) +#else +#define DUK__RZ_SUPPRESS_ASSERT2() \ + do { \ + } while (0) +#define DUK__RZ_SUPPRESS_COND() (heap->ms_running != 0) +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + +#define DUK__RZ_SUPPRESS_CHECK() \ + do { \ + DUK__RZ_SUPPRESS_ASSERT1(); \ + DUK__RZ_SUPPRESS_ASSERT2(); \ + if (DUK_UNLIKELY(DUK__RZ_SUPPRESS_COND())) { \ + DUK_DDD( \ + DUK_DDDPRINT("refzero handling suppressed (not even queued) when mark-and-sweep running, object: %p", \ + (void *) h)); \ + return; \ + } \ + } while (0) + +#define DUK__RZ_STRING() \ + do { \ + duk__refcount_refzero_hstring(heap, (duk_hstring *) h); \ + } while (0) +#define DUK__RZ_BUFFER() \ + do { \ + duk__refcount_refzero_hbuffer(heap, (duk_hbuffer *) h); \ + } while (0) +#define DUK__RZ_OBJECT() \ + do { \ + duk__refcount_refzero_hobject(heap, (duk_hobject *) h, skip_free_pending); \ + } while (0) + +/* XXX: test the effect of inlining here vs. NOINLINE in refzero helpers */ +#if defined(DUK_USE_FAST_REFCOUNT_DEFAULT) +#define DUK__RZ_INLINE DUK_ALWAYS_INLINE +#else +#define DUK__RZ_INLINE /*nop*/ +#endif + +DUK_LOCAL DUK__RZ_INLINE void duk__hstring_refzero_helper(duk_hthread *thr, duk_hstring *h) { + duk_heap *heap; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(h != NULL); + heap = thr->heap; + + DUK__RZ_SUPPRESS_CHECK(); + DUK__RZ_STRING(); +} + +DUK_LOCAL DUK__RZ_INLINE void duk__hbuffer_refzero_helper(duk_hthread *thr, duk_hbuffer *h) { + duk_heap *heap; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(h != NULL); + heap = thr->heap; + + DUK__RZ_SUPPRESS_CHECK(); + DUK__RZ_BUFFER(); +} + +DUK_LOCAL DUK__RZ_INLINE void duk__hobject_refzero_helper(duk_hthread *thr, duk_hobject *h, duk_bool_t skip_free_pending) { + duk_heap *heap; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(h != NULL); + heap = thr->heap; + + DUK__RZ_SUPPRESS_CHECK(); + DUK__RZ_OBJECT(); +} + +DUK_LOCAL DUK__RZ_INLINE void duk__heaphdr_refzero_helper(duk_hthread *thr, duk_heaphdr *h, duk_bool_t skip_free_pending) { + duk_heap *heap; + duk_small_uint_t htype; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(h != NULL); + heap = thr->heap; + + htype = (duk_small_uint_t) DUK_HEAPHDR_GET_TYPE(h); + DUK_DDD(DUK_DDDPRINT("ms_running=%ld, heap_thread=%p", (long) thr->heap->ms_running, thr->heap->heap_thread)); + DUK__RZ_SUPPRESS_CHECK(); + + switch (htype) { + case DUK_HTYPE_STRING: + /* Strings have no internal references but do have "weak" + * references in the string cache. Also note that strings + * are not on the heap_allocated list like other heap + * elements. + */ + + DUK__RZ_STRING(); + break; + + case DUK_HTYPE_OBJECT: + /* Objects have internal references. Must finalize through + * the "refzero" work list. + */ + + DUK__RZ_OBJECT(); + break; + + default: + /* Buffers have no internal references. However, a dynamic + * buffer has a separate allocation for the buffer. This is + * freed by duk_heap_free_heaphdr_raw(). + */ + + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(h) == DUK_HTYPE_BUFFER); + DUK__RZ_BUFFER(); + break; + } +} + +DUK_INTERNAL DUK_NOINLINE void duk_heaphdr_refzero(duk_hthread *thr, duk_heaphdr *h) { + duk__heaphdr_refzero_helper(thr, h, 0 /*skip_free_pending*/); +} + +DUK_INTERNAL DUK_NOINLINE void duk_heaphdr_refzero_norz(duk_hthread *thr, duk_heaphdr *h) { + duk__heaphdr_refzero_helper(thr, h, 1 /*skip_free_pending*/); +} + +DUK_INTERNAL DUK_NOINLINE void duk_hstring_refzero(duk_hthread *thr, duk_hstring *h) { + duk__hstring_refzero_helper(thr, h); +} + +DUK_INTERNAL DUK_NOINLINE void duk_hbuffer_refzero(duk_hthread *thr, duk_hbuffer *h) { + duk__hbuffer_refzero_helper(thr, h); +} + +DUK_INTERNAL DUK_NOINLINE void duk_hobject_refzero(duk_hthread *thr, duk_hobject *h) { + duk__hobject_refzero_helper(thr, h, 0 /*skip_free_pending*/); +} + +DUK_INTERNAL DUK_NOINLINE void duk_hobject_refzero_norz(duk_hthread *thr, duk_hobject *h) { + duk__hobject_refzero_helper(thr, h, 1 /*skip_free_pending*/); +} + +#if !defined(DUK_USE_FAST_REFCOUNT_DEFAULT) +DUK_INTERNAL void duk_tval_incref(duk_tval *tv) { + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_NEEDS_REFCOUNT_UPDATE(tv)) { + duk_heaphdr *h = DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(h)); + DUK_ASSERT_DISABLE(h->h_refcount >= 0); + DUK_HEAPHDR_PREINC_REFCOUNT(h); + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(h) != 0); /* No wrapping. */ + } +} + +DUK_INTERNAL void duk_tval_decref(duk_hthread *thr, duk_tval *tv) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_NEEDS_REFCOUNT_UPDATE(tv)) { + duk_heaphdr *h = DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(h)); + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(h) >= 1); +#if 0 + if (DUK_HEAPHDR_PREDEC_REFCOUNT(h) != 0) { + return; + } + duk_heaphdr_refzero(thr, h); +#else + duk_heaphdr_decref(thr, h); +#endif + } +} + +DUK_INTERNAL void duk_tval_decref_norz(duk_hthread *thr, duk_tval *tv) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv != NULL); + + if (DUK_TVAL_NEEDS_REFCOUNT_UPDATE(tv)) { + duk_heaphdr *h = DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(h)); + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT(h) >= 1); +#if 0 + if (DUK_HEAPHDR_PREDEC_REFCOUNT(h) != 0) { + return; + } + duk_heaphdr_refzero_norz(thr, h); +#else + duk_heaphdr_decref_norz(thr, h); +#endif + } +} +#endif /* !DUK_USE_FAST_REFCOUNT_DEFAULT */ + +#define DUK__DECREF_ASSERTS() \ + do { \ + DUK_ASSERT(thr != NULL); \ + DUK_ASSERT(thr->heap != NULL); \ + DUK_ASSERT(h != NULL); \ + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID((duk_heaphdr *) h)); \ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT((duk_heaphdr *) h) >= 1); \ + } while (0) +#if defined(DUK_USE_ROM_OBJECTS) +#define DUK__INCREF_SHARED() \ + do { \ + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) h)) { \ + return; \ + } \ + DUK_HEAPHDR_PREINC_REFCOUNT((duk_heaphdr *) h); \ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT((duk_heaphdr *) h) != 0); /* No wrapping. */ \ + } while (0) +#define DUK__DECREF_SHARED() \ + do { \ + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) h)) { \ + return; \ + } \ + if (DUK_HEAPHDR_PREDEC_REFCOUNT((duk_heaphdr *) h) != 0) { \ + return; \ + } \ + } while (0) +#else +#define DUK__INCREF_SHARED() \ + do { \ + DUK_HEAPHDR_PREINC_REFCOUNT((duk_heaphdr *) h); \ + DUK_ASSERT(DUK_HEAPHDR_GET_REFCOUNT((duk_heaphdr *) h) != 0); /* No wrapping. */ \ + } while (0) +#define DUK__DECREF_SHARED() \ + do { \ + if (DUK_HEAPHDR_PREDEC_REFCOUNT((duk_heaphdr *) h) != 0) { \ + return; \ + } \ + } while (0) +#endif + +#if !defined(DUK_USE_FAST_REFCOUNT_DEFAULT) +/* This will in practice be inlined because it's just an INC instructions + * and a bit test + INC when ROM objects are enabled. + */ +DUK_INTERNAL void duk_heaphdr_incref(duk_heaphdr *h) { + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(h)); + DUK_ASSERT_DISABLE(DUK_HEAPHDR_GET_REFCOUNT(h) >= 0); + + DUK__INCREF_SHARED(); +} + +DUK_INTERNAL void duk_heaphdr_decref(duk_hthread *thr, duk_heaphdr *h) { + DUK__DECREF_ASSERTS(); + DUK__DECREF_SHARED(); + duk_heaphdr_refzero(thr, h); + + /* Forced mark-and-sweep when GC torture enabled; this could happen + * on any DECREF (but not DECREF_NORZ). + */ + DUK_GC_TORTURE(thr->heap); +} +DUK_INTERNAL void duk_heaphdr_decref_norz(duk_hthread *thr, duk_heaphdr *h) { + DUK__DECREF_ASSERTS(); + DUK__DECREF_SHARED(); + duk_heaphdr_refzero_norz(thr, h); +} +#endif /* !DUK_USE_FAST_REFCOUNT_DEFAULT */ + +#if 0 /* Not needed. */ +DUK_INTERNAL void duk_hstring_decref(duk_hthread *thr, duk_hstring *h) { + DUK__DECREF_ASSERTS(); + DUK__DECREF_SHARED(); + duk_hstring_refzero(thr, h); +} +DUK_INTERNAL void duk_hstring_decref_norz(duk_hthread *thr, duk_hstring *h) { + DUK__DECREF_ASSERTS(); + DUK__DECREF_SHARED(); + duk_hstring_refzero_norz(thr, h); +} +DUK_INTERNAL void duk_hbuffer_decref(duk_hthread *thr, duk_hbuffer *h) { + DUK__DECREF_ASSERTS(); + DUK__DECREF_SHARED(); + duk_hbuffer_refzero(thr, h); +} +DUK_INTERNAL void duk_hbuffer_decref_norz(duk_hthread *thr, duk_hbuffer *h) { + DUK__DECREF_ASSERTS(); + DUK__DECREF_SHARED(); + duk_hbuffer_refzero_norz(thr, h); +} +DUK_INTERNAL void duk_hobject_decref(duk_hthread *thr, duk_hobject *h) { + DUK__DECREF_ASSERTS(); + DUK__DECREF_SHARED(); + duk_hobject_refzero(thr, h); +} +DUK_INTERNAL void duk_hobject_decref_norz(duk_hthread *thr, duk_hobject *h) { + DUK__DECREF_ASSERTS(); + DUK__DECREF_SHARED(); + duk_hobject_refzero_norz(thr, h); +} +#endif + +#else /* DUK_USE_REFERENCE_COUNTING */ + +/* no refcounting */ + +#endif /* DUK_USE_REFERENCE_COUNTING */ + +/* automatic undefs */ +#undef DUK__DECREF_ASSERTS +#undef DUK__DECREF_SHARED +#undef DUK__INCREF_SHARED +#undef DUK__RZ_BUFFER +#undef DUK__RZ_INLINE +#undef DUK__RZ_OBJECT +#undef DUK__RZ_STRING +#undef DUK__RZ_SUPPRESS_ASSERT1 +#undef DUK__RZ_SUPPRESS_ASSERT2 +#undef DUK__RZ_SUPPRESS_CHECK +#undef DUK__RZ_SUPPRESS_COND +#line 1 "duk_heap_stringcache.c" +/* + * String cache. + * + * Provides a cache to optimize indexed string lookups. The cache keeps + * track of (byte offset, char offset) states for a fixed number of strings. + * Otherwise we'd need to scan from either end of the string, as we store + * strings in (extended) UTF-8. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Delete references to given hstring from the heap string cache. + * + * String cache references are 'weak': they are not counted towards + * reference counts, nor serve as roots for mark-and-sweep. When an + * object is about to be freed, such references need to be removed. + */ + +DUK_INTERNAL void duk_heap_strcache_string_remove(duk_heap *heap, duk_hstring *h) { + duk_uint_t i; + for (i = 0; i < DUK_HEAP_STRCACHE_SIZE; i++) { + duk_strcache_entry *c = heap->strcache + i; + if (c->h == h) { + DUK_DD( + DUK_DDPRINT("deleting weak strcache reference to hstring %p from heap %p", (void *) h, (void *) heap)); + c->h = NULL; + + /* XXX: the string shouldn't appear twice, but we now loop to the + * end anyway; if fixed, add a looping assertion to ensure there + * is no duplicate. + */ + } + } +} + +/* + * String scanning helpers + * + * All bytes other than UTF-8 continuation bytes ([0x80,0xbf]) are + * considered to contribute a character. This must match how string + * character length is computed. + */ + +DUK_LOCAL const duk_uint8_t *duk__scan_forwards(const duk_uint8_t *p, const duk_uint8_t *q, duk_uint_fast32_t n) { + while (n > 0) { + for (;;) { + p++; + if (p >= q) { + return NULL; + } + if ((*p & 0xc0) != 0x80) { + break; + } + } + n--; + } + return p; +} + +DUK_LOCAL const duk_uint8_t *duk__scan_backwards(const duk_uint8_t *p, const duk_uint8_t *q, duk_uint_fast32_t n) { + while (n > 0) { + for (;;) { + p--; + if (p < q) { + return NULL; + } + if ((*p & 0xc0) != 0x80) { + break; + } + } + n--; + } + return p; +} + +/* + * Convert char offset to byte offset + * + * Avoid using the string cache if possible: for ASCII strings byte and + * char offsets are equal and for short strings direct scanning may be + * better than using the string cache (which may evict a more important + * entry). + * + * Typing now assumes 32-bit string byte/char offsets (duk_uint_fast32_t). + * Better typing might be to use duk_size_t. + * + * Caller should ensure 'char_offset' is within the string bounds [0,charlen] + * (endpoint is inclusive). If this is not the case, no memory unsafe + * behavior will happen but an error will be thrown. + */ + +DUK_INTERNAL duk_uint_fast32_t duk_heap_strcache_offset_char2byte(duk_hthread *thr, duk_hstring *h, duk_uint_fast32_t char_offset) { + duk_heap *heap; + duk_strcache_entry *sce; + duk_uint_fast32_t byte_offset; + duk_uint_t i; + duk_bool_t use_cache; + duk_uint_fast32_t dist_start, dist_end, dist_sce; + duk_uint_fast32_t char_length; + const duk_uint8_t *p_start; + const duk_uint8_t *p_end; + const duk_uint8_t *p_found; + + /* + * For ASCII strings, the answer is simple. + */ + + if (DUK_LIKELY(DUK_HSTRING_IS_ASCII(h))) { + return char_offset; + } + + char_length = (duk_uint_fast32_t) DUK_HSTRING_GET_CHARLEN(h); + DUK_ASSERT(char_offset <= char_length); + + if (DUK_LIKELY(DUK_HSTRING_IS_ASCII(h))) { + /* Must recheck because the 'is ascii' flag may be set + * lazily. Alternatively, we could just compare charlen + * to bytelen. + */ + return char_offset; + } + + /* + * For non-ASCII strings, we need to scan forwards or backwards + * from some starting point. The starting point may be the start + * or end of the string, or some cached midpoint in the string + * cache. + * + * For "short" strings we simply scan without checking or updating + * the cache. For longer strings we check and update the cache as + * necessary, inserting a new cache entry if none exists. + */ + + DUK_DDD(DUK_DDDPRINT("non-ascii string %p, char_offset=%ld, clen=%ld, blen=%ld", + (void *) h, + (long) char_offset, + (long) DUK_HSTRING_GET_CHARLEN(h), + (long) DUK_HSTRING_GET_BYTELEN(h))); + + heap = thr->heap; + sce = NULL; + use_cache = (char_length > DUK_HEAP_STRINGCACHE_NOCACHE_LIMIT); + + if (use_cache) { +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) + DUK_DDD(DUK_DDDPRINT("stringcache before char2byte (using cache):")); + for (i = 0; i < DUK_HEAP_STRCACHE_SIZE; i++) { + duk_strcache_entry *c = heap->strcache + i; + DUK_DDD(DUK_DDDPRINT(" [%ld] -> h=%p, cidx=%ld, bidx=%ld", + (long) i, + (void *) c->h, + (long) c->cidx, + (long) c->bidx)); + } +#endif + + for (i = 0; i < DUK_HEAP_STRCACHE_SIZE; i++) { + duk_strcache_entry *c = heap->strcache + i; + + if (c->h == h) { + sce = c; + break; + } + } + } + + /* + * Scan from shortest distance: + * - start of string + * - end of string + * - cache entry (if exists) + */ + + DUK_ASSERT(DUK_HSTRING_GET_CHARLEN(h) >= char_offset); + dist_start = char_offset; + dist_end = char_length - char_offset; + dist_sce = 0; + DUK_UNREF(dist_sce); /* initialize for debug prints, needed if sce==NULL */ + + p_start = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h); + p_end = (const duk_uint8_t *) (p_start + DUK_HSTRING_GET_BYTELEN(h)); + p_found = NULL; + + if (sce) { + if (char_offset >= sce->cidx) { + dist_sce = char_offset - sce->cidx; + if ((dist_sce <= dist_start) && (dist_sce <= dist_end)) { + DUK_DDD(DUK_DDDPRINT("non-ascii string, use_cache=%ld, sce=%p:%ld:%ld, " + "dist_start=%ld, dist_end=%ld, dist_sce=%ld => " + "scan forwards from sce", + (long) use_cache, + (void *) (sce ? sce->h : NULL), + (sce ? (long) sce->cidx : (long) -1), + (sce ? (long) sce->bidx : (long) -1), + (long) dist_start, + (long) dist_end, + (long) dist_sce)); + + p_found = duk__scan_forwards(p_start + sce->bidx, p_end, dist_sce); + goto scan_done; + } + } else { + dist_sce = sce->cidx - char_offset; + if ((dist_sce <= dist_start) && (dist_sce <= dist_end)) { + DUK_DDD(DUK_DDDPRINT("non-ascii string, use_cache=%ld, sce=%p:%ld:%ld, " + "dist_start=%ld, dist_end=%ld, dist_sce=%ld => " + "scan backwards from sce", + (long) use_cache, + (void *) (sce ? sce->h : NULL), + (sce ? (long) sce->cidx : (long) -1), + (sce ? (long) sce->bidx : (long) -1), + (long) dist_start, + (long) dist_end, + (long) dist_sce)); + + p_found = duk__scan_backwards(p_start + sce->bidx, p_start, dist_sce); + goto scan_done; + } + } + } + + /* no sce, or sce scan not best */ + + if (dist_start <= dist_end) { + DUK_DDD(DUK_DDDPRINT("non-ascii string, use_cache=%ld, sce=%p:%ld:%ld, " + "dist_start=%ld, dist_end=%ld, dist_sce=%ld => " + "scan forwards from string start", + (long) use_cache, + (void *) (sce ? sce->h : NULL), + (sce ? (long) sce->cidx : (long) -1), + (sce ? (long) sce->bidx : (long) -1), + (long) dist_start, + (long) dist_end, + (long) dist_sce)); + + p_found = duk__scan_forwards(p_start, p_end, dist_start); + } else { + DUK_DDD(DUK_DDDPRINT("non-ascii string, use_cache=%ld, sce=%p:%ld:%ld, " + "dist_start=%ld, dist_end=%ld, dist_sce=%ld => " + "scan backwards from string end", + (long) use_cache, + (void *) (sce ? sce->h : NULL), + (sce ? (long) sce->cidx : (long) -1), + (sce ? (long) sce->bidx : (long) -1), + (long) dist_start, + (long) dist_end, + (long) dist_sce)); + + p_found = duk__scan_backwards(p_end, p_start, dist_end); + } + +scan_done: + + if (DUK_UNLIKELY(p_found == NULL)) { + /* Scan error: this shouldn't normally happen; it could happen if + * string is not valid UTF-8 data, and clen/blen are not consistent + * with the scanning algorithm. + */ + goto scan_error; + } + + DUK_ASSERT(p_found >= p_start); + DUK_ASSERT(p_found <= p_end); /* may be equal */ + byte_offset = (duk_uint32_t) (p_found - p_start); + + DUK_DDD(DUK_DDDPRINT("-> string %p, cidx %ld -> bidx %ld", (void *) h, (long) char_offset, (long) byte_offset)); + + /* + * Update cache entry (allocating if necessary), and move the + * cache entry to the first place (in an "LRU" policy). + */ + + if (use_cache) { + /* update entry, allocating if necessary */ + if (!sce) { + sce = heap->strcache + DUK_HEAP_STRCACHE_SIZE - 1; /* take last entry */ + sce->h = h; + } + DUK_ASSERT(sce != NULL); + sce->bidx = (duk_uint32_t) (p_found - p_start); + sce->cidx = (duk_uint32_t) char_offset; + + /* LRU: move our entry to first */ + if (sce > &heap->strcache[0]) { + /* + * A C + * B A + * C <- sce ==> B + * D D + */ + duk_strcache_entry tmp; + + tmp = *sce; + duk_memmove((void *) (&heap->strcache[1]), + (const void *) (&heap->strcache[0]), + (size_t) (((char *) sce) - ((char *) &heap->strcache[0]))); + heap->strcache[0] = tmp; + + /* 'sce' points to the wrong entry here, but is no longer used */ + } +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) + DUK_DDD(DUK_DDDPRINT("stringcache after char2byte (using cache):")); + for (i = 0; i < DUK_HEAP_STRCACHE_SIZE; i++) { + duk_strcache_entry *c = heap->strcache + i; + DUK_DDD(DUK_DDDPRINT(" [%ld] -> h=%p, cidx=%ld, bidx=%ld", + (long) i, + (void *) c->h, + (long) c->cidx, + (long) c->bidx)); + } +#endif + } + + return byte_offset; + +scan_error: + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return 0;); +} +#line 1 "duk_heap_stringtable.c" +/* + * Heap string table handling, string interning. + */ + +/* #include duk_internal.h -> already included */ + +/* Resize checks not needed if minsize == maxsize, typical for low memory + * targets. + */ +#define DUK__STRTAB_RESIZE_CHECK +#if (DUK_USE_STRTAB_MINSIZE == DUK_USE_STRTAB_MAXSIZE) +#undef DUK__STRTAB_RESIZE_CHECK +#endif + +#if defined(DUK_USE_STRTAB_PTRCOMP) +#define DUK__HEAPPTR_ENC16(heap, ptr) DUK_USE_HEAPPTR_ENC16((heap)->heap_udata, (ptr)) +#define DUK__HEAPPTR_DEC16(heap, val) DUK_USE_HEAPPTR_DEC16((heap)->heap_udata, (val)) +#define DUK__GET_STRTABLE(heap) ((heap)->strtable16) +#else +#define DUK__HEAPPTR_ENC16(heap, ptr) (ptr) +#define DUK__HEAPPTR_DEC16(heap, val) (val) +#define DUK__GET_STRTABLE(heap) ((heap)->strtable) +#endif + +#define DUK__STRTAB_U32_MAX_STRLEN 10 /* 4'294'967'295 */ + +/* + * Debug dump stringtable. + */ + +#if defined(DUK_USE_DEBUG) +DUK_INTERNAL void duk_heap_strtable_dump(duk_heap *heap) { +#if defined(DUK_USE_STRTAB_PTRCOMP) + duk_uint16_t *strtable; +#else + duk_hstring **strtable; +#endif + duk_uint32_t i; + duk_hstring *h; + duk_size_t count_total = 0; + duk_size_t count_chain; + duk_size_t count_chain_min = DUK_SIZE_MAX; + duk_size_t count_chain_max = 0; + duk_size_t count_len[8]; /* chain lengths from 0 to 7 */ + + if (heap == NULL) { + DUK_D(DUK_DPRINT("string table, heap=NULL")); + return; + } + + strtable = DUK__GET_STRTABLE(heap); + if (strtable == NULL) { + DUK_D(DUK_DPRINT("string table, strtab=NULL")); + return; + } + + duk_memzero((void *) count_len, sizeof(count_len)); + for (i = 0; i < heap->st_size; i++) { + h = DUK__HEAPPTR_DEC16(heap, strtable[i]); + count_chain = 0; + while (h != NULL) { + count_chain++; + h = h->hdr.h_next; + } + if (count_chain < sizeof(count_len) / sizeof(duk_size_t)) { + count_len[count_chain]++; + } + count_chain_max = (count_chain > count_chain_max ? count_chain : count_chain_max); + count_chain_min = (count_chain < count_chain_min ? count_chain : count_chain_min); + count_total += count_chain; + } + + DUK_D(DUK_DPRINT("string table, strtab=%p, count=%lu, chain min=%lu max=%lu avg=%lf: " + "counts: %lu %lu %lu %lu %lu %lu %lu %lu ...", + (void *) heap->strtable, + (unsigned long) count_total, + (unsigned long) count_chain_min, + (unsigned long) count_chain_max, + (double) count_total / (double) heap->st_size, + (unsigned long) count_len[0], + (unsigned long) count_len[1], + (unsigned long) count_len[2], + (unsigned long) count_len[3], + (unsigned long) count_len[4], + (unsigned long) count_len[5], + (unsigned long) count_len[6], + (unsigned long) count_len[7])); +} +#endif /* DUK_USE_DEBUG */ + +/* + * Assertion helper to ensure strtable is populated correctly. + */ + +#if defined(DUK_USE_ASSERTIONS) +DUK_LOCAL void duk__strtable_assert_checks(duk_heap *heap) { +#if defined(DUK_USE_STRTAB_PTRCOMP) + duk_uint16_t *strtable; +#else + duk_hstring **strtable; +#endif + duk_uint32_t i; + duk_hstring *h; + duk_size_t count = 0; + + DUK_ASSERT(heap != NULL); + + strtable = DUK__GET_STRTABLE(heap); + if (strtable != NULL) { + DUK_ASSERT(heap->st_size != 0); + DUK_ASSERT(heap->st_mask == heap->st_size - 1); + + for (i = 0; i < heap->st_size; i++) { + h = DUK__HEAPPTR_DEC16(heap, strtable[i]); + while (h != NULL) { + DUK_ASSERT((DUK_HSTRING_GET_HASH(h) & heap->st_mask) == i); + count++; + h = h->hdr.h_next; + } + } + } else { + DUK_ASSERT(heap->st_size == 0); + DUK_ASSERT(heap->st_mask == 0); + } + +#if defined(DUK__STRTAB_RESIZE_CHECK) + DUK_ASSERT(count == (duk_size_t) heap->st_count); +#endif +} +#endif /* DUK_USE_ASSERTIONS */ + +/* + * Allocate and initialize a duk_hstring. + * + * Returns a NULL if allocation or initialization fails for some reason. + * + * The string won't be inserted into the string table and isn't tracked in + * any way (link pointers will be NULL). The caller must place the string + * into the string table without any risk of a longjmp, otherwise the string + * is leaked. + */ + +DUK_LOCAL duk_hstring *duk__strtable_alloc_hstring(duk_heap *heap, + const duk_uint8_t *str, + duk_uint32_t blen, + duk_uint32_t strhash, + const duk_uint8_t *extdata) { + duk_hstring *res; + const duk_uint8_t *data; +#if !defined(DUK_USE_HSTRING_ARRIDX) + duk_uarridx_t dummy; +#endif + + DUK_ASSERT(heap != NULL); + DUK_UNREF(extdata); + +#if defined(DUK_USE_STRLEN16) + /* If blen <= 0xffffUL, clen is also guaranteed to be <= 0xffffUL. */ + if (blen > 0xffffUL) { + DUK_D(DUK_DPRINT("16-bit string blen/clen active and blen over 16 bits, reject intern")); + goto alloc_error; + } +#endif + + /* XXX: Memzeroing the allocated structure is not really necessary + * because we could just initialize all fields explicitly (almost + * all fields are initialized explicitly anyway). + */ +#if defined(DUK_USE_HSTRING_EXTDATA) && defined(DUK_USE_EXTSTR_INTERN_CHECK) + if (extdata) { + res = (duk_hstring *) DUK_ALLOC(heap, sizeof(duk_hstring_external)); + if (DUK_UNLIKELY(res == NULL)) { + goto alloc_error; + } + duk_memzero(res, sizeof(duk_hstring_external)); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + DUK_HEAPHDR_STRING_INIT_NULLS(&res->hdr); +#endif + DUK_HEAPHDR_SET_TYPE_AND_FLAGS(&res->hdr, DUK_HTYPE_STRING, DUK_HSTRING_FLAG_EXTDATA); + + DUK_ASSERT(extdata[blen] == 0); /* Application responsibility. */ + data = extdata; + ((duk_hstring_external *) res)->extdata = extdata; + } else +#endif /* DUK_USE_HSTRING_EXTDATA && DUK_USE_EXTSTR_INTERN_CHECK */ + { + duk_uint8_t *data_tmp; + + /* NUL terminate for convenient C access */ + DUK_ASSERT(sizeof(duk_hstring) + blen + 1 > blen); /* No wrap, limits ensure. */ + res = (duk_hstring *) DUK_ALLOC(heap, sizeof(duk_hstring) + blen + 1); + if (DUK_UNLIKELY(res == NULL)) { + goto alloc_error; + } + duk_memzero(res, sizeof(duk_hstring)); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + DUK_HEAPHDR_STRING_INIT_NULLS(&res->hdr); +#endif + DUK_HEAPHDR_SET_TYPE_AND_FLAGS(&res->hdr, DUK_HTYPE_STRING, 0); + + data_tmp = (duk_uint8_t *) (res + 1); + duk_memcpy(data_tmp, str, blen); + data_tmp[blen] = (duk_uint8_t) 0; + data = (const duk_uint8_t *) data_tmp; + } + + DUK_HSTRING_SET_BYTELEN(res, blen); + DUK_HSTRING_SET_HASH(res, strhash); + + DUK_ASSERT(!DUK_HSTRING_HAS_ARRIDX(res)); +#if defined(DUK_USE_HSTRING_ARRIDX) + res->arridx = duk_js_to_arrayindex_string(data, blen); + if (res->arridx != DUK_HSTRING_NO_ARRAY_INDEX) { +#else + dummy = duk_js_to_arrayindex_string(data, blen); + if (dummy != DUK_HSTRING_NO_ARRAY_INDEX) { +#endif + /* Array index strings cannot be symbol strings, + * and they're always pure ASCII so blen == clen. + */ + DUK_HSTRING_SET_ARRIDX(res); + DUK_HSTRING_SET_ASCII(res); + DUK_ASSERT(duk_unicode_unvalidated_utf8_length(data, (duk_size_t) blen) == blen); + } else { + /* Because 'data' is NUL-terminated, we don't need a + * blen > 0 check here. For NUL (0x00) the symbol + * checks will be false. + */ + if (DUK_UNLIKELY(data[0] >= 0x80U)) { + if (data[0] <= 0x81) { + DUK_HSTRING_SET_SYMBOL(res); + } else if (data[0] == 0x82U || data[0] == 0xffU) { + DUK_HSTRING_SET_HIDDEN(res); + DUK_HSTRING_SET_SYMBOL(res); + } + } + + /* Using an explicit 'ASCII' flag has larger footprint (one call site + * only) but is quite useful for the case when there's no explicit + * 'clen' in duk_hstring. + * + * The flag is set lazily for RAM strings. + */ + DUK_ASSERT(!DUK_HSTRING_HAS_ASCII(res)); + +#if defined(DUK_USE_HSTRING_LAZY_CLEN) + /* Charlen initialized to 0, updated on-the-fly. */ +#else + duk_hstring_init_charlen(res); /* Also sets ASCII flag. */ +#endif + } + + DUK_DDD(DUK_DDDPRINT("interned string, hash=0x%08lx, blen=%ld, has_arridx=%ld, has_extdata=%ld", + (unsigned long) DUK_HSTRING_GET_HASH(res), + (long) DUK_HSTRING_GET_BYTELEN(res), + (long) (DUK_HSTRING_HAS_ARRIDX(res) ? 1 : 0), + (long) (DUK_HSTRING_HAS_EXTDATA(res) ? 1 : 0))); + + DUK_ASSERT(res != NULL); + return res; + +alloc_error: + return NULL; +} + +/* + * Grow strtable allocation in-place. + */ + +#if defined(DUK__STRTAB_RESIZE_CHECK) +DUK_LOCAL void duk__strtable_grow_inplace(duk_heap *heap) { + duk_uint32_t new_st_size; + duk_uint32_t old_st_size; + duk_uint32_t i; + duk_hstring *h; + duk_hstring *next; + duk_hstring *prev; +#if defined(DUK_USE_STRTAB_PTRCOMP) + duk_uint16_t *new_ptr; + duk_uint16_t *new_ptr_high; +#else + duk_hstring **new_ptr; + duk_hstring **new_ptr_high; +#endif + + DUK_DD(DUK_DDPRINT("grow in-place: %lu -> %lu", (unsigned long) heap->st_size, (unsigned long) heap->st_size * 2)); + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->st_resizing == 1); + DUK_ASSERT(heap->st_size >= 2); + DUK_ASSERT((heap->st_size & (heap->st_size - 1)) == 0); /* 2^N */ + DUK_ASSERT(DUK__GET_STRTABLE(heap) != NULL); + + DUK_STATS_INC(heap, stats_strtab_resize_grow); + + new_st_size = heap->st_size << 1U; + DUK_ASSERT(new_st_size > heap->st_size); /* No overflow. */ + + /* Reallocate the strtable first and then work in-place to rehash + * strings. We don't need an indirect allocation here: even if GC + * is triggered to satisfy the allocation, recursive strtable resize + * is prevented by flags. This is also why we don't need to use + * DUK_REALLOC_INDIRECT(). + */ + +#if defined(DUK_USE_STRTAB_PTRCOMP) + new_ptr = (duk_uint16_t *) DUK_REALLOC(heap, heap->strtable16, sizeof(duk_uint16_t) * new_st_size); +#else + new_ptr = (duk_hstring **) DUK_REALLOC(heap, heap->strtable, sizeof(duk_hstring *) * new_st_size); +#endif + if (DUK_UNLIKELY(new_ptr == NULL)) { + /* If realloc fails we can continue normally: the string table + * won't "fill up" although chains will gradually get longer. + * When string insertions continue, we'll quite soon try again + * with no special handling. + */ + DUK_D(DUK_DPRINT("string table grow failed, ignoring")); + return; + } +#if defined(DUK_USE_STRTAB_PTRCOMP) + heap->strtable16 = new_ptr; +#else + heap->strtable = new_ptr; +#endif + + /* Rehash a single bucket into two separate ones. When we grow + * by x2 the highest 'new' bit determines whether a string remains + * in its old position (bit is 0) or goes to a new one (bit is 1). + */ + + old_st_size = heap->st_size; + new_ptr_high = new_ptr + old_st_size; + for (i = 0; i < old_st_size; i++) { + duk_hstring *new_root; + duk_hstring *new_root_high; + + h = DUK__HEAPPTR_DEC16(heap, new_ptr[i]); + new_root = h; + new_root_high = NULL; + + prev = NULL; + while (h != NULL) { + duk_uint32_t mask; + + DUK_ASSERT((DUK_HSTRING_GET_HASH(h) & heap->st_mask) == i); + next = h->hdr.h_next; + + /* Example: if previous size was 256, previous mask is 0xFF + * and size is 0x100 which corresponds to the new bit that + * comes into play. + */ + DUK_ASSERT(heap->st_mask == old_st_size - 1); + mask = old_st_size; + if (DUK_HSTRING_GET_HASH(h) & mask) { + if (prev != NULL) { + prev->hdr.h_next = h->hdr.h_next; + } else { + DUK_ASSERT(h == new_root); + new_root = h->hdr.h_next; + } + + h->hdr.h_next = new_root_high; + new_root_high = h; + } else { + prev = h; + } + h = next; + } + + new_ptr[i] = DUK__HEAPPTR_ENC16(heap, new_root); + new_ptr_high[i] = DUK__HEAPPTR_ENC16(heap, new_root_high); + } + + heap->st_size = new_st_size; + heap->st_mask = new_st_size - 1; + +#if defined(DUK_USE_ASSERTIONS) + duk__strtable_assert_checks(heap); +#endif +} +#endif /* DUK__STRTAB_RESIZE_CHECK */ + +/* + * Shrink strtable allocation in-place. + */ + +#if defined(DUK__STRTAB_RESIZE_CHECK) +DUK_LOCAL void duk__strtable_shrink_inplace(duk_heap *heap) { + duk_uint32_t new_st_size; + duk_uint32_t i; + duk_hstring *h; + duk_hstring *other; + duk_hstring *root; +#if defined(DUK_USE_STRTAB_PTRCOMP) + duk_uint16_t *old_ptr; + duk_uint16_t *old_ptr_high; + duk_uint16_t *new_ptr; +#else + duk_hstring **old_ptr; + duk_hstring **old_ptr_high; + duk_hstring **new_ptr; +#endif + + DUK_DD(DUK_DDPRINT("shrink in-place: %lu -> %lu", (unsigned long) heap->st_size, (unsigned long) heap->st_size / 2)); + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(heap->st_resizing == 1); + DUK_ASSERT(heap->st_size >= 2); + DUK_ASSERT((heap->st_size & (heap->st_size - 1)) == 0); /* 2^N */ + DUK_ASSERT(DUK__GET_STRTABLE(heap) != NULL); + + DUK_STATS_INC(heap, stats_strtab_resize_shrink); + + new_st_size = heap->st_size >> 1U; + + /* Combine two buckets into a single one. When we shrink, one hash + * bit (highest) disappears. + */ + old_ptr = DUK__GET_STRTABLE(heap); + old_ptr_high = old_ptr + new_st_size; + for (i = 0; i < new_st_size; i++) { + h = DUK__HEAPPTR_DEC16(heap, old_ptr[i]); + other = DUK__HEAPPTR_DEC16(heap, old_ptr_high[i]); + + if (h == NULL) { + /* First chain is empty, so use second one as is. */ + root = other; + } else { + /* Find end of first chain, and link in the second. */ + root = h; + while (h->hdr.h_next != NULL) { + h = h->hdr.h_next; + } + h->hdr.h_next = other; + } + + old_ptr[i] = DUK__HEAPPTR_ENC16(heap, root); + } + + heap->st_size = new_st_size; + heap->st_mask = new_st_size - 1; + + /* The strtable is now consistent and we can realloc safely. Even + * if side effects cause string interning or removal the strtable + * updates are safe. Recursive resize has been prevented by caller. + * This is also why we don't need to use DUK_REALLOC_INDIRECT(). + * + * We assume a realloc() to a smaller size is guaranteed to succeed. + * It would be relatively straightforward to handle the error by + * essentially performing a "grow" step to recover. + */ + +#if defined(DUK_USE_STRTAB_PTRCOMP) + new_ptr = (duk_uint16_t *) DUK_REALLOC(heap, heap->strtable16, sizeof(duk_uint16_t) * new_st_size); + DUK_ASSERT(new_ptr != NULL); + heap->strtable16 = new_ptr; +#else + new_ptr = (duk_hstring **) DUK_REALLOC(heap, heap->strtable, sizeof(duk_hstring *) * new_st_size); + DUK_ASSERT(new_ptr != NULL); + heap->strtable = new_ptr; +#endif + +#if defined(DUK_USE_ASSERTIONS) + duk__strtable_assert_checks(heap); +#endif +} +#endif /* DUK__STRTAB_RESIZE_CHECK */ + +/* + * Grow/shrink check. + */ + +#if defined(DUK__STRTAB_RESIZE_CHECK) +DUK_LOCAL DUK_COLD DUK_NOINLINE void duk__strtable_resize_check(duk_heap *heap) { + duk_uint32_t load_factor; /* fixed point */ + + DUK_ASSERT(heap != NULL); +#if defined(DUK_USE_STRTAB_PTRCOMP) + DUK_ASSERT(heap->strtable16 != NULL); +#else + DUK_ASSERT(heap->strtable != NULL); +#endif + + DUK_STATS_INC(heap, stats_strtab_resize_check); + + /* Prevent recursive resizing. */ + if (DUK_UNLIKELY(heap->st_resizing != 0U)) { + DUK_D(DUK_DPRINT("prevent recursive strtable resize")); + return; + } + + heap->st_resizing = 1; + + DUK_ASSERT(heap->st_size >= 16U); + DUK_ASSERT((heap->st_size >> 4U) >= 1); + load_factor = heap->st_count / (heap->st_size >> 4U); + + DUK_DD(DUK_DDPRINT("resize check string table: size=%lu, count=%lu, load_factor=%lu (fixed point .4; float %lf)", + (unsigned long) heap->st_size, + (unsigned long) heap->st_count, + (unsigned long) load_factor, + (double) heap->st_count / (double) heap->st_size)); + + if (load_factor >= DUK_USE_STRTAB_GROW_LIMIT) { + if (heap->st_size >= DUK_USE_STRTAB_MAXSIZE) { + DUK_DD(DUK_DDPRINT("want to grow strtable (based on load factor) but already maximum size")); + } else { + DUK_D(DUK_DPRINT("grow string table: %lu -> %lu", + (unsigned long) heap->st_size, + (unsigned long) heap->st_size * 2)); +#if defined(DUK_USE_DEBUG) + duk_heap_strtable_dump(heap); +#endif + duk__strtable_grow_inplace(heap); + } + } else if (load_factor <= DUK_USE_STRTAB_SHRINK_LIMIT) { + if (heap->st_size <= DUK_USE_STRTAB_MINSIZE) { + DUK_DD(DUK_DDPRINT("want to shrink strtable (based on load factor) but already minimum size")); + } else { + DUK_D(DUK_DPRINT("shrink string table: %lu -> %lu", + (unsigned long) heap->st_size, + (unsigned long) heap->st_size / 2)); +#if defined(DUK_USE_DEBUG) + duk_heap_strtable_dump(heap); +#endif + duk__strtable_shrink_inplace(heap); + } + } else { + DUK_DD(DUK_DDPRINT("no need for strtable resize")); + } + + heap->st_resizing = 0; +} +#endif /* DUK__STRTAB_RESIZE_CHECK */ + +/* + * Torture grow/shrink: unconditionally grow and shrink back. + */ + +#if defined(DUK_USE_STRTAB_TORTURE) && defined(DUK__STRTAB_RESIZE_CHECK) +DUK_LOCAL void duk__strtable_resize_torture(duk_heap *heap) { + duk_uint32_t old_st_size; + + DUK_ASSERT(heap != NULL); + + old_st_size = heap->st_size; + if (old_st_size >= DUK_USE_STRTAB_MAXSIZE) { + return; + } + + heap->st_resizing = 1; + duk__strtable_grow_inplace(heap); + if (heap->st_size > old_st_size) { + duk__strtable_shrink_inplace(heap); + } + heap->st_resizing = 0; +} +#endif /* DUK_USE_STRTAB_TORTURE && DUK__STRTAB_RESIZE_CHECK */ + +/* + * Raw intern; string already checked not to be present. + */ + +DUK_LOCAL duk_hstring *duk__strtable_do_intern(duk_heap *heap, const duk_uint8_t *str, duk_uint32_t blen, duk_uint32_t strhash) { + duk_hstring *res; + const duk_uint8_t *extdata; +#if defined(DUK_USE_STRTAB_PTRCOMP) + duk_uint16_t *slot; +#else + duk_hstring **slot; +#endif + + DUK_DDD(DUK_DDDPRINT("do_intern: heap=%p, str=%p, blen=%lu, strhash=%lx, st_size=%lu, st_count=%lu, load=%lf", + (void *) heap, + (const void *) str, + (unsigned long) blen, + (unsigned long) strhash, + (unsigned long) heap->st_size, + (unsigned long) heap->st_count, + (double) heap->st_count / (double) heap->st_size)); + + DUK_ASSERT(heap != NULL); + + /* Prevent any side effects on the string table and the caller provided + * str/blen arguments while interning is in progress. For example, if + * the caller provided str/blen from a dynamic buffer, a finalizer + * might resize or modify that dynamic buffer, invalidating the call + * arguments. + * + * While finalizers must be prevented, mark-and-sweep itself is fine. + * Recursive string table resize is prevented explicitly here. + */ + + heap->pf_prevent_count++; + DUK_ASSERT(heap->pf_prevent_count != 0); /* Wrap. */ + +#if defined(DUK_USE_STRTAB_TORTURE) && defined(DUK__STRTAB_RESIZE_CHECK) + duk__strtable_resize_torture(heap); +#endif + + /* String table grow/shrink check. Because of chaining (and no + * accumulation issues as with hash probe chains and DELETED + * markers) there's never a mandatory need to resize right now. + * Check for the resize only periodically, based on st_count + * bit pattern. Because string table removal doesn't do a shrink + * check, we do that also here. + * + * Do the resize and possible grow/shrink before the new duk_hstring + * has been allocated. Otherwise we may trigger a GC when the result + * duk_hstring is not yet strongly referenced. + */ + +#if defined(DUK__STRTAB_RESIZE_CHECK) + if (DUK_UNLIKELY((heap->st_count & DUK_USE_STRTAB_RESIZE_CHECK_MASK) == 0)) { + duk__strtable_resize_check(heap); + } +#endif + + /* External string check (low memory optimization). */ + +#if defined(DUK_USE_HSTRING_EXTDATA) && defined(DUK_USE_EXTSTR_INTERN_CHECK) + extdata = + (const duk_uint8_t *) DUK_USE_EXTSTR_INTERN_CHECK(heap->heap_udata, (void *) DUK_LOSE_CONST(str), (duk_size_t) blen); +#else + extdata = (const duk_uint8_t *) NULL; +#endif + + /* Allocate and initialize string, not yet linked. This may cause a + * GC which may cause other strings to be interned and inserted into + * the string table before we insert our string. Finalizer execution + * is disabled intentionally to avoid a finalizer from e.g. resizing + * a buffer used as a data area for 'str'. + */ + + res = duk__strtable_alloc_hstring(heap, str, blen, strhash, extdata); + + /* Allow side effects again: GC must be avoided until duk_hstring + * result (if successful) has been INCREF'd. + */ + DUK_ASSERT(heap->pf_prevent_count > 0); + heap->pf_prevent_count--; + + /* Alloc error handling. */ + + if (DUK_UNLIKELY(res == NULL)) { +#if defined(DUK_USE_HSTRING_EXTDATA) && defined(DUK_USE_EXTSTR_INTERN_CHECK) + if (extdata != NULL) { + DUK_USE_EXTSTR_FREE(heap->heap_udata, (const void *) extdata); + } +#endif + return NULL; + } + + /* Insert into string table. */ + +#if defined(DUK_USE_STRTAB_PTRCOMP) + slot = heap->strtable16 + (strhash & heap->st_mask); +#else + slot = heap->strtable + (strhash & heap->st_mask); +#endif + DUK_ASSERT(res->hdr.h_next == NULL); /* This is the case now, but unnecessary zeroing/NULLing. */ + res->hdr.h_next = DUK__HEAPPTR_DEC16(heap, *slot); + *slot = DUK__HEAPPTR_ENC16(heap, res); + + /* Update string count only for successful inserts. */ + +#if defined(DUK__STRTAB_RESIZE_CHECK) + heap->st_count++; +#endif + + /* The duk_hstring is in the string table but is not yet strongly + * reachable. Calling code MUST NOT make any allocations or other + * side effects before the duk_hstring has been INCREF'd and made + * reachable. + */ + + return res; +} + +/* + * Intern a string from str/blen, returning either an existing duk_hstring + * or adding a new one into the string table. The input string does -not- + * need to be NUL terminated. + * + * The input 'str' argument may point to a Duktape managed data area such as + * the data area of a dynamic buffer. It's crucial to avoid any side effects + * that might affect the data area (e.g. resize the dynamic buffer, or write + * to the buffer) before the string is fully interned. + */ + +#if defined(DUK_USE_ROM_STRINGS) +DUK_LOCAL duk_hstring *duk__strtab_romstring_lookup(duk_heap *heap, const duk_uint8_t *str, duk_size_t blen, duk_uint32_t strhash) { + duk_size_t lookup_hash; + duk_hstring *curr; + + DUK_ASSERT(heap != NULL); + DUK_UNREF(heap); + + lookup_hash = (blen << 4); + if (blen > 0) { + lookup_hash += str[0]; + } + lookup_hash &= 0xff; + + curr = (duk_hstring *) DUK_LOSE_CONST(duk_rom_strings_lookup[lookup_hash]); + while (curr != NULL) { + /* Unsafe memcmp() because for zero blen, str may be NULL. */ + if (strhash == DUK_HSTRING_GET_HASH(curr) && blen == DUK_HSTRING_GET_BYTELEN(curr) && + duk_memcmp_unsafe((const void *) str, (const void *) DUK_HSTRING_GET_DATA(curr), blen) == 0) { + DUK_DDD(DUK_DDDPRINT("intern check: rom string: %!O, computed hash 0x%08lx, rom hash 0x%08lx", + curr, + (unsigned long) strhash, + (unsigned long) DUK_HSTRING_GET_HASH(curr))); + return curr; + } + curr = curr->hdr.h_next; + } + + return NULL; +} +#endif /* DUK_USE_ROM_STRINGS */ + +DUK_INTERNAL duk_hstring *duk_heap_strtable_intern(duk_heap *heap, const duk_uint8_t *str, duk_uint32_t blen) { + duk_uint32_t strhash; + duk_hstring *h; + + DUK_DDD(DUK_DDDPRINT("intern check: heap=%p, str=%p, blen=%lu", (void *) heap, (const void *) str, (unsigned long) blen)); + + /* Preliminaries. */ + + /* XXX: maybe just require 'str != NULL' even for zero size? */ + DUK_ASSERT(heap != NULL); + DUK_ASSERT(blen == 0 || str != NULL); + DUK_ASSERT(blen <= DUK_HSTRING_MAX_BYTELEN); /* Caller is responsible for ensuring this. */ + strhash = duk_heap_hashstring(heap, str, (duk_size_t) blen); + + /* String table lookup. */ + + DUK_ASSERT(DUK__GET_STRTABLE(heap) != NULL); + DUK_ASSERT(heap->st_size > 0); + DUK_ASSERT(heap->st_size == heap->st_mask + 1); +#if defined(DUK_USE_STRTAB_PTRCOMP) + h = DUK__HEAPPTR_DEC16(heap, heap->strtable16[strhash & heap->st_mask]); +#else + h = heap->strtable[strhash & heap->st_mask]; +#endif + while (h != NULL) { + if (DUK_HSTRING_GET_HASH(h) == strhash && DUK_HSTRING_GET_BYTELEN(h) == blen && + duk_memcmp_unsafe((const void *) str, (const void *) DUK_HSTRING_GET_DATA(h), (size_t) blen) == 0) { + /* Found existing entry. */ + DUK_STATS_INC(heap, stats_strtab_intern_hit); + return h; + } + h = h->hdr.h_next; + } + + /* ROM table lookup. Because this lookup is slower, do it only after + * RAM lookup. This works because no ROM string is ever interned into + * the RAM string table. + */ + +#if defined(DUK_USE_ROM_STRINGS) + h = duk__strtab_romstring_lookup(heap, str, blen, strhash); + if (h != NULL) { + DUK_STATS_INC(heap, stats_strtab_intern_hit); + return h; + } +#endif + + /* Not found in string table; insert. */ + + DUK_STATS_INC(heap, stats_strtab_intern_miss); + h = duk__strtable_do_intern(heap, str, blen, strhash); + return h; /* may be NULL */ +} + +/* + * Intern a string from u32. + */ + +/* XXX: Could arrange some special handling because we know that the result + * will have an arridx flag and an ASCII flag, won't need a clen check, etc. + */ + +DUK_INTERNAL duk_hstring *duk_heap_strtable_intern_u32(duk_heap *heap, duk_uint32_t val) { + duk_uint8_t buf[DUK__STRTAB_U32_MAX_STRLEN]; + duk_uint8_t *p; + + DUK_ASSERT(heap != NULL); + + /* This is smaller and faster than a %lu sprintf. */ + p = buf + sizeof(buf); + do { + p--; + *p = duk_lc_digits[val % 10]; + val = val / 10; + } while (val != 0); /* For val == 0, emit exactly one '0'. */ + DUK_ASSERT(p >= buf); + + return duk_heap_strtable_intern(heap, (const duk_uint8_t *) p, (duk_uint32_t) ((buf + sizeof(buf)) - p)); +} + +/* + * Checked convenience variants. + * + * XXX: Because the main use case is for the checked variants, make them the + * main functionality and provide a safe variant separately (it is only needed + * during heap init). The problem with that is that longjmp state and error + * creation must already be possible to throw. + */ + +DUK_INTERNAL duk_hstring *duk_heap_strtable_intern_checked(duk_hthread *thr, const duk_uint8_t *str, duk_uint32_t blen) { + duk_hstring *res; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(blen == 0 || str != NULL); + + res = duk_heap_strtable_intern(thr->heap, str, blen); + if (DUK_UNLIKELY(res == NULL)) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return NULL;); + } + return res; +} + +#if defined(DUK_USE_LITCACHE_SIZE) +DUK_LOCAL duk_uint_t duk__strtable_litcache_key(const duk_uint8_t *str, duk_uint32_t blen) { + duk_uintptr_t key; + + DUK_ASSERT(DUK_USE_LITCACHE_SIZE > 0); + DUK_ASSERT(DUK_IS_POWER_OF_TWO((duk_uint_t) DUK_USE_LITCACHE_SIZE)); + + key = (duk_uintptr_t) blen ^ (duk_uintptr_t) str; + key &= (duk_uintptr_t) (DUK_USE_LITCACHE_SIZE - 1); /* Assumes size is power of 2. */ + /* Due to masking, cast is in 32-bit range. */ + DUK_ASSERT(key <= DUK_UINT_MAX); + return (duk_uint_t) key; +} + +DUK_INTERNAL duk_hstring *duk_heap_strtable_intern_literal_checked(duk_hthread *thr, const duk_uint8_t *str, duk_uint32_t blen) { + duk_uint_t key; + duk_litcache_entry *ent; + duk_hstring *h; + + /* Fast path check: literal exists in literal cache. */ + key = duk__strtable_litcache_key(str, blen); + ent = thr->heap->litcache + key; + if (ent->addr == str) { + DUK_DD(DUK_DDPRINT("intern check for cached, pinned literal: str=%p, blen=%ld -> duk_hstring %!O", + (const void *) str, + (long) blen, + (duk_heaphdr *) ent->h)); + DUK_ASSERT(ent->h != NULL); + DUK_ASSERT(DUK_HSTRING_HAS_PINNED_LITERAL(ent->h)); + DUK_STATS_INC(thr->heap, stats_strtab_litcache_hit); + return ent->h; + } + + /* Intern and update (overwrite) cache entry. */ + h = duk_heap_strtable_intern_checked(thr, str, blen); + ent->addr = str; + ent->h = h; + DUK_STATS_INC(thr->heap, stats_strtab_litcache_miss); + + /* Pin the duk_hstring until the next mark-and-sweep. This means + * litcache entries don't need to be invalidated until the next + * mark-and-sweep as their target duk_hstring is not freed before + * the mark-and-sweep happens. The pin remains even if the literal + * cache entry is overwritten, and is still useful to avoid string + * table traffic. + */ + if (!DUK_HSTRING_HAS_PINNED_LITERAL(h)) { + DUK_DD(DUK_DDPRINT("pin duk_hstring because it is a literal: %!O", (duk_heaphdr *) h)); + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) h)); + DUK_HSTRING_INCREF(thr, h); + DUK_HSTRING_SET_PINNED_LITERAL(h); + DUK_STATS_INC(thr->heap, stats_strtab_litcache_pin); + } + + return h; +} +#endif /* DUK_USE_LITCACHE_SIZE */ + +DUK_INTERNAL duk_hstring *duk_heap_strtable_intern_u32_checked(duk_hthread *thr, duk_uint32_t val) { + duk_hstring *res; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + + res = duk_heap_strtable_intern_u32(thr->heap, val); + if (DUK_UNLIKELY(res == NULL)) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return NULL;); + } + return res; +} + +/* + * Remove (unlink) a string from the string table. + * + * Just unlinks the duk_hstring, leaving link pointers as garbage. + * Caller must free the string itself. + */ + +#if defined(DUK_USE_REFERENCE_COUNTING) +/* Unlink without a 'prev' pointer. */ +DUK_INTERNAL void duk_heap_strtable_unlink(duk_heap *heap, duk_hstring *h) { +#if defined(DUK_USE_STRTAB_PTRCOMP) + duk_uint16_t *slot; +#else + duk_hstring **slot; +#endif + duk_hstring *other; + duk_hstring *prev; + + DUK_DDD(DUK_DDDPRINT("remove: heap=%p, h=%p, blen=%lu, strhash=%lx", + (void *) heap, + (void *) h, + (unsigned long) (h != NULL ? DUK_HSTRING_GET_BYTELEN(h) : 0), + (unsigned long) (h != NULL ? DUK_HSTRING_GET_HASH(h) : 0))); + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(h != NULL); + +#if defined(DUK__STRTAB_RESIZE_CHECK) + DUK_ASSERT(heap->st_count > 0); + heap->st_count--; +#endif + +#if defined(DUK_USE_STRTAB_PTRCOMP) + slot = heap->strtable16 + (DUK_HSTRING_GET_HASH(h) & heap->st_mask); +#else + slot = heap->strtable + (DUK_HSTRING_GET_HASH(h) & heap->st_mask); +#endif + other = DUK__HEAPPTR_DEC16(heap, *slot); + DUK_ASSERT(other != NULL); /* At least argument string is in the chain. */ + + prev = NULL; + while (other != h) { + prev = other; + other = other->hdr.h_next; + DUK_ASSERT(other != NULL); /* We'll eventually find 'h'. */ + } + if (prev != NULL) { + /* Middle of list. */ + prev->hdr.h_next = h->hdr.h_next; + } else { + /* Head of list. */ + *slot = DUK__HEAPPTR_ENC16(heap, h->hdr.h_next); + } + + /* There's no resize check on a string free. The next string + * intern will do one. + */ +} +#endif /* DUK_USE_REFERENCE_COUNTING */ + +/* Unlink with a 'prev' pointer. */ +DUK_INTERNAL void duk_heap_strtable_unlink_prev(duk_heap *heap, duk_hstring *h, duk_hstring *prev) { +#if defined(DUK_USE_STRTAB_PTRCOMP) + duk_uint16_t *slot; +#else + duk_hstring **slot; +#endif + + DUK_DDD(DUK_DDDPRINT("remove: heap=%p, prev=%p, h=%p, blen=%lu, strhash=%lx", + (void *) heap, + (void *) prev, + (void *) h, + (unsigned long) (h != NULL ? DUK_HSTRING_GET_BYTELEN(h) : 0), + (unsigned long) (h != NULL ? DUK_HSTRING_GET_HASH(h) : 0))); + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(h != NULL); + DUK_ASSERT(prev == NULL || prev->hdr.h_next == h); + +#if defined(DUK__STRTAB_RESIZE_CHECK) + DUK_ASSERT(heap->st_count > 0); + heap->st_count--; +#endif + + if (prev != NULL) { + /* Middle of list. */ + prev->hdr.h_next = h->hdr.h_next; + } else { + /* Head of list. */ +#if defined(DUK_USE_STRTAB_PTRCOMP) + slot = heap->strtable16 + (DUK_HSTRING_GET_HASH(h) & heap->st_mask); +#else + slot = heap->strtable + (DUK_HSTRING_GET_HASH(h) & heap->st_mask); +#endif + DUK_ASSERT(DUK__HEAPPTR_DEC16(heap, *slot) == h); + *slot = DUK__HEAPPTR_ENC16(heap, h->hdr.h_next); + } +} + +/* + * Force string table resize check in mark-and-sweep. + */ + +DUK_INTERNAL void duk_heap_strtable_force_resize(duk_heap *heap) { + /* Does only one grow/shrink step if needed. The heap->st_resizing + * flag protects against recursive resizing. + */ + + DUK_ASSERT(heap != NULL); + DUK_UNREF(heap); + +#if defined(DUK__STRTAB_RESIZE_CHECK) +#if defined(DUK_USE_STRTAB_PTRCOMP) + if (heap->strtable16 != NULL) { +#else + if (heap->strtable != NULL) { +#endif + duk__strtable_resize_check(heap); + } +#endif +} + +/* + * Free strings in the string table and the string table itself. + */ + +DUK_INTERNAL void duk_heap_strtable_free(duk_heap *heap) { +#if defined(DUK_USE_STRTAB_PTRCOMP) + duk_uint16_t *strtable; + duk_uint16_t *st; +#else + duk_hstring **strtable; + duk_hstring **st; +#endif + duk_hstring *h; + + DUK_ASSERT(heap != NULL); + +#if defined(DUK_USE_ASSERTIONS) + duk__strtable_assert_checks(heap); +#endif + + /* Strtable can be NULL if heap init fails. However, in that case + * heap->st_size is 0, so strtable == strtable_end and we skip the + * loop without a special check. + */ + strtable = DUK__GET_STRTABLE(heap); + st = strtable + heap->st_size; + DUK_ASSERT(strtable != NULL || heap->st_size == 0); + + while (strtable != st) { + --st; + h = DUK__HEAPPTR_DEC16(heap, *st); + while (h) { + duk_hstring *h_next; + h_next = h->hdr.h_next; + + /* Strings may have inner refs (extdata) in some cases. */ + duk_free_hstring(heap, h); + + h = h_next; + } + } + + DUK_FREE(heap, strtable); +} + +/* automatic undefs */ +#undef DUK__GET_STRTABLE +#undef DUK__HEAPPTR_DEC16 +#undef DUK__HEAPPTR_ENC16 +#undef DUK__STRTAB_U32_MAX_STRLEN +#line 1 "duk_heaphdr_assert.c" +/* + * duk_heaphdr assertion helpers + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_ASSERTIONS) + +#if defined(DUK_USE_DOUBLE_LINKED_HEAP) +DUK_INTERNAL void duk_heaphdr_assert_links(duk_heap *heap, duk_heaphdr *h) { + DUK_UNREF(heap); + if (h != NULL) { + duk_heaphdr *h_prev, *h_next; + h_prev = DUK_HEAPHDR_GET_PREV(heap, h); + h_next = DUK_HEAPHDR_GET_NEXT(heap, h); + DUK_ASSERT(h_prev == NULL || (DUK_HEAPHDR_GET_NEXT(heap, h_prev) == h)); + DUK_ASSERT(h_next == NULL || (DUK_HEAPHDR_GET_PREV(heap, h_next) == h)); + } +} +#else +DUK_INTERNAL void duk_heaphdr_assert_links(duk_heap *heap, duk_heaphdr *h) { + DUK_UNREF(heap); + DUK_UNREF(h); +} +#endif + +DUK_INTERNAL void duk_heaphdr_assert_valid(duk_heaphdr *h) { + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HEAPHDR_HTYPE_VALID(h)); +} + +/* Assert validity of a heaphdr, including all subclasses. */ +DUK_INTERNAL void duk_heaphdr_assert_valid_subclassed(duk_heaphdr *h) { + switch (DUK_HEAPHDR_GET_TYPE(h)) { + case DUK_HTYPE_OBJECT: { + duk_hobject *h_obj = (duk_hobject *) h; + DUK_HOBJECT_ASSERT_VALID(h_obj); + if (DUK_HOBJECT_IS_COMPFUNC(h_obj)) { + DUK_HCOMPFUNC_ASSERT_VALID((duk_hcompfunc *) h_obj); + } else if (DUK_HOBJECT_IS_NATFUNC(h_obj)) { + DUK_HNATFUNC_ASSERT_VALID((duk_hnatfunc *) h_obj); + } else if (DUK_HOBJECT_IS_DECENV(h_obj)) { + DUK_HDECENV_ASSERT_VALID((duk_hdecenv *) h_obj); + } else if (DUK_HOBJECT_IS_OBJENV(h_obj)) { + DUK_HOBJENV_ASSERT_VALID((duk_hobjenv *) h_obj); + } else if (DUK_HOBJECT_IS_BUFOBJ(h_obj)) { +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + DUK_HBUFOBJ_ASSERT_VALID((duk_hbufobj *) h_obj); +#endif + } else if (DUK_HOBJECT_IS_BOUNDFUNC(h_obj)) { + DUK_HBOUNDFUNC_ASSERT_VALID((duk_hboundfunc *) h_obj); + } else if (DUK_HOBJECT_IS_PROXY(h_obj)) { + DUK_HPROXY_ASSERT_VALID((duk_hproxy *) h_obj); + } else if (DUK_HOBJECT_IS_THREAD(h_obj)) { + DUK_HTHREAD_ASSERT_VALID((duk_hthread *) h_obj); + } else { + /* Just a plain object. */ + ; + } + break; + } + case DUK_HTYPE_STRING: { + duk_hstring *h_str = (duk_hstring *) h; + DUK_HSTRING_ASSERT_VALID(h_str); + break; + } + case DUK_HTYPE_BUFFER: { + duk_hbuffer *h_buf = (duk_hbuffer *) h; + DUK_HBUFFER_ASSERT_VALID(h_buf); + break; + } + default: { + DUK_ASSERT(0); + } + } +} + +#endif /* DUK_USE_ASSERTIONS */ +#line 1 "duk_hobject_alloc.c" +/* + * Hobject allocation. + * + * Provides primitive allocation functions for all object types (plain object, + * compiled function, native function, thread). The object return is not yet + * in "heap allocated" list and has a refcount of zero, so caller must careful. + */ + +/* XXX: In most cases there's no need for plain allocation without pushing + * to the value stack. Maybe rework contract? + */ + +/* #include duk_internal.h -> already included */ + +/* + * Helpers. + */ + +DUK_LOCAL void duk__init_object_parts(duk_heap *heap, duk_uint_t hobject_flags, duk_hobject *obj) { + DUK_ASSERT(obj != NULL); + /* Zeroed by caller. */ + + obj->hdr.h_flags = hobject_flags | DUK_HTYPE_OBJECT; + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE(&obj->hdr) == DUK_HTYPE_OBJECT); /* Assume zero shift. */ + +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + DUK_HOBJECT_SET_PROTOTYPE(heap, obj, NULL); + DUK_HOBJECT_SET_PROPS(heap, obj, NULL); +#endif +#if defined(DUK_USE_HEAPPTR16) + /* Zero encoded pointer is required to match NULL. */ + DUK_HEAPHDR_SET_NEXT(heap, &obj->hdr, NULL); +#if defined(DUK_USE_DOUBLE_LINKED_HEAP) + DUK_HEAPHDR_SET_PREV(heap, &obj->hdr, NULL); +#endif +#endif + DUK_HEAPHDR_ASSERT_LINKS(heap, &obj->hdr); + DUK_HEAP_INSERT_INTO_HEAP_ALLOCATED(heap, &obj->hdr); + + /* obj->props is intentionally left as NULL, and duk_hobject_props.c must deal + * with this properly. This is intentional: empty objects consume a minimum + * amount of memory. Further, an initial allocation might fail and cause + * 'obj' to "leak" (require a mark-and-sweep) since it is not reachable yet. + */ +} + +DUK_LOCAL void *duk__hobject_alloc_init(duk_hthread *thr, duk_uint_t hobject_flags, duk_size_t size) { + void *res; + + res = (void *) DUK_ALLOC_CHECKED_ZEROED(thr, size); + DUK_ASSERT(res != NULL); + duk__init_object_parts(thr->heap, hobject_flags, (duk_hobject *) res); + return res; +} + +/* + * Allocate an duk_hobject. + * + * The allocated object has no allocation for properties; the caller may + * want to force a resize if a desired size is known. + * + * The allocated object has zero reference count and is not reachable. + * The caller MUST make the object reachable and increase its reference + * count before invoking any operation that might require memory allocation. + */ + +DUK_INTERNAL duk_hobject *duk_hobject_alloc_unchecked(duk_heap *heap, duk_uint_t hobject_flags) { + duk_hobject *res; + + DUK_ASSERT(heap != NULL); + + /* different memory layout, alloc size, and init */ + DUK_ASSERT((hobject_flags & DUK_HOBJECT_FLAG_COMPFUNC) == 0); + DUK_ASSERT((hobject_flags & DUK_HOBJECT_FLAG_NATFUNC) == 0); + DUK_ASSERT((hobject_flags & DUK_HOBJECT_FLAG_BOUNDFUNC) == 0); + + res = (duk_hobject *) DUK_ALLOC_ZEROED(heap, sizeof(duk_hobject)); + if (DUK_UNLIKELY(res == NULL)) { + return NULL; + } + DUK_ASSERT(!DUK_HOBJECT_IS_THREAD(res)); + + duk__init_object_parts(heap, hobject_flags, res); + + DUK_ASSERT(!DUK_HOBJECT_IS_THREAD(res)); + return res; +} + +DUK_INTERNAL duk_hobject *duk_hobject_alloc(duk_hthread *thr, duk_uint_t hobject_flags) { + duk_hobject *res; + + res = (duk_hobject *) duk__hobject_alloc_init(thr, hobject_flags, sizeof(duk_hobject)); + return res; +} + +DUK_INTERNAL duk_hcompfunc *duk_hcompfunc_alloc(duk_hthread *thr, duk_uint_t hobject_flags) { + duk_hcompfunc *res; + + res = (duk_hcompfunc *) duk__hobject_alloc_init(thr, hobject_flags, sizeof(duk_hcompfunc)); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) +#if defined(DUK_USE_HEAPPTR16) + /* NULL pointer is required to encode to zero, so memset is enough. */ +#else + res->data = NULL; + res->funcs = NULL; + res->bytecode = NULL; +#endif + res->lex_env = NULL; + res->var_env = NULL; +#endif + + return res; +} + +DUK_INTERNAL duk_hnatfunc *duk_hnatfunc_alloc(duk_hthread *thr, duk_uint_t hobject_flags) { + duk_hnatfunc *res; + + res = (duk_hnatfunc *) duk__hobject_alloc_init(thr, hobject_flags, sizeof(duk_hnatfunc)); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + res->func = NULL; +#endif + + return res; +} + +DUK_INTERNAL duk_hboundfunc *duk_hboundfunc_alloc(duk_heap *heap, duk_uint_t hobject_flags) { + duk_hboundfunc *res; + + res = (duk_hboundfunc *) DUK_ALLOC(heap, sizeof(duk_hboundfunc)); + if (!res) { + return NULL; + } + duk_memzero(res, sizeof(duk_hboundfunc)); + + duk__init_object_parts(heap, hobject_flags, &res->obj); + + DUK_TVAL_SET_UNDEFINED(&res->target); + DUK_TVAL_SET_UNDEFINED(&res->this_binding); + +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + res->args = NULL; +#endif + + return res; +} + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL duk_hbufobj *duk_hbufobj_alloc(duk_hthread *thr, duk_uint_t hobject_flags) { + duk_hbufobj *res; + + res = (duk_hbufobj *) duk__hobject_alloc_init(thr, hobject_flags, sizeof(duk_hbufobj)); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + res->buf = NULL; + res->buf_prop = NULL; +#endif + + DUK_HBUFOBJ_ASSERT_VALID(res); + return res; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* Allocate a new thread. + * + * Leaves the built-ins array uninitialized. The caller must either + * initialize a new global context or share existing built-ins from + * another thread. + */ +DUK_INTERNAL duk_hthread *duk_hthread_alloc_unchecked(duk_heap *heap, duk_uint_t hobject_flags) { + duk_hthread *res; + + res = (duk_hthread *) DUK_ALLOC(heap, sizeof(duk_hthread)); + if (DUK_UNLIKELY(res == NULL)) { + return NULL; + } + duk_memzero(res, sizeof(duk_hthread)); + + duk__init_object_parts(heap, hobject_flags, &res->obj); + +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + res->ptr_curr_pc = NULL; + res->heap = NULL; + res->valstack = NULL; + res->valstack_end = NULL; + res->valstack_alloc_end = NULL; + res->valstack_bottom = NULL; + res->valstack_top = NULL; + res->callstack_curr = NULL; + res->resumer = NULL; + res->compile_ctx = NULL, +#if defined(DUK_USE_HEAPPTR16) + res->strs16 = NULL; +#else + res->strs = NULL; +#endif + { + duk_small_uint_t i; + for (i = 0; i < DUK_NUM_BUILTINS; i++) { + res->builtins[i] = NULL; + } + } +#endif + /* When nothing is running, API calls are in non-strict mode. */ + DUK_ASSERT(res->strict == 0); + + res->heap = heap; + + /* XXX: Any reason not to merge duk_hthread_alloc.c here? */ + return res; +} + +DUK_INTERNAL duk_hthread *duk_hthread_alloc(duk_hthread *thr, duk_uint_t hobject_flags) { + duk_hthread *res; + + res = duk_hthread_alloc_unchecked(thr->heap, hobject_flags); + if (res == NULL) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return NULL;); + } + return res; +} + +DUK_INTERNAL duk_harray *duk_harray_alloc(duk_hthread *thr, duk_uint_t hobject_flags) { + duk_harray *res; + + res = (duk_harray *) duk__hobject_alloc_init(thr, hobject_flags, sizeof(duk_harray)); + + DUK_ASSERT(res->length == 0); + + return res; +} + +DUK_INTERNAL duk_hdecenv *duk_hdecenv_alloc(duk_hthread *thr, duk_uint_t hobject_flags) { + duk_hdecenv *res; + + res = (duk_hdecenv *) duk__hobject_alloc_init(thr, hobject_flags, sizeof(duk_hdecenv)); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + res->thread = NULL; + res->varmap = NULL; +#endif + + DUK_ASSERT(res->thread == NULL); + DUK_ASSERT(res->varmap == NULL); + DUK_ASSERT(res->regbase_byteoff == 0); + + return res; +} + +DUK_INTERNAL duk_hobjenv *duk_hobjenv_alloc(duk_hthread *thr, duk_uint_t hobject_flags) { + duk_hobjenv *res; + + res = (duk_hobjenv *) duk__hobject_alloc_init(thr, hobject_flags, sizeof(duk_hobjenv)); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + res->target = NULL; +#endif + + DUK_ASSERT(res->target == NULL); + + return res; +} + +DUK_INTERNAL duk_hproxy *duk_hproxy_alloc(duk_hthread *thr, duk_uint_t hobject_flags) { + duk_hproxy *res; + + res = (duk_hproxy *) duk__hobject_alloc_init(thr, hobject_flags, sizeof(duk_hproxy)); + + /* Leave ->target and ->handler uninitialized, as caller will always + * explicitly initialize them before any side effects are possible. + */ + + return res; +} +#line 1 "duk_hobject_assert.c" +/* + * duk_hobject and subclass assertion helpers + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_ASSERTIONS) + +DUK_INTERNAL void duk_hobject_assert_valid(duk_hobject *h) { + DUK_ASSERT(h != NULL); + DUK_ASSERT(!DUK_HOBJECT_IS_CALLABLE(h) || DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_FUNCTION); + DUK_ASSERT(!DUK_HOBJECT_IS_BUFOBJ(h) || (DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_ARRAYBUFFER || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_DATAVIEW || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_INT8ARRAY || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_UINT8ARRAY || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_UINT8CLAMPEDARRAY || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_INT16ARRAY || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_UINT16ARRAY || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_INT32ARRAY || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_UINT32ARRAY || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_FLOAT32ARRAY || + DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_FLOAT64ARRAY)); + /* Object is an Array <=> object has exotic array behavior */ + DUK_ASSERT((DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_ARRAY && DUK_HOBJECT_HAS_EXOTIC_ARRAY(h)) || + (DUK_HOBJECT_GET_CLASS_NUMBER(h) != DUK_HOBJECT_CLASS_ARRAY && !DUK_HOBJECT_HAS_EXOTIC_ARRAY(h))); +} + +DUK_INTERNAL void duk_harray_assert_valid(duk_harray *h) { + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_ARRAY((duk_hobject *) h)); + DUK_ASSERT(DUK_HOBJECT_HAS_EXOTIC_ARRAY((duk_hobject *) h)); +} + +DUK_INTERNAL void duk_hboundfunc_assert_valid(duk_hboundfunc *h) { + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_BOUNDFUNC((duk_hobject *) h)); + DUK_ASSERT(DUK_TVAL_IS_LIGHTFUNC(&h->target) || + (DUK_TVAL_IS_OBJECT(&h->target) && DUK_HOBJECT_IS_CALLABLE(DUK_TVAL_GET_OBJECT(&h->target)))); + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(&h->this_binding)); + DUK_ASSERT(h->nargs == 0 || h->args != NULL); +} + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_INTERNAL void duk_hbufobj_assert_valid(duk_hbufobj *h) { + DUK_ASSERT(h != NULL); + DUK_ASSERT(h->shift <= 3); + DUK_ASSERT(h->elem_type <= DUK_HBUFOBJ_ELEM_MAX); + DUK_ASSERT((h->shift == 0 && h->elem_type == DUK_HBUFOBJ_ELEM_UINT8) || + (h->shift == 0 && h->elem_type == DUK_HBUFOBJ_ELEM_UINT8CLAMPED) || + (h->shift == 0 && h->elem_type == DUK_HBUFOBJ_ELEM_INT8) || + (h->shift == 1 && h->elem_type == DUK_HBUFOBJ_ELEM_UINT16) || + (h->shift == 1 && h->elem_type == DUK_HBUFOBJ_ELEM_INT16) || + (h->shift == 2 && h->elem_type == DUK_HBUFOBJ_ELEM_UINT32) || + (h->shift == 2 && h->elem_type == DUK_HBUFOBJ_ELEM_INT32) || + (h->shift == 2 && h->elem_type == DUK_HBUFOBJ_ELEM_FLOAT32) || + (h->shift == 3 && h->elem_type == DUK_HBUFOBJ_ELEM_FLOAT64)); + DUK_ASSERT(h->is_typedarray == 0 || h->is_typedarray == 1); + DUK_ASSERT(DUK_HOBJECT_IS_BUFOBJ((duk_hobject *) h)); + if (h->buf == NULL) { + DUK_ASSERT(h->offset == 0); + DUK_ASSERT(h->length == 0); + } else { + /* No assertions for offset or length; in particular, + * it's OK for length to be longer than underlying + * buffer. Just ensure they don't wrap when added. + */ + DUK_ASSERT(h->offset + h->length >= h->offset); + } +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +DUK_INTERNAL void duk_hcompfunc_assert_valid(duk_hcompfunc *h) { + DUK_ASSERT(h != NULL); +} + +DUK_INTERNAL void duk_hnatfunc_assert_valid(duk_hnatfunc *h) { + DUK_ASSERT(h != NULL); +} + +DUK_INTERNAL void duk_hdecenv_assert_valid(duk_hdecenv *h) { + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_DECENV((duk_hobject *) h)); + DUK_ASSERT(h->thread == NULL || h->varmap != NULL); +} + +DUK_INTERNAL void duk_hobjenv_assert_valid(duk_hobjenv *h) { + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_OBJENV((duk_hobject *) h)); + DUK_ASSERT(h->target != NULL); + DUK_ASSERT(h->has_this == 0 || h->has_this == 1); +} + +DUK_INTERNAL void duk_hproxy_assert_valid(duk_hproxy *h) { + DUK_ASSERT(h != NULL); + DUK_ASSERT(h->target != NULL); + DUK_ASSERT(h->handler != NULL); + DUK_ASSERT(DUK_HOBJECT_HAS_EXOTIC_PROXYOBJ((duk_hobject *) h)); +} + +DUK_INTERNAL void duk_hthread_assert_valid(duk_hthread *thr) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(DUK_HEAPHDR_GET_TYPE((duk_heaphdr *) thr) == DUK_HTYPE_OBJECT); + DUK_ASSERT(DUK_HOBJECT_IS_THREAD((duk_hobject *) thr)); + DUK_ASSERT(thr->unused1 == 0); + DUK_ASSERT(thr->unused2 == 0); +} + +DUK_INTERNAL void duk_ctx_assert_valid(duk_hthread *thr) { + DUK_ASSERT(thr != NULL); + DUK_HTHREAD_ASSERT_VALID(thr); + DUK_ASSERT(thr->valstack != NULL); + DUK_ASSERT(thr->valstack_bottom != NULL); + DUK_ASSERT(thr->valstack_top != NULL); + DUK_ASSERT(thr->valstack_end != NULL); + DUK_ASSERT(thr->valstack_alloc_end != NULL); + DUK_ASSERT(thr->valstack_alloc_end >= thr->valstack); + DUK_ASSERT(thr->valstack_end >= thr->valstack); + DUK_ASSERT(thr->valstack_top >= thr->valstack); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT(thr->valstack_end >= thr->valstack_top); + DUK_ASSERT(thr->valstack_alloc_end >= thr->valstack_end); +} + +#endif /* DUK_USE_ASSERTIONS */ +#line 1 "duk_hobject_enum.c" +/* + * Object enumeration support. + * + * Creates an internal enumeration state object to be used e.g. with for-in + * enumeration. The state object contains a snapshot of target object keys + * and internal control state for enumeration. Enumerator flags allow caller + * to e.g. request internal/non-enumerable properties, and to enumerate only + * "own" properties. + * + * Also creates the result value for e.g. Object.keys() based on the same + * internal structure. + * + * This snapshot-based enumeration approach is used to simplify enumeration: + * non-snapshot-based approaches are difficult to reconcile with mutating + * the enumeration target, running multiple long-lived enumerators at the + * same time, garbage collection details, etc. The downside is that the + * enumerator object is memory inefficient especially for iterating arrays. + */ + +/* #include duk_internal.h -> already included */ + +/* XXX: identify enumeration target with an object index (not top of stack) */ + +/* First enumerated key index in enumerator object, must match exactly the + * number of control properties inserted to the enumerator. + */ +#define DUK__ENUM_START_INDEX 2 + +/* Current implementation suffices for ES2015 for now because there's no symbol + * sorting, so commented out for now. + */ + +/* + * Helper to sort enumeration keys using a callback for pairwise duk_hstring + * comparisons. The keys are in the enumeration object entry part, starting + * from DUK__ENUM_START_INDEX, and the entry part is dense. Entry part values + * are all "true", e.g. "1" -> true, "3" -> true, "foo" -> true, "2" -> true, + * so it suffices to just switch keys without switching values. + * + * ES2015 [[OwnPropertyKeys]] enumeration order for ordinary objects: + * (1) array indices in ascending order, + * (2) non-array-index keys in insertion order, and + * (3) symbols in insertion order. + * http://www.ecma-international.org/ecma-262/6.0/#sec-ordinary-object-internal-methods-and-internal-slots-ownpropertykeys. + * + * This rule is applied to "own properties" at each inheritance level; + * non-duplicate parent keys always follow child keys. For example, + * an inherited array index will enumerate -after- a symbol in the + * child. + * + * Insertion sort is used because (1) it's simple and compact, (2) works + * in-place, (3) minimizes operations if data is already nearly sorted, + * (4) doesn't reorder elements considered equal. + * http://en.wikipedia.org/wiki/Insertion_sort + */ + +/* Sort key, must hold array indices, "not array index" marker, and one more + * higher value for symbols. + */ +#if !defined(DUK_USE_SYMBOL_BUILTIN) +typedef duk_uint32_t duk__sort_key_t; +#elif defined(DUK_USE_64BIT_OPS) +typedef duk_uint64_t duk__sort_key_t; +#else +typedef duk_double_t duk__sort_key_t; +#endif + +/* Get sort key for a duk_hstring. */ +DUK_LOCAL duk__sort_key_t duk__hstring_sort_key(duk_hstring *x) { + duk__sort_key_t val; + + /* For array indices [0,0xfffffffe] use the array index as is. + * For strings, use 0xffffffff, the marker 'arridx' already in + * duk_hstring. For symbols, any value above 0xffffffff works, + * as long as it is the same for all symbols; currently just add + * the masked flag field into the arridx temporary. + */ + DUK_ASSERT(x != NULL); + DUK_ASSERT(!DUK_HSTRING_HAS_SYMBOL(x) || DUK_HSTRING_GET_ARRIDX_FAST(x) == DUK_HSTRING_NO_ARRAY_INDEX); + + val = (duk__sort_key_t) DUK_HSTRING_GET_ARRIDX_FAST(x); + +#if defined(DUK_USE_SYMBOL_BUILTIN) + val = val + (duk__sort_key_t) (DUK_HEAPHDR_GET_FLAGS_RAW((duk_heaphdr *) x) & DUK_HSTRING_FLAG_SYMBOL); +#endif + + return (duk__sort_key_t) val; +} + +/* Insert element 'b' after element 'a'? */ +DUK_LOCAL duk_bool_t duk__sort_compare_es6(duk_hstring *a, duk_hstring *b, duk__sort_key_t val_b) { + duk__sort_key_t val_a; + + DUK_ASSERT(a != NULL); + DUK_ASSERT(b != NULL); + DUK_UNREF(b); /* Not actually needed now, val_b suffices. */ + + val_a = duk__hstring_sort_key(a); + + if (val_a > val_b) { + return 0; + } else { + return 1; + } +} + +DUK_LOCAL void duk__sort_enum_keys_es6(duk_hthread *thr, duk_hobject *h_obj, duk_int_fast32_t idx_start, duk_int_fast32_t idx_end) { + duk_hstring **keys; + duk_int_fast32_t idx; + + DUK_ASSERT(h_obj != NULL); + DUK_ASSERT(idx_start >= DUK__ENUM_START_INDEX); + DUK_ASSERT(idx_end >= idx_start); + DUK_UNREF(thr); + + if (idx_end <= idx_start + 1) { + return; /* Zero or one element(s). */ + } + + keys = DUK_HOBJECT_E_GET_KEY_BASE(thr->heap, h_obj); + + for (idx = idx_start + 1; idx < idx_end; idx++) { + duk_hstring *h_curr; + duk_int_fast32_t idx_insert; + duk__sort_key_t val_curr; + + h_curr = keys[idx]; + DUK_ASSERT(h_curr != NULL); + + /* Scan backwards for insertion place. This works very well + * when the elements are nearly in order which is the common + * (and optimized for) case. + */ + + val_curr = duk__hstring_sort_key(h_curr); /* Remains same during scanning. */ + for (idx_insert = idx - 1; idx_insert >= idx_start; idx_insert--) { + duk_hstring *h_insert; + h_insert = keys[idx_insert]; + DUK_ASSERT(h_insert != NULL); + + if (duk__sort_compare_es6(h_insert, h_curr, val_curr)) { + break; + } + } + /* If we're out of indices, idx_insert == idx_start - 1 and idx_insert++ + * brings us back to idx_start. + */ + idx_insert++; + DUK_ASSERT(idx_insert >= 0 && idx_insert <= idx); + + /* .-- p_insert .-- p_curr + * v v + * | ... | insert | ... | curr + */ + + /* This could also done when the keys are in order, i.e. + * idx_insert == idx. The result would be an unnecessary + * memmove() but we use an explicit check because the keys + * are very often in order already. + */ + if (idx != idx_insert) { + duk_memmove((void *) (keys + idx_insert + 1), + (const void *) (keys + idx_insert), + ((size_t) (idx - idx_insert) * sizeof(duk_hstring *))); + keys[idx_insert] = h_curr; + } + } + + /* Entry part has been reordered now with no side effects. + * If the object has a hash part, it will now be incorrect + * and we need to rehash. Do that by forcing a resize to + * the current size. + */ + duk_hobject_resize_entrypart(thr, h_obj, DUK_HOBJECT_GET_ESIZE(h_obj)); +} + +/* + * Create an internal enumerator object E, which has its keys ordered + * to match desired enumeration ordering. Also initialize internal control + * properties for enumeration. + * + * Note: if an array was used to hold enumeration keys instead, an array + * scan would be needed to eliminate duplicates found in the prototype chain. + */ + +DUK_LOCAL void duk__add_enum_key(duk_hthread *thr, duk_hstring *k) { + /* 'k' may be unreachable on entry so must push without any + * potential for GC. + */ + duk_push_hstring(thr, k); + duk_push_true(thr); + duk_put_prop(thr, -3); +} + +DUK_LOCAL void duk__add_enum_key_stridx(duk_hthread *thr, duk_small_uint_t stridx) { + duk__add_enum_key(thr, DUK_HTHREAD_GET_STRING(thr, stridx)); +} + +DUK_INTERNAL void duk_hobject_enumerator_create(duk_hthread *thr, duk_small_uint_t enum_flags) { + duk_hobject *enum_target; + duk_hobject *curr; + duk_hobject *res; +#if defined(DUK_USE_ES6_PROXY) + duk_hobject *h_proxy_target; + duk_hobject *h_proxy_handler; + duk_hobject *h_trap_result; +#endif + duk_uint_fast32_t i, len; /* used for array, stack, and entry indices */ + duk_uint_fast32_t sort_start_index; + + DUK_ASSERT(thr != NULL); + + enum_target = duk_require_hobject(thr, -1); + DUK_ASSERT(enum_target != NULL); + + duk_push_bare_object(thr); + res = duk_known_hobject(thr, -1); + + /* [enum_target res] */ + + /* Target must be stored so that we can recheck whether or not + * keys still exist when we enumerate. This is not done if the + * enumeration result comes from a proxy trap as there is no + * real object to check against. + */ + duk_push_hobject(thr, enum_target); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_INT_TARGET); /* Target is bare, plain put OK. */ + + /* Initialize index so that we skip internal control keys. */ + duk_push_int(thr, DUK__ENUM_START_INDEX); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_INT_NEXT); /* Target is bare, plain put OK. */ + + /* + * Proxy object handling + */ + +#if defined(DUK_USE_ES6_PROXY) + if (DUK_LIKELY((enum_flags & DUK_ENUM_NO_PROXY_BEHAVIOR) != 0)) { + goto skip_proxy; + } + if (DUK_LIKELY(!duk_hobject_proxy_check(enum_target, &h_proxy_target, &h_proxy_handler))) { + goto skip_proxy; + } + + /* XXX: share code with Object.keys() Proxy handling */ + + /* In ES2015 for-in invoked the "enumerate" trap; in ES2016 "enumerate" + * has been obsoleted and "ownKeys" is used instead. + */ + DUK_DDD(DUK_DDDPRINT("proxy enumeration")); + duk_push_hobject(thr, h_proxy_handler); + if (!duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_OWN_KEYS)) { + /* No need to replace the 'enum_target' value in stack, only the + * enum_target reference. This also ensures that the original + * enum target is reachable, which keeps the proxy and the proxy + * target reachable. We do need to replace the internal _Target. + */ + DUK_DDD(DUK_DDDPRINT("no ownKeys trap, enumerate proxy target instead")); + DUK_DDD(DUK_DDDPRINT("h_proxy_target=%!O", (duk_heaphdr *) h_proxy_target)); + enum_target = h_proxy_target; + + duk_push_hobject(thr, enum_target); /* -> [ ... enum_target res handler undefined target ] */ + duk_put_prop_stridx_short(thr, -4, DUK_STRIDX_INT_TARGET); /* Target is bare, plain put OK. */ + + duk_pop_2(thr); /* -> [ ... enum_target res ] */ + goto skip_proxy; + } + + /* [ ... enum_target res handler trap ] */ + duk_insert(thr, -2); + duk_push_hobject(thr, h_proxy_target); /* -> [ ... enum_target res trap handler target ] */ + duk_call_method(thr, 1 /*nargs*/); /* -> [ ... enum_target res trap_result ] */ + h_trap_result = duk_require_hobject(thr, -1); + DUK_UNREF(h_trap_result); + + duk_proxy_ownkeys_postprocess(thr, h_proxy_target, enum_flags); + /* -> [ ... enum_target res trap_result keys_array ] */ + + /* Copy cleaned up trap result keys into the enumerator object. */ + /* XXX: result is a dense array; could make use of that. */ + DUK_ASSERT(duk_is_array(thr, -1)); + len = (duk_uint_fast32_t) duk_get_length(thr, -1); + for (i = 0; i < len; i++) { + (void) duk_get_prop_index(thr, -1, (duk_uarridx_t) i); + DUK_ASSERT(duk_is_string(thr, -1)); /* postprocess cleaned up */ + /* [ ... enum_target res trap_result keys_array val ] */ + duk_push_true(thr); + /* [ ... enum_target res trap_result keys_array val true ] */ + duk_put_prop(thr, -5); + } + /* [ ... enum_target res trap_result keys_array ] */ + duk_pop_2(thr); + duk_remove_m2(thr); + + /* [ ... res ] */ + + /* The internal _Target property is kept pointing to the original + * enumeration target (the proxy object), so that the enumerator + * 'next' operation can read property values if so requested. The + * fact that the _Target is a proxy disables key existence check + * during enumeration. + */ + DUK_DDD(DUK_DDDPRINT("proxy enumeration, final res: %!O", (duk_heaphdr *) res)); + goto compact_and_return; + +skip_proxy: +#endif /* DUK_USE_ES6_PROXY */ + + curr = enum_target; + sort_start_index = DUK__ENUM_START_INDEX; + DUK_ASSERT(DUK_HOBJECT_GET_ENEXT(res) == DUK__ENUM_START_INDEX); + while (curr) { + duk_uint_fast32_t sort_end_index; +#if !defined(DUK_USE_PREFER_SIZE) + duk_bool_t need_sort = 0; +#endif + duk_bool_t cond; + + /* Enumeration proceeds by inheritance level. Virtual + * properties need to be handled specially, followed by + * array part, and finally entry part. + * + * If there are array index keys in the entry part or any + * other risk of the ES2015 [[OwnPropertyKeys]] order being + * violated, need_sort is set and an explicit ES2015 sort is + * done for the inheritance level. + */ + + /* XXX: inheriting from proxy */ + + /* + * Virtual properties. + * + * String and buffer indices are virtual and always enumerable, + * 'length' is virtual and non-enumerable. Array and arguments + * object props have special behavior but are concrete. + * + * String and buffer objects don't have an array part so as long + * as virtual array index keys are enumerated first, we don't + * need to set need_sort. + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + cond = DUK_HOBJECT_HAS_EXOTIC_STRINGOBJ(curr) || DUK_HOBJECT_IS_BUFOBJ(curr); +#else + cond = DUK_HOBJECT_HAS_EXOTIC_STRINGOBJ(curr); +#endif + cond = cond && !(enum_flags & DUK_ENUM_EXCLUDE_STRINGS); + if (cond) { + duk_bool_t have_length = 1; + + /* String and buffer enumeration behavior is identical now, + * so use shared handler. + */ + if (DUK_HOBJECT_HAS_EXOTIC_STRINGOBJ(curr)) { + duk_hstring *h_val; + h_val = duk_hobject_get_internal_value_string(thr->heap, curr); + DUK_ASSERT(h_val != NULL); /* string objects must not created without internal value */ + len = (duk_uint_fast32_t) DUK_HSTRING_GET_CHARLEN(h_val); + } +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + else { + duk_hbufobj *h_bufobj; + DUK_ASSERT(DUK_HOBJECT_IS_BUFOBJ(curr)); + h_bufobj = (duk_hbufobj *) curr; + + if (h_bufobj == NULL || !h_bufobj->is_typedarray) { + /* Zero length seems like a good behavior for neutered buffers. + * ArrayBuffer (non-view) and DataView don't have index properties + * or .length property. + */ + len = 0; + have_length = 0; + } else { + /* There's intentionally no check for + * current underlying buffer length. + */ + len = (duk_uint_fast32_t) (h_bufobj->length >> h_bufobj->shift); + } + } +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + + for (i = 0; i < len; i++) { + duk_hstring *k; + + /* This is a bit fragile: the string is not + * reachable until it is pushed by the helper. + */ + k = duk_heap_strtable_intern_u32_checked(thr, (duk_uint32_t) i); + DUK_ASSERT(k); + + duk__add_enum_key(thr, k); + + /* [enum_target res] */ + } + + /* 'length' and other virtual properties are not + * enumerable, but are included if non-enumerable + * properties are requested. + */ + + if (have_length && (enum_flags & DUK_ENUM_INCLUDE_NONENUMERABLE)) { + duk__add_enum_key_stridx(thr, DUK_STRIDX_LENGTH); + } + } + + /* + * Array part + */ + + cond = !(enum_flags & DUK_ENUM_EXCLUDE_STRINGS); + if (cond) { + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ASIZE(curr); i++) { + duk_hstring *k; + duk_tval *tv; + + tv = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, curr, i); + if (DUK_TVAL_IS_UNUSED(tv)) { + continue; + } + k = duk_heap_strtable_intern_u32_checked(thr, (duk_uint32_t) i); /* Fragile reachability. */ + DUK_ASSERT(k); + + duk__add_enum_key(thr, k); + + /* [enum_target res] */ + } + + if (DUK_HOBJECT_HAS_EXOTIC_ARRAY(curr)) { + /* Array .length comes after numeric indices. */ + if (enum_flags & DUK_ENUM_INCLUDE_NONENUMERABLE) { + duk__add_enum_key_stridx(thr, DUK_STRIDX_LENGTH); + } + } + } + + /* + * Entries part + */ + + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ENEXT(curr); i++) { + duk_hstring *k; + + k = DUK_HOBJECT_E_GET_KEY(thr->heap, curr, i); + if (!k) { + continue; + } + if (!(enum_flags & DUK_ENUM_INCLUDE_NONENUMERABLE) && + !DUK_HOBJECT_E_SLOT_IS_ENUMERABLE(thr->heap, curr, i)) { + continue; + } + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(k))) { + if (!(enum_flags & DUK_ENUM_INCLUDE_HIDDEN) && DUK_HSTRING_HAS_HIDDEN(k)) { + continue; + } + if (!(enum_flags & DUK_ENUM_INCLUDE_SYMBOLS)) { + continue; + } +#if !defined(DUK_USE_PREFER_SIZE) + need_sort = 1; +#endif + } else { + DUK_ASSERT(!DUK_HSTRING_HAS_HIDDEN(k)); /* would also have symbol flag */ + if (enum_flags & DUK_ENUM_EXCLUDE_STRINGS) { + continue; + } + } + if (DUK_HSTRING_HAS_ARRIDX(k)) { + /* This in currently only possible if the + * object has no array part: the array part + * is exhaustive when it is present. + */ +#if !defined(DUK_USE_PREFER_SIZE) + need_sort = 1; +#endif + } else { + if (enum_flags & DUK_ENUM_ARRAY_INDICES_ONLY) { + continue; + } + } + + DUK_ASSERT(DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, curr, i) || + !DUK_TVAL_IS_UNUSED(&DUK_HOBJECT_E_GET_VALUE_PTR(thr->heap, curr, i)->v)); + + duk__add_enum_key(thr, k); + + /* [enum_target res] */ + } + + /* Sort enumerated keys according to ES2015 requirements for + * the "inheritance level" just processed. This is far from + * optimal, ES2015 semantics could be achieved more efficiently + * by handling array index string keys (and symbol keys) + * specially above in effect doing the sort inline. + * + * Skip the sort if array index sorting is requested because + * we must consider all keys, also inherited, so an explicit + * sort is done for the whole result after we're done with the + * prototype chain. + * + * Also skip the sort if need_sort == 0, i.e. we know for + * certain that the enumerated order is already correct. + */ + sort_end_index = DUK_HOBJECT_GET_ENEXT(res); + + if (!(enum_flags & DUK_ENUM_SORT_ARRAY_INDICES)) { +#if defined(DUK_USE_PREFER_SIZE) + duk__sort_enum_keys_es6(thr, res, (duk_int_fast32_t) sort_start_index, (duk_int_fast32_t) sort_end_index); +#else + if (need_sort) { + DUK_DDD(DUK_DDDPRINT("need to sort")); + duk__sort_enum_keys_es6(thr, + res, + (duk_int_fast32_t) sort_start_index, + (duk_int_fast32_t) sort_end_index); + } else { + DUK_DDD(DUK_DDDPRINT("no need to sort")); + } +#endif + } + + sort_start_index = sort_end_index; + + if (enum_flags & DUK_ENUM_OWN_PROPERTIES_ONLY) { + break; + } + + curr = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, curr); + } + + /* [enum_target res] */ + + duk_remove_m2(thr); + + /* [res] */ + + if (enum_flags & DUK_ENUM_SORT_ARRAY_INDICES) { + /* Some E5/E5.1 algorithms require that array indices are iterated + * in a strictly ascending order. This is the case for e.g. + * Array.prototype.forEach() and JSON.stringify() PropertyList + * handling. The caller can request an explicit sort in these + * cases. + */ + + /* Sort to ES2015 order which works for pure array incides but + * also for mixed keys. + */ + duk__sort_enum_keys_es6(thr, + res, + (duk_int_fast32_t) DUK__ENUM_START_INDEX, + (duk_int_fast32_t) DUK_HOBJECT_GET_ENEXT(res)); + } + +#if defined(DUK_USE_ES6_PROXY) +compact_and_return: +#endif + /* compact; no need to seal because object is internal */ + duk_hobject_compact_props(thr, res); + + DUK_DDD(DUK_DDDPRINT("created enumerator object: %!iT", (duk_tval *) duk_get_tval(thr, -1))); +} + +/* + * Returns non-zero if a key and/or value was enumerated, and: + * + * [enum] -> [key] (get_value == 0) + * [enum] -> [key value] (get_value == 1) + * + * Returns zero without pushing anything on the stack otherwise. + */ +DUK_INTERNAL duk_bool_t duk_hobject_enumerator_next(duk_hthread *thr, duk_bool_t get_value) { + duk_hobject *e; + duk_hobject *enum_target; + duk_hstring *res = NULL; + duk_uint_fast32_t idx; + duk_bool_t check_existence; + + DUK_ASSERT(thr != NULL); + + /* [... enum] */ + + e = duk_require_hobject(thr, -1); + + /* XXX use get tval ptr, more efficient */ + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_INT_NEXT); + idx = (duk_uint_fast32_t) duk_require_uint(thr, -1); + duk_pop(thr); + DUK_DDD(DUK_DDDPRINT("enumeration: index is: %ld", (long) idx)); + + /* Enumeration keys are checked against the enumeration target (to see + * that they still exist). In the proxy enumeration case _Target will + * be the proxy, and checking key existence against the proxy is not + * required (or sensible, as the keys may be fully virtual). + */ + duk_xget_owndataprop_stridx_short(thr, -1, DUK_STRIDX_INT_TARGET); + enum_target = duk_require_hobject(thr, -1); + DUK_ASSERT(enum_target != NULL); +#if defined(DUK_USE_ES6_PROXY) + check_existence = (!DUK_HOBJECT_IS_PROXY(enum_target)); +#else + check_existence = 1; +#endif + duk_pop(thr); /* still reachable */ + + DUK_DDD(DUK_DDDPRINT("getting next enum value, enum_target=%!iO, enumerator=%!iT", + (duk_heaphdr *) enum_target, + (duk_tval *) duk_get_tval(thr, -1))); + + /* no array part */ + for (;;) { + duk_hstring *k; + + if (idx >= DUK_HOBJECT_GET_ENEXT(e)) { + DUK_DDD(DUK_DDDPRINT("enumeration: ran out of elements")); + break; + } + + /* we know these because enum objects are internally created */ + k = DUK_HOBJECT_E_GET_KEY(thr->heap, e, idx); + DUK_ASSERT(k != NULL); + DUK_ASSERT(!DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, e, idx)); + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(&DUK_HOBJECT_E_GET_VALUE(thr->heap, e, idx).v)); + + idx++; + + /* recheck that the property still exists */ + if (check_existence && !duk_hobject_hasprop_raw(thr, enum_target, k)) { + DUK_DDD(DUK_DDDPRINT("property deleted during enumeration, skip")); + continue; + } + + DUK_DDD(DUK_DDDPRINT("enumeration: found element, key: %!O", (duk_heaphdr *) k)); + res = k; + break; + } + + DUK_DDD(DUK_DDDPRINT("enumeration: updating next index to %ld", (long) idx)); + + duk_push_u32(thr, (duk_uint32_t) idx); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_INT_NEXT); + + /* [... enum] */ + + if (res) { + duk_push_hstring(thr, res); + if (get_value) { + duk_push_hobject(thr, enum_target); + duk_dup_m2(thr); /* -> [... enum key enum_target key] */ + duk_get_prop(thr, -2); /* -> [... enum key enum_target val] */ + duk_remove_m2(thr); /* -> [... enum key val] */ + duk_remove(thr, -3); /* -> [... key val] */ + } else { + duk_remove_m2(thr); /* -> [... key] */ + } + return 1; + } else { + duk_pop(thr); /* -> [...] */ + return 0; + } +} + +/* + * Get enumerated keys in an ECMAScript array. Matches Object.keys() behavior + * described in E5 Section 15.2.3.14. + */ + +DUK_INTERNAL duk_ret_t duk_hobject_get_enumerated_keys(duk_hthread *thr, duk_small_uint_t enum_flags) { + duk_hobject *e; + duk_hstring **keys; + duk_tval *tv; + duk_uint_fast32_t count; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(duk_get_hobject(thr, -1) != NULL); + + /* Create a temporary enumerator to get the (non-duplicated) key list; + * the enumerator state is initialized without being needed, but that + * has little impact. + */ + + duk_hobject_enumerator_create(thr, enum_flags); + e = duk_known_hobject(thr, -1); + + /* [enum_target enum res] */ + + /* Create dense result array to exact size. */ + DUK_ASSERT(DUK_HOBJECT_GET_ENEXT(e) >= DUK__ENUM_START_INDEX); + count = (duk_uint32_t) (DUK_HOBJECT_GET_ENEXT(e) - DUK__ENUM_START_INDEX); + + /* XXX: uninit would be OK */ + tv = duk_push_harray_with_size_outptr(thr, (duk_uint32_t) count); + DUK_ASSERT(count == 0 || tv != NULL); + DUK_ASSERT(!duk_is_bare_object(thr, -1)); + + /* Fill result array, no side effects. */ + + keys = DUK_HOBJECT_E_GET_KEY_BASE(thr->heap, e); + keys += DUK__ENUM_START_INDEX; + + while (count-- > 0) { + duk_hstring *k; + + k = *keys++; + DUK_ASSERT(k != NULL); /* enumerator must have no keys deleted */ + + DUK_TVAL_SET_STRING(tv, k); + tv++; + DUK_HSTRING_INCREF(thr, k); + } + + /* [enum_target enum res] */ + duk_remove_m2(thr); + + /* [enum_target res] */ + + return 1; /* return 1 to allow callers to tail call */ +} + +/* automatic undefs */ +#undef DUK__ENUM_START_INDEX +#line 1 "duk_hobject_misc.c" +/* + * Misc support functions + */ + +/* #include duk_internal.h -> already included */ + +DUK_INTERNAL duk_bool_t duk_hobject_prototype_chain_contains(duk_hthread *thr, + duk_hobject *h, + duk_hobject *p, + duk_bool_t ignore_loop) { + duk_uint_t sanity; + + DUK_ASSERT(thr != NULL); + + /* False if the object is NULL or the prototype 'p' is NULL. + * In particular, false if both are NULL (don't compare equal). + */ + if (h == NULL || p == NULL) { + return 0; + } + + sanity = DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY; + do { + if (h == p) { + return 1; + } + + if (sanity-- == 0) { + if (ignore_loop) { + break; + } else { + DUK_ERROR_RANGE(thr, DUK_STR_PROTOTYPE_CHAIN_LIMIT); + DUK_WO_NORETURN(return 0;); + } + } + h = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h); + } while (h); + + return 0; +} + +DUK_INTERNAL void duk_hobject_set_prototype_updref(duk_hthread *thr, duk_hobject *h, duk_hobject *p) { +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_hobject *tmp; + + DUK_ASSERT(h); + tmp = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h); + DUK_HOBJECT_SET_PROTOTYPE(thr->heap, h, p); + DUK_HOBJECT_INCREF_ALLOWNULL(thr, p); /* avoid problems if p == h->prototype */ + DUK_HOBJECT_DECREF_ALLOWNULL(thr, tmp); +#else + DUK_ASSERT(h); + DUK_UNREF(thr); + DUK_HOBJECT_SET_PROTOTYPE(thr->heap, h, p); +#endif +} +#line 1 "duk_hobject_pc2line.c" +/* + * Helpers for creating and querying pc2line debug data, which + * converts a bytecode program counter to a source line number. + * + * The run-time pc2line data is bit-packed, and documented in: + * + * doc/function-objects.rst + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_PC2LINE) + +/* Generate pc2line data for an instruction sequence, leaving a buffer on stack top. */ +DUK_INTERNAL void duk_hobject_pc2line_pack(duk_hthread *thr, duk_compiler_instr *instrs, duk_uint_fast32_t length) { + duk_hbuffer_dynamic *h_buf; + duk_bitencoder_ctx be_ctx_alloc; + duk_bitencoder_ctx *be_ctx = &be_ctx_alloc; + duk_uint32_t *hdr; + duk_size_t new_size; + duk_uint_fast32_t num_header_entries; + duk_uint_fast32_t curr_offset; + duk_int_fast32_t curr_line, next_line, diff_line; + duk_uint_fast32_t curr_pc; + duk_uint_fast32_t hdr_index; + + DUK_ASSERT(length <= DUK_COMPILER_MAX_BYTECODE_LENGTH); + + num_header_entries = (length + DUK_PC2LINE_SKIP - 1) / DUK_PC2LINE_SKIP; + curr_offset = (duk_uint_fast32_t) (sizeof(duk_uint32_t) + num_header_entries * sizeof(duk_uint32_t) * 2); + + duk_push_dynamic_buffer(thr, (duk_size_t) curr_offset); + h_buf = (duk_hbuffer_dynamic *) duk_known_hbuffer(thr, -1); + DUK_ASSERT(DUK_HBUFFER_HAS_DYNAMIC(h_buf) && !DUK_HBUFFER_HAS_EXTERNAL(h_buf)); + + hdr = (duk_uint32_t *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(thr->heap, h_buf); + DUK_ASSERT(hdr != NULL); + hdr[0] = (duk_uint32_t) length; /* valid pc range is [0, length[ */ + + curr_pc = 0U; + while (curr_pc < length) { + new_size = (duk_size_t) (curr_offset + DUK_PC2LINE_MAX_DIFF_LENGTH); + duk_hbuffer_resize(thr, h_buf, new_size); + + hdr = (duk_uint32_t *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(thr->heap, h_buf); + DUK_ASSERT(hdr != NULL); + DUK_ASSERT(curr_pc < length); + hdr_index = 1 + (curr_pc / DUK_PC2LINE_SKIP) * 2; + curr_line = (duk_int_fast32_t) instrs[curr_pc].line; + hdr[hdr_index + 0] = (duk_uint32_t) curr_line; + hdr[hdr_index + 1] = (duk_uint32_t) curr_offset; + +#if 0 + DUK_DDD(DUK_DDDPRINT("hdr[%ld]: pc=%ld line=%ld offset=%ld", + (long) (curr_pc / DUK_PC2LINE_SKIP), + (long) curr_pc, + (long) hdr[hdr_index + 0], + (long) hdr[hdr_index + 1])); +#endif + + duk_memzero(be_ctx, sizeof(*be_ctx)); + be_ctx->data = ((duk_uint8_t *) hdr) + curr_offset; + be_ctx->length = (duk_size_t) DUK_PC2LINE_MAX_DIFF_LENGTH; + + for (;;) { + curr_pc++; + if (((curr_pc % DUK_PC2LINE_SKIP) == 0) || /* end of diff run */ + (curr_pc >= length)) { /* end of bytecode */ + break; + } + DUK_ASSERT(curr_pc < length); + next_line = (duk_int32_t) instrs[curr_pc].line; + diff_line = next_line - curr_line; + +#if 0 + DUK_DDD(DUK_DDDPRINT("curr_line=%ld, next_line=%ld -> diff_line=%ld", + (long) curr_line, (long) next_line, (long) diff_line)); +#endif + + if (diff_line == 0) { + /* 0 */ + duk_be_encode(be_ctx, 0, 1); + } else if (diff_line >= 1 && diff_line <= 4) { + /* 1 0 <2 bits> */ + duk_be_encode(be_ctx, (duk_uint32_t) ((0x02 << 2) + (diff_line - 1)), 4); + } else if (diff_line >= -0x80 && diff_line <= 0x7f) { + /* 1 1 0 <8 bits> */ + DUK_ASSERT(diff_line + 0x80 >= 0 && diff_line + 0x80 <= 0xff); + duk_be_encode(be_ctx, (duk_uint32_t) ((0x06 << 8) + (diff_line + 0x80)), 11); + } else { + /* 1 1 1 <32 bits> + * Encode in two parts to avoid bitencode 24-bit limitation + */ + duk_be_encode(be_ctx, (duk_uint32_t) ((0x07 << 16) + ((next_line >> 16) & 0xffff)), 19); + duk_be_encode(be_ctx, (duk_uint32_t) (next_line & 0xffff), 16); + } + + curr_line = next_line; + } + + duk_be_finish(be_ctx); + DUK_ASSERT(!be_ctx->truncated); + + /* be_ctx->offset == length of encoded bitstream */ + curr_offset += (duk_uint_fast32_t) be_ctx->offset; + } + + /* compact */ + new_size = (duk_size_t) curr_offset; + duk_hbuffer_resize(thr, h_buf, new_size); + + (void) duk_to_fixed_buffer(thr, -1, NULL); + + DUK_DDD(DUK_DDDPRINT("final pc2line data: pc_limit=%ld, length=%ld, %lf bits/opcode --> %!ixT", + (long) length, + (long) new_size, + (double) new_size * 8.0 / (double) length, + (duk_tval *) duk_get_tval(thr, -1))); +} + +/* PC is unsigned. If caller does PC arithmetic and gets a negative result, + * it will map to a large PC which is out of bounds and causes a zero to be + * returned. + */ +DUK_LOCAL duk_uint_fast32_t duk__hobject_pc2line_query_raw(duk_hthread *thr, duk_hbuffer_fixed *buf, duk_uint_fast32_t pc) { + duk_bitdecoder_ctx bd_ctx_alloc; + duk_bitdecoder_ctx *bd_ctx = &bd_ctx_alloc; + duk_uint32_t *hdr; + duk_uint_fast32_t start_offset; + duk_uint_fast32_t pc_limit; + duk_uint_fast32_t hdr_index; + duk_uint_fast32_t pc_base; + duk_uint_fast32_t n; + duk_uint_fast32_t curr_line; + + DUK_ASSERT(buf != NULL); + DUK_ASSERT(!DUK_HBUFFER_HAS_DYNAMIC((duk_hbuffer *) buf) && !DUK_HBUFFER_HAS_EXTERNAL((duk_hbuffer *) buf)); + DUK_UNREF(thr); + + /* + * Use the index in the header to find the right starting point + */ + + hdr_index = pc / DUK_PC2LINE_SKIP; + pc_base = hdr_index * DUK_PC2LINE_SKIP; + n = pc - pc_base; + + if (DUK_HBUFFER_FIXED_GET_SIZE(buf) <= sizeof(duk_uint32_t)) { + DUK_DD(DUK_DDPRINT("pc2line lookup failed: buffer is smaller than minimal header")); + goto pc2line_error; + } + + hdr = (duk_uint32_t *) (void *) DUK_HBUFFER_FIXED_GET_DATA_PTR(thr->heap, buf); + pc_limit = hdr[0]; + if (pc >= pc_limit) { + /* Note: pc is unsigned and cannot be negative */ + DUK_DD(DUK_DDPRINT("pc2line lookup failed: pc out of bounds (pc=%ld, limit=%ld)", (long) pc, (long) pc_limit)); + goto pc2line_error; + } + + curr_line = hdr[1 + hdr_index * 2]; + start_offset = hdr[1 + hdr_index * 2 + 1]; + if ((duk_size_t) start_offset > DUK_HBUFFER_FIXED_GET_SIZE(buf)) { + DUK_DD(DUK_DDPRINT("pc2line lookup failed: start_offset out of bounds (start_offset=%ld, buffer_size=%ld)", + (long) start_offset, + (long) DUK_HBUFFER_GET_SIZE((duk_hbuffer *) buf))); + goto pc2line_error; + } + + /* + * Iterate the bitstream (line diffs) until PC is reached + */ + + duk_memzero(bd_ctx, sizeof(*bd_ctx)); + bd_ctx->data = ((duk_uint8_t *) hdr) + start_offset; + bd_ctx->length = (duk_size_t) (DUK_HBUFFER_FIXED_GET_SIZE(buf) - start_offset); + +#if 0 + DUK_DDD(DUK_DDDPRINT("pc2line lookup: pc=%ld -> hdr_index=%ld, pc_base=%ld, n=%ld, start_offset=%ld", + (long) pc, (long) hdr_index, (long) pc_base, (long) n, (long) start_offset)); +#endif + + while (n > 0) { +#if 0 + DUK_DDD(DUK_DDDPRINT("lookup: n=%ld, curr_line=%ld", (long) n, (long) curr_line)); +#endif + + if (duk_bd_decode_flag(bd_ctx)) { + if (duk_bd_decode_flag(bd_ctx)) { + if (duk_bd_decode_flag(bd_ctx)) { + /* 1 1 1 <32 bits> */ + duk_uint_fast32_t t; + t = duk_bd_decode(bd_ctx, 16); /* workaround: max nbits = 24 now */ + t = (t << 16) + duk_bd_decode(bd_ctx, 16); + curr_line = t; + } else { + /* 1 1 0 <8 bits> */ + duk_uint_fast32_t t; + t = duk_bd_decode(bd_ctx, 8); + curr_line = curr_line + t - 0x80; + } + } else { + /* 1 0 <2 bits> */ + duk_uint_fast32_t t; + t = duk_bd_decode(bd_ctx, 2); + curr_line = curr_line + t + 1; + } + } else { + /* 0: no change */ + } + + n--; + } + + DUK_DDD(DUK_DDDPRINT("pc2line lookup result: pc %ld -> line %ld", (long) pc, (long) curr_line)); + return curr_line; + +pc2line_error: + DUK_D(DUK_DPRINT("pc2line conversion failed for pc=%ld", (long) pc)); + return 0; +} + +DUK_INTERNAL duk_uint_fast32_t duk_hobject_pc2line_query(duk_hthread *thr, duk_idx_t idx_func, duk_uint_fast32_t pc) { + duk_hbuffer_fixed *pc2line; + duk_uint_fast32_t line; + + /* XXX: now that pc2line is used by the debugger quite heavily in + * checked execution, this should be optimized to avoid value stack + * and perhaps also implement some form of pc2line caching (see + * future work in debugger.rst). + */ + + duk_xget_owndataprop_stridx_short(thr, idx_func, DUK_STRIDX_INT_PC2LINE); + pc2line = (duk_hbuffer_fixed *) (void *) duk_get_hbuffer(thr, -1); + if (pc2line != NULL) { + DUK_ASSERT(!DUK_HBUFFER_HAS_DYNAMIC((duk_hbuffer *) pc2line) && !DUK_HBUFFER_HAS_EXTERNAL((duk_hbuffer *) pc2line)); + line = duk__hobject_pc2line_query_raw(thr, pc2line, (duk_uint_fast32_t) pc); + } else { + line = 0; + } + duk_pop(thr); + + return line; +} + +#endif /* DUK_USE_PC2LINE */ +#line 1 "duk_hobject_props.c" +/* + * duk_hobject property access functionality. + * + * This is very central functionality for size, performance, and compliance. + * It is also rather intricate; see hobject-algorithms.rst for discussion on + * the algorithms and memory-management.rst for discussion on refcounts and + * side effect issues. + * + * Notes: + * + * - It might be tempting to assert "refcount nonzero" for objects + * being operated on, but that's not always correct: objects with + * a zero refcount may be operated on by the refcount implementation + * (finalization) for instance. Hence, no refcount assertions are made. + * + * - Many operations (memory allocation, identifier operations, etc) + * may cause arbitrary side effects (e.g. through GC and finalization). + * These side effects may invalidate duk_tval pointers which point to + * areas subject to reallocation (like value stack). Heap objects + * themselves have stable pointers. Holding heap object pointers or + * duk_tval copies is not problematic with respect to side effects; + * care must be taken when holding and using argument duk_tval pointers. + * + * - If a finalizer is executed, it may operate on the the same object + * we're currently dealing with. For instance, the finalizer might + * delete a certain property which has already been looked up and + * confirmed to exist. Ideally finalizers would be disabled if GC + * happens during property access. At the moment property table realloc + * disables finalizers, and all DECREFs may cause arbitrary changes so + * handle DECREF carefully. + * + * - The order of operations for a DECREF matters. When DECREF is executed, + * the entire object graph must be consistent; note that a refzero may + * lead to a mark-and-sweep through a refcount finalizer. Use NORZ macros + * and an explicit DUK_REFZERO_CHECK_xxx() if achieving correct order is hard. + */ + +/* + * XXX: array indices are mostly typed as duk_uint32_t here; duk_uarridx_t + * might be more appropriate. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Local defines + */ + +#define DUK__NO_ARRAY_INDEX DUK_HSTRING_NO_ARRAY_INDEX + +/* Marker values for hash part. */ +#define DUK__HASH_UNUSED DUK_HOBJECT_HASHIDX_UNUSED +#define DUK__HASH_DELETED DUK_HOBJECT_HASHIDX_DELETED + +/* Valstack space that suffices for all local calls, excluding any recursion + * into ECMAScript or Duktape/C calls (Proxy, getters, etc). + */ +#define DUK__VALSTACK_SPACE 10 + +/* Valstack space allocated especially for proxy lookup which does a + * recursive property lookup. + */ +#define DUK__VALSTACK_PROXY_LOOKUP 20 + +/* + * Local prototypes + */ + +DUK_LOCAL_DECL duk_bool_t duk__check_arguments_map_for_get(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_propdesc *temp_desc); +DUK_LOCAL_DECL void duk__check_arguments_map_for_put(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_propdesc *temp_desc, + duk_bool_t throw_flag); +DUK_LOCAL_DECL void duk__check_arguments_map_for_delete(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_propdesc *temp_desc); + +DUK_LOCAL_DECL duk_bool_t duk__handle_put_array_length_smaller(duk_hthread *thr, + duk_hobject *obj, + duk_uint32_t old_len, + duk_uint32_t new_len, + duk_bool_t force_flag, + duk_uint32_t *out_result_len); +DUK_LOCAL_DECL duk_bool_t duk__handle_put_array_length(duk_hthread *thr, duk_hobject *obj); + +DUK_LOCAL_DECL duk_bool_t +duk__get_propdesc(duk_hthread *thr, duk_hobject *obj, duk_hstring *key, duk_propdesc *out_desc, duk_small_uint_t flags); +DUK_LOCAL_DECL duk_bool_t duk__get_own_propdesc_raw(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_uint32_t arr_idx, + duk_propdesc *out_desc, + duk_small_uint_t flags); + +DUK_LOCAL_DECL void duk__abandon_array_part(duk_hthread *thr, duk_hobject *obj); +DUK_LOCAL_DECL void duk__grow_props_for_array_item(duk_hthread *thr, duk_hobject *obj, duk_uint32_t highest_arr_idx); + +/* + * Misc helpers + */ + +/* Convert a duk_tval number (caller checks) to a 32-bit index. Returns + * DUK__NO_ARRAY_INDEX if the number is not whole or not a valid array + * index. + */ +/* XXX: for fastints, could use a variant which assumes a double duk_tval + * (and doesn't need to check for fastint again). + */ +DUK_LOCAL duk_uint32_t duk__tval_number_to_arr_idx(duk_tval *tv) { + duk_double_t dbl; + duk_uint32_t idx; + + DUK_ASSERT(tv != NULL); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + + /* -0 is accepted here as index 0 because ToString(-0) == "0" which is + * in canonical form and thus an array index. + */ + dbl = DUK_TVAL_GET_NUMBER(tv); + idx = (duk_uint32_t) dbl; + if (duk_double_equals((duk_double_t) idx, dbl)) { + /* Is whole and within 32 bit range. If the value happens to be 0xFFFFFFFF, + * it's not a valid array index but will then match DUK__NO_ARRAY_INDEX. + */ + return idx; + } + return DUK__NO_ARRAY_INDEX; +} + +#if defined(DUK_USE_FASTINT) +/* Convert a duk_tval fastint (caller checks) to a 32-bit index. */ +DUK_LOCAL duk_uint32_t duk__tval_fastint_to_arr_idx(duk_tval *tv) { + duk_int64_t t; + + DUK_ASSERT(tv != NULL); + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv)); + + t = DUK_TVAL_GET_FASTINT(tv); + if (((duk_uint64_t) t & ~DUK_U64_CONSTANT(0xffffffff)) != 0) { + /* Catches >0x100000000 and negative values. */ + return DUK__NO_ARRAY_INDEX; + } + + /* If the value happens to be 0xFFFFFFFF, it's not a valid array index + * but will then match DUK__NO_ARRAY_INDEX. + */ + return (duk_uint32_t) t; +} +#endif /* DUK_USE_FASTINT */ + +/* Convert a duk_tval on the value stack (in a trusted index we don't validate) + * to a string or symbol using ES2015 ToPropertyKey(): + * http://www.ecma-international.org/ecma-262/6.0/#sec-topropertykey. + * + * Also check if it's a valid array index and return that (or DUK__NO_ARRAY_INDEX + * if not). + */ +DUK_LOCAL duk_uint32_t duk__to_property_key(duk_hthread *thr, duk_idx_t idx, duk_hstring **out_h) { + duk_uint32_t arr_idx; + duk_hstring *h; + duk_tval *tv_dst; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(out_h != NULL); + DUK_ASSERT(duk_is_valid_index(thr, idx)); + DUK_ASSERT(idx < 0); + + /* XXX: The revised ES2015 ToPropertyKey() handling (ES5.1 was just + * ToString()) involves a ToPrimitive(), a symbol check, and finally + * a ToString(). Figure out the best way to have a good fast path + * but still be compliant and share code. + */ + + tv_dst = DUK_GET_TVAL_NEGIDX(thr, idx); /* intentionally unvalidated */ + if (DUK_TVAL_IS_STRING(tv_dst)) { + /* Most important path: strings and plain symbols are used as + * is. For symbols the array index check below is unnecessary + * (they're never valid array indices) but checking that the + * string is a symbol would make the plain string path slower + * unnecessarily. + */ + h = DUK_TVAL_GET_STRING(tv_dst); + } else { + h = duk_to_property_key_hstring(thr, idx); + } + DUK_ASSERT(h != NULL); + *out_h = h; + + arr_idx = DUK_HSTRING_GET_ARRIDX_FAST(h); + return arr_idx; +} + +DUK_LOCAL duk_uint32_t duk__push_tval_to_property_key(duk_hthread *thr, duk_tval *tv_key, duk_hstring **out_h) { + duk_push_tval(thr, tv_key); /* XXX: could use an unsafe push here */ + return duk__to_property_key(thr, -1, out_h); +} + +/* String is an own (virtual) property of a plain buffer. */ +DUK_LOCAL duk_bool_t duk__key_is_plain_buf_ownprop(duk_hthread *thr, duk_hbuffer *buf, duk_hstring *key, duk_uint32_t arr_idx) { + DUK_UNREF(thr); + + /* Virtual index properties. Checking explicitly for + * 'arr_idx != DUK__NO_ARRAY_INDEX' is not necessary + * because DUK__NO_ARRAY_INDEXi is always larger than + * maximum allowed buffer size. + */ + DUK_ASSERT(DUK__NO_ARRAY_INDEX >= DUK_HBUFFER_GET_SIZE(buf)); + if (arr_idx < DUK_HBUFFER_GET_SIZE(buf)) { + return 1; + } + + /* Other virtual properties. */ + return (key == DUK_HTHREAD_STRING_LENGTH(thr)); +} + +/* + * Helpers for managing property storage size + */ + +/* Get default hash part size for a certain entry part size. */ +#if defined(DUK_USE_HOBJECT_HASH_PART) +DUK_LOCAL duk_uint32_t duk__get_default_h_size(duk_uint32_t e_size) { + DUK_ASSERT(e_size <= DUK_HOBJECT_MAX_PROPERTIES); + + if (e_size >= DUK_USE_HOBJECT_HASH_PROP_LIMIT) { + duk_uint32_t res; + duk_uint32_t tmp; + + /* Hash size should be 2^N where N is chosen so that 2^N is + * larger than e_size. Extra shifting is used to ensure hash + * is relatively sparse. + */ + tmp = e_size; + res = 2; /* Result will be 2 ** (N + 1). */ + while (tmp >= 0x40) { + tmp >>= 6; + res <<= 6; + } + while (tmp != 0) { + tmp >>= 1; + res <<= 1; + } + DUK_ASSERT((DUK_HOBJECT_MAX_PROPERTIES << 2U) > DUK_HOBJECT_MAX_PROPERTIES); /* Won't wrap, even shifted by 2. */ + DUK_ASSERT(res > e_size); + return res; + } else { + return 0; + } +} +#endif /* USE_PROP_HASH_PART */ + +/* Get minimum entry part growth for a certain size. */ +DUK_LOCAL duk_uint32_t duk__get_min_grow_e(duk_uint32_t e_size) { + duk_uint32_t res; + + res = (e_size + DUK_USE_HOBJECT_ENTRY_MINGROW_ADD) / DUK_USE_HOBJECT_ENTRY_MINGROW_DIVISOR; + DUK_ASSERT(res >= 1); /* important for callers */ + return res; +} + +/* Get minimum array part growth for a certain size. */ +DUK_LOCAL duk_uint32_t duk__get_min_grow_a(duk_uint32_t a_size) { + duk_uint32_t res; + + res = (a_size + DUK_USE_HOBJECT_ARRAY_MINGROW_ADD) / DUK_USE_HOBJECT_ARRAY_MINGROW_DIVISOR; + DUK_ASSERT(res >= 1); /* important for callers */ + return res; +} + +/* Count actually used entry part entries (non-NULL keys). */ +DUK_LOCAL duk_uint32_t duk__count_used_e_keys(duk_hthread *thr, duk_hobject *obj) { + duk_uint_fast32_t i; + duk_uint_fast32_t n = 0; + duk_hstring **e; + + DUK_ASSERT(obj != NULL); + DUK_UNREF(thr); + + e = DUK_HOBJECT_E_GET_KEY_BASE(thr->heap, obj); + for (i = 0; i < DUK_HOBJECT_GET_ENEXT(obj); i++) { + if (*e++) { + n++; + } + } + return (duk_uint32_t) n; +} + +/* Count actually used array part entries and array minimum size. + * NOTE: 'out_min_size' can be computed much faster by starting from the + * end and breaking out early when finding first used entry, but this is + * not needed now. + */ +DUK_LOCAL void duk__compute_a_stats(duk_hthread *thr, duk_hobject *obj, duk_uint32_t *out_used, duk_uint32_t *out_min_size) { + duk_uint_fast32_t i; + duk_uint_fast32_t used = 0; + duk_uint_fast32_t highest_idx = (duk_uint_fast32_t) -1; /* see below */ + duk_tval *a; + + DUK_ASSERT(obj != NULL); + DUK_ASSERT(out_used != NULL); + DUK_ASSERT(out_min_size != NULL); + DUK_UNREF(thr); + + a = DUK_HOBJECT_A_GET_BASE(thr->heap, obj); + for (i = 0; i < DUK_HOBJECT_GET_ASIZE(obj); i++) { + duk_tval *tv = a++; + if (!DUK_TVAL_IS_UNUSED(tv)) { + used++; + highest_idx = i; + } + } + + /* Initial value for highest_idx is -1 coerced to unsigned. This + * is a bit odd, but (highest_idx + 1) will then wrap to 0 below + * for out_min_size as intended. + */ + + *out_used = (duk_uint32_t) used; + *out_min_size = (duk_uint32_t) (highest_idx + 1); /* 0 if no used entries */ +} + +/* Check array density and indicate whether or not the array part should be abandoned. */ +DUK_LOCAL duk_bool_t duk__abandon_array_density_check(duk_uint32_t a_used, duk_uint32_t a_size) { + /* + * Array abandon check; abandon if: + * + * new_used / new_size < limit + * new_used < limit * new_size || limit is 3 bits fixed point + * new_used < limit' / 8 * new_size || *8 + * 8*new_used < limit' * new_size || :8 + * new_used < limit' * (new_size / 8) + * + * Here, new_used = a_used, new_size = a_size. + * + * Note: some callers use approximate values for a_used and/or a_size + * (e.g. dropping a '+1' term). This doesn't affect the usefulness + * of the check, but may confuse debugging. + */ + + return (a_used < DUK_USE_HOBJECT_ARRAY_ABANDON_LIMIT * (a_size >> 3)); +} + +/* Fast check for extending array: check whether or not a slow density check is required. */ +DUK_LOCAL duk_bool_t duk__abandon_array_slow_check_required(duk_uint32_t arr_idx, duk_uint32_t old_size) { + duk_uint32_t new_size_min; + + /* + * In a fast check we assume old_size equals old_used (i.e., existing + * array is fully dense). + * + * Slow check if: + * + * (new_size - old_size) / old_size > limit + * new_size - old_size > limit * old_size + * new_size > (1 + limit) * old_size || limit' is 3 bits fixed point + * new_size > (1 + (limit' / 8)) * old_size || * 8 + * 8 * new_size > (8 + limit') * old_size || : 8 + * new_size > (8 + limit') * (old_size / 8) + * new_size > limit'' * (old_size / 8) || limit'' = 9 -> max 25% increase + * arr_idx + 1 > limit'' * (old_size / 8) + * + * This check doesn't work well for small values, so old_size is rounded + * up for the check (and the '+ 1' of arr_idx can be ignored in practice): + * + * arr_idx > limit'' * ((old_size + 7) / 8) + */ + + new_size_min = arr_idx + 1; + return (new_size_min >= DUK_USE_HOBJECT_ARRAY_ABANDON_MINSIZE) && + (arr_idx > DUK_USE_HOBJECT_ARRAY_FAST_RESIZE_LIMIT * ((old_size + 7) >> 3)); +} + +DUK_LOCAL duk_bool_t duk__abandon_array_check(duk_hthread *thr, duk_uint32_t arr_idx, duk_hobject *obj) { + duk_uint32_t min_size; + duk_uint32_t old_used; + duk_uint32_t old_size; + + if (!duk__abandon_array_slow_check_required(arr_idx, DUK_HOBJECT_GET_ASIZE(obj))) { + DUK_DDD(DUK_DDDPRINT("=> fast resize is OK")); + return 0; + } + + duk__compute_a_stats(thr, obj, &old_used, &old_size); + + DUK_DDD(DUK_DDDPRINT("abandon check, array stats: old_used=%ld, old_size=%ld, arr_idx=%ld", + (long) old_used, + (long) old_size, + (long) arr_idx)); + + min_size = arr_idx + 1; +#if defined(DUK_USE_OBJSIZES16) + if (min_size > DUK_UINT16_MAX) { + goto do_abandon; + } +#endif + DUK_UNREF(min_size); + + /* Note: intentionally use approximations to shave a few instructions: + * a_used = old_used (accurate: old_used + 1) + * a_size = arr_idx (accurate: arr_idx + 1) + */ + if (duk__abandon_array_density_check(old_used, arr_idx)) { + DUK_DD(DUK_DDPRINT("write to new array entry beyond current length, " + "decided to abandon array part (would become too sparse)")); + + /* Abandoning requires a props allocation resize and + * 'rechecks' the valstack, invalidating any existing + * valstack value pointers. + */ + goto do_abandon; + } + + DUK_DDD(DUK_DDDPRINT("=> decided to keep array part")); + return 0; + +do_abandon: + duk__abandon_array_part(thr, obj); + DUK_ASSERT(!DUK_HOBJECT_HAS_ARRAY_PART(obj)); + return 1; +} + +DUK_LOCAL duk_tval *duk__obtain_arridx_slot_slowpath(duk_hthread *thr, duk_uint32_t arr_idx, duk_hobject *obj) { + /* + * Array needs to grow, but we don't want it becoming too sparse. + * If it were to become sparse, abandon array part, moving all + * array entries into the entries part (for good). + * + * Since we don't keep track of actual density (used vs. size) of + * the array part, we need to estimate somehow. The check is made + * in two parts: + * + * - Check whether the resize need is small compared to the + * current size (relatively); if so, resize without further + * checking (essentially we assume that the original part is + * "dense" so that the result would be dense enough). + * + * - Otherwise, compute the resize using an actual density + * measurement based on counting the used array entries. + */ + + DUK_DDD(DUK_DDDPRINT("write to new array requires array resize, decide whether to do a " + "fast resize without abandon check (arr_idx=%ld, old_size=%ld)", + (long) arr_idx, + (long) DUK_HOBJECT_GET_ASIZE(obj))); + + if (DUK_UNLIKELY(duk__abandon_array_check(thr, arr_idx, obj) != 0)) { + DUK_ASSERT(!DUK_HOBJECT_HAS_ARRAY_PART(obj)); + return NULL; + } + + DUK_DD(DUK_DDPRINT("write to new array entry beyond current length, " + "decided to extend current allocation")); + + /* In principle it's possible to run out of memory extending the + * array but with the allocation going through if we were to abandon + * the array part and try again. In practice this should be rare + * because abandoned arrays have a higher per-entry footprint. + */ + + duk__grow_props_for_array_item(thr, obj, arr_idx); + + DUK_ASSERT(DUK_HOBJECT_HAS_ARRAY_PART(obj)); + DUK_ASSERT(arr_idx < DUK_HOBJECT_GET_ASIZE(obj)); + return DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, arr_idx); +} + +DUK_LOCAL DUK_INLINE duk_tval *duk__obtain_arridx_slot(duk_hthread *thr, duk_uint32_t arr_idx, duk_hobject *obj) { + if (DUK_LIKELY(arr_idx < DUK_HOBJECT_GET_ASIZE(obj))) { + return DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, arr_idx); + } else { + return duk__obtain_arridx_slot_slowpath(thr, arr_idx, obj); + } +} + +/* + * Proxy helpers + */ + +#if defined(DUK_USE_ES6_PROXY) +DUK_INTERNAL duk_bool_t duk_hobject_proxy_check(duk_hobject *obj, duk_hobject **out_target, duk_hobject **out_handler) { + duk_hproxy *h_proxy; + + DUK_ASSERT(obj != NULL); + DUK_ASSERT(out_target != NULL); + DUK_ASSERT(out_handler != NULL); + + /* Caller doesn't need to check exotic proxy behavior (but does so for + * some fast paths). + */ + if (DUK_LIKELY(!DUK_HOBJECT_IS_PROXY(obj))) { + return 0; + } + h_proxy = (duk_hproxy *) obj; + DUK_HPROXY_ASSERT_VALID(h_proxy); + + DUK_ASSERT(h_proxy->handler != NULL); + DUK_ASSERT(h_proxy->target != NULL); + *out_handler = h_proxy->handler; + *out_target = h_proxy->target; + + return 1; +} +#endif /* DUK_USE_ES6_PROXY */ + +/* Get Proxy target object. If the argument is not a Proxy, return it as is. + * If a Proxy is revoked, an error is thrown. + */ +#if defined(DUK_USE_ES6_PROXY) +DUK_INTERNAL duk_hobject *duk_hobject_resolve_proxy_target(duk_hobject *obj) { + DUK_ASSERT(obj != NULL); + + /* Resolve Proxy targets until Proxy chain ends. No explicit check for + * a Proxy loop: user code cannot create such a loop (it would only be + * possible by editing duk_hproxy references directly). + */ + + while (DUK_HOBJECT_IS_PROXY(obj)) { + duk_hproxy *h_proxy; + + h_proxy = (duk_hproxy *) obj; + DUK_HPROXY_ASSERT_VALID(h_proxy); + obj = h_proxy->target; + DUK_ASSERT(obj != NULL); + } + + DUK_ASSERT(obj != NULL); + return obj; +} +#endif /* DUK_USE_ES6_PROXY */ + +#if defined(DUK_USE_ES6_PROXY) +DUK_LOCAL duk_bool_t duk__proxy_check_prop(duk_hthread *thr, + duk_hobject *obj, + duk_small_uint_t stridx_trap, + duk_tval *tv_key, + duk_hobject **out_target) { + duk_hobject *h_handler; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(tv_key != NULL); + DUK_ASSERT(out_target != NULL); + + if (!duk_hobject_proxy_check(obj, out_target, &h_handler)) { + return 0; + } + DUK_ASSERT(*out_target != NULL); + DUK_ASSERT(h_handler != NULL); + + /* XXX: At the moment Duktape accesses internal keys like _Finalizer using a + * normal property set/get which would allow a proxy handler to interfere with + * such behavior and to get access to internal key strings. This is not a problem + * as such because internal key strings can be created in other ways too (e.g. + * through buffers). The best fix is to change Duktape internal lookups to + * skip proxy behavior. Until that, internal property accesses bypass the + * proxy and are applied to the target (as if the handler did not exist). + * This has some side effects, see test-bi-proxy-internal-keys.js. + */ + + if (DUK_TVAL_IS_STRING(tv_key)) { + duk_hstring *h_key = (duk_hstring *) DUK_TVAL_GET_STRING(tv_key); + DUK_ASSERT(h_key != NULL); + if (DUK_HSTRING_HAS_HIDDEN(h_key)) { + /* Symbol accesses must go through proxy lookup in ES2015. + * Hidden symbols behave like Duktape 1.x internal keys + * and currently won't. + */ + DUK_DDD(DUK_DDDPRINT("hidden key, skip proxy handler and apply to target")); + return 0; + } + } + + /* The handler is looked up with a normal property lookup; it may be an + * accessor or the handler object itself may be a proxy object. If the + * handler is a proxy, we need to extend the valstack as we make a + * recursive proxy check without a function call in between (in fact + * there is no limit to the potential recursion here). + * + * (For sanity, proxy creation rejects another proxy object as either + * the handler or the target at the moment so recursive proxy cases + * are not realized now.) + */ + + /* XXX: C recursion limit if proxies are allowed as handler/target values */ + + duk_require_stack(thr, DUK__VALSTACK_PROXY_LOOKUP); + duk_push_hobject(thr, h_handler); + if (duk_get_prop_stridx_short(thr, -1, stridx_trap)) { + /* -> [ ... handler trap ] */ + duk_insert(thr, -2); /* -> [ ... trap handler ] */ + + /* stack prepped for func call: [ ... trap handler ] */ + return 1; + } else { + duk_pop_2_unsafe(thr); + return 0; + } +} +#endif /* DUK_USE_ES6_PROXY */ + +/* + * Reallocate property allocation, moving properties to the new allocation. + * + * Includes key compaction, rehashing, and can also optionally abandon + * the array part, 'migrating' array entries into the beginning of the + * new entry part. + * + * There is no support for in-place reallocation or just compacting keys + * without resizing the property allocation. This is intentional to keep + * code size minimal, but would be useful future work. + * + * The implementation is relatively straightforward, except for the array + * abandonment process. Array abandonment requires that new string keys + * are interned, which may trigger GC. All keys interned so far must be + * reachable for GC at all times and correctly refcounted for; valstack is + * used for that now. + * + * Also, a GC triggered during this reallocation process must not interfere + * with the object being resized. This is currently controlled by preventing + * finalizers (as they may affect ANY object) and object compaction in + * mark-and-sweep. It would suffice to protect only this particular object + * from compaction, however. DECREF refzero cascades are side effect free + * and OK. + * + * Note: because we need to potentially resize the valstack (as part + * of abandoning the array part), any tval pointers to the valstack + * will become invalid after this call. + */ + +DUK_INTERNAL void duk_hobject_realloc_props(duk_hthread *thr, + duk_hobject *obj, + duk_uint32_t new_e_size, + duk_uint32_t new_a_size, + duk_uint32_t new_h_size, + duk_bool_t abandon_array) { + duk_small_uint_t prev_ms_base_flags; + duk_uint32_t new_alloc_size; + duk_uint32_t new_e_size_adjusted; + duk_uint8_t *new_p; + duk_hstring **new_e_k; + duk_propvalue *new_e_pv; + duk_uint8_t *new_e_f; + duk_tval *new_a; + duk_uint32_t *new_h; + duk_uint32_t new_e_next; + duk_uint_fast32_t i; + duk_size_t array_copy_size; +#if defined(DUK_USE_ASSERTIONS) + duk_bool_t prev_error_not_allowed; +#endif + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(!abandon_array || new_a_size == 0); /* if abandon_array, new_a_size must be 0 */ + DUK_ASSERT(DUK_HOBJECT_GET_PROPS(thr->heap, obj) != NULL || + (DUK_HOBJECT_GET_ESIZE(obj) == 0 && DUK_HOBJECT_GET_ASIZE(obj) == 0)); + DUK_ASSERT(new_h_size == 0 || new_h_size >= new_e_size); /* required to guarantee success of rehashing, + * intentionally use unadjusted new_e_size + */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)); + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + DUK_STATS_INC(thr->heap, stats_object_realloc_props); + + /* + * Pre resize assertions. + */ + +#if defined(DUK_USE_ASSERTIONS) + /* XXX: pre-checks (such as no duplicate keys) */ +#endif + + /* + * For property layout 1, tweak e_size to ensure that the whole entry + * part (key + val + flags) is a suitable multiple for alignment + * (platform specific). + * + * Property layout 2 does not require this tweaking and is preferred + * on low RAM platforms requiring alignment. + */ + +#if defined(DUK_USE_HOBJECT_LAYOUT_2) || defined(DUK_USE_HOBJECT_LAYOUT_3) + DUK_DDD(DUK_DDDPRINT("using layout 2 or 3, no need to pad e_size: %ld", (long) new_e_size)); + new_e_size_adjusted = new_e_size; +#elif defined(DUK_USE_HOBJECT_LAYOUT_1) && (DUK_HOBJECT_ALIGN_TARGET == 1) + DUK_DDD(DUK_DDDPRINT("using layout 1, but no need to pad e_size: %ld", (long) new_e_size)); + new_e_size_adjusted = new_e_size; +#elif defined(DUK_USE_HOBJECT_LAYOUT_1) && ((DUK_HOBJECT_ALIGN_TARGET == 4) || (DUK_HOBJECT_ALIGN_TARGET == 8)) + new_e_size_adjusted = + (new_e_size + (duk_uint32_t) DUK_HOBJECT_ALIGN_TARGET - 1U) & (~((duk_uint32_t) DUK_HOBJECT_ALIGN_TARGET - 1U)); + DUK_DDD(DUK_DDDPRINT("using layout 1, and alignment target is %ld, adjusted e_size: %ld -> %ld", + (long) DUK_HOBJECT_ALIGN_TARGET, + (long) new_e_size, + (long) new_e_size_adjusted)); + DUK_ASSERT(new_e_size_adjusted >= new_e_size); +#else +#error invalid hobject layout defines +#endif + + /* + * Debug logging after adjustment. + */ + + DUK_DDD(DUK_DDDPRINT( + "attempt to resize hobject %p props (%ld -> %ld bytes), from {p=%p,e_size=%ld,e_next=%ld,a_size=%ld,h_size=%ld} to " + "{e_size=%ld,a_size=%ld,h_size=%ld}, abandon_array=%ld, unadjusted new_e_size=%ld", + (void *) obj, + (long) DUK_HOBJECT_P_COMPUTE_SIZE(DUK_HOBJECT_GET_ESIZE(obj), DUK_HOBJECT_GET_ASIZE(obj), DUK_HOBJECT_GET_HSIZE(obj)), + (long) DUK_HOBJECT_P_COMPUTE_SIZE(new_e_size_adjusted, new_a_size, new_h_size), + (void *) DUK_HOBJECT_GET_PROPS(thr->heap, obj), + (long) DUK_HOBJECT_GET_ESIZE(obj), + (long) DUK_HOBJECT_GET_ENEXT(obj), + (long) DUK_HOBJECT_GET_ASIZE(obj), + (long) DUK_HOBJECT_GET_HSIZE(obj), + (long) new_e_size_adjusted, + (long) new_a_size, + (long) new_h_size, + (long) abandon_array, + (long) new_e_size)); + + /* + * Property count check. This is the only point where we ensure that + * we don't get more (allocated) property space that we can handle. + * There aren't hard limits as such, but some algorithms may fail + * if we get too close to the 4G property limit. + * + * Since this works based on allocation size (not actually used size), + * the limit is a bit approximate but good enough in practice. + */ + + if (new_e_size_adjusted + new_a_size > DUK_HOBJECT_MAX_PROPERTIES) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return;); + } +#if defined(DUK_USE_OBJSIZES16) + if (new_e_size_adjusted > DUK_UINT16_MAX || new_a_size > DUK_UINT16_MAX) { + /* If caller gave us sizes larger than what we can store, + * fail memory safely with an internal error rather than + * truncating the sizes. + */ + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return;); + } +#endif + + /* + * Compute new alloc size and alloc new area. + * + * The new area is not tracked in the heap at all, so it's critical + * we get to free/keep it in a controlled manner. + */ + +#if defined(DUK_USE_ASSERTIONS) + /* Whole path must be error throw free, but we may be called from + * within error handling so can't assert for error_not_allowed == 0. + */ + prev_error_not_allowed = thr->heap->error_not_allowed; + thr->heap->error_not_allowed = 1; +#endif + prev_ms_base_flags = thr->heap->ms_base_flags; + thr->heap->ms_base_flags |= + DUK_MS_FLAG_NO_OBJECT_COMPACTION; /* Avoid attempt to compact the current object (all objects really). */ + thr->heap->pf_prevent_count++; /* Avoid finalizers. */ + DUK_ASSERT(thr->heap->pf_prevent_count != 0); /* Wrap. */ + + new_alloc_size = DUK_HOBJECT_P_COMPUTE_SIZE(new_e_size_adjusted, new_a_size, new_h_size); + DUK_DDD(DUK_DDDPRINT("new hobject allocation size is %ld", (long) new_alloc_size)); + if (new_alloc_size == 0) { + DUK_ASSERT(new_e_size_adjusted == 0); + DUK_ASSERT(new_a_size == 0); + DUK_ASSERT(new_h_size == 0); + new_p = NULL; + } else { + /* Alloc may trigger mark-and-sweep but no compaction, and + * cannot throw. + */ +#if 0 /* XXX: inject test */ + if (1) { + new_p = NULL; + goto alloc_failed; + } +#endif + new_p = (duk_uint8_t *) DUK_ALLOC(thr->heap, new_alloc_size); + if (new_p == NULL) { + /* NULL always indicates alloc failure because + * new_alloc_size > 0. + */ + goto alloc_failed; + } + } + + /* Set up pointers to the new property area: this is hidden behind a macro + * because it is memory layout specific. + */ + DUK_HOBJECT_P_SET_REALLOC_PTRS(new_p, + new_e_k, + new_e_pv, + new_e_f, + new_a, + new_h, + new_e_size_adjusted, + new_a_size, + new_h_size); + DUK_UNREF(new_h); /* happens when hash part dropped */ + new_e_next = 0; + + /* if new_p == NULL, all of these pointers are NULL */ + DUK_ASSERT((new_p != NULL) || (new_e_k == NULL && new_e_pv == NULL && new_e_f == NULL && new_a == NULL && new_h == NULL)); + + DUK_DDD(DUK_DDDPRINT("new alloc size %ld, new_e_k=%p, new_e_pv=%p, new_e_f=%p, new_a=%p, new_h=%p", + (long) new_alloc_size, + (void *) new_e_k, + (void *) new_e_pv, + (void *) new_e_f, + (void *) new_a, + (void *) new_h)); + + /* + * Migrate array part to start of entries if requested. + * + * Note: from an enumeration perspective the order of entry keys matters. + * Array keys should appear wherever they appeared before the array abandon + * operation. (This no longer matters much because keys are ES2015 sorted.) + */ + + if (abandon_array) { + /* Assuming new_a_size == 0, and that entry part contains + * no conflicting keys, refcounts do not need to be adjusted for + * the values, as they remain exactly the same. + * + * The keys, however, need to be interned, incref'd, and be + * reachable for GC. Any intern attempt may trigger a GC and + * claim any non-reachable strings, so every key must be reachable + * at all times. Refcounts must be correct to satisfy refcount + * assertions. + * + * A longjmp must not occur here, as the new_p allocation would + * leak. Refcounts would come out correctly as the interned + * strings are valstack tracked. + */ + DUK_ASSERT(new_a_size == 0); + + DUK_STATS_INC(thr->heap, stats_object_abandon_array); + + for (i = 0; i < DUK_HOBJECT_GET_ASIZE(obj); i++) { + duk_tval *tv1; + duk_tval *tv2; + duk_hstring *key; + + DUK_ASSERT(DUK_HOBJECT_GET_PROPS(thr->heap, obj) != NULL); + + tv1 = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, i); + if (DUK_TVAL_IS_UNUSED(tv1)) { + continue; + } + + DUK_ASSERT(new_p != NULL && new_e_k != NULL && new_e_pv != NULL && new_e_f != NULL); + + /* + * Intern key via the valstack to ensure reachability behaves + * properly. We must avoid longjmp's here so use non-checked + * primitives. + * + * Note: duk_check_stack() potentially reallocs the valstack, + * invalidating any duk_tval pointers to valstack. Callers + * must be careful. + */ + +#if 0 /* XXX: inject test */ + if (1) { + goto abandon_error; + } +#endif + /* Never shrinks; auto-adds DUK_VALSTACK_INTERNAL_EXTRA, which + * is generous. + */ + if (!duk_check_stack(thr, 1)) { + goto abandon_error; + } + DUK_ASSERT_VALSTACK_SPACE(thr, 1); + key = duk_heap_strtable_intern_u32(thr->heap, (duk_uint32_t) i); + if (key == NULL) { + goto abandon_error; + } + duk_push_hstring(thr, key); /* keep key reachable for GC etc; guaranteed not to fail */ + + /* Key is now reachable in the valstack, don't INCREF + * the new allocation yet (we'll steal the refcounts + * from the value stack once all keys are done). + */ + + new_e_k[new_e_next] = key; + tv2 = &new_e_pv[new_e_next].v; /* array entries are all plain values */ + DUK_TVAL_SET_TVAL(tv2, tv1); + new_e_f[new_e_next] = + DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_ENUMERABLE | DUK_PROPDESC_FLAG_CONFIGURABLE; + new_e_next++; + + /* Note: new_e_next matches pushed temp key count, and nothing can + * fail above between the push and this point. + */ + } + + /* Steal refcounts from value stack. */ + DUK_DDD(DUK_DDDPRINT("abandon array: pop %ld key temps from valstack", (long) new_e_next)); + duk_pop_n_nodecref_unsafe(thr, (duk_idx_t) new_e_next); + } + + /* + * Copy keys and values in the entry part (compacting them at the same time). + */ + + for (i = 0; i < DUK_HOBJECT_GET_ENEXT(obj); i++) { + duk_hstring *key; + + DUK_ASSERT(DUK_HOBJECT_GET_PROPS(thr->heap, obj) != NULL); + + key = DUK_HOBJECT_E_GET_KEY(thr->heap, obj, i); + if (key == NULL) { + continue; + } + + DUK_ASSERT(new_p != NULL && new_e_k != NULL && new_e_pv != NULL && new_e_f != NULL); + + new_e_k[new_e_next] = key; + new_e_pv[new_e_next] = DUK_HOBJECT_E_GET_VALUE(thr->heap, obj, i); + new_e_f[new_e_next] = DUK_HOBJECT_E_GET_FLAGS(thr->heap, obj, i); + new_e_next++; + } + /* the entries [new_e_next, new_e_size_adjusted[ are left uninitialized on purpose (ok, not gc reachable) */ + + /* + * Copy array elements to new array part. If the new array part is + * larger, initialize the unused entries as UNUSED because they are + * GC reachable. + */ + +#if defined(DUK_USE_ASSERTIONS) + /* Caller must have decref'd values above new_a_size (if that is necessary). */ + if (!abandon_array) { + for (i = new_a_size; i < DUK_HOBJECT_GET_ASIZE(obj); i++) { + duk_tval *tv; + tv = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, i); + DUK_ASSERT(DUK_TVAL_IS_UNUSED(tv)); + } + } +#endif + if (new_a_size > DUK_HOBJECT_GET_ASIZE(obj)) { + array_copy_size = sizeof(duk_tval) * DUK_HOBJECT_GET_ASIZE(obj); + } else { + array_copy_size = sizeof(duk_tval) * new_a_size; + } + + DUK_ASSERT(new_a != NULL || array_copy_size == 0U); + DUK_ASSERT(DUK_HOBJECT_GET_PROPS(thr->heap, obj) != NULL || array_copy_size == 0U); + DUK_ASSERT(DUK_HOBJECT_GET_ASIZE(obj) > 0 || array_copy_size == 0U); + duk_memcpy_unsafe((void *) new_a, (const void *) DUK_HOBJECT_A_GET_BASE(thr->heap, obj), array_copy_size); + + for (i = DUK_HOBJECT_GET_ASIZE(obj); i < new_a_size; i++) { + duk_tval *tv = &new_a[i]; + DUK_TVAL_SET_UNUSED(tv); + } + + /* + * Rebuild the hash part always from scratch (guaranteed to finish + * as long as caller gave consistent parameters). + * + * Any resize of hash part requires rehashing. In addition, by rehashing + * get rid of any elements marked deleted (DUK__HASH_DELETED) which is critical + * to ensuring the hash part never fills up. + */ + +#if defined(DUK_USE_HOBJECT_HASH_PART) + if (new_h_size == 0) { + DUK_DDD(DUK_DDDPRINT("no hash part, no rehash")); + } else { + duk_uint32_t mask; + + DUK_ASSERT(new_h != NULL); + + /* fill new_h with u32 0xff = UNUSED */ + DUK_ASSERT(new_h_size > 0); + duk_memset(new_h, 0xff, sizeof(duk_uint32_t) * new_h_size); + + DUK_ASSERT(new_e_next <= new_h_size); /* equality not actually possible */ + + mask = new_h_size - 1; + for (i = 0; i < new_e_next; i++) { + duk_hstring *key = new_e_k[i]; + duk_uint32_t j, step; + + DUK_ASSERT(key != NULL); + j = DUK_HSTRING_GET_HASH(key) & mask; + step = 1; /* Cache friendly but clustering prone. */ + + for (;;) { + DUK_ASSERT(new_h[j] != DUK__HASH_DELETED); /* should never happen */ + if (new_h[j] == DUK__HASH_UNUSED) { + DUK_DDD(DUK_DDDPRINT("rebuild hit %ld -> %ld", (long) j, (long) i)); + new_h[j] = (duk_uint32_t) i; + break; + } + DUK_DDD(DUK_DDDPRINT("rebuild miss %ld, step %ld", (long) j, (long) step)); + j = (j + step) & mask; + + /* Guaranteed to finish (hash is larger than #props). */ + } + } + } +#endif /* DUK_USE_HOBJECT_HASH_PART */ + + /* + * Nice debug log. + */ + + DUK_DD(DUK_DDPRINT( + "resized hobject %p props (%ld -> %ld bytes), from {p=%p,e_size=%ld,e_next=%ld,a_size=%ld,h_size=%ld} to " + "{p=%p,e_size=%ld,e_next=%ld,a_size=%ld,h_size=%ld}, abandon_array=%ld, unadjusted new_e_size=%ld", + (void *) obj, + (long) DUK_HOBJECT_P_COMPUTE_SIZE(DUK_HOBJECT_GET_ESIZE(obj), DUK_HOBJECT_GET_ASIZE(obj), DUK_HOBJECT_GET_HSIZE(obj)), + (long) new_alloc_size, + (void *) DUK_HOBJECT_GET_PROPS(thr->heap, obj), + (long) DUK_HOBJECT_GET_ESIZE(obj), + (long) DUK_HOBJECT_GET_ENEXT(obj), + (long) DUK_HOBJECT_GET_ASIZE(obj), + (long) DUK_HOBJECT_GET_HSIZE(obj), + (void *) new_p, + (long) new_e_size_adjusted, + (long) new_e_next, + (long) new_a_size, + (long) new_h_size, + (long) abandon_array, + (long) new_e_size)); + + /* + * All done, switch properties ('p') allocation to new one. + */ + + DUK_FREE_CHECKED(thr, DUK_HOBJECT_GET_PROPS(thr->heap, obj)); /* NULL obj->p is OK */ + DUK_HOBJECT_SET_PROPS(thr->heap, obj, new_p); + DUK_HOBJECT_SET_ESIZE(obj, new_e_size_adjusted); + DUK_HOBJECT_SET_ENEXT(obj, new_e_next); + DUK_HOBJECT_SET_ASIZE(obj, new_a_size); + DUK_HOBJECT_SET_HSIZE(obj, new_h_size); + + /* Clear array part flag only after switching. */ + if (abandon_array) { + DUK_HOBJECT_CLEAR_ARRAY_PART(obj); + } + + DUK_DDD(DUK_DDDPRINT("resize result: %!O", (duk_heaphdr *) obj)); + + DUK_ASSERT(thr->heap->pf_prevent_count > 0); + thr->heap->pf_prevent_count--; + thr->heap->ms_base_flags = prev_ms_base_flags; +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(thr->heap->error_not_allowed == 1); + thr->heap->error_not_allowed = prev_error_not_allowed; +#endif + + /* + * Post resize assertions. + */ + +#if defined(DUK_USE_ASSERTIONS) + /* XXX: post-checks (such as no duplicate keys) */ +#endif + return; + + /* + * Abandon array failed. We don't need to DECREF anything + * because the references in the new allocation are not + * INCREF'd until abandon is complete. The string interned + * keys are on the value stack and are handled normally by + * unwind. + */ + +abandon_error: +alloc_failed: + DUK_D(DUK_DPRINT("object property table resize failed")); + + DUK_FREE_CHECKED(thr, new_p); /* OK for NULL. */ + + thr->heap->pf_prevent_count--; + thr->heap->ms_base_flags = prev_ms_base_flags; +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(thr->heap->error_not_allowed == 1); + thr->heap->error_not_allowed = prev_error_not_allowed; +#endif + + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return;); +} + +/* + * Helpers to resize properties allocation on specific needs. + */ + +DUK_INTERNAL void duk_hobject_resize_entrypart(duk_hthread *thr, duk_hobject *obj, duk_uint32_t new_e_size) { + duk_uint32_t old_e_size; + duk_uint32_t new_a_size; + duk_uint32_t new_h_size; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + + old_e_size = DUK_HOBJECT_GET_ESIZE(obj); + if (old_e_size > new_e_size) { + new_e_size = old_e_size; + } +#if defined(DUK_USE_HOBJECT_HASH_PART) + new_h_size = duk__get_default_h_size(new_e_size); +#else + new_h_size = 0; +#endif + new_a_size = DUK_HOBJECT_GET_ASIZE(obj); + + duk_hobject_realloc_props(thr, obj, new_e_size, new_a_size, new_h_size, 0); +} + +/* Grow entry part allocation for one additional entry. */ +DUK_LOCAL void duk__grow_props_for_new_entry_item(duk_hthread *thr, duk_hobject *obj) { + duk_uint32_t old_e_used; /* actually used, non-NULL entries */ + duk_uint32_t new_e_size_minimum; + duk_uint32_t new_e_size; + duk_uint32_t new_a_size; + duk_uint32_t new_h_size; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + + /* Duktape 0.11.0 and prior tried to optimize the resize by not + * counting the number of actually used keys prior to the resize. + * This worked mostly well but also caused weird leak-like behavior + * as in: test-bug-object-prop-alloc-unbounded.js. So, now we count + * the keys explicitly to compute the new entry part size. + */ + + old_e_used = duk__count_used_e_keys(thr, obj); + new_e_size_minimum = old_e_used + 1; + new_e_size = old_e_used + duk__get_min_grow_e(old_e_used); +#if defined(DUK_USE_HOBJECT_HASH_PART) + new_h_size = duk__get_default_h_size(new_e_size); +#else + new_h_size = 0; +#endif + new_a_size = DUK_HOBJECT_GET_ASIZE(obj); + +#if defined(DUK_USE_OBJSIZES16) + if (new_e_size > DUK_UINT16_MAX) { + new_e_size = DUK_UINT16_MAX; + } + if (new_h_size > DUK_UINT16_MAX) { + new_h_size = DUK_UINT16_MAX; + } + if (new_a_size > DUK_UINT16_MAX) { + new_a_size = DUK_UINT16_MAX; + } +#endif + DUK_ASSERT(new_h_size == 0 || new_h_size >= new_e_size); + + if (!(new_e_size >= new_e_size_minimum)) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return;); + } + + duk_hobject_realloc_props(thr, obj, new_e_size, new_a_size, new_h_size, 0); +} + +/* Grow array part for a new highest array index. */ +DUK_LOCAL void duk__grow_props_for_array_item(duk_hthread *thr, duk_hobject *obj, duk_uint32_t highest_arr_idx) { + duk_uint32_t new_e_size; + duk_uint32_t new_a_size; + duk_uint32_t new_a_size_minimum; + duk_uint32_t new_h_size; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(highest_arr_idx >= DUK_HOBJECT_GET_ASIZE(obj)); + + new_e_size = DUK_HOBJECT_GET_ESIZE(obj); + new_h_size = DUK_HOBJECT_GET_HSIZE(obj); + new_a_size_minimum = highest_arr_idx + 1; + new_a_size = highest_arr_idx + duk__get_min_grow_a(highest_arr_idx); + DUK_ASSERT(new_a_size >= highest_arr_idx + 1); /* duk__get_min_grow_a() is always >= 1 */ + +#if defined(DUK_USE_OBJSIZES16) + if (new_e_size > DUK_UINT16_MAX) { + new_e_size = DUK_UINT16_MAX; + } + if (new_h_size > DUK_UINT16_MAX) { + new_h_size = DUK_UINT16_MAX; + } + if (new_a_size > DUK_UINT16_MAX) { + new_a_size = DUK_UINT16_MAX; + } +#endif + + if (!(new_a_size >= new_a_size_minimum)) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return;); + } + + duk_hobject_realloc_props(thr, obj, new_e_size, new_a_size, new_h_size, 0); +} + +/* Abandon array part, moving array entries into entries part. + * This requires a props resize, which is a heavy operation. + * We also compact the entries part while we're at it, although + * this is not strictly required. + */ +DUK_LOCAL void duk__abandon_array_part(duk_hthread *thr, duk_hobject *obj) { + duk_uint32_t new_e_size_minimum; + duk_uint32_t new_e_size; + duk_uint32_t new_a_size; + duk_uint32_t new_h_size; + duk_uint32_t e_used; /* actually used, non-NULL keys */ + duk_uint32_t a_used; + duk_uint32_t a_size; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + + e_used = duk__count_used_e_keys(thr, obj); + duk__compute_a_stats(thr, obj, &a_used, &a_size); + + /* + * Must guarantee all actually used array entries will fit into + * new entry part. Add one growth step to ensure we don't run out + * of space right away. + */ + + new_e_size_minimum = e_used + a_used; + new_e_size = new_e_size_minimum + duk__get_min_grow_e(new_e_size_minimum); + new_a_size = 0; +#if defined(DUK_USE_HOBJECT_HASH_PART) + new_h_size = duk__get_default_h_size(new_e_size); +#else + new_h_size = 0; +#endif + +#if defined(DUK_USE_OBJSIZES16) + if (new_e_size > DUK_UINT16_MAX) { + new_e_size = DUK_UINT16_MAX; + } + if (new_h_size > DUK_UINT16_MAX) { + new_h_size = DUK_UINT16_MAX; + } + if (new_a_size > DUK_UINT16_MAX) { + new_a_size = DUK_UINT16_MAX; + } +#endif + + if (!(new_e_size >= new_e_size_minimum)) { + DUK_ERROR_ALLOC_FAILED(thr); + DUK_WO_NORETURN(return;); + } + + DUK_DD(DUK_DDPRINT("abandon array part for hobject %p, " + "array stats before: e_used=%ld, a_used=%ld, a_size=%ld; " + "resize to e_size=%ld, a_size=%ld, h_size=%ld", + (void *) obj, + (long) e_used, + (long) a_used, + (long) a_size, + (long) new_e_size, + (long) new_a_size, + (long) new_h_size)); + + duk_hobject_realloc_props(thr, obj, new_e_size, new_a_size, new_h_size, 1); +} + +/* + * Compact an object. Minimizes allocation size for objects which are + * not likely to be extended. This is useful for internal and non- + * extensible objects, but can also be called for non-extensible objects. + * May abandon the array part if it is computed to be too sparse. + * + * This call is relatively expensive, as it needs to scan both the + * entries and the array part. + * + * The call may fail due to allocation error. + */ + +DUK_INTERNAL void duk_hobject_compact_props(duk_hthread *thr, duk_hobject *obj) { + duk_uint32_t e_size; /* currently used -> new size */ + duk_uint32_t a_size; /* currently required */ + duk_uint32_t a_used; /* actually used */ + duk_uint32_t h_size; + duk_bool_t abandon_array; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + +#if defined(DUK_USE_ROM_OBJECTS) + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)) { + DUK_DD(DUK_DDPRINT("ignore attempt to compact a rom object")); + return; + } +#endif + + e_size = duk__count_used_e_keys(thr, obj); + duk__compute_a_stats(thr, obj, &a_used, &a_size); + + DUK_DD(DUK_DDPRINT("compacting hobject, used e keys %ld, used a keys %ld, min a size %ld, " + "resized array density would be: %ld/%ld = %lf", + (long) e_size, + (long) a_used, + (long) a_size, + (long) a_used, + (long) a_size, + (double) a_used / (double) a_size)); + + if (duk__abandon_array_density_check(a_used, a_size)) { + DUK_DD(DUK_DDPRINT("decided to abandon array during compaction, a_used=%ld, a_size=%ld", + (long) a_used, + (long) a_size)); + abandon_array = 1; + e_size += a_used; + a_size = 0; + } else { + DUK_DD(DUK_DDPRINT("decided to keep array during compaction")); + abandon_array = 0; + } + +#if defined(DUK_USE_HOBJECT_HASH_PART) + if (e_size >= DUK_USE_HOBJECT_HASH_PROP_LIMIT) { + h_size = duk__get_default_h_size(e_size); + } else { + h_size = 0; + } +#else + h_size = 0; +#endif + + DUK_DD(DUK_DDPRINT("compacting hobject -> new e_size %ld, new a_size=%ld, new h_size=%ld, abandon_array=%ld", + (long) e_size, + (long) a_size, + (long) h_size, + (long) abandon_array)); + + duk_hobject_realloc_props(thr, obj, e_size, a_size, h_size, abandon_array); +} + +/* + * Find an existing key from entry part either by linear scan or by + * using the hash index (if it exists). + * + * Sets entry index (and possibly the hash index) to output variables, + * which allows the caller to update the entry and hash entries in-place. + * If entry is not found, both values are set to -1. If entry is found + * but there is no hash part, h_idx is set to -1. + */ + +DUK_INTERNAL duk_bool_t +duk_hobject_find_entry(duk_heap *heap, duk_hobject *obj, duk_hstring *key, duk_int_t *e_idx, duk_int_t *h_idx) { + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + DUK_ASSERT(e_idx != NULL); + DUK_ASSERT(h_idx != NULL); + DUK_UNREF(heap); + + if (DUK_LIKELY(DUK_HOBJECT_GET_HSIZE(obj) == 0)) { + /* Linear scan: more likely because most objects are small. + * This is an important fast path. + * + * XXX: this might be worth inlining for property lookups. + */ + duk_uint_fast32_t i; + duk_uint_fast32_t n; + duk_hstring **h_keys_base; + DUK_DDD(DUK_DDDPRINT("duk_hobject_find_entry() using linear scan for lookup")); + + h_keys_base = DUK_HOBJECT_E_GET_KEY_BASE(heap, obj); + n = DUK_HOBJECT_GET_ENEXT(obj); + for (i = 0; i < n; i++) { + if (h_keys_base[i] == key) { + *e_idx = (duk_int_t) i; + *h_idx = -1; + return 1; + } + } + } +#if defined(DUK_USE_HOBJECT_HASH_PART) + else { + /* hash lookup */ + duk_uint32_t n; + duk_uint32_t i, step; + duk_uint32_t *h_base; + duk_uint32_t mask; + + DUK_DDD(DUK_DDDPRINT("duk_hobject_find_entry() using hash part for lookup")); + + h_base = DUK_HOBJECT_H_GET_BASE(heap, obj); + n = DUK_HOBJECT_GET_HSIZE(obj); + mask = n - 1; + i = DUK_HSTRING_GET_HASH(key) & mask; + step = 1; /* Cache friendly but clustering prone. */ + + for (;;) { + duk_uint32_t t; + + DUK_ASSERT_DISABLE(i >= 0); /* unsigned */ + DUK_ASSERT(i < DUK_HOBJECT_GET_HSIZE(obj)); + t = h_base[i]; + DUK_ASSERT(t == DUK__HASH_UNUSED || t == DUK__HASH_DELETED || + (t < DUK_HOBJECT_GET_ESIZE(obj))); /* t >= 0 always true, unsigned */ + + if (t == DUK__HASH_UNUSED) { + break; + } else if (t == DUK__HASH_DELETED) { + DUK_DDD(DUK_DDDPRINT("lookup miss (deleted) i=%ld, t=%ld", (long) i, (long) t)); + } else { + DUK_ASSERT(t < DUK_HOBJECT_GET_ESIZE(obj)); + if (DUK_HOBJECT_E_GET_KEY(heap, obj, t) == key) { + DUK_DDD( + DUK_DDDPRINT("lookup hit i=%ld, t=%ld -> key %p", (long) i, (long) t, (void *) key)); + *e_idx = (duk_int_t) t; + *h_idx = (duk_int_t) i; + return 1; + } + DUK_DDD(DUK_DDDPRINT("lookup miss i=%ld, t=%ld", (long) i, (long) t)); + } + i = (i + step) & mask; + + /* Guaranteed to finish (hash is larger than #props). */ + } + } +#endif /* DUK_USE_HOBJECT_HASH_PART */ + + /* Not found, leave e_idx and h_idx unset. */ + return 0; +} + +/* For internal use: get non-accessor entry value */ +DUK_INTERNAL duk_tval *duk_hobject_find_entry_tval_ptr(duk_heap *heap, duk_hobject *obj, duk_hstring *key) { + duk_int_t e_idx; + duk_int_t h_idx; + + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + DUK_UNREF(heap); + + if (duk_hobject_find_entry(heap, obj, key, &e_idx, &h_idx)) { + DUK_ASSERT(e_idx >= 0); + if (!DUK_HOBJECT_E_SLOT_IS_ACCESSOR(heap, obj, e_idx)) { + return DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(heap, obj, e_idx); + } + } + return NULL; +} + +DUK_INTERNAL duk_tval *duk_hobject_find_entry_tval_ptr_stridx(duk_heap *heap, duk_hobject *obj, duk_small_uint_t stridx) { + return duk_hobject_find_entry_tval_ptr(heap, obj, DUK_HEAP_GET_STRING(heap, stridx)); +} + +/* For internal use: get non-accessor entry value and attributes */ +DUK_INTERNAL duk_tval *duk_hobject_find_entry_tval_ptr_and_attrs(duk_heap *heap, + duk_hobject *obj, + duk_hstring *key, + duk_uint_t *out_attrs) { + duk_int_t e_idx; + duk_int_t h_idx; + + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + DUK_ASSERT(out_attrs != NULL); + DUK_UNREF(heap); + + if (duk_hobject_find_entry(heap, obj, key, &e_idx, &h_idx)) { + DUK_ASSERT(e_idx >= 0); + if (!DUK_HOBJECT_E_SLOT_IS_ACCESSOR(heap, obj, e_idx)) { + *out_attrs = DUK_HOBJECT_E_GET_FLAGS(heap, obj, e_idx); + return DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(heap, obj, e_idx); + } + } + /* If not found, out_attrs is left unset. */ + return NULL; +} + +/* For internal use: get array part value */ +DUK_INTERNAL duk_tval *duk_hobject_find_array_entry_tval_ptr(duk_heap *heap, duk_hobject *obj, duk_uarridx_t i) { + duk_tval *tv; + + DUK_ASSERT(obj != NULL); + DUK_UNREF(heap); + + if (!DUK_HOBJECT_HAS_ARRAY_PART(obj)) { + return NULL; + } + if (i >= DUK_HOBJECT_GET_ASIZE(obj)) { + return NULL; + } + tv = DUK_HOBJECT_A_GET_VALUE_PTR(heap, obj, i); + return tv; +} + +/* + * Allocate and initialize a new entry, resizing the properties allocation + * if necessary. Returns entry index (e_idx) or throws an error if alloc fails. + * + * Sets the key of the entry (increasing the key's refcount), and updates + * the hash part if it exists. Caller must set value and flags, and update + * the entry value refcount. A decref for the previous value is not necessary. + */ + +DUK_LOCAL duk_int_t duk__hobject_alloc_entry_checked(duk_hthread *thr, duk_hobject *obj, duk_hstring *key) { + duk_uint32_t idx; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_ENEXT(obj) <= DUK_HOBJECT_GET_ESIZE(obj)); + +#if defined(DUK_USE_ASSERTIONS) + /* key must not already exist in entry part */ + { + duk_uint_fast32_t i; + for (i = 0; i < DUK_HOBJECT_GET_ENEXT(obj); i++) { + DUK_ASSERT(DUK_HOBJECT_E_GET_KEY(thr->heap, obj, i) != key); + } + } +#endif + + if (DUK_HOBJECT_GET_ENEXT(obj) >= DUK_HOBJECT_GET_ESIZE(obj)) { + /* only need to guarantee 1 more slot, but allocation growth is in chunks */ + DUK_DDD(DUK_DDDPRINT("entry part full, allocate space for one more entry")); + duk__grow_props_for_new_entry_item(thr, obj); + } + DUK_ASSERT(DUK_HOBJECT_GET_ENEXT(obj) < DUK_HOBJECT_GET_ESIZE(obj)); + idx = DUK_HOBJECT_POSTINC_ENEXT(obj); + + /* previous value is assumed to be garbage, so don't touch it */ + DUK_HOBJECT_E_SET_KEY(thr->heap, obj, idx, key); + DUK_HSTRING_INCREF(thr, key); + +#if defined(DUK_USE_HOBJECT_HASH_PART) + if (DUK_UNLIKELY(DUK_HOBJECT_GET_HSIZE(obj) > 0)) { + duk_uint32_t n, mask; + duk_uint32_t i, step; + duk_uint32_t *h_base = DUK_HOBJECT_H_GET_BASE(thr->heap, obj); + + n = DUK_HOBJECT_GET_HSIZE(obj); + mask = n - 1; + i = DUK_HSTRING_GET_HASH(key) & mask; + step = 1; /* Cache friendly but clustering prone. */ + + for (;;) { + duk_uint32_t t = h_base[i]; + if (t == DUK__HASH_UNUSED || t == DUK__HASH_DELETED) { + DUK_DDD(DUK_DDDPRINT("duk__hobject_alloc_entry_checked() inserted key into hash part, %ld -> %ld", + (long) i, + (long) idx)); + DUK_ASSERT_DISABLE(i >= 0); /* unsigned */ + DUK_ASSERT(i < DUK_HOBJECT_GET_HSIZE(obj)); + DUK_ASSERT_DISABLE(idx >= 0); + DUK_ASSERT(idx < DUK_HOBJECT_GET_ESIZE(obj)); + h_base[i] = idx; + break; + } + DUK_DDD(DUK_DDDPRINT("duk__hobject_alloc_entry_checked() miss %ld", (long) i)); + i = (i + step) & mask; + + /* Guaranteed to finish (hash is larger than #props). */ + } + } +#endif /* DUK_USE_HOBJECT_HASH_PART */ + + /* Note: we could return the hash index here too, but it's not + * needed right now. + */ + + DUK_ASSERT_DISABLE(idx >= 0); + DUK_ASSERT(idx < DUK_HOBJECT_GET_ESIZE(obj)); + DUK_ASSERT(idx < DUK_HOBJECT_GET_ENEXT(obj)); + return (duk_int_t) idx; +} + +/* + * Object internal value + * + * Returned value is guaranteed to be reachable / incref'd, caller does not need + * to incref OR decref. No proxies or accessors are invoked, no prototype walk. + */ + +DUK_INTERNAL duk_tval *duk_hobject_get_internal_value_tval_ptr(duk_heap *heap, duk_hobject *obj) { + return duk_hobject_find_entry_tval_ptr_stridx(heap, obj, DUK_STRIDX_INT_VALUE); +} + +DUK_LOCAL duk_heaphdr *duk_hobject_get_internal_value_heaphdr(duk_heap *heap, duk_hobject *obj) { + duk_tval *tv; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(obj != NULL); + + tv = duk_hobject_get_internal_value_tval_ptr(heap, obj); + if (tv != NULL) { + duk_heaphdr *h = DUK_TVAL_GET_HEAPHDR(tv); + DUK_ASSERT(h != NULL); + return h; + } + + return NULL; +} + +DUK_INTERNAL duk_hstring *duk_hobject_get_internal_value_string(duk_heap *heap, duk_hobject *obj) { + duk_hstring *h; + + h = (duk_hstring *) duk_hobject_get_internal_value_heaphdr(heap, obj); + if (h != NULL) { + DUK_ASSERT(DUK_HEAPHDR_IS_STRING((duk_heaphdr *) h)); + } + return h; +} + +DUK_LOCAL duk_hobject *duk__hobject_get_entry_object_stridx(duk_heap *heap, duk_hobject *obj, duk_small_uint_t stridx) { + duk_tval *tv; + duk_hobject *h; + + tv = duk_hobject_find_entry_tval_ptr_stridx(heap, obj, stridx); + if (tv != NULL && DUK_TVAL_IS_OBJECT(tv)) { + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + return h; + } + return NULL; +} + +DUK_INTERNAL duk_harray *duk_hobject_get_formals(duk_hthread *thr, duk_hobject *obj) { + duk_harray *h; + + h = (duk_harray *) duk__hobject_get_entry_object_stridx(thr->heap, obj, DUK_STRIDX_INT_FORMALS); + if (h != NULL) { + DUK_ASSERT(DUK_HOBJECT_IS_ARRAY((duk_hobject *) h)); + DUK_ASSERT(h->length <= DUK_HOBJECT_GET_ASIZE((duk_hobject *) h)); + } + return h; +} + +DUK_INTERNAL duk_hobject *duk_hobject_get_varmap(duk_hthread *thr, duk_hobject *obj) { + duk_hobject *h; + + h = duk__hobject_get_entry_object_stridx(thr->heap, obj, DUK_STRIDX_INT_VARMAP); + return h; +} + +/* + * Arguments handling helpers (argument map mainly). + * + * An arguments object has exotic behavior for some numeric indices. + * Accesses may translate to identifier operations which may have + * arbitrary side effects (potentially invalidating any duk_tval + * pointers). + */ + +/* Lookup 'key' from arguments internal 'map', perform a variable lookup + * if mapped, and leave the result on top of stack (and return non-zero). + * Used in E5 Section 10.6 algorithms [[Get]] and [[GetOwnProperty]]. + */ +DUK_LOCAL +duk_bool_t duk__lookup_arguments_map(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_propdesc *temp_desc, + duk_hobject **out_map, + duk_hobject **out_varenv) { + duk_hobject *map; + duk_hobject *varenv; + duk_bool_t rc; + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + DUK_DDD(DUK_DDDPRINT("arguments map lookup: thr=%p, obj=%p, key=%p, temp_desc=%p " + "(obj -> %!O, key -> %!O)", + (void *) thr, + (void *) obj, + (void *) key, + (void *) temp_desc, + (duk_heaphdr *) obj, + (duk_heaphdr *) key)); + + if (!duk_hobject_get_own_propdesc(thr, obj, DUK_HTHREAD_STRING_INT_MAP(thr), temp_desc, DUK_GETDESC_FLAG_PUSH_VALUE)) { + DUK_DDD(DUK_DDDPRINT("-> no 'map'")); + return 0; + } + + map = duk_require_hobject(thr, -1); + DUK_ASSERT(map != NULL); + duk_pop_unsafe(thr); /* map is reachable through obj */ + + if (!duk_hobject_get_own_propdesc(thr, map, key, temp_desc, DUK_GETDESC_FLAG_PUSH_VALUE)) { + DUK_DDD(DUK_DDDPRINT("-> 'map' exists, but key not in map")); + return 0; + } + + /* [... varname] */ + DUK_DDD(DUK_DDDPRINT("-> 'map' exists, and contains key, key is mapped to argument/variable binding %!T", + (duk_tval *) duk_get_tval(thr, -1))); + DUK_ASSERT(duk_is_string(thr, -1)); /* guaranteed when building arguments */ + + /* get varenv for varname (callee's declarative lexical environment) */ + rc = duk_hobject_get_own_propdesc(thr, obj, DUK_HTHREAD_STRING_INT_VARENV(thr), temp_desc, DUK_GETDESC_FLAG_PUSH_VALUE); + DUK_UNREF(rc); + DUK_ASSERT(rc != 0); /* arguments MUST have an initialized lexical environment reference */ + varenv = duk_require_hobject(thr, -1); + DUK_ASSERT(varenv != NULL); + duk_pop_unsafe(thr); /* varenv remains reachable through 'obj' */ + + DUK_DDD(DUK_DDDPRINT("arguments varenv is: %!dO", (duk_heaphdr *) varenv)); + + /* success: leave varname in stack */ + *out_map = map; + *out_varenv = varenv; + return 1; /* [... varname] */ +} + +/* Lookup 'key' from arguments internal 'map', and leave replacement value + * on stack top if mapped (and return non-zero). + * Used in E5 Section 10.6 algorithm for [[GetOwnProperty]] (used by [[Get]]). + */ +DUK_LOCAL duk_bool_t duk__check_arguments_map_for_get(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_propdesc *temp_desc) { + duk_hobject *map; + duk_hobject *varenv; + duk_hstring *varname; + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + if (!duk__lookup_arguments_map(thr, obj, key, temp_desc, &map, &varenv)) { + DUK_DDD(DUK_DDDPRINT("arguments: key not mapped, no exotic get behavior")); + return 0; + } + + /* [... varname] */ + + varname = duk_require_hstring(thr, -1); + DUK_ASSERT(varname != NULL); + duk_pop_unsafe(thr); /* varname is still reachable */ + + DUK_DDD(DUK_DDDPRINT("arguments object automatic getvar for a bound variable; " + "key=%!O, varname=%!O", + (duk_heaphdr *) key, + (duk_heaphdr *) varname)); + + (void) duk_js_getvar_envrec(thr, varenv, varname, 1 /*throw*/); + + /* [... value this_binding] */ + + duk_pop_unsafe(thr); + + /* leave result on stack top */ + return 1; +} + +/* Lookup 'key' from arguments internal 'map', perform a variable write if mapped. + * Used in E5 Section 10.6 algorithm for [[DefineOwnProperty]] (used by [[Put]]). + * Assumes stack top contains 'put' value (which is NOT popped). + */ +DUK_LOCAL void duk__check_arguments_map_for_put(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_propdesc *temp_desc, + duk_bool_t throw_flag) { + duk_hobject *map; + duk_hobject *varenv; + duk_hstring *varname; + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + if (!duk__lookup_arguments_map(thr, obj, key, temp_desc, &map, &varenv)) { + DUK_DDD(DUK_DDDPRINT("arguments: key not mapped, no exotic put behavior")); + return; + } + + /* [... put_value varname] */ + + varname = duk_require_hstring(thr, -1); + DUK_ASSERT(varname != NULL); + duk_pop_unsafe(thr); /* varname is still reachable */ + + DUK_DDD(DUK_DDDPRINT("arguments object automatic putvar for a bound variable; " + "key=%!O, varname=%!O, value=%!T", + (duk_heaphdr *) key, + (duk_heaphdr *) varname, + (duk_tval *) duk_require_tval(thr, -1))); + + /* [... put_value] */ + + /* + * Note: although arguments object variable mappings are only established + * for non-strict functions (and a call to a non-strict function created + * the arguments object in question), an inner strict function may be doing + * the actual property write. Hence the throw_flag applied here comes from + * the property write call. + */ + + duk_js_putvar_envrec(thr, varenv, varname, duk_require_tval(thr, -1), throw_flag); + + /* [... put_value] */ +} + +/* Lookup 'key' from arguments internal 'map', delete mapping if found. + * Used in E5 Section 10.6 algorithm for [[Delete]]. Note that the + * variable/argument itself (where the map points) is not deleted. + */ +DUK_LOCAL void duk__check_arguments_map_for_delete(duk_hthread *thr, duk_hobject *obj, duk_hstring *key, duk_propdesc *temp_desc) { + duk_hobject *map; + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + if (!duk_hobject_get_own_propdesc(thr, obj, DUK_HTHREAD_STRING_INT_MAP(thr), temp_desc, DUK_GETDESC_FLAG_PUSH_VALUE)) { + DUK_DDD(DUK_DDDPRINT("arguments: key not mapped, no exotic delete behavior")); + return; + } + + map = duk_require_hobject(thr, -1); + DUK_ASSERT(map != NULL); + duk_pop_unsafe(thr); /* map is reachable through obj */ + + DUK_DDD(DUK_DDDPRINT("-> have 'map', delete key %!O from map (if exists)); ignore result", (duk_heaphdr *) key)); + + /* Note: no recursion issue, we can trust 'map' to behave */ + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_BEHAVIOR(map)); + DUK_DDD(DUK_DDDPRINT("map before deletion: %!O", (duk_heaphdr *) map)); + (void) duk_hobject_delprop_raw(thr, map, key, 0); /* ignore result */ + DUK_DDD(DUK_DDDPRINT("map after deletion: %!O", (duk_heaphdr *) map)); +} + +/* + * ECMAScript compliant [[GetOwnProperty]](P), for internal use only. + * + * If property is found: + * - Fills descriptor fields to 'out_desc' + * - If DUK_GETDESC_FLAG_PUSH_VALUE is set, pushes a value related to the + * property onto the stack ('undefined' for accessor properties). + * - Returns non-zero + * + * If property is not found: + * - 'out_desc' is left in untouched state (possibly garbage) + * - Nothing is pushed onto the stack (not even with DUK_GETDESC_FLAG_PUSH_VALUE + * set) + * - Returns zero + * + * Notes: + * + * - Getting a property descriptor may cause an allocation (and hence + * GC) to take place, hence reachability and refcount of all related + * values matter. Reallocation of value stack, properties, etc may + * invalidate many duk_tval pointers (concretely, those which reside + * in memory areas subject to reallocation). However, heap object + * pointers are never affected (heap objects have stable pointers). + * + * - The value of a plain property is always reachable and has a non-zero + * reference count. + * + * - The value of a virtual property is not necessarily reachable from + * elsewhere and may have a refcount of zero. Hence we push it onto + * the valstack for the caller, which ensures it remains reachable + * while it is needed. + * + * - There are no virtual accessor properties. Hence, all getters and + * setters are always related to concretely stored properties, which + * ensures that the get/set functions in the resulting descriptor are + * reachable and have non-zero refcounts. Should there be virtual + * accessor properties later, this would need to change. + */ + +DUK_LOCAL duk_bool_t duk__get_own_propdesc_raw(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_uint32_t arr_idx, + duk_propdesc *out_desc, + duk_small_uint_t flags) { + duk_tval *tv; + + DUK_DDD(DUK_DDDPRINT("duk_hobject_get_own_propdesc: thr=%p, obj=%p, key=%p, out_desc=%p, flags=%lx, " + "arr_idx=%ld (obj -> %!O, key -> %!O)", + (void *) thr, + (void *) obj, + (void *) key, + (void *) out_desc, + (long) flags, + (long) arr_idx, + (duk_heaphdr *) obj, + (duk_heaphdr *) key)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + DUK_ASSERT(out_desc != NULL); + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + DUK_STATS_INC(thr->heap, stats_getownpropdesc_count); + + /* Each code path returning 1 (= found) must fill in all the output + * descriptor fields. We don't do it beforehand because it'd be + * unnecessary work if the property isn't found and would happen + * multiple times for an inheritance chain. + */ + DUK_ASSERT_SET_GARBAGE(out_desc, sizeof(*out_desc)); +#if 0 + out_desc->flags = 0; + out_desc->get = NULL; + out_desc->set = NULL; + out_desc->e_idx = -1; + out_desc->h_idx = -1; + out_desc->a_idx = -1; +#endif + + /* + * Try entries part first because it's the common case. + * + * Array part lookups are usually handled by the array fast path, and + * are not usually inherited. Array and entry parts never contain the + * same keys so the entry part vs. array part order doesn't matter. + */ + + if (duk_hobject_find_entry(thr->heap, obj, key, &out_desc->e_idx, &out_desc->h_idx)) { + duk_int_t e_idx = out_desc->e_idx; + DUK_ASSERT(out_desc->e_idx >= 0); + out_desc->a_idx = -1; + out_desc->flags = DUK_HOBJECT_E_GET_FLAGS(thr->heap, obj, e_idx); + out_desc->get = NULL; + out_desc->set = NULL; + if (DUK_UNLIKELY(out_desc->flags & DUK_PROPDESC_FLAG_ACCESSOR)) { + DUK_DDD(DUK_DDDPRINT("-> found accessor property in entry part")); + out_desc->get = DUK_HOBJECT_E_GET_VALUE_GETTER(thr->heap, obj, e_idx); + out_desc->set = DUK_HOBJECT_E_GET_VALUE_SETTER(thr->heap, obj, e_idx); + if (flags & DUK_GETDESC_FLAG_PUSH_VALUE) { + /* a dummy undefined value is pushed to make valstack + * behavior uniform for caller + */ + duk_push_undefined(thr); + } + } else { + DUK_DDD(DUK_DDDPRINT("-> found plain property in entry part")); + tv = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, obj, e_idx); + if (flags & DUK_GETDESC_FLAG_PUSH_VALUE) { + duk_push_tval(thr, tv); + } + } + goto prop_found; + } + + /* + * Try array part. + */ + + if (DUK_HOBJECT_HAS_ARRAY_PART(obj) && arr_idx != DUK__NO_ARRAY_INDEX) { + if (arr_idx < DUK_HOBJECT_GET_ASIZE(obj)) { + tv = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, arr_idx); + if (!DUK_TVAL_IS_UNUSED(tv)) { + DUK_DDD(DUK_DDDPRINT("-> found in array part")); + if (flags & DUK_GETDESC_FLAG_PUSH_VALUE) { + duk_push_tval(thr, tv); + } + /* implicit attributes */ + out_desc->flags = + DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_CONFIGURABLE | DUK_PROPDESC_FLAG_ENUMERABLE; + out_desc->get = NULL; + out_desc->set = NULL; + out_desc->e_idx = -1; + out_desc->h_idx = -1; + out_desc->a_idx = (duk_int_t) arr_idx; /* XXX: limit 2G due to being signed */ + goto prop_found; + } + } + } + + DUK_DDD(DUK_DDDPRINT("-> not found as a concrete property")); + + /* + * Not found as a concrete property, check for virtual properties. + */ + + if (!DUK_HOBJECT_HAS_VIRTUAL_PROPERTIES(obj)) { + /* Quick skip. */ + goto prop_not_found; + } + + if (DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)) { + duk_harray *a; + + DUK_DDD(DUK_DDDPRINT("array object exotic property get for key: %!O, arr_idx: %ld", + (duk_heaphdr *) key, + (long) arr_idx)); + + a = (duk_harray *) obj; + DUK_HARRAY_ASSERT_VALID(a); + + if (key == DUK_HTHREAD_STRING_LENGTH(thr)) { + DUK_DDD(DUK_DDDPRINT("-> found, key is 'length', length exotic behavior")); + + if (flags & DUK_GETDESC_FLAG_PUSH_VALUE) { + duk_push_uint(thr, (duk_uint_t) a->length); + } + out_desc->flags = DUK_PROPDESC_FLAG_VIRTUAL; + if (DUK_HARRAY_LENGTH_WRITABLE(a)) { + out_desc->flags |= DUK_PROPDESC_FLAG_WRITABLE; + } + out_desc->get = NULL; + out_desc->set = NULL; + out_desc->e_idx = -1; + out_desc->h_idx = -1; + out_desc->a_idx = -1; + + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(obj)); + goto prop_found_noexotic; /* cannot be arguments exotic */ + } + } else if (DUK_HOBJECT_HAS_EXOTIC_STRINGOBJ(obj)) { + DUK_DDD(DUK_DDDPRINT("string object exotic property get for key: %!O, arr_idx: %ld", + (duk_heaphdr *) key, + (long) arr_idx)); + + /* XXX: charlen; avoid multiple lookups? */ + + if (arr_idx != DUK__NO_ARRAY_INDEX) { + duk_hstring *h_val; + + DUK_DDD(DUK_DDDPRINT("array index exists")); + + h_val = duk_hobject_get_internal_value_string(thr->heap, obj); + DUK_ASSERT(h_val); + if (arr_idx < DUK_HSTRING_GET_CHARLEN(h_val)) { + DUK_DDD(DUK_DDDPRINT("-> found, array index inside string")); + if (flags & DUK_GETDESC_FLAG_PUSH_VALUE) { + duk_push_hstring(thr, h_val); + duk_substring(thr, -1, arr_idx, arr_idx + 1); /* [str] -> [substr] */ + } + out_desc->flags = DUK_PROPDESC_FLAG_ENUMERABLE | /* E5 Section 15.5.5.2 */ + DUK_PROPDESC_FLAG_VIRTUAL; + out_desc->get = NULL; + out_desc->set = NULL; + out_desc->e_idx = -1; + out_desc->h_idx = -1; + out_desc->a_idx = -1; + + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(obj)); + goto prop_found_noexotic; /* cannot be arguments exotic */ + } else { + /* index is above internal string length -> property is fully normal */ + DUK_DDD(DUK_DDDPRINT("array index outside string -> normal property")); + } + } else if (key == DUK_HTHREAD_STRING_LENGTH(thr)) { + duk_hstring *h_val; + + DUK_DDD(DUK_DDDPRINT("-> found, key is 'length', length exotic behavior")); + + h_val = duk_hobject_get_internal_value_string(thr->heap, obj); + DUK_ASSERT(h_val != NULL); + if (flags & DUK_GETDESC_FLAG_PUSH_VALUE) { + duk_push_uint(thr, (duk_uint_t) DUK_HSTRING_GET_CHARLEN(h_val)); + } + out_desc->flags = DUK_PROPDESC_FLAG_VIRTUAL; /* E5 Section 15.5.5.1 */ + out_desc->get = NULL; + out_desc->set = NULL; + out_desc->e_idx = -1; + out_desc->h_idx = -1; + out_desc->a_idx = -1; + + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(obj)); + goto prop_found_noexotic; /* cannot be arguments exotic */ + } + } +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + else if (DUK_HOBJECT_IS_BUFOBJ(obj)) { + duk_hbufobj *h_bufobj; + duk_uint_t byte_off; + duk_small_uint_t elem_size; + + h_bufobj = (duk_hbufobj *) obj; + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + DUK_DDD(DUK_DDDPRINT("bufobj property get for key: %!O, arr_idx: %ld", (duk_heaphdr *) key, (long) arr_idx)); + + if (arr_idx != DUK__NO_ARRAY_INDEX && DUK_HBUFOBJ_HAS_VIRTUAL_INDICES(h_bufobj)) { + DUK_DDD(DUK_DDDPRINT("array index exists")); + + /* Careful with wrapping: arr_idx upshift may easily wrap, whereas + * length downshift won't. + */ + if (arr_idx < (h_bufobj->length >> h_bufobj->shift)) { + byte_off = arr_idx << h_bufobj->shift; /* no wrap assuming h_bufobj->length is valid */ + elem_size = (duk_small_uint_t) (1U << h_bufobj->shift); + if (flags & DUK_GETDESC_FLAG_PUSH_VALUE) { + duk_uint8_t *data; + + if (h_bufobj->buf != NULL && + DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h_bufobj, byte_off + elem_size)) { + data = (duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_bufobj->buf) + + h_bufobj->offset + byte_off; + duk_hbufobj_push_validated_read(thr, h_bufobj, data, elem_size); + } else { + DUK_D(DUK_DPRINT("bufobj access out of underlying buffer, ignoring (read zero)")); + duk_push_uint(thr, 0); + } + } + out_desc->flags = DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_VIRTUAL; + if (DUK_HOBJECT_GET_CLASS_NUMBER(obj) != DUK_HOBJECT_CLASS_ARRAYBUFFER) { + /* ArrayBuffer indices are non-standard and are + * non-enumerable to avoid their serialization. + */ + out_desc->flags |= DUK_PROPDESC_FLAG_ENUMERABLE; + } + out_desc->get = NULL; + out_desc->set = NULL; + out_desc->e_idx = -1; + out_desc->h_idx = -1; + out_desc->a_idx = -1; + + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(obj)); + goto prop_found_noexotic; /* cannot be e.g. arguments exotic, since exotic 'traits' are mutually + exclusive */ + } else { + /* index is above internal buffer length -> property is fully normal */ + DUK_DDD(DUK_DDDPRINT("array index outside buffer -> normal property")); + } + } else if (key == DUK_HTHREAD_STRING_LENGTH(thr) && DUK_HBUFOBJ_HAS_VIRTUAL_INDICES(h_bufobj)) { + DUK_DDD(DUK_DDDPRINT("-> found, key is 'length', length exotic behavior")); + + if (flags & DUK_GETDESC_FLAG_PUSH_VALUE) { + /* Length in elements: take into account shift, but + * intentionally don't check the underlying buffer here. + */ + duk_push_uint(thr, h_bufobj->length >> h_bufobj->shift); + } + out_desc->flags = DUK_PROPDESC_FLAG_VIRTUAL; + out_desc->get = NULL; + out_desc->set = NULL; + out_desc->e_idx = -1; + out_desc->h_idx = -1; + out_desc->a_idx = -1; + + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(obj)); + goto prop_found_noexotic; /* cannot be arguments exotic */ + } + } +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + + /* Array properties have exotic behavior but they are concrete, + * so no special handling here. + * + * Arguments exotic behavior (E5 Section 10.6, [[GetOwnProperty]] + * is only relevant as a post-check implemented below; hence no + * check here. + */ + + /* + * Not found as concrete or virtual. + */ + +prop_not_found: + DUK_DDD(DUK_DDDPRINT("-> not found (virtual, entry part, or array part)")); + DUK_STATS_INC(thr->heap, stats_getownpropdesc_miss); + return 0; + + /* + * Found. + * + * Arguments object has exotic post-processing, see E5 Section 10.6, + * description of [[GetOwnProperty]] variant for arguments. + */ + +prop_found: + DUK_DDD(DUK_DDDPRINT("-> property found, checking for arguments exotic post-behavior")); + + /* Notes: + * - Only numbered indices are relevant, so arr_idx fast reject is good + * (this is valid unless there are more than 4**32-1 arguments). + * - Since variable lookup has no side effects, this can be skipped if + * DUK_GETDESC_FLAG_PUSH_VALUE is not set. + */ + + if (DUK_UNLIKELY(DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(obj) && arr_idx != DUK__NO_ARRAY_INDEX && + (flags & DUK_GETDESC_FLAG_PUSH_VALUE))) { + duk_propdesc temp_desc; + + /* Magically bound variable cannot be an accessor. However, + * there may be an accessor property (or a plain property) in + * place with magic behavior removed. This happens e.g. when + * a magic property is redefined with defineProperty(). + * Cannot assert for "not accessor" here. + */ + + /* replaces top of stack with new value if necessary */ + DUK_ASSERT((flags & DUK_GETDESC_FLAG_PUSH_VALUE) != 0); + + /* This can perform a variable lookup but only into a declarative + * environment which has no side effects. + */ + if (duk__check_arguments_map_for_get(thr, obj, key, &temp_desc)) { + DUK_DDD(DUK_DDDPRINT("-> arguments exotic behavior overrides result: %!T -> %!T", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + /* [... old_result result] -> [... result] */ + duk_remove_m2(thr); + } + } + +prop_found_noexotic: + DUK_STATS_INC(thr->heap, stats_getownpropdesc_hit); + return 1; +} + +DUK_INTERNAL duk_bool_t +duk_hobject_get_own_propdesc(duk_hthread *thr, duk_hobject *obj, duk_hstring *key, duk_propdesc *out_desc, duk_small_uint_t flags) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + DUK_ASSERT(out_desc != NULL); + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + return duk__get_own_propdesc_raw(thr, obj, key, DUK_HSTRING_GET_ARRIDX_SLOW(key), out_desc, flags); +} + +/* + * ECMAScript compliant [[GetProperty]](P), for internal use only. + * + * If property is found: + * - Fills descriptor fields to 'out_desc' + * - If DUK_GETDESC_FLAG_PUSH_VALUE is set, pushes a value related to the + * property onto the stack ('undefined' for accessor properties). + * - Returns non-zero + * + * If property is not found: + * - 'out_desc' is left in untouched state (possibly garbage) + * - Nothing is pushed onto the stack (not even with DUK_GETDESC_FLAG_PUSH_VALUE + * set) + * - Returns zero + * + * May cause arbitrary side effects and invalidate (most) duk_tval + * pointers. + */ + +DUK_LOCAL duk_bool_t +duk__get_propdesc(duk_hthread *thr, duk_hobject *obj, duk_hstring *key, duk_propdesc *out_desc, duk_small_uint_t flags) { + duk_hobject *curr; + duk_uint32_t arr_idx; + duk_uint_t sanity; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + DUK_ASSERT(out_desc != NULL); + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + DUK_STATS_INC(thr->heap, stats_getpropdesc_count); + + arr_idx = DUK_HSTRING_GET_ARRIDX_FAST(key); + + DUK_DDD(DUK_DDDPRINT("duk__get_propdesc: thr=%p, obj=%p, key=%p, out_desc=%p, flags=%lx, " + "arr_idx=%ld (obj -> %!O, key -> %!O)", + (void *) thr, + (void *) obj, + (void *) key, + (void *) out_desc, + (long) flags, + (long) arr_idx, + (duk_heaphdr *) obj, + (duk_heaphdr *) key)); + + curr = obj; + DUK_ASSERT(curr != NULL); + sanity = DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY; + do { + if (duk__get_own_propdesc_raw(thr, curr, key, arr_idx, out_desc, flags)) { + /* stack contains value (if requested), 'out_desc' is set */ + DUK_STATS_INC(thr->heap, stats_getpropdesc_hit); + return 1; + } + + /* not found in 'curr', next in prototype chain; impose max depth */ + if (DUK_UNLIKELY(sanity-- == 0)) { + if (flags & DUK_GETDESC_FLAG_IGNORE_PROTOLOOP) { + /* treat like property not found */ + break; + } else { + DUK_ERROR_RANGE(thr, DUK_STR_PROTOTYPE_CHAIN_LIMIT); + DUK_WO_NORETURN(return 0;); + } + } + curr = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, curr); + } while (curr != NULL); + + /* out_desc is left untouched (possibly garbage), caller must use return + * value to determine whether out_desc can be looked up + */ + + DUK_STATS_INC(thr->heap, stats_getpropdesc_miss); + return 0; +} + +/* + * Shallow fast path checks for accessing array elements with numeric + * indices. The goal is to try to avoid coercing an array index to an + * (interned) string for the most common lookups, in particular, for + * standard Array objects. + * + * Interning is avoided but only for a very narrow set of cases: + * - Object has array part, index is within array allocation, and + * value is not unused (= key exists) + * - Object has no interfering exotic behavior (e.g. arguments or + * string object exotic behaviors interfere, array exotic + * behavior does not). + * + * Current shortcoming: if key does not exist (even if it is within + * the array allocation range) a slow path lookup with interning is + * always required. This can probably be fixed so that there is a + * quick fast path for non-existent elements as well, at least for + * standard Array objects. + */ + +#if defined(DUK_USE_ARRAY_PROP_FASTPATH) +DUK_LOCAL duk_tval *duk__getprop_shallow_fastpath_array_tval(duk_hthread *thr, duk_hobject *obj, duk_tval *tv_key) { + duk_tval *tv; + duk_uint32_t idx; + + DUK_UNREF(thr); + + if (!(DUK_HOBJECT_HAS_ARRAY_PART(obj) && !DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(obj) && !DUK_HOBJECT_HAS_EXOTIC_STRINGOBJ(obj) && + !DUK_HOBJECT_IS_BUFOBJ(obj) && !DUK_HOBJECT_IS_PROXY(obj))) { + /* Must have array part and no conflicting exotic behaviors. + * Doesn't need to have array special behavior, e.g. Arguments + * object has array part. + */ + return NULL; + } + + /* Arrays never have other exotic behaviors. */ + + DUK_DDD(DUK_DDDPRINT("fast path attempt (no exotic string/arguments/buffer " + "behavior, object has array part)")); + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_key)) { + idx = duk__tval_fastint_to_arr_idx(tv_key); + } else +#endif + if (DUK_TVAL_IS_DOUBLE(tv_key)) { + idx = duk__tval_number_to_arr_idx(tv_key); + } else { + DUK_DDD(DUK_DDDPRINT("key is not a number")); + return NULL; + } + + /* If index is not valid, idx will be DUK__NO_ARRAY_INDEX which + * is 0xffffffffUL. We don't need to check for that explicitly + * because 0xffffffffUL will never be inside object 'a_size'. + */ + + if (idx >= DUK_HOBJECT_GET_ASIZE(obj)) { + DUK_DDD(DUK_DDDPRINT("key is not an array index or outside array part")); + return NULL; + } + DUK_ASSERT(idx != 0xffffffffUL); + DUK_ASSERT(idx != DUK__NO_ARRAY_INDEX); + + /* XXX: for array instances we could take a shortcut here and assume + * Array.prototype doesn't contain an array index property. + */ + + DUK_DDD(DUK_DDDPRINT("key is a valid array index and inside array part")); + tv = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, idx); + if (!DUK_TVAL_IS_UNUSED(tv)) { + DUK_DDD(DUK_DDDPRINT("-> fast path successful")); + return tv; + } + + DUK_DDD(DUK_DDDPRINT("fast path attempt failed, fall back to slow path")); + return NULL; +} + +DUK_LOCAL duk_bool_t duk__putprop_shallow_fastpath_array_tval(duk_hthread *thr, + duk_hobject *obj, + duk_tval *tv_key, + duk_tval *tv_val) { + duk_tval *tv; + duk_harray *a; + duk_uint32_t idx; + duk_uint32_t old_len, new_len; + + if (!(DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj) && DUK_HOBJECT_HAS_ARRAY_PART(obj) && DUK_HOBJECT_HAS_EXTENSIBLE(obj))) { + return 0; + } + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)); /* caller ensures */ + + a = (duk_harray *) obj; + DUK_HARRAY_ASSERT_VALID(a); + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_key)) { + idx = duk__tval_fastint_to_arr_idx(tv_key); + } else +#endif + if (DUK_TVAL_IS_DOUBLE(tv_key)) { + idx = duk__tval_number_to_arr_idx(tv_key); + } else { + DUK_DDD(DUK_DDDPRINT("key is not a number")); + return 0; + } + + /* If index is not valid, idx will be DUK__NO_ARRAY_INDEX which + * is 0xffffffffUL. We don't need to check for that explicitly + * because 0xffffffffUL will never be inside object 'a_size'. + */ + + if (idx >= DUK_HOBJECT_GET_ASIZE(obj)) { /* for resizing of array part, use slow path */ + return 0; + } + DUK_ASSERT(idx != 0xffffffffUL); + DUK_ASSERT(idx != DUK__NO_ARRAY_INDEX); + + old_len = a->length; + + if (idx >= old_len) { + DUK_DDD(DUK_DDDPRINT("write new array entry requires length update " + "(arr_idx=%ld, old_len=%ld)", + (long) idx, + (long) old_len)); + if (DUK_HARRAY_LENGTH_NONWRITABLE(a)) { + /* The correct behavior here is either a silent error + * or a TypeError, depending on strictness. Fall back + * to the slow path to handle the situation. + */ + return 0; + } + new_len = idx + 1; + + ((duk_harray *) obj)->length = new_len; + } + + tv = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, idx); + DUK_TVAL_SET_TVAL_UPDREF(thr, tv, tv_val); /* side effects */ + + DUK_DDD(DUK_DDDPRINT("array fast path success for index %ld", (long) idx)); + return 1; +} +#endif /* DUK_USE_ARRAY_PROP_FASTPATH */ + +/* + * Fast path for bufobj getprop/putprop + */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_LOCAL duk_bool_t duk__getprop_fastpath_bufobj_tval(duk_hthread *thr, duk_hobject *obj, duk_tval *tv_key) { + duk_uint32_t idx; + duk_hbufobj *h_bufobj; + duk_uint_t byte_off; + duk_small_uint_t elem_size; + duk_uint8_t *data; + + if (!DUK_HOBJECT_IS_BUFOBJ(obj)) { + return 0; + } + h_bufobj = (duk_hbufobj *) obj; + if (!DUK_HBUFOBJ_HAS_VIRTUAL_INDICES(h_bufobj)) { + return 0; + } + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_key)) { + idx = duk__tval_fastint_to_arr_idx(tv_key); + } else +#endif + if (DUK_TVAL_IS_DOUBLE(tv_key)) { + idx = duk__tval_number_to_arr_idx(tv_key); + } else { + return 0; + } + + /* If index is not valid, idx will be DUK__NO_ARRAY_INDEX which + * is 0xffffffffUL. We don't need to check for that explicitly + * because 0xffffffffUL will never be inside bufobj length. + */ + + /* Careful with wrapping (left shifting idx would be unsafe). */ + if (idx >= (h_bufobj->length >> h_bufobj->shift)) { + return 0; + } + DUK_ASSERT(idx != DUK__NO_ARRAY_INDEX); + + byte_off = idx << h_bufobj->shift; /* no wrap assuming h_bufobj->length is valid */ + elem_size = (duk_small_uint_t) (1U << h_bufobj->shift); + + if (h_bufobj->buf != NULL && DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h_bufobj, byte_off + elem_size)) { + data = (duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_bufobj->buf) + h_bufobj->offset + byte_off; + duk_hbufobj_push_validated_read(thr, h_bufobj, data, elem_size); + } else { + DUK_D(DUK_DPRINT("bufobj access out of underlying buffer, ignoring (read zero)")); + duk_push_uint(thr, 0); + } + + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) +DUK_LOCAL duk_bool_t duk__putprop_fastpath_bufobj_tval(duk_hthread *thr, duk_hobject *obj, duk_tval *tv_key, duk_tval *tv_val) { + duk_uint32_t idx; + duk_hbufobj *h_bufobj; + duk_uint_t byte_off; + duk_small_uint_t elem_size; + duk_uint8_t *data; + + if (!(DUK_HOBJECT_IS_BUFOBJ(obj) && DUK_TVAL_IS_NUMBER(tv_val))) { + return 0; + } + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)); /* caller ensures; rom objects are never bufobjs now */ + + h_bufobj = (duk_hbufobj *) obj; + if (!DUK_HBUFOBJ_HAS_VIRTUAL_INDICES(h_bufobj)) { + return 0; + } + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_key)) { + idx = duk__tval_fastint_to_arr_idx(tv_key); + } else +#endif + if (DUK_TVAL_IS_DOUBLE(tv_key)) { + idx = duk__tval_number_to_arr_idx(tv_key); + } else { + return 0; + } + + /* If index is not valid, idx will be DUK__NO_ARRAY_INDEX which + * is 0xffffffffUL. We don't need to check for that explicitly + * because 0xffffffffUL will never be inside bufobj length. + */ + + /* Careful with wrapping (left shifting idx would be unsafe). */ + if (idx >= (h_bufobj->length >> h_bufobj->shift)) { + return 0; + } + DUK_ASSERT(idx != DUK__NO_ARRAY_INDEX); + + byte_off = idx << h_bufobj->shift; /* no wrap assuming h_bufobj->length is valid */ + elem_size = (duk_small_uint_t) (1U << h_bufobj->shift); + + /* Value is required to be a number in the fast path so there + * are no side effects in write coercion. + */ + duk_push_tval(thr, tv_val); + DUK_ASSERT(duk_is_number(thr, -1)); + + if (h_bufobj->buf != NULL && DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h_bufobj, byte_off + elem_size)) { + data = (duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_bufobj->buf) + h_bufobj->offset + byte_off; + duk_hbufobj_validated_write(thr, h_bufobj, data, elem_size); + } else { + DUK_D(DUK_DPRINT("bufobj access out of underlying buffer, ignoring (write skipped)")); + } + + duk_pop_unsafe(thr); + return 1; +} +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + +/* + * GETPROP: ECMAScript property read. + */ + +DUK_INTERNAL duk_bool_t duk_hobject_getprop(duk_hthread *thr, duk_tval *tv_obj, duk_tval *tv_key) { + duk_tval tv_obj_copy; + duk_tval tv_key_copy; + duk_hobject *curr = NULL; + duk_hstring *key = NULL; + duk_uint32_t arr_idx = DUK__NO_ARRAY_INDEX; + duk_propdesc desc; + duk_uint_t sanity; + + DUK_DDD(DUK_DDDPRINT("getprop: thr=%p, obj=%p, key=%p (obj -> %!T, key -> %!T)", + (void *) thr, + (void *) tv_obj, + (void *) tv_key, + (duk_tval *) tv_obj, + (duk_tval *) tv_key)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(tv_obj != NULL); + DUK_ASSERT(tv_key != NULL); + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + DUK_STATS_INC(thr->heap, stats_getprop_all); + + /* + * Make a copy of tv_obj, tv_key, and tv_val to avoid any issues of + * them being invalidated by a valstack resize. + * + * XXX: this is now an overkill for many fast paths. Rework this + * to be faster (although switching to a valstack discipline might + * be a better solution overall). + */ + + DUK_TVAL_SET_TVAL(&tv_obj_copy, tv_obj); + DUK_TVAL_SET_TVAL(&tv_key_copy, tv_key); + tv_obj = &tv_obj_copy; + tv_key = &tv_key_copy; + + /* + * Coercion and fast path processing + */ + + switch (DUK_TVAL_GET_TAG(tv_obj)) { + case DUK_TAG_UNDEFINED: + case DUK_TAG_NULL: { + /* Note: unconditional throw */ + DUK_DDD(DUK_DDDPRINT("base object is undefined or null -> reject")); +#if defined(DUK_USE_PARANOID_ERRORS) + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_BASE); +#else + DUK_ERROR_FMT2(thr, + DUK_ERR_TYPE_ERROR, + "cannot read property %s of %s", + duk_push_string_tval_readable(thr, tv_key), + duk_push_string_tval_readable(thr, tv_obj)); +#endif + DUK_WO_NORETURN(return 0;); + break; + } + + case DUK_TAG_BOOLEAN: { + DUK_DDD(DUK_DDDPRINT("base object is a boolean, start lookup from boolean prototype")); + curr = thr->builtins[DUK_BIDX_BOOLEAN_PROTOTYPE]; + break; + } + + case DUK_TAG_STRING: { + duk_hstring *h = DUK_TVAL_GET_STRING(tv_obj); + duk_int_t pop_count; + + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + /* Symbols (ES2015 or hidden) don't have virtual properties. */ + DUK_DDD(DUK_DDDPRINT("base object is a symbol, start lookup from symbol prototype")); + curr = thr->builtins[DUK_BIDX_SYMBOL_PROTOTYPE]; + break; + } + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_key)) { + arr_idx = duk__tval_fastint_to_arr_idx(tv_key); + DUK_DDD(DUK_DDDPRINT("base object string, key is a fast-path fastint; arr_idx %ld", (long) arr_idx)); + pop_count = 0; + } else +#endif + if (DUK_TVAL_IS_NUMBER(tv_key)) { + arr_idx = duk__tval_number_to_arr_idx(tv_key); + DUK_DDD(DUK_DDDPRINT("base object string, key is a fast-path number; arr_idx %ld", (long) arr_idx)); + pop_count = 0; + } else { + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + DUK_DDD(DUK_DDDPRINT("base object string, key is a non-fast-path number; after " + "coercion key is %!T, arr_idx %ld", + (duk_tval *) duk_get_tval(thr, -1), + (long) arr_idx)); + pop_count = 1; + } + + if (arr_idx != DUK__NO_ARRAY_INDEX && arr_idx < DUK_HSTRING_GET_CHARLEN(h)) { + duk_pop_n_unsafe(thr, pop_count); + duk_push_hstring(thr, h); + duk_substring(thr, -1, arr_idx, arr_idx + 1); /* [str] -> [substr] */ + + DUK_STATS_INC(thr->heap, stats_getprop_stringidx); + DUK_DDD(DUK_DDDPRINT("-> %!T (base is string, key is an index inside string length " + "after coercion -> return char)", + (duk_tval *) duk_get_tval(thr, -1))); + return 1; + } + + if (pop_count == 0) { + /* This is a pretty awkward control flow, but we need to recheck the + * key coercion here. + */ + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + DUK_DDD(DUK_DDDPRINT("base object string, key is a non-fast-path number; after " + "coercion key is %!T, arr_idx %ld", + (duk_tval *) duk_get_tval(thr, -1), + (long) arr_idx)); + } + + if (key == DUK_HTHREAD_STRING_LENGTH(thr)) { + duk_pop_unsafe(thr); /* [key] -> [] */ + duk_push_uint(thr, (duk_uint_t) DUK_HSTRING_GET_CHARLEN(h)); /* [] -> [res] */ + + DUK_STATS_INC(thr->heap, stats_getprop_stringlen); + DUK_DDD(DUK_DDDPRINT("-> %!T (base is string, key is 'length' after coercion -> " + "return string length)", + (duk_tval *) duk_get_tval(thr, -1))); + return 1; + } + + DUK_DDD(DUK_DDDPRINT("base object is a string, start lookup from string prototype")); + curr = thr->builtins[DUK_BIDX_STRING_PROTOTYPE]; + goto lookup; /* avoid double coercion */ + } + + case DUK_TAG_OBJECT: { +#if defined(DUK_USE_ARRAY_PROP_FASTPATH) + duk_tval *tmp; +#endif + + curr = DUK_TVAL_GET_OBJECT(tv_obj); + DUK_ASSERT(curr != NULL); + + /* XXX: array .length fast path (important in e.g. loops)? */ + +#if defined(DUK_USE_ARRAY_PROP_FASTPATH) + tmp = duk__getprop_shallow_fastpath_array_tval(thr, curr, tv_key); + if (tmp) { + duk_push_tval(thr, tmp); + + DUK_DDD(DUK_DDDPRINT("-> %!T (base is object, key is a number, array part " + "fast path)", + (duk_tval *) duk_get_tval(thr, -1))); + DUK_STATS_INC(thr->heap, stats_getprop_arrayidx); + return 1; + } +#endif + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + if (duk__getprop_fastpath_bufobj_tval(thr, curr, tv_key) != 0) { + /* Read value pushed on stack. */ + DUK_DDD(DUK_DDDPRINT("-> %!T (base is bufobj, key is a number, bufobj " + "fast path)", + (duk_tval *) duk_get_tval(thr, -1))); + DUK_STATS_INC(thr->heap, stats_getprop_bufobjidx); + return 1; + } +#endif + +#if defined(DUK_USE_ES6_PROXY) + if (DUK_UNLIKELY(DUK_HOBJECT_IS_PROXY(curr))) { + duk_hobject *h_target; + + if (duk__proxy_check_prop(thr, curr, DUK_STRIDX_GET, tv_key, &h_target)) { + /* -> [ ... trap handler ] */ + DUK_DDD(DUK_DDDPRINT("-> proxy object 'get' for key %!T", (duk_tval *) tv_key)); + DUK_STATS_INC(thr->heap, stats_getprop_proxy); + duk_push_hobject(thr, h_target); /* target */ + duk_push_tval(thr, tv_key); /* P */ + duk_push_tval(thr, tv_obj); /* Receiver: Proxy object */ + duk_call_method(thr, 3 /*nargs*/); + + /* Target object must be checked for a conflicting + * non-configurable property. + */ + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + + if (duk__get_own_propdesc_raw(thr, h_target, key, arr_idx, &desc, DUK_GETDESC_FLAG_PUSH_VALUE)) { + duk_tval *tv_hook = duk_require_tval(thr, -3); /* value from hook */ + duk_tval *tv_targ = duk_require_tval(thr, -1); /* value from target */ + duk_bool_t datadesc_reject; + duk_bool_t accdesc_reject; + + DUK_DDD(DUK_DDDPRINT("proxy 'get': target has matching property %!O, check for " + "conflicting property; tv_hook=%!T, tv_targ=%!T, desc.flags=0x%08lx, " + "desc.get=%p, desc.set=%p", + (duk_heaphdr *) key, + (duk_tval *) tv_hook, + (duk_tval *) tv_targ, + (unsigned long) desc.flags, + (void *) desc.get, + (void *) desc.set)); + + datadesc_reject = !(desc.flags & DUK_PROPDESC_FLAG_ACCESSOR) && + !(desc.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && + !(desc.flags & DUK_PROPDESC_FLAG_WRITABLE) && + !duk_js_samevalue(tv_hook, tv_targ); + accdesc_reject = (desc.flags & DUK_PROPDESC_FLAG_ACCESSOR) && + !(desc.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && (desc.get == NULL) && + !DUK_TVAL_IS_UNDEFINED(tv_hook); + if (datadesc_reject || accdesc_reject) { + DUK_ERROR_TYPE(thr, DUK_STR_PROXY_REJECTED); + DUK_WO_NORETURN(return 0;); + } + + duk_pop_2_unsafe(thr); + } else { + duk_pop_unsafe(thr); + } + return 1; /* return value */ + } + + curr = h_target; /* resume lookup from target */ + DUK_TVAL_SET_OBJECT(tv_obj, curr); + } +#endif /* DUK_USE_ES6_PROXY */ + + if (DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(curr)) { + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + + DUK_STATS_INC(thr->heap, stats_getprop_arguments); + if (duk__check_arguments_map_for_get(thr, curr, key, &desc)) { + DUK_DDD(DUK_DDDPRINT("-> %!T (base is object with arguments exotic behavior, " + "key matches magically bound property -> skip standard " + "Get with replacement value)", + (duk_tval *) duk_get_tval(thr, -1))); + + /* no need for 'caller' post-check, because 'key' must be an array index */ + + duk_remove_m2(thr); /* [key result] -> [result] */ + return 1; + } + + goto lookup; /* avoid double coercion */ + } + break; + } + + /* Buffer has virtual properties similar to string, but indexed values + * are numbers, not 1-byte buffers/strings which would perform badly. + */ + case DUK_TAG_BUFFER: { + duk_hbuffer *h = DUK_TVAL_GET_BUFFER(tv_obj); + duk_int_t pop_count; + + /* + * Because buffer values are often looped over, a number fast path + * is important. + */ + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_key)) { + arr_idx = duk__tval_fastint_to_arr_idx(tv_key); + DUK_DDD(DUK_DDDPRINT("base object buffer, key is a fast-path fastint; arr_idx %ld", (long) arr_idx)); + pop_count = 0; + } else +#endif + if (DUK_TVAL_IS_NUMBER(tv_key)) { + arr_idx = duk__tval_number_to_arr_idx(tv_key); + DUK_DDD(DUK_DDDPRINT("base object buffer, key is a fast-path number; arr_idx %ld", (long) arr_idx)); + pop_count = 0; + } else { + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + DUK_DDD(DUK_DDDPRINT("base object buffer, key is a non-fast-path number; after " + "coercion key is %!T, arr_idx %ld", + (duk_tval *) duk_get_tval(thr, -1), + (long) arr_idx)); + pop_count = 1; + } + + if (arr_idx != DUK__NO_ARRAY_INDEX && arr_idx < DUK_HBUFFER_GET_SIZE(h)) { + duk_pop_n_unsafe(thr, pop_count); + duk_push_uint(thr, ((duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h))[arr_idx]); + DUK_STATS_INC(thr->heap, stats_getprop_bufferidx); + DUK_DDD(DUK_DDDPRINT("-> %!T (base is buffer, key is an index inside buffer length " + "after coercion -> return byte as number)", + (duk_tval *) duk_get_tval(thr, -1))); + return 1; + } + + if (pop_count == 0) { + /* This is a pretty awkward control flow, but we need to recheck the + * key coercion here. + */ + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + DUK_DDD(DUK_DDDPRINT("base object buffer, key is a non-fast-path number; after " + "coercion key is %!T, arr_idx %ld", + (duk_tval *) duk_get_tval(thr, -1), + (long) arr_idx)); + } + + if (key == DUK_HTHREAD_STRING_LENGTH(thr)) { + duk_pop_unsafe(thr); /* [key] -> [] */ + duk_push_uint(thr, (duk_uint_t) DUK_HBUFFER_GET_SIZE(h)); /* [] -> [res] */ + DUK_STATS_INC(thr->heap, stats_getprop_bufferlen); + + DUK_DDD(DUK_DDDPRINT("-> %!T (base is buffer, key is 'length' " + "after coercion -> return buffer length)", + (duk_tval *) duk_get_tval(thr, -1))); + return 1; + } + + DUK_DDD(DUK_DDDPRINT("base object is a buffer, start lookup from Uint8Array prototype")); + curr = thr->builtins[DUK_BIDX_UINT8ARRAY_PROTOTYPE]; + goto lookup; /* avoid double coercion */ + } + + case DUK_TAG_POINTER: { + DUK_DDD(DUK_DDDPRINT("base object is a pointer, start lookup from pointer prototype")); + curr = thr->builtins[DUK_BIDX_POINTER_PROTOTYPE]; + break; + } + + case DUK_TAG_LIGHTFUNC: { + /* Lightfuncs inherit getter .name and .length from %NativeFunctionPrototype%. */ + DUK_DDD(DUK_DDDPRINT("base object is a lightfunc, start lookup from function prototype")); + curr = thr->builtins[DUK_BIDX_NATIVE_FUNCTION_PROTOTYPE]; + break; + } + +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: { + /* number */ + DUK_DDD(DUK_DDDPRINT("base object is a number, start lookup from number prototype")); + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv_obj)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_obj)); + curr = thr->builtins[DUK_BIDX_NUMBER_PROTOTYPE]; + break; + } + } + + /* key coercion (unless already coerced above) */ + DUK_ASSERT(key == NULL); + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + /* + * Property lookup + */ + +lookup: + /* [key] (coerced) */ + DUK_ASSERT(curr != NULL); + DUK_ASSERT(key != NULL); + + sanity = DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY; + do { + if (!duk__get_own_propdesc_raw(thr, curr, key, arr_idx, &desc, DUK_GETDESC_FLAG_PUSH_VALUE)) { + goto next_in_chain; + } + + if (desc.get != NULL) { + /* accessor with defined getter */ + DUK_ASSERT((desc.flags & DUK_PROPDESC_FLAG_ACCESSOR) != 0); + + duk_pop_unsafe(thr); /* [key undefined] -> [key] */ + duk_push_hobject(thr, desc.get); + duk_push_tval(thr, tv_obj); /* note: original, uncoerced base */ +#if defined(DUK_USE_NONSTD_GETTER_KEY_ARGUMENT) + duk_dup_m3(thr); + duk_call_method(thr, 1); /* [key getter this key] -> [key retval] */ +#else + duk_call_method(thr, 0); /* [key getter this] -> [key retval] */ +#endif + } else { + /* [key value] or [key undefined] */ + + /* data property or accessor without getter */ + DUK_ASSERT(((desc.flags & DUK_PROPDESC_FLAG_ACCESSOR) == 0) || (desc.get == NULL)); + + /* if accessor without getter, return value is undefined */ + DUK_ASSERT(((desc.flags & DUK_PROPDESC_FLAG_ACCESSOR) == 0) || duk_is_undefined(thr, -1)); + + /* Note: for an accessor without getter, falling through to + * check for "caller" exotic behavior is unnecessary as + * "undefined" will never activate the behavior. But it does + * no harm, so we'll do it anyway. + */ + } + + goto found; /* [key result] */ + + next_in_chain: + /* XXX: option to pretend property doesn't exist if sanity limit is + * hit might be useful. + */ + if (DUK_UNLIKELY(sanity-- == 0)) { + DUK_ERROR_RANGE(thr, DUK_STR_PROTOTYPE_CHAIN_LIMIT); + DUK_WO_NORETURN(return 0;); + } + curr = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, curr); + } while (curr != NULL); + + /* + * Not found + */ + + duk_to_undefined(thr, -1); /* [key] -> [undefined] (default value) */ + + DUK_DDD(DUK_DDDPRINT("-> %!T (not found)", (duk_tval *) duk_get_tval(thr, -1))); + return 0; + + /* + * Found; post-processing (Function and arguments objects) + */ + +found: + /* [key result] */ + +#if !defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) + /* Special behavior for 'caller' property of (non-bound) function objects + * and non-strict Arguments objects: if 'caller' -value- (!) is a strict + * mode function, throw a TypeError (E5 Sections 15.3.5.4, 10.6). + * Quite interestingly, a non-strict function with no formal arguments + * will get an arguments object -without- special 'caller' behavior! + * + * The E5.1 spec is a bit ambiguous if this special behavior applies when + * a bound function is the base value (not the 'caller' value): Section + * 15.3.4.5 (describing bind()) states that [[Get]] for bound functions + * matches that of Section 15.3.5.4 ([[Get]] for Function instances). + * However, Section 13.3.5.4 has "NOTE: Function objects created using + * Function.prototype.bind use the default [[Get]] internal method." + * The current implementation assumes this means that bound functions + * should not have the special [[Get]] behavior. + * + * The E5.1 spec is also a bit unclear if the TypeError throwing is + * applied if the 'caller' value is a strict bound function. The + * current implementation will throw even for both strict non-bound + * and strict bound functions. + * + * See test-dev-strict-func-as-caller-prop-value.js for quite extensive + * tests. + * + * This exotic behavior is disabled when the non-standard 'caller' property + * is enabled, as it conflicts with the free use of 'caller'. + */ + if (key == DUK_HTHREAD_STRING_CALLER(thr) && DUK_TVAL_IS_OBJECT(tv_obj)) { + duk_hobject *orig = DUK_TVAL_GET_OBJECT(tv_obj); + DUK_ASSERT(orig != NULL); + + if (DUK_HOBJECT_IS_NONBOUND_FUNCTION(orig) || DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(orig)) { + duk_hobject *h; + + /* XXX: The TypeError is currently not applied to bound + * functions because the 'strict' flag is not copied by + * bind(). This may or may not be correct, the specification + * only refers to the value being a "strict mode Function + * object" which is ambiguous. + */ + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(orig)); + + h = duk_get_hobject(thr, -1); /* NULL if not an object */ + if (h && DUK_HOBJECT_IS_FUNCTION(h) && DUK_HOBJECT_HAS_STRICT(h)) { + /* XXX: sufficient to check 'strict', assert for 'is function' */ + DUK_ERROR_TYPE(thr, DUK_STR_STRICT_CALLER_READ); + DUK_WO_NORETURN(return 0;); + } + } + } +#endif /* !DUK_USE_NONSTD_FUNC_CALLER_PROPERTY */ + + duk_remove_m2(thr); /* [key result] -> [result] */ + + DUK_DDD(DUK_DDDPRINT("-> %!T (found)", (duk_tval *) duk_get_tval(thr, -1))); + return 1; +} + +/* + * HASPROP: ECMAScript property existence check ("in" operator). + * + * Interestingly, the 'in' operator does not do any coercion of + * the target object. + */ + +DUK_INTERNAL duk_bool_t duk_hobject_hasprop(duk_hthread *thr, duk_tval *tv_obj, duk_tval *tv_key) { + duk_tval tv_key_copy; + duk_hobject *obj; + duk_hstring *key; + duk_uint32_t arr_idx; + duk_bool_t rc; + duk_propdesc desc; + + DUK_DDD(DUK_DDDPRINT("hasprop: thr=%p, obj=%p, key=%p (obj -> %!T, key -> %!T)", + (void *) thr, + (void *) tv_obj, + (void *) tv_key, + (duk_tval *) tv_obj, + (duk_tval *) tv_key)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(tv_obj != NULL); + DUK_ASSERT(tv_key != NULL); + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + DUK_TVAL_SET_TVAL(&tv_key_copy, tv_key); + tv_key = &tv_key_copy; + + /* + * The 'in' operator requires an object as its right hand side, + * throwing a TypeError unconditionally if this is not the case. + * + * However, lightfuncs need to behave like fully fledged objects + * here to be maximally transparent, so we need to handle them + * here. Same goes for plain buffers which behave like ArrayBuffers. + */ + + /* XXX: Refactor key coercion so that it's only called once. It can't + * be trivially lifted here because the object must be type checked + * first. + */ + + if (DUK_TVAL_IS_OBJECT(tv_obj)) { + obj = DUK_TVAL_GET_OBJECT(tv_obj); + DUK_ASSERT(obj != NULL); + + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + } else if (DUK_TVAL_IS_BUFFER(tv_obj)) { + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + if (duk__key_is_plain_buf_ownprop(thr, DUK_TVAL_GET_BUFFER(tv_obj), key, arr_idx)) { + rc = 1; + goto pop_and_return; + } + obj = thr->builtins[DUK_BIDX_UINT8ARRAY_PROTOTYPE]; + } else if (DUK_TVAL_IS_LIGHTFUNC(tv_obj)) { + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + + /* If not found, resume existence check from %NativeFunctionPrototype%. + * We can just substitute the value in this case; nothing will + * need the original base value (as would be the case with e.g. + * setters/getters. + */ + obj = thr->builtins[DUK_BIDX_NATIVE_FUNCTION_PROTOTYPE]; + } else { + /* Note: unconditional throw */ + DUK_DDD(DUK_DDDPRINT("base object is not an object -> reject")); + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_BASE); + DUK_WO_NORETURN(return 0;); + } + + /* XXX: fast path for arrays? */ + + DUK_ASSERT(key != NULL); + DUK_ASSERT(obj != NULL); + DUK_UNREF(arr_idx); + +#if defined(DUK_USE_ES6_PROXY) + if (DUK_UNLIKELY(DUK_HOBJECT_IS_PROXY(obj))) { + duk_hobject *h_target; + duk_bool_t tmp_bool; + + /* XXX: the key in 'key in obj' is string coerced before we're called + * (which is the required behavior in E5/E5.1/E6) so the key is a string + * here already. + */ + + if (duk__proxy_check_prop(thr, obj, DUK_STRIDX_HAS, tv_key, &h_target)) { + /* [ ... key trap handler ] */ + DUK_DDD(DUK_DDDPRINT("-> proxy object 'has' for key %!T", (duk_tval *) tv_key)); + duk_push_hobject(thr, h_target); /* target */ + duk_push_tval(thr, tv_key); /* P */ + duk_call_method(thr, 2 /*nargs*/); + tmp_bool = duk_to_boolean_top_pop(thr); + if (!tmp_bool) { + /* Target object must be checked for a conflicting + * non-configurable property. + */ + + if (duk__get_own_propdesc_raw(thr, h_target, key, arr_idx, &desc, 0 /*flags*/)) { /* don't push + value */ + DUK_DDD(DUK_DDDPRINT("proxy 'has': target has matching property %!O, check for " + "conflicting property; desc.flags=0x%08lx, " + "desc.get=%p, desc.set=%p", + (duk_heaphdr *) key, + (unsigned long) desc.flags, + (void *) desc.get, + (void *) desc.set)); + /* XXX: Extensibility check for target uses IsExtensible(). If we + * implemented the isExtensible trap and didn't reject proxies as + * proxy targets, it should be respected here. + */ + if (!((desc.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && /* property is configurable and */ + DUK_HOBJECT_HAS_EXTENSIBLE(h_target))) { /* ... target is extensible */ + DUK_ERROR_TYPE(thr, DUK_STR_PROXY_REJECTED); + DUK_WO_NORETURN(return 0;); + } + } + } + + duk_pop_unsafe(thr); /* [ key ] -> [] */ + return tmp_bool; + } + + obj = h_target; /* resume check from proxy target */ + } +#endif /* DUK_USE_ES6_PROXY */ + + /* XXX: inline into a prototype walking loop? */ + + rc = duk__get_propdesc(thr, obj, key, &desc, 0 /*flags*/); /* don't push value */ + /* fall through */ + +pop_and_return: + duk_pop_unsafe(thr); /* [ key ] -> [] */ + return rc; +} + +/* + * HASPROP variant used internally. + * + * This primitive must never throw an error, callers rely on this. + * In particular, don't throw an error for prototype loops; instead, + * pretend like the property doesn't exist if a prototype sanity limit + * is reached. + * + * Does not implement proxy behavior: if applied to a proxy object, + * returns key existence on the proxy object itself. + */ + +DUK_INTERNAL duk_bool_t duk_hobject_hasprop_raw(duk_hthread *thr, duk_hobject *obj, duk_hstring *key) { + duk_propdesc dummy; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + return duk__get_propdesc(thr, obj, key, &dummy, DUK_GETDESC_FLAG_IGNORE_PROTOLOOP); /* don't push value */ +} + +/* + * Helper: handle Array object 'length' write which automatically + * deletes properties, see E5 Section 15.4.5.1, step 3. This is + * quite tricky to get right. + * + * Used by duk_hobject_putprop(). + */ + +/* Coerce a new .length candidate to a number and check that it's a valid + * .length. + */ +DUK_LOCAL duk_uint32_t duk__to_new_array_length_checked(duk_hthread *thr, duk_tval *tv) { + duk_uint32_t res; + duk_double_t d; + +#if !defined(DUK_USE_PREFER_SIZE) +#if defined(DUK_USE_FASTINT) + /* When fastints are enabled, the most interesting case is assigning + * a fastint to .length (e.g. arr.length = 0). + */ + if (DUK_TVAL_IS_FASTINT(tv)) { + /* Very common case. */ + duk_int64_t fi; + fi = DUK_TVAL_GET_FASTINT(tv); + if (fi < 0 || fi > DUK_I64_CONSTANT(0xffffffff)) { + goto fail_range; + } + return (duk_uint32_t) fi; + } +#else /* DUK_USE_FASTINT */ + /* When fastints are not enabled, the most interesting case is any + * number. + */ + if (DUK_TVAL_IS_DOUBLE(tv)) { + d = DUK_TVAL_GET_NUMBER(tv); + } +#endif /* DUK_USE_FASTINT */ + else +#endif /* !DUK_USE_PREFER_SIZE */ + { + /* In all other cases, and when doing a size optimized build, + * fall back to the comprehensive handler. + */ + d = duk_js_tonumber(thr, tv); + } + + /* Refuse to update an Array's 'length' to a value outside the + * 32-bit range. Negative zero is accepted as zero. + */ + res = duk_double_to_uint32_t(d); + if (!duk_double_equals((duk_double_t) res, d)) { + goto fail_range; + } + + return res; + +fail_range: + DUK_ERROR_RANGE(thr, DUK_STR_INVALID_ARRAY_LENGTH); + DUK_WO_NORETURN(return 0;); +} + +/* Delete elements required by a smaller length, taking into account + * potentially non-configurable elements. Returns non-zero if all + * elements could be deleted, and zero if all or some elements could + * not be deleted. Also writes final "target length" to 'out_result_len'. + * This is the length value that should go into the 'length' property + * (must be set by the caller). Never throws an error. + */ +DUK_LOCAL +duk_bool_t duk__handle_put_array_length_smaller(duk_hthread *thr, + duk_hobject *obj, + duk_uint32_t old_len, + duk_uint32_t new_len, + duk_bool_t force_flag, + duk_uint32_t *out_result_len) { + duk_uint32_t target_len; + duk_uint_fast32_t i; + duk_uint32_t arr_idx; + duk_hstring *key; + duk_tval *tv; + duk_bool_t rc; + + DUK_DDD(DUK_DDDPRINT("new array length smaller than old (%ld -> %ld), " + "probably need to remove elements", + (long) old_len, + (long) new_len)); + + /* + * New length is smaller than old length, need to delete properties above + * the new length. + * + * If array part exists, this is straightforward: array entries cannot + * be non-configurable so this is guaranteed to work. + * + * If array part does not exist, array-indexed values are scattered + * in the entry part, and some may not be configurable (preventing length + * from becoming lower than their index + 1). To handle the algorithm + * in E5 Section 15.4.5.1, step l correctly, we scan the entire property + * set twice. + */ + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(new_len < old_len); + DUK_ASSERT(out_result_len != NULL); + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + DUK_ASSERT(DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)); + DUK_ASSERT(DUK_HOBJECT_IS_ARRAY(obj)); + + if (DUK_HOBJECT_HAS_ARRAY_PART(obj)) { + /* + * All defined array-indexed properties are in the array part + * (we assume the array part is comprehensive), and all array + * entries are writable, configurable, and enumerable. Thus, + * nothing can prevent array entries from being deleted. + */ + + DUK_DDD(DUK_DDDPRINT("have array part, easy case")); + + if (old_len < DUK_HOBJECT_GET_ASIZE(obj)) { + /* XXX: assertion that entries >= old_len are already unused */ + i = old_len; + } else { + i = DUK_HOBJECT_GET_ASIZE(obj); + } + DUK_ASSERT(i <= DUK_HOBJECT_GET_ASIZE(obj)); + + while (i > new_len) { + i--; + tv = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, i); + DUK_TVAL_SET_UNUSED_UPDREF(thr, tv); /* side effects */ + } + + *out_result_len = new_len; + return 1; + } else { + /* + * Entries part is a bit more complex. + */ + + /* Stage 1: find highest preventing non-configurable entry (if any). + * When forcing, ignore non-configurability. + */ + + DUK_DDD(DUK_DDDPRINT("no array part, slow case")); + + DUK_DDD(DUK_DDDPRINT("array length write, no array part, stage 1: find target_len " + "(highest preventing non-configurable entry (if any))")); + + target_len = new_len; + if (force_flag) { + DUK_DDD(DUK_DDDPRINT("array length write, no array part; force flag -> skip stage 1")); + goto skip_stage1; + } + for (i = 0; i < DUK_HOBJECT_GET_ENEXT(obj); i++) { + key = DUK_HOBJECT_E_GET_KEY(thr->heap, obj, i); + if (!key) { + DUK_DDD(DUK_DDDPRINT("skip entry index %ld: null key", (long) i)); + continue; + } + if (!DUK_HSTRING_HAS_ARRIDX(key)) { + DUK_DDD(DUK_DDDPRINT("skip entry index %ld: key not an array index", (long) i)); + continue; + } + + DUK_ASSERT( + DUK_HSTRING_HAS_ARRIDX(key)); /* XXX: macro checks for array index flag, which is unnecessary here */ + arr_idx = DUK_HSTRING_GET_ARRIDX_SLOW(key); + DUK_ASSERT(arr_idx != DUK__NO_ARRAY_INDEX); + DUK_ASSERT(arr_idx < old_len); /* consistency requires this */ + + if (arr_idx < new_len) { + DUK_DDD(DUK_DDDPRINT("skip entry index %ld: key is array index %ld, below new_len", + (long) i, + (long) arr_idx)); + continue; + } + if (DUK_HOBJECT_E_SLOT_IS_CONFIGURABLE(thr->heap, obj, i)) { + DUK_DDD(DUK_DDDPRINT("skip entry index %ld: key is a relevant array index %ld, but configurable", + (long) i, + (long) arr_idx)); + continue; + } + + /* relevant array index is non-configurable, blocks write */ + if (arr_idx >= target_len) { + DUK_DDD(DUK_DDDPRINT("entry at index %ld has arr_idx %ld, is not configurable, " + "update target_len %ld -> %ld", + (long) i, + (long) arr_idx, + (long) target_len, + (long) (arr_idx + 1))); + target_len = arr_idx + 1; + } + } + skip_stage1: + + /* stage 2: delete configurable entries above target length */ + + DUK_DDD( + DUK_DDDPRINT("old_len=%ld, new_len=%ld, target_len=%ld", (long) old_len, (long) new_len, (long) target_len)); + + DUK_DDD(DUK_DDDPRINT("array length write, no array part, stage 2: remove " + "entries >= target_len")); + + for (i = 0; i < DUK_HOBJECT_GET_ENEXT(obj); i++) { + key = DUK_HOBJECT_E_GET_KEY(thr->heap, obj, i); + if (!key) { + DUK_DDD(DUK_DDDPRINT("skip entry index %ld: null key", (long) i)); + continue; + } + if (!DUK_HSTRING_HAS_ARRIDX(key)) { + DUK_DDD(DUK_DDDPRINT("skip entry index %ld: key not an array index", (long) i)); + continue; + } + + DUK_ASSERT( + DUK_HSTRING_HAS_ARRIDX(key)); /* XXX: macro checks for array index flag, which is unnecessary here */ + arr_idx = DUK_HSTRING_GET_ARRIDX_SLOW(key); + DUK_ASSERT(arr_idx != DUK__NO_ARRAY_INDEX); + DUK_ASSERT(arr_idx < old_len); /* consistency requires this */ + + if (arr_idx < target_len) { + DUK_DDD(DUK_DDDPRINT("skip entry index %ld: key is array index %ld, below target_len", + (long) i, + (long) arr_idx)); + continue; + } + DUK_ASSERT(force_flag || DUK_HOBJECT_E_SLOT_IS_CONFIGURABLE(thr->heap, obj, i)); /* stage 1 guarantees */ + + DUK_DDD(DUK_DDDPRINT("delete entry index %ld: key is array index %ld", (long) i, (long) arr_idx)); + + /* + * Slow delete, but we don't care as we're already in a very slow path. + * The delete always succeeds: key has no exotic behavior, property + * is configurable, and no resize occurs. + */ + rc = duk_hobject_delprop_raw(thr, obj, key, force_flag ? DUK_DELPROP_FLAG_FORCE : 0); + DUK_UNREF(rc); + DUK_ASSERT(rc != 0); + } + + /* stage 3: update length (done by caller), decide return code */ + + DUK_DDD(DUK_DDDPRINT("array length write, no array part, stage 3: update length (done by caller)")); + + *out_result_len = target_len; + + if (target_len == new_len) { + DUK_DDD(DUK_DDDPRINT("target_len matches new_len, return success")); + return 1; + } + DUK_DDD(DUK_DDDPRINT("target_len does not match new_len (some entry prevented " + "full length adjustment), return error")); + return 0; + } + + DUK_UNREACHABLE(); +} + +/* XXX: is valstack top best place for argument? */ +DUK_LOCAL duk_bool_t duk__handle_put_array_length(duk_hthread *thr, duk_hobject *obj) { + duk_harray *a; + duk_uint32_t old_len; + duk_uint32_t new_len; + duk_uint32_t result_len; + duk_bool_t rc; + + DUK_DDD(DUK_DDDPRINT("handling a put operation to array 'length' exotic property, " + "new val: %!T", + (duk_tval *) duk_get_tval(thr, -1))); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(obj != NULL); + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + DUK_ASSERT(DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)); + DUK_ASSERT(DUK_HOBJECT_IS_ARRAY(obj)); + a = (duk_harray *) obj; + DUK_HARRAY_ASSERT_VALID(a); + + DUK_ASSERT(duk_is_valid_index(thr, -1)); + + /* + * Get old and new length + */ + + old_len = a->length; + new_len = duk__to_new_array_length_checked(thr, DUK_GET_TVAL_NEGIDX(thr, -1)); + DUK_DDD(DUK_DDDPRINT("old_len=%ld, new_len=%ld", (long) old_len, (long) new_len)); + + /* + * Writability check + */ + + if (DUK_HARRAY_LENGTH_NONWRITABLE(a)) { + DUK_DDD(DUK_DDDPRINT("length is not writable, fail")); + return 0; + } + + /* + * New length not lower than old length => no changes needed + * (not even array allocation). + */ + + if (new_len >= old_len) { + DUK_DDD(DUK_DDDPRINT("new length is same or higher than old length, just update length, no deletions")); + a->length = new_len; + return 1; + } + + DUK_DDD(DUK_DDDPRINT("new length is lower than old length, probably must delete entries")); + + /* + * New length lower than old length => delete elements, then + * update length. + * + * Note: even though a bunch of elements have been deleted, the 'desc' is + * still valid as properties haven't been resized (and entries compacted). + */ + + rc = duk__handle_put_array_length_smaller(thr, obj, old_len, new_len, 0 /*force_flag*/, &result_len); + DUK_ASSERT(result_len >= new_len && result_len <= old_len); + + a->length = result_len; + + /* XXX: shrink array allocation or entries compaction here? */ + + return rc; +} + +/* + * PUTPROP: ECMAScript property write. + * + * Unlike ECMAScript primitive which returns nothing, returns 1 to indicate + * success and 0 to indicate failure (assuming throw is not set). + * + * This is an extremely tricky function. Some examples: + * + * * Currently a decref may trigger a GC, which may compact an object's + * property allocation. Consequently, any entry indices (e_idx) will + * be potentially invalidated by a decref. + * + * * Exotic behaviors (strings, arrays, arguments object) require, + * among other things: + * + * - Preprocessing before and postprocessing after an actual property + * write. For example, array index write requires pre-checking the + * array 'length' property for access control, and may require an + * array 'length' update after the actual write has succeeded (but + * not if it fails). + * + * - Deletion of multiple entries, as a result of array 'length' write. + * + * * Input values are taken as pointers which may point to the valstack. + * If valstack is resized because of the put (this may happen at least + * when the array part is abandoned), the pointers can be invalidated. + * (We currently make a copy of all of the input values to avoid issues.) + */ + +DUK_INTERNAL duk_bool_t +duk_hobject_putprop(duk_hthread *thr, duk_tval *tv_obj, duk_tval *tv_key, duk_tval *tv_val, duk_bool_t throw_flag) { + duk_tval tv_obj_copy; + duk_tval tv_key_copy; + duk_tval tv_val_copy; + duk_hobject *orig = NULL; /* NULL if tv_obj is primitive */ + duk_hobject *curr; + duk_hstring *key = NULL; + duk_propdesc desc; + duk_tval *tv; + duk_uint32_t arr_idx; + duk_bool_t rc; + duk_int_t e_idx; + duk_uint_t sanity; + duk_uint32_t new_array_length = 0; /* 0 = no update */ + + DUK_DDD(DUK_DDDPRINT("putprop: thr=%p, obj=%p, key=%p, val=%p, throw=%ld " + "(obj -> %!T, key -> %!T, val -> %!T)", + (void *) thr, + (void *) tv_obj, + (void *) tv_key, + (void *) tv_val, + (long) throw_flag, + (duk_tval *) tv_obj, + (duk_tval *) tv_key, + (duk_tval *) tv_val)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(tv_obj != NULL); + DUK_ASSERT(tv_key != NULL); + DUK_ASSERT(tv_val != NULL); + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + DUK_STATS_INC(thr->heap, stats_putprop_all); + + /* + * Make a copy of tv_obj, tv_key, and tv_val to avoid any issues of + * them being invalidated by a valstack resize. + * + * XXX: this is an overkill for some paths, so optimize this later + * (or maybe switch to a stack arguments model entirely). + */ + + DUK_TVAL_SET_TVAL(&tv_obj_copy, tv_obj); + DUK_TVAL_SET_TVAL(&tv_key_copy, tv_key); + DUK_TVAL_SET_TVAL(&tv_val_copy, tv_val); + tv_obj = &tv_obj_copy; + tv_key = &tv_key_copy; + tv_val = &tv_val_copy; + + /* + * Coercion and fast path processing. + */ + + switch (DUK_TVAL_GET_TAG(tv_obj)) { + case DUK_TAG_UNDEFINED: + case DUK_TAG_NULL: { + /* Note: unconditional throw */ + DUK_DDD(DUK_DDDPRINT("base object is undefined or null -> reject (object=%!iT)", (duk_tval *) tv_obj)); +#if defined(DUK_USE_PARANOID_ERRORS) + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_BASE); +#else + DUK_ERROR_FMT2(thr, + DUK_ERR_TYPE_ERROR, + "cannot write property %s of %s", + duk_push_string_tval_readable(thr, tv_key), + duk_push_string_tval_readable(thr, tv_obj)); +#endif + DUK_WO_NORETURN(return 0;); + break; + } + + case DUK_TAG_BOOLEAN: { + DUK_DDD(DUK_DDDPRINT("base object is a boolean, start lookup from boolean prototype")); + curr = thr->builtins[DUK_BIDX_BOOLEAN_PROTOTYPE]; + break; + } + + case DUK_TAG_STRING: { + duk_hstring *h = DUK_TVAL_GET_STRING(tv_obj); + + /* + * Note: currently no fast path for array index writes. + * They won't be possible anyway as strings are immutable. + */ + + DUK_ASSERT(key == NULL); + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + /* Symbols (ES2015 or hidden) don't have virtual properties. */ + curr = thr->builtins[DUK_BIDX_SYMBOL_PROTOTYPE]; + goto lookup; + } + + if (key == DUK_HTHREAD_STRING_LENGTH(thr)) { + goto fail_not_writable; + } + + if (arr_idx != DUK__NO_ARRAY_INDEX && arr_idx < DUK_HSTRING_GET_CHARLEN(h)) { + goto fail_not_writable; + } + + DUK_DDD(DUK_DDDPRINT("base object is a string, start lookup from string prototype")); + curr = thr->builtins[DUK_BIDX_STRING_PROTOTYPE]; + goto lookup; /* avoid double coercion */ + } + + case DUK_TAG_OBJECT: { + orig = DUK_TVAL_GET_OBJECT(tv_obj); + DUK_ASSERT(orig != NULL); + +#if defined(DUK_USE_ROM_OBJECTS) + /* With this check in place fast paths won't need read-only + * object checks. This is technically incorrect if there are + * setters that cause no writes to ROM objects, but current + * built-ins don't have such setters. + */ + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) orig)) { + DUK_DD(DUK_DDPRINT("attempt to putprop on read-only target object")); + goto fail_not_writable_no_pop; /* Must avoid duk_pop() in exit path */ + } +#endif + + /* The fast path for array property put is not fully compliant: + * If one places conflicting number-indexed properties into + * Array.prototype (for example, a non-writable Array.prototype[7]) + * the fast path will incorrectly ignore them. + * + * This fast path could be made compliant by falling through + * to the slow path if the previous value was UNUSED. This would + * also remove the need to check for extensibility. Right now a + * non-extensible array is slower than an extensible one as far + * as writes are concerned. + * + * The fast path behavior is documented in more detail here: + * tests/ecmascript/test-misc-array-fast-write.js + */ + + /* XXX: array .length? */ + +#if defined(DUK_USE_ARRAY_PROP_FASTPATH) + if (duk__putprop_shallow_fastpath_array_tval(thr, orig, tv_key, tv_val) != 0) { + DUK_DDD(DUK_DDDPRINT("array fast path success")); + DUK_STATS_INC(thr->heap, stats_putprop_arrayidx); + return 1; + } +#endif + +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + if (duk__putprop_fastpath_bufobj_tval(thr, orig, tv_key, tv_val) != 0) { + DUK_DDD(DUK_DDDPRINT("base is bufobj, key is a number, bufobj fast path")); + DUK_STATS_INC(thr->heap, stats_putprop_bufobjidx); + return 1; + } +#endif + +#if defined(DUK_USE_ES6_PROXY) + if (DUK_UNLIKELY(DUK_HOBJECT_IS_PROXY(orig))) { + duk_hobject *h_target; + duk_bool_t tmp_bool; + + if (duk__proxy_check_prop(thr, orig, DUK_STRIDX_SET, tv_key, &h_target)) { + /* -> [ ... trap handler ] */ + DUK_DDD(DUK_DDDPRINT("-> proxy object 'set' for key %!T", (duk_tval *) tv_key)); + DUK_STATS_INC(thr->heap, stats_putprop_proxy); + duk_push_hobject(thr, h_target); /* target */ + duk_push_tval(thr, tv_key); /* P */ + duk_push_tval(thr, tv_val); /* V */ + duk_push_tval(thr, tv_obj); /* Receiver: Proxy object */ + duk_call_method(thr, 4 /*nargs*/); + tmp_bool = duk_to_boolean_top_pop(thr); + if (!tmp_bool) { + goto fail_proxy_rejected; + } + + /* Target object must be checked for a conflicting + * non-configurable property. + */ + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + + if (duk__get_own_propdesc_raw(thr, h_target, key, arr_idx, &desc, DUK_GETDESC_FLAG_PUSH_VALUE)) { + duk_tval *tv_targ = duk_require_tval(thr, -1); + duk_bool_t datadesc_reject; + duk_bool_t accdesc_reject; + + DUK_DDD(DUK_DDDPRINT("proxy 'set': target has matching property %!O, check for " + "conflicting property; tv_val=%!T, tv_targ=%!T, desc.flags=0x%08lx, " + "desc.get=%p, desc.set=%p", + (duk_heaphdr *) key, + (duk_tval *) tv_val, + (duk_tval *) tv_targ, + (unsigned long) desc.flags, + (void *) desc.get, + (void *) desc.set)); + + datadesc_reject = !(desc.flags & DUK_PROPDESC_FLAG_ACCESSOR) && + !(desc.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && + !(desc.flags & DUK_PROPDESC_FLAG_WRITABLE) && + !duk_js_samevalue(tv_val, tv_targ); + accdesc_reject = (desc.flags & DUK_PROPDESC_FLAG_ACCESSOR) && + !(desc.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && (desc.set == NULL); + if (datadesc_reject || accdesc_reject) { + DUK_ERROR_TYPE(thr, DUK_STR_PROXY_REJECTED); + DUK_WO_NORETURN(return 0;); + } + + duk_pop_2_unsafe(thr); + } else { + duk_pop_unsafe(thr); + } + return 1; /* success */ + } + + orig = h_target; /* resume write to target */ + DUK_TVAL_SET_OBJECT(tv_obj, orig); + } +#endif /* DUK_USE_ES6_PROXY */ + + curr = orig; + break; + } + + case DUK_TAG_BUFFER: { + duk_hbuffer *h = DUK_TVAL_GET_BUFFER(tv_obj); + duk_int_t pop_count = 0; + + /* + * Because buffer values may be looped over and read/written + * from, an array index fast path is important. + */ + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_key)) { + arr_idx = duk__tval_fastint_to_arr_idx(tv_key); + DUK_DDD(DUK_DDDPRINT("base object buffer, key is a fast-path fastint; arr_idx %ld", (long) arr_idx)); + pop_count = 0; + } else +#endif + if (DUK_TVAL_IS_NUMBER(tv_key)) { + arr_idx = duk__tval_number_to_arr_idx(tv_key); + DUK_DDD(DUK_DDDPRINT("base object buffer, key is a fast-path number; arr_idx %ld", (long) arr_idx)); + pop_count = 0; + } else { + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + DUK_DDD(DUK_DDDPRINT("base object buffer, key is a non-fast-path number; after " + "coercion key is %!T, arr_idx %ld", + (duk_tval *) duk_get_tval(thr, -1), + (long) arr_idx)); + pop_count = 1; + } + + if (arr_idx != DUK__NO_ARRAY_INDEX && arr_idx < DUK_HBUFFER_GET_SIZE(h)) { + duk_uint8_t *data; + DUK_DDD(DUK_DDDPRINT("writing to buffer data at index %ld", (long) arr_idx)); + data = (duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h); + + /* XXX: duk_to_int() ensures we'll get 8 lowest bits as + * as input is within duk_int_t range (capped outside it). + */ +#if defined(DUK_USE_FASTINT) + /* Buffer writes are often integers. */ + if (DUK_TVAL_IS_FASTINT(tv_val)) { + data[arr_idx] = (duk_uint8_t) DUK_TVAL_GET_FASTINT_U32(tv_val); + } else +#endif + { + duk_push_tval(thr, tv_val); + data[arr_idx] = (duk_uint8_t) duk_to_uint32(thr, -1); + pop_count++; + } + + duk_pop_n_unsafe(thr, pop_count); + DUK_DDD(DUK_DDDPRINT("result: success (buffer data write)")); + DUK_STATS_INC(thr->heap, stats_putprop_bufferidx); + return 1; + } + + if (pop_count == 0) { + /* This is a pretty awkward control flow, but we need to recheck the + * key coercion here. + */ + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + DUK_DDD(DUK_DDDPRINT("base object buffer, key is a non-fast-path number; after " + "coercion key is %!T, arr_idx %ld", + (duk_tval *) duk_get_tval(thr, -1), + (long) arr_idx)); + } + + if (key == DUK_HTHREAD_STRING_LENGTH(thr)) { + goto fail_not_writable; + } + + DUK_DDD(DUK_DDDPRINT("base object is a buffer, start lookup from Uint8Array prototype")); + curr = thr->builtins[DUK_BIDX_UINT8ARRAY_PROTOTYPE]; + goto lookup; /* avoid double coercion */ + } + + case DUK_TAG_POINTER: { + DUK_DDD(DUK_DDDPRINT("base object is a pointer, start lookup from pointer prototype")); + curr = thr->builtins[DUK_BIDX_POINTER_PROTOTYPE]; + break; + } + + case DUK_TAG_LIGHTFUNC: { + /* Lightfuncs have no own properties and are considered non-extensible. + * However, the write may be captured by an inherited setter which + * means we can't stop the lookup here. + */ + DUK_DDD(DUK_DDDPRINT("base object is a lightfunc, start lookup from function prototype")); + curr = thr->builtins[DUK_BIDX_NATIVE_FUNCTION_PROTOTYPE]; + break; + } + +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: { + /* number */ + DUK_DDD(DUK_DDDPRINT("base object is a number, start lookup from number prototype")); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_obj)); + curr = thr->builtins[DUK_BIDX_NUMBER_PROTOTYPE]; + break; + } + } + + DUK_ASSERT(key == NULL); + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + +lookup: + + /* + * Check whether the property already exists in the prototype chain. + * Note that the actual write goes into the original base object + * (except if an accessor property captures the write). + */ + + /* [key] */ + + DUK_ASSERT(curr != NULL); + sanity = DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY; + do { + if (!duk__get_own_propdesc_raw(thr, curr, key, arr_idx, &desc, 0 /*flags*/)) { /* don't push value */ + goto next_in_chain; + } + + if (desc.flags & DUK_PROPDESC_FLAG_ACCESSOR) { + /* + * Found existing accessor property (own or inherited). + * Call setter with 'this' set to orig, and value as the only argument. + * Setter calls are OK even for ROM objects. + * + * Note: no exotic arguments object behavior, because [[Put]] never + * calls [[DefineOwnProperty]] (E5 Section 8.12.5, step 5.b). + */ + + duk_hobject *setter; + + DUK_DD(DUK_DDPRINT("put to an own or inherited accessor, calling setter")); + + setter = DUK_HOBJECT_E_GET_VALUE_SETTER(thr->heap, curr, desc.e_idx); + if (!setter) { + goto fail_no_setter; + } + duk_push_hobject(thr, setter); + duk_push_tval(thr, tv_obj); /* note: original, uncoerced base */ + duk_push_tval(thr, tv_val); /* [key setter this val] */ +#if defined(DUK_USE_NONSTD_SETTER_KEY_ARGUMENT) + duk_dup_m4(thr); + duk_call_method(thr, 2); /* [key setter this val key] -> [key retval] */ +#else + duk_call_method(thr, 1); /* [key setter this val] -> [key retval] */ +#endif + duk_pop_unsafe(thr); /* ignore retval -> [key] */ + goto success_no_arguments_exotic; + } + + if (orig == NULL) { + /* + * Found existing own or inherited plain property, but original + * base is a primitive value. + */ + DUK_DD(DUK_DDPRINT("attempt to create a new property in a primitive base object")); + goto fail_base_primitive; + } + + if (curr != orig) { + /* + * Found existing inherited plain property. + * Do an access control check, and if OK, write + * new property to 'orig'. + */ + if (!DUK_HOBJECT_HAS_EXTENSIBLE(orig)) { + DUK_DD( + DUK_DDPRINT("found existing inherited plain property, but original object is not extensible")); + goto fail_not_extensible; + } + if (!(desc.flags & DUK_PROPDESC_FLAG_WRITABLE)) { + DUK_DD(DUK_DDPRINT("found existing inherited plain property, original object is extensible, but " + "inherited property is not writable")); + goto fail_not_writable; + } + DUK_DD(DUK_DDPRINT("put to new property, object extensible, inherited property found and is writable")); + goto create_new; + } else { + /* + * Found existing own (non-inherited) plain property. + * Do an access control check and update in place. + */ + + if (!(desc.flags & DUK_PROPDESC_FLAG_WRITABLE)) { + DUK_DD( + DUK_DDPRINT("found existing own (non-inherited) plain property, but property is not writable")); + goto fail_not_writable; + } + if (desc.flags & DUK_PROPDESC_FLAG_VIRTUAL) { + DUK_DD(DUK_DDPRINT("found existing own (non-inherited) virtual property, property is writable")); + + if (DUK_HOBJECT_IS_ARRAY(curr)) { + /* + * Write to 'length' of an array is a very complex case + * handled in a helper which updates both the array elements + * and writes the new 'length'. The write may result in an + * unconditional RangeError or a partial write (indicated + * by a return code). + * + * Note: the helper has an unnecessary writability check + * for 'length', we already know it is writable. + */ + DUK_ASSERT(key == DUK_HTHREAD_STRING_LENGTH(thr)); /* only virtual array property */ + + DUK_DDD(DUK_DDDPRINT( + "writing existing 'length' property to array exotic, invoke complex helper")); + + /* XXX: the helper currently assumes stack top contains new + * 'length' value and the whole calling convention is not very + * compatible with what we need. + */ + + duk_push_tval(thr, tv_val); /* [key val] */ + rc = duk__handle_put_array_length(thr, orig); + duk_pop_unsafe(thr); /* [key val] -> [key] */ + if (!rc) { + goto fail_array_length_partial; + } + + /* key is 'length', cannot match argument exotic behavior */ + goto success_no_arguments_exotic; + } +#if defined(DUK_USE_BUFFEROBJECT_SUPPORT) + else if (DUK_HOBJECT_IS_BUFOBJ(curr)) { + duk_hbufobj *h_bufobj; + duk_uint_t byte_off; + duk_small_uint_t elem_size; + + h_bufobj = (duk_hbufobj *) curr; + DUK_HBUFOBJ_ASSERT_VALID(h_bufobj); + + DUK_DD(DUK_DDPRINT("writable virtual property is in buffer object")); + + /* Careful with wrapping: arr_idx upshift may easily wrap, whereas + * length downshift won't. + */ + if (arr_idx < (h_bufobj->length >> h_bufobj->shift) && + DUK_HBUFOBJ_HAS_VIRTUAL_INDICES(h_bufobj)) { + duk_uint8_t *data; + DUK_DDD(DUK_DDDPRINT("writing to buffer data at index %ld", (long) arr_idx)); + + DUK_ASSERT(arr_idx != DUK__NO_ARRAY_INDEX); /* index/length check guarantees */ + byte_off = arr_idx + << h_bufobj->shift; /* no wrap assuming h_bufobj->length is valid */ + elem_size = (duk_small_uint_t) (1U << h_bufobj->shift); + + /* Coerce to number before validating pointers etc so that the + * number coercions in duk_hbufobj_validated_write() are + * guaranteed to be side effect free and not invalidate the + * pointer checks we do here. + */ + duk_push_tval(thr, tv_val); + (void) duk_to_number_m1(thr); + + if (h_bufobj->buf != NULL && + DUK_HBUFOBJ_VALID_BYTEOFFSET_EXCL(h_bufobj, byte_off + elem_size)) { + data = (duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(thr->heap, h_bufobj->buf) + + h_bufobj->offset + byte_off; + duk_hbufobj_validated_write(thr, h_bufobj, data, elem_size); + } else { + DUK_D(DUK_DPRINT( + "bufobj access out of underlying buffer, ignoring (write skipped)")); + } + duk_pop_unsafe(thr); + goto success_no_arguments_exotic; + } + } +#endif /* DUK_USE_BUFFEROBJECT_SUPPORT */ + + DUK_D(DUK_DPRINT("should not happen, key %!O", key)); + goto fail_internal; /* should not happen */ + } + DUK_DD(DUK_DDPRINT("put to existing own plain property, property is writable")); + goto update_old; + } + DUK_UNREACHABLE(); + + next_in_chain: + /* XXX: option to pretend property doesn't exist if sanity limit is + * hit might be useful. + */ + if (DUK_UNLIKELY(sanity-- == 0)) { + DUK_ERROR_RANGE(thr, DUK_STR_PROTOTYPE_CHAIN_LIMIT); + DUK_WO_NORETURN(return 0;); + } + curr = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, curr); + } while (curr != NULL); + + /* + * Property not found in prototype chain. + */ + + DUK_DDD(DUK_DDDPRINT("property not found in prototype chain")); + + if (orig == NULL) { + DUK_DD(DUK_DDPRINT("attempt to create a new property in a primitive base object")); + goto fail_base_primitive; + } + + if (!DUK_HOBJECT_HAS_EXTENSIBLE(orig)) { + DUK_DD(DUK_DDPRINT("put to a new property (not found in prototype chain), but original object not extensible")); + goto fail_not_extensible; + } + + goto create_new; + +update_old: + + /* + * Update an existing property of the base object. + */ + + /* [key] */ + + DUK_DDD(DUK_DDDPRINT("update an existing property of the original object")); + + DUK_ASSERT(orig != NULL); +#if defined(DUK_USE_ROM_OBJECTS) + /* This should not happen because DUK_TAG_OBJECT case checks + * for this already, but check just in case. + */ + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) orig)) { + goto fail_not_writable; + } +#endif + + /* Although there are writable virtual properties (e.g. plain buffer + * and buffer object number indices), they are handled before we come + * here. + */ + DUK_ASSERT((desc.flags & DUK_PROPDESC_FLAG_VIRTUAL) == 0); + DUK_ASSERT(desc.a_idx >= 0 || desc.e_idx >= 0); + + /* Array own property .length is handled above. */ + DUK_ASSERT(!(DUK_HOBJECT_IS_ARRAY(orig) && key == DUK_HTHREAD_STRING_LENGTH(thr))); + + if (desc.e_idx >= 0) { + tv = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, orig, desc.e_idx); + DUK_DDD(DUK_DDDPRINT("previous entry value: %!iT", (duk_tval *) tv)); + DUK_TVAL_SET_TVAL_UPDREF(thr, tv, tv_val); /* side effects; e_idx may be invalidated */ + /* don't touch property attributes or hash part */ + DUK_DD(DUK_DDPRINT("put to an existing entry at index %ld -> new value %!iT", (long) desc.e_idx, (duk_tval *) tv)); + } else { + /* Note: array entries are always writable, so the writability check + * above is pointless for them. The check could be avoided with some + * refactoring but is probably not worth it. + */ + + DUK_ASSERT(desc.a_idx >= 0); + tv = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, orig, desc.a_idx); + DUK_DDD(DUK_DDDPRINT("previous array value: %!iT", (duk_tval *) tv)); + DUK_TVAL_SET_TVAL_UPDREF(thr, tv, tv_val); /* side effects; a_idx may be invalidated */ + DUK_DD(DUK_DDPRINT("put to an existing array entry at index %ld -> new value %!iT", + (long) desc.a_idx, + (duk_tval *) tv)); + } + + /* Regardless of whether property is found in entry or array part, + * it may have arguments exotic behavior (array indices may reside + * in entry part for abandoned / non-existent array parts). + */ + goto success_with_arguments_exotic; + +create_new: + + /* + * Create a new property in the original object. + * + * Exotic properties need to be reconsidered here from a write + * perspective (not just property attributes perspective). + * However, the property does not exist in the object already, + * so this limits the kind of exotic properties that apply. + */ + + /* [key] */ + + DUK_DDD(DUK_DDDPRINT("create new property to original object")); + + DUK_ASSERT(orig != NULL); + + /* Array own property .length is handled above. */ + DUK_ASSERT(!(DUK_HOBJECT_IS_ARRAY(orig) && key == DUK_HTHREAD_STRING_LENGTH(thr))); + +#if defined(DUK_USE_ROM_OBJECTS) + /* This should not happen because DUK_TAG_OBJECT case checks + * for this already, but check just in case. + */ + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) orig)) { + goto fail_not_writable; + } +#endif + + /* Not possible because array object 'length' is present + * from its creation and cannot be deleted, and is thus + * caught as an existing property above. + */ + DUK_ASSERT(!(DUK_HOBJECT_HAS_EXOTIC_ARRAY(orig) && key == DUK_HTHREAD_STRING_LENGTH(thr))); + + if (DUK_HOBJECT_HAS_EXOTIC_ARRAY(orig) && arr_idx != DUK__NO_ARRAY_INDEX) { + /* automatic length update */ + duk_uint32_t old_len; + duk_harray *a; + + a = (duk_harray *) orig; + DUK_HARRAY_ASSERT_VALID(a); + + old_len = a->length; + + if (arr_idx >= old_len) { + DUK_DDD(DUK_DDDPRINT("write new array entry requires length update " + "(arr_idx=%ld, old_len=%ld)", + (long) arr_idx, + (long) old_len)); + + if (DUK_HARRAY_LENGTH_NONWRITABLE(a)) { + DUK_DD(DUK_DDPRINT("attempt to extend array, but array 'length' is not writable")); + goto fail_not_writable; + } + + /* Note: actual update happens once write has been completed + * without error below. The write should always succeed + * from a specification viewpoint, but we may e.g. run out + * of memory. It's safer in this order. + */ + + DUK_ASSERT(arr_idx != 0xffffffffUL); + new_array_length = arr_idx + 1; /* flag for later write */ + } else { + DUK_DDD(DUK_DDDPRINT("write new array entry does not require length update " + "(arr_idx=%ld, old_len=%ld)", + (long) arr_idx, + (long) old_len)); + } + } + + /* write_to_array_part: */ + + /* + * Write to array part? + * + * Note: array abandonding requires a property resize which uses + * 'rechecks' valstack for temporaries and may cause any existing + * valstack pointers to be invalidated. To protect against this, + * tv_obj, tv_key, and tv_val are copies of the original inputs. + */ + + if (arr_idx != DUK__NO_ARRAY_INDEX && DUK_HOBJECT_HAS_ARRAY_PART(orig)) { + tv = duk__obtain_arridx_slot(thr, arr_idx, orig); + if (tv == NULL) { + DUK_ASSERT(!DUK_HOBJECT_HAS_ARRAY_PART(orig)); + goto write_to_entry_part; + } + + /* prev value must be unused, no decref */ + DUK_ASSERT(DUK_TVAL_IS_UNUSED(tv)); + DUK_TVAL_SET_TVAL(tv, tv_val); + DUK_TVAL_INCREF(thr, tv); + DUK_DD(DUK_DDPRINT("put to new array entry: %ld -> %!T", (long) arr_idx, (duk_tval *) tv)); + + /* Note: array part values are [[Writable]], [[Enumerable]], + * and [[Configurable]] which matches the required attributes + * here. + */ + goto entry_updated; + } + +write_to_entry_part: + + /* + * Write to entry part + */ + + /* entry allocation updates hash part and increases the key + * refcount; may need a props allocation resize but doesn't + * 'recheck' the valstack. + */ + e_idx = duk__hobject_alloc_entry_checked(thr, orig, key); + DUK_ASSERT(e_idx >= 0); + + tv = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, orig, e_idx); + /* prev value can be garbage, no decref */ + DUK_TVAL_SET_TVAL(tv, tv_val); + DUK_TVAL_INCREF(thr, tv); + DUK_HOBJECT_E_SET_FLAGS(thr->heap, orig, e_idx, DUK_PROPDESC_FLAGS_WEC); + goto entry_updated; + +entry_updated: + + /* + * Possible pending array length update, which must only be done + * if the actual entry write succeeded. + */ + + if (new_array_length > 0) { + /* Note: zero works as a "no update" marker because the new length + * can never be zero after a new property is written. + */ + + DUK_ASSERT(DUK_HOBJECT_HAS_EXOTIC_ARRAY(orig)); + + DUK_DDD(DUK_DDDPRINT("write successful, pending array length update to: %ld", (long) new_array_length)); + + ((duk_harray *) orig)->length = new_array_length; + } + + /* + * Arguments exotic behavior not possible for new properties: all + * magically bound properties are initially present in the arguments + * object, and if they are deleted, the binding is also removed from + * parameter map. + */ + + goto success_no_arguments_exotic; + +success_with_arguments_exotic: + + /* + * Arguments objects have exotic [[DefineOwnProperty]] which updates + * the internal 'map' of arguments for writes to currently mapped + * arguments. More conretely, writes to mapped arguments generate + * a write to a bound variable. + * + * The [[Put]] algorithm invokes [[DefineOwnProperty]] for existing + * data properties and new properties, but not for existing accessors. + * Hence, in E5 Section 10.6 ([[DefinedOwnProperty]] algorithm), we + * have a Desc with 'Value' (and possibly other properties too), and + * we end up in step 5.b.i. + */ + + if (arr_idx != DUK__NO_ARRAY_INDEX && DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(orig)) { + /* Note: only numbered indices are relevant, so arr_idx fast reject + * is good (this is valid unless there are more than 4**32-1 arguments). + */ + + DUK_DDD(DUK_DDDPRINT("putprop successful, arguments exotic behavior needed")); + + /* Note: we can reuse 'desc' here */ + + /* XXX: top of stack must contain value, which helper doesn't touch, + * rework to use tv_val directly? + */ + + duk_push_tval(thr, tv_val); + (void) duk__check_arguments_map_for_put(thr, orig, key, &desc, throw_flag); + duk_pop_unsafe(thr); + } + /* fall thru */ + +success_no_arguments_exotic: + /* shared exit path now */ + DUK_DDD(DUK_DDDPRINT("result: success")); + duk_pop_unsafe(thr); /* remove key */ + return 1; + +#if defined(DUK_USE_ES6_PROXY) +fail_proxy_rejected: + DUK_DDD(DUK_DDDPRINT("result: error, proxy rejects")); + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_PROXY_REJECTED); + DUK_WO_NORETURN(return 0;); + } + /* Note: no key on stack */ + return 0; +#endif + +fail_base_primitive: + DUK_DDD(DUK_DDDPRINT("result: error, base primitive")); + if (throw_flag) { +#if defined(DUK_USE_PARANOID_ERRORS) + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_BASE); +#else + DUK_ERROR_FMT2(thr, + DUK_ERR_TYPE_ERROR, + "cannot write property %s of %s", + duk_push_string_tval_readable(thr, tv_key), + duk_push_string_tval_readable(thr, tv_obj)); +#endif + DUK_WO_NORETURN(return 0;); + } + duk_pop_unsafe(thr); /* remove key */ + return 0; + +fail_not_extensible: + DUK_DDD(DUK_DDDPRINT("result: error, not extensible")); + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_EXTENSIBLE); + DUK_WO_NORETURN(return 0;); + } + duk_pop_unsafe(thr); /* remove key */ + return 0; + +fail_not_writable: + DUK_DDD(DUK_DDDPRINT("result: error, not writable")); + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_WRITABLE); + DUK_WO_NORETURN(return 0;); + } + duk_pop_unsafe(thr); /* remove key */ + return 0; + +#if defined(DUK_USE_ROM_OBJECTS) +fail_not_writable_no_pop: + DUK_DDD(DUK_DDDPRINT("result: error, not writable")); + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_WRITABLE); + DUK_WO_NORETURN(return 0;); + } + return 0; +#endif + +fail_array_length_partial: + DUK_DD(DUK_DDPRINT("result: error, array length write only partially successful")); + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CONFIGURABLE); + DUK_WO_NORETURN(return 0;); + } + duk_pop_unsafe(thr); /* remove key */ + return 0; + +fail_no_setter: + DUK_DDD(DUK_DDDPRINT("result: error, accessor property without setter")); + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_SETTER_UNDEFINED); + DUK_WO_NORETURN(return 0;); + } + duk_pop_unsafe(thr); /* remove key */ + return 0; + +fail_internal: + DUK_DDD(DUK_DDDPRINT("result: error, internal")); + if (throw_flag) { + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return 0;); + } + duk_pop_unsafe(thr); /* remove key */ + return 0; +} + +/* + * ECMAScript compliant [[Delete]](P, Throw). + */ + +DUK_INTERNAL duk_bool_t duk_hobject_delprop_raw(duk_hthread *thr, duk_hobject *obj, duk_hstring *key, duk_small_uint_t flags) { + duk_propdesc desc; + duk_tval *tv; + duk_uint32_t arr_idx; + duk_bool_t throw_flag; + duk_bool_t force_flag; + + throw_flag = (flags & DUK_DELPROP_FLAG_THROW); + force_flag = (flags & DUK_DELPROP_FLAG_FORCE); + + DUK_DDD(DUK_DDDPRINT("delprop_raw: thr=%p, obj=%p, key=%p, throw=%ld, force=%ld (obj -> %!O, key -> %!O)", + (void *) thr, + (void *) obj, + (void *) key, + (long) throw_flag, + (long) force_flag, + (duk_heaphdr *) obj, + (duk_heaphdr *) key)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + arr_idx = DUK_HSTRING_GET_ARRIDX_FAST(key); + + /* 0 = don't push current value */ + if (!duk__get_own_propdesc_raw(thr, obj, key, arr_idx, &desc, 0 /*flags*/)) { /* don't push value */ + DUK_DDD(DUK_DDDPRINT("property not found, succeed always")); + goto success; + } + +#if defined(DUK_USE_ROM_OBJECTS) + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)) { + DUK_DD(DUK_DDPRINT("attempt to delprop on read-only target object")); + goto fail_not_configurable; + } +#endif + + if ((desc.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) == 0 && !force_flag) { + goto fail_not_configurable; + } + if (desc.a_idx < 0 && desc.e_idx < 0) { + /* Currently there are no deletable virtual properties, but + * with force_flag we might attempt to delete one. + */ + DUK_DD(DUK_DDPRINT("delete failed: property found, force flag, but virtual (and implicitly non-configurable)")); + goto fail_virtual; + } + + if (desc.a_idx >= 0) { + DUK_ASSERT(desc.e_idx < 0); + + tv = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, desc.a_idx); + DUK_TVAL_SET_UNUSED_UPDREF(thr, tv); /* side effects */ + goto success; + } else { + DUK_ASSERT(desc.a_idx < 0); + + /* remove hash entry (no decref) */ +#if defined(DUK_USE_HOBJECT_HASH_PART) + if (desc.h_idx >= 0) { + duk_uint32_t *h_base = DUK_HOBJECT_H_GET_BASE(thr->heap, obj); + + DUK_DDD(DUK_DDDPRINT("removing hash entry at h_idx %ld", (long) desc.h_idx)); + DUK_ASSERT(DUK_HOBJECT_GET_HSIZE(obj) > 0); + DUK_ASSERT((duk_uint32_t) desc.h_idx < DUK_HOBJECT_GET_HSIZE(obj)); + h_base[desc.h_idx] = DUK__HASH_DELETED; + } else { + DUK_ASSERT(DUK_HOBJECT_GET_HSIZE(obj) == 0); + } +#else + DUK_ASSERT(DUK_HOBJECT_GET_HSIZE(obj) == 0); +#endif + + /* Remove value. This requires multiple writes so avoid side + * effects via no-refzero macros so that e_idx is not + * invalidated. + */ + DUK_DDD(DUK_DDDPRINT("before removing value, e_idx %ld, key %p, key at slot %p", + (long) desc.e_idx, + (void *) key, + (void *) DUK_HOBJECT_E_GET_KEY(thr->heap, obj, desc.e_idx))); + DUK_DDD(DUK_DDDPRINT("removing value at e_idx %ld", (long) desc.e_idx)); + if (DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, obj, desc.e_idx)) { + duk_hobject *tmp; + + tmp = DUK_HOBJECT_E_GET_VALUE_GETTER(thr->heap, obj, desc.e_idx); + DUK_HOBJECT_E_SET_VALUE_GETTER(thr->heap, obj, desc.e_idx, NULL); + DUK_UNREF(tmp); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, tmp); + + tmp = DUK_HOBJECT_E_GET_VALUE_SETTER(thr->heap, obj, desc.e_idx); + DUK_HOBJECT_E_SET_VALUE_SETTER(thr->heap, obj, desc.e_idx, NULL); + DUK_UNREF(tmp); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, tmp); + } else { + tv = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, obj, desc.e_idx); + DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ(thr, tv); + } +#if 0 + /* Not strictly necessary because if key == NULL, flag MUST be ignored. */ + DUK_HOBJECT_E_SET_FLAGS(thr->heap, obj, desc.e_idx, 0); +#endif + + /* Remove key. */ + DUK_DDD(DUK_DDDPRINT("before removing key, e_idx %ld, key %p, key at slot %p", + (long) desc.e_idx, + (void *) key, + (void *) DUK_HOBJECT_E_GET_KEY(thr->heap, obj, desc.e_idx))); + DUK_DDD(DUK_DDDPRINT("removing key at e_idx %ld", (long) desc.e_idx)); + DUK_ASSERT(key == DUK_HOBJECT_E_GET_KEY(thr->heap, obj, desc.e_idx)); + DUK_HOBJECT_E_SET_KEY(thr->heap, obj, desc.e_idx, NULL); + DUK_HSTRING_DECREF_NORZ(thr, key); + + /* Trigger refzero side effects only when we're done as a + * finalizer might operate on the object and affect the + * e_idx we're supposed to use. + */ + DUK_REFZERO_CHECK_SLOW(thr); + goto success; + } + + DUK_UNREACHABLE(); + +success: + /* + * Argument exotic [[Delete]] behavior (E5 Section 10.6) is + * a post-check, keeping arguments internal 'map' in sync with + * any successful deletes (note that property does not need to + * exist for delete to 'succeed'). + * + * Delete key from 'map'. Since 'map' only contains array index + * keys, we can use arr_idx for a fast skip. + */ + + DUK_DDD(DUK_DDDPRINT("delete successful, check for arguments exotic behavior")); + + if (arr_idx != DUK__NO_ARRAY_INDEX && DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(obj)) { + /* Note: only numbered indices are relevant, so arr_idx fast reject + * is good (this is valid unless there are more than 4**32-1 arguments). + */ + + DUK_DDD(DUK_DDDPRINT("delete successful, arguments exotic behavior needed")); + + /* Note: we can reuse 'desc' here */ + (void) duk__check_arguments_map_for_delete(thr, obj, key, &desc); + } + + DUK_DDD(DUK_DDDPRINT("delete successful")); + return 1; + +fail_virtual: /* just use the same "not configurable" error message */ +fail_not_configurable: + DUK_DDD(DUK_DDDPRINT("delete failed: property found, not configurable")); + + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CONFIGURABLE); + DUK_WO_NORETURN(return 0;); + } + return 0; +} + +/* + * DELPROP: ECMAScript property deletion. + */ + +DUK_INTERNAL duk_bool_t duk_hobject_delprop(duk_hthread *thr, duk_tval *tv_obj, duk_tval *tv_key, duk_bool_t throw_flag) { + duk_hstring *key = NULL; +#if defined(DUK_USE_ES6_PROXY) + duk_propdesc desc; +#endif + duk_int_t entry_top; + duk_uint32_t arr_idx = DUK__NO_ARRAY_INDEX; + duk_bool_t rc; + + DUK_DDD(DUK_DDDPRINT("delprop: thr=%p, obj=%p, key=%p (obj -> %!T, key -> %!T)", + (void *) thr, + (void *) tv_obj, + (void *) tv_key, + (duk_tval *) tv_obj, + (duk_tval *) tv_key)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(tv_obj != NULL); + DUK_ASSERT(tv_key != NULL); + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + /* Storing the entry top is cheaper here to ensure stack is correct at exit, + * as there are several paths out. + */ + entry_top = duk_get_top(thr); + + if (DUK_TVAL_IS_UNDEFINED(tv_obj) || DUK_TVAL_IS_NULL(tv_obj)) { + DUK_DDD(DUK_DDDPRINT("base object is undefined or null -> reject")); + goto fail_invalid_base_uncond; + } + + duk_push_tval(thr, tv_obj); + duk_push_tval(thr, tv_key); + + tv_obj = DUK_GET_TVAL_NEGIDX(thr, -2); + if (DUK_TVAL_IS_OBJECT(tv_obj)) { + duk_hobject *obj = DUK_TVAL_GET_OBJECT(tv_obj); + DUK_ASSERT(obj != NULL); + +#if defined(DUK_USE_ES6_PROXY) + if (DUK_UNLIKELY(DUK_HOBJECT_IS_PROXY(obj))) { + duk_hobject *h_target; + duk_bool_t tmp_bool; + + /* Note: proxy handling must happen before key is string coerced. */ + + if (duk__proxy_check_prop(thr, obj, DUK_STRIDX_DELETE_PROPERTY, tv_key, &h_target)) { + /* -> [ ... obj key trap handler ] */ + DUK_DDD(DUK_DDDPRINT("-> proxy object 'deleteProperty' for key %!T", (duk_tval *) tv_key)); + duk_push_hobject(thr, h_target); /* target */ + duk_dup_m4(thr); /* P */ + duk_call_method(thr, 2 /*nargs*/); + tmp_bool = duk_to_boolean_top_pop(thr); + if (!tmp_bool) { + goto fail_proxy_rejected; /* retval indicates delete failed */ + } + + /* Target object must be checked for a conflicting + * non-configurable property. + */ + tv_key = DUK_GET_TVAL_NEGIDX(thr, -1); + arr_idx = duk__push_tval_to_property_key(thr, tv_key, &key); + DUK_ASSERT(key != NULL); + + if (duk__get_own_propdesc_raw(thr, h_target, key, arr_idx, &desc, 0 /*flags*/)) { /* don't push + value */ + duk_small_int_t desc_reject; + + DUK_DDD(DUK_DDDPRINT("proxy 'deleteProperty': target has matching property %!O, check for " + "conflicting property; desc.flags=0x%08lx, " + "desc.get=%p, desc.set=%p", + (duk_heaphdr *) key, + (unsigned long) desc.flags, + (void *) desc.get, + (void *) desc.set)); + + desc_reject = !(desc.flags & DUK_PROPDESC_FLAG_CONFIGURABLE); + if (desc_reject) { + /* unconditional */ + DUK_ERROR_TYPE(thr, DUK_STR_PROXY_REJECTED); + DUK_WO_NORETURN(return 0;); + } + } + rc = 1; /* success */ + goto done_rc; + } + + obj = h_target; /* resume delete to target */ + } +#endif /* DUK_USE_ES6_PROXY */ + + arr_idx = duk__to_property_key(thr, -1, &key); + DUK_ASSERT(key != NULL); + + rc = duk_hobject_delprop_raw(thr, obj, key, throw_flag ? DUK_DELPROP_FLAG_THROW : 0); + goto done_rc; + } else if (DUK_TVAL_IS_STRING(tv_obj)) { + /* String has .length and array index virtual properties + * which can't be deleted. No need for a symbol check; + * no offending virtual symbols exist. + */ + /* XXX: unnecessary string coercion for array indices, + * intentional to keep small. + */ + duk_hstring *h = DUK_TVAL_GET_STRING(tv_obj); + DUK_ASSERT(h != NULL); + + arr_idx = duk__to_property_key(thr, -1, &key); + DUK_ASSERT(key != NULL); + + if (key == DUK_HTHREAD_STRING_LENGTH(thr)) { + goto fail_not_configurable; + } + + if (arr_idx != DUK__NO_ARRAY_INDEX && arr_idx < DUK_HSTRING_GET_CHARLEN(h)) { + goto fail_not_configurable; + } + } else if (DUK_TVAL_IS_BUFFER(tv_obj)) { + /* XXX: unnecessary string coercion for array indices, + * intentional to keep small; some overlap with string + * handling. + */ + duk_hbuffer *h = DUK_TVAL_GET_BUFFER(tv_obj); + DUK_ASSERT(h != NULL); + + arr_idx = duk__to_property_key(thr, -1, &key); + DUK_ASSERT(key != NULL); + + if (key == DUK_HTHREAD_STRING_LENGTH(thr)) { + goto fail_not_configurable; + } + + if (arr_idx != DUK__NO_ARRAY_INDEX && arr_idx < DUK_HBUFFER_GET_SIZE(h)) { + goto fail_not_configurable; + } + } else if (DUK_TVAL_IS_LIGHTFUNC(tv_obj)) { + /* Lightfunc has no virtual properties since Duktape 2.2 + * so success. Still must coerce key for side effects. + */ + + arr_idx = duk__to_property_key(thr, -1, &key); + DUK_ASSERT(key != NULL); + DUK_UNREF(key); + } + + /* non-object base, no offending virtual property */ + rc = 1; + goto done_rc; + +done_rc: + duk_set_top_unsafe(thr, entry_top); + return rc; + +fail_invalid_base_uncond: + /* Note: unconditional throw */ + DUK_ASSERT(duk_get_top(thr) == entry_top); +#if defined(DUK_USE_PARANOID_ERRORS) + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_BASE); +#else + DUK_ERROR_FMT2(thr, + DUK_ERR_TYPE_ERROR, + "cannot delete property %s of %s", + duk_push_string_tval_readable(thr, tv_key), + duk_push_string_tval_readable(thr, tv_obj)); +#endif + DUK_WO_NORETURN(return 0;); + +#if defined(DUK_USE_ES6_PROXY) +fail_proxy_rejected: + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_PROXY_REJECTED); + DUK_WO_NORETURN(return 0;); + } + duk_set_top_unsafe(thr, entry_top); + return 0; +#endif + +fail_not_configurable: + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CONFIGURABLE); + DUK_WO_NORETURN(return 0;); + } + duk_set_top_unsafe(thr, entry_top); + return 0; +} + +/* + * Internal helper to define a property with specific flags, ignoring + * normal semantics such as extensibility, write protection etc. + * Overwrites any existing value and attributes unless caller requests + * that value only be updated if it doesn't already exists. + * + * Does not support: + * - virtual properties (error if write attempted) + * - getter/setter properties (error if write attempted) + * - non-default (!= WEC) attributes for array entries (error if attempted) + * - array abandoning: if array part exists, it is always extended + * - array 'length' updating + * + * Stack: [... in_val] -> [] + * + * Used for e.g. built-in initialization and environment record + * operations. + */ + +DUK_INTERNAL void duk_hobject_define_property_internal(duk_hthread *thr, + duk_hobject *obj, + duk_hstring *key, + duk_small_uint_t flags) { + duk_propdesc desc; + duk_uint32_t arr_idx; + duk_int_t e_idx; + duk_tval *tv1 = NULL; + duk_tval *tv2 = NULL; + duk_small_uint_t propflags = flags & DUK_PROPDESC_FLAGS_MASK; /* mask out flags not actually stored */ + + DUK_DDD(DUK_DDDPRINT("define new property (internal): thr=%p, obj=%!O, key=%!O, flags=0x%02lx, val=%!T", + (void *) thr, + (duk_heaphdr *) obj, + (duk_heaphdr *) key, + (unsigned long) flags, + (duk_tval *) duk_get_tval(thr, -1))); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)); + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + DUK_ASSERT(duk_is_valid_index(thr, -1)); /* contains value */ + + arr_idx = DUK_HSTRING_GET_ARRIDX_SLOW(key); + + if (duk__get_own_propdesc_raw(thr, obj, key, arr_idx, &desc, 0 /*flags*/)) { /* don't push value */ + if (desc.e_idx >= 0) { + if (flags & DUK_PROPDESC_FLAG_NO_OVERWRITE) { + DUK_DDD(DUK_DDDPRINT("property already exists in the entry part -> skip as requested")); + goto pop_exit; + } + DUK_DDD(DUK_DDDPRINT("property already exists in the entry part -> update value and attributes")); + if (DUK_UNLIKELY(DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, obj, desc.e_idx))) { + DUK_D(DUK_DPRINT("existing property is an accessor, not supported")); + goto error_internal; + } + + DUK_HOBJECT_E_SET_FLAGS(thr->heap, obj, desc.e_idx, propflags); + tv1 = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, obj, desc.e_idx); + } else if (desc.a_idx >= 0) { + if (flags & DUK_PROPDESC_FLAG_NO_OVERWRITE) { + DUK_DDD(DUK_DDDPRINT("property already exists in the array part -> skip as requested")); + goto pop_exit; + } + DUK_DDD(DUK_DDDPRINT("property already exists in the array part -> update value (assert attributes)")); + if (propflags != DUK_PROPDESC_FLAGS_WEC) { + DUK_D(DUK_DPRINT("existing property in array part, but propflags not WEC (0x%02lx)", + (unsigned long) propflags)); + goto error_internal; + } + + tv1 = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, desc.a_idx); + } else { + if (flags & DUK_PROPDESC_FLAG_NO_OVERWRITE) { + DUK_DDD(DUK_DDDPRINT("property already exists but is virtual -> skip as requested")); + goto pop_exit; + } + if (key == DUK_HTHREAD_STRING_LENGTH(thr) && DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)) { + duk_uint32_t new_len; +#if defined(DUK_USE_DEBUG) + duk_uint32_t prev_len; + prev_len = ((duk_harray *) obj)->length; +#endif + new_len = duk__to_new_array_length_checked(thr, DUK_GET_TVAL_NEGIDX(thr, -1)); + ((duk_harray *) obj)->length = new_len; + DUK_DD(DUK_DDPRINT("internal define property for array .length: %ld -> %ld", + (long) prev_len, + (long) ((duk_harray *) obj)->length)); + goto pop_exit; + } + DUK_DD(DUK_DDPRINT("property already exists but is virtual -> failure")); + goto error_virtual; + } + + goto write_value; + } + + if (DUK_HOBJECT_HAS_ARRAY_PART(obj)) { + if (arr_idx != DUK__NO_ARRAY_INDEX) { + DUK_DDD(DUK_DDDPRINT("property does not exist, object has array part -> possibly extend array part and " + "write value (assert attributes)")); + DUK_ASSERT(propflags == DUK_PROPDESC_FLAGS_WEC); + + tv1 = duk__obtain_arridx_slot(thr, arr_idx, obj); + if (tv1 == NULL) { + DUK_ASSERT(!DUK_HOBJECT_HAS_ARRAY_PART(obj)); + goto write_to_entry_part; + } + + tv1 = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, arr_idx); + goto write_value; + } + } + +write_to_entry_part: + DUK_DDD(DUK_DDDPRINT( + "property does not exist, object belongs in entry part -> allocate new entry and write value and attributes")); + e_idx = duk__hobject_alloc_entry_checked(thr, obj, key); /* increases key refcount */ + DUK_ASSERT(e_idx >= 0); + DUK_HOBJECT_E_SET_FLAGS(thr->heap, obj, e_idx, propflags); + tv1 = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, obj, e_idx); + /* new entry: previous value is garbage; set to undefined to share write_value */ + DUK_TVAL_SET_UNDEFINED(tv1); + goto write_value; + +write_value: + /* tv1 points to value storage */ + + tv2 = duk_require_tval(thr, -1); /* late lookup, avoid side effects */ + DUK_DDD(DUK_DDDPRINT("writing/updating value: %!T -> %!T", (duk_tval *) tv1, (duk_tval *) tv2)); + + DUK_TVAL_SET_TVAL_UPDREF(thr, tv1, tv2); /* side effects */ + goto pop_exit; + +pop_exit: + duk_pop_unsafe(thr); /* remove in_val */ + return; + +error_virtual: /* share error message */ +error_internal: + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return;); +} + +/* + * Fast path for defining array indexed values without interning the key. + * This is used by e.g. code for Array prototype and traceback creation so + * must avoid interning. + */ + +DUK_INTERNAL void duk_hobject_define_property_internal_arridx(duk_hthread *thr, + duk_hobject *obj, + duk_uarridx_t arr_idx, + duk_small_uint_t flags) { + duk_hstring *key; + duk_tval *tv1, *tv2; + + DUK_DDD(DUK_DDDPRINT("define new property (internal) arr_idx fast path: thr=%p, obj=%!O, " + "arr_idx=%ld, flags=0x%02lx, val=%!T", + (void *) thr, + obj, + (long) arr_idx, + (unsigned long) flags, + (duk_tval *) duk_get_tval(thr, -1))); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)); + + if (DUK_HOBJECT_HAS_ARRAY_PART(obj) && arr_idx != DUK__NO_ARRAY_INDEX && flags == DUK_PROPDESC_FLAGS_WEC) { + DUK_ASSERT((flags & DUK_PROPDESC_FLAG_NO_OVERWRITE) == 0); /* covered by comparison */ + + DUK_DDD(DUK_DDDPRINT("define property to array part (property may or may not exist yet)")); + + tv1 = duk__obtain_arridx_slot(thr, arr_idx, obj); + if (tv1 == NULL) { + DUK_ASSERT(!DUK_HOBJECT_HAS_ARRAY_PART(obj)); + goto write_slow; + } + tv2 = duk_require_tval(thr, -1); + + DUK_TVAL_SET_TVAL_UPDREF(thr, tv1, tv2); /* side effects */ + + duk_pop_unsafe(thr); /* [ ...val ] -> [ ... ] */ + return; + } + +write_slow: + DUK_DDD(DUK_DDDPRINT("define property fast path didn't work, use slow path")); + + key = duk_push_uint_to_hstring(thr, (duk_uint_t) arr_idx); + DUK_ASSERT(key != NULL); + duk_insert(thr, -2); /* [ ... val key ] -> [ ... key val ] */ + + duk_hobject_define_property_internal(thr, obj, key, flags); + + duk_pop_unsafe(thr); /* [ ... key ] -> [ ... ] */ +} + +/* + * Internal helpers for managing object 'length' + */ + +DUK_INTERNAL duk_size_t duk_hobject_get_length(duk_hthread *thr, duk_hobject *obj) { + duk_double_t val; + + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(obj != NULL); + + /* Fast path for Arrays. */ + if (DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)) { + return ((duk_harray *) obj)->length; + } + + /* Slow path, .length can be e.g. accessor, obj can be a Proxy, etc. */ + duk_push_hobject(thr, obj); + duk_push_hstring_stridx(thr, DUK_STRIDX_LENGTH); + (void) duk_hobject_getprop(thr, DUK_GET_TVAL_NEGIDX(thr, -2), DUK_GET_TVAL_NEGIDX(thr, -1)); + val = duk_to_number_m1(thr); + duk_pop_3_unsafe(thr); + + /* This isn't part of ECMAScript semantics; return a value within + * duk_size_t range, or 0 otherwise. + */ + if (val >= 0.0 && val <= (duk_double_t) DUK_SIZE_MAX) { + return (duk_size_t) val; + } + return 0; +} + +/* + * Fast finalizer check for an object. Walks the prototype chain, checking + * for finalizer presence using DUK_HOBJECT_FLAG_HAVE_FINALIZER which is kept + * in sync with the actual property when setting/removing the finalizer. + */ + +#if defined(DUK_USE_HEAPPTR16) +DUK_INTERNAL duk_bool_t duk_hobject_has_finalizer_fast_raw(duk_heap *heap, duk_hobject *obj) { +#else +DUK_INTERNAL duk_bool_t duk_hobject_has_finalizer_fast_raw(duk_hobject *obj) { +#endif + duk_uint_t sanity; + + DUK_ASSERT(obj != NULL); + + sanity = DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY; + do { + if (DUK_UNLIKELY(DUK_HOBJECT_HAS_HAVE_FINALIZER(obj))) { + return 1; + } + if (DUK_UNLIKELY(sanity-- == 0)) { + DUK_D(DUK_DPRINT("prototype loop when checking for finalizer existence; returning false")); + return 0; + } +#if defined(DUK_USE_HEAPPTR16) + DUK_ASSERT(heap != NULL); + obj = DUK_HOBJECT_GET_PROTOTYPE(heap, obj); +#else + obj = DUK_HOBJECT_GET_PROTOTYPE(NULL, obj); /* 'heap' arg ignored */ +#endif + } while (obj != NULL); + + return 0; +} + +/* + * Object.getOwnPropertyDescriptor() (E5 Sections 15.2.3.3, 8.10.4) + * + * [ ... key ] -> [ ... desc/undefined ] + */ + +DUK_INTERNAL void duk_hobject_object_get_own_property_descriptor(duk_hthread *thr, duk_idx_t obj_idx) { + duk_hobject *obj; + duk_hstring *key; + duk_propdesc pd; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + + obj = duk_require_hobject_promote_mask(thr, obj_idx, DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + key = duk_to_property_key_hstring(thr, -1); + DUK_ASSERT(key != NULL); + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + if (!duk_hobject_get_own_propdesc(thr, obj, key, &pd, DUK_GETDESC_FLAG_PUSH_VALUE)) { + duk_push_undefined(thr); + duk_remove_m2(thr); + return; + } + + duk_push_object(thr); + + /* [ ... key value desc ] */ + + if (DUK_PROPDESC_IS_ACCESSOR(&pd)) { + /* If a setter/getter is missing (undefined), the descriptor must + * still have the property present with the value 'undefined'. + */ + if (pd.get) { + duk_push_hobject(thr, pd.get); + } else { + duk_push_undefined(thr); + } + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_GET); + if (pd.set) { + duk_push_hobject(thr, pd.set); + } else { + duk_push_undefined(thr); + } + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_SET); + } else { + duk_dup_m2(thr); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_VALUE); + duk_push_boolean(thr, DUK_PROPDESC_IS_WRITABLE(&pd)); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_WRITABLE); + } + duk_push_boolean(thr, DUK_PROPDESC_IS_ENUMERABLE(&pd)); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_ENUMERABLE); + duk_push_boolean(thr, DUK_PROPDESC_IS_CONFIGURABLE(&pd)); + duk_put_prop_stridx_short(thr, -2, DUK_STRIDX_CONFIGURABLE); + + /* [ ... key value desc ] */ + + duk_replace(thr, -3); + duk_pop_unsafe(thr); /* -> [ ... desc ] */ +} + +/* + * NormalizePropertyDescriptor() related helper. + * + * Internal helper which validates and normalizes a property descriptor + * represented as an ECMAScript object (e.g. argument to defineProperty()). + * The output of this conversion is a set of defprop_flags and possibly + * some values pushed on the value stack to (1) ensure borrowed pointers + * remain valid, and (2) avoid unnecessary pops for footprint reasons. + * Caller must manage stack top carefully because the number of values + * pushed depends on the input property descriptor. + * + * The original descriptor object must not be altered in the process. + */ + +/* XXX: very basic optimization -> duk_get_prop_stridx_top */ + +DUK_INTERNAL +void duk_hobject_prepare_property_descriptor(duk_hthread *thr, + duk_idx_t idx_in, + duk_uint_t *out_defprop_flags, + duk_idx_t *out_idx_value, + duk_hobject **out_getter, + duk_hobject **out_setter) { + duk_idx_t idx_value = -1; + duk_hobject *getter = NULL; + duk_hobject *setter = NULL; + duk_bool_t is_data_desc = 0; + duk_bool_t is_acc_desc = 0; + duk_uint_t defprop_flags = 0; + + DUK_ASSERT(out_defprop_flags != NULL); + DUK_ASSERT(out_idx_value != NULL); + DUK_ASSERT(out_getter != NULL); + DUK_ASSERT(out_setter != NULL); + DUK_ASSERT(idx_in <= 0x7fffL); /* short variants would be OK, but not used to avoid shifts */ + + /* Must be an object, otherwise TypeError (E5.1 Section 8.10.5, step 1). */ + idx_in = duk_require_normalize_index(thr, idx_in); + (void) duk_require_hobject(thr, idx_in); + + /* The coercion order must match the ToPropertyDescriptor() algorithm + * so that side effects in coercion happen in the correct order. + * (This order also happens to be compatible with duk_def_prop(), + * although it doesn't matter in practice.) + */ + + if (duk_get_prop_stridx(thr, idx_in, DUK_STRIDX_VALUE)) { + is_data_desc = 1; + defprop_flags |= DUK_DEFPROP_HAVE_VALUE; + idx_value = duk_get_top_index(thr); + } + + if (duk_get_prop_stridx(thr, idx_in, DUK_STRIDX_WRITABLE)) { + is_data_desc = 1; + if (duk_to_boolean_top_pop(thr)) { + defprop_flags |= DUK_DEFPROP_HAVE_WRITABLE | DUK_DEFPROP_WRITABLE; + } else { + defprop_flags |= DUK_DEFPROP_HAVE_WRITABLE; + } + } + + if (duk_get_prop_stridx(thr, idx_in, DUK_STRIDX_GET)) { + duk_tval *tv = duk_require_tval(thr, -1); + duk_hobject *h_get; + + if (DUK_TVAL_IS_UNDEFINED(tv)) { + /* undefined is accepted */ + DUK_ASSERT(getter == NULL); + } else { + /* NOTE: lightfuncs are coerced to full functions because + * lightfuncs don't fit into a property value slot. This + * has some side effects, see test-dev-lightfunc-accessor.js. + */ + h_get = duk_get_hobject_promote_lfunc(thr, -1); + if (h_get == NULL || !DUK_HOBJECT_IS_CALLABLE(h_get)) { + goto type_error; + } + getter = h_get; + } + is_acc_desc = 1; + defprop_flags |= DUK_DEFPROP_HAVE_GETTER; + } + + if (duk_get_prop_stridx(thr, idx_in, DUK_STRIDX_SET)) { + duk_tval *tv = duk_require_tval(thr, -1); + duk_hobject *h_set; + + if (DUK_TVAL_IS_UNDEFINED(tv)) { + /* undefined is accepted */ + DUK_ASSERT(setter == NULL); + } else { + /* NOTE: lightfuncs are coerced to full functions because + * lightfuncs don't fit into a property value slot. This + * has some side effects, see test-dev-lightfunc-accessor.js. + */ + h_set = duk_get_hobject_promote_lfunc(thr, -1); + if (h_set == NULL || !DUK_HOBJECT_IS_CALLABLE(h_set)) { + goto type_error; + } + setter = h_set; + } + is_acc_desc = 1; + defprop_flags |= DUK_DEFPROP_HAVE_SETTER; + } + + if (duk_get_prop_stridx(thr, idx_in, DUK_STRIDX_ENUMERABLE)) { + if (duk_to_boolean_top_pop(thr)) { + defprop_flags |= DUK_DEFPROP_HAVE_ENUMERABLE | DUK_DEFPROP_ENUMERABLE; + } else { + defprop_flags |= DUK_DEFPROP_HAVE_ENUMERABLE; + } + } + + if (duk_get_prop_stridx(thr, idx_in, DUK_STRIDX_CONFIGURABLE)) { + if (duk_to_boolean_top_pop(thr)) { + defprop_flags |= DUK_DEFPROP_HAVE_CONFIGURABLE | DUK_DEFPROP_CONFIGURABLE; + } else { + defprop_flags |= DUK_DEFPROP_HAVE_CONFIGURABLE; + } + } + + if (is_data_desc && is_acc_desc) { + goto type_error; + } + + *out_defprop_flags = defprop_flags; + *out_idx_value = idx_value; + *out_getter = getter; + *out_setter = setter; + + /* [ ... [multiple values] ] */ + return; + +type_error: + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_DESCRIPTOR); + DUK_WO_NORETURN(return;); +} + +/* + * Object.defineProperty() related helper (E5 Section 15.2.3.6). + * Also handles ES2015 Reflect.defineProperty(). + * + * Inlines all [[DefineOwnProperty]] exotic behaviors. + * + * Note: ECMAScript compliant [[DefineOwnProperty]](P, Desc, Throw) is not + * implemented directly, but Object.defineProperty() serves its purpose. + * We don't need the [[DefineOwnProperty]] internally and we don't have a + * property descriptor with 'missing values' so it's easier to avoid it + * entirely. + * + * Note: this is only called for actual objects, not primitive values. + * This must support virtual properties for full objects (e.g. Strings) + * but not for plain values (e.g. strings). Lightfuncs, even though + * primitive in a sense, are treated like objects and accepted as target + * values. + */ + +/* XXX: this is a major target for size optimization */ +DUK_INTERNAL +duk_bool_t duk_hobject_define_property_helper(duk_hthread *thr, + duk_uint_t defprop_flags, + duk_hobject *obj, + duk_hstring *key, + duk_idx_t idx_value, + duk_hobject *get, + duk_hobject *set, + duk_bool_t throw_flag) { + duk_uint32_t arr_idx; + duk_tval tv; + duk_bool_t has_enumerable; + duk_bool_t has_configurable; + duk_bool_t has_writable; + duk_bool_t has_value; + duk_bool_t has_get; + duk_bool_t has_set; + duk_bool_t is_enumerable; + duk_bool_t is_configurable; + duk_bool_t is_writable; + duk_bool_t force_flag; + duk_small_uint_t new_flags; + duk_propdesc curr; + duk_uint32_t arridx_new_array_length; /* != 0 => post-update for array 'length' (used when key is an array index) */ + duk_uint32_t arrlen_old_len; + duk_uint32_t arrlen_new_len; + duk_bool_t pending_write_protect; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(obj != NULL); + DUK_ASSERT(key != NULL); + /* idx_value may be < 0 (no value), set and get may be NULL */ + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + + /* All the flags fit in 16 bits, so will fit into duk_bool_t. */ + + has_writable = (defprop_flags & DUK_DEFPROP_HAVE_WRITABLE); + has_enumerable = (defprop_flags & DUK_DEFPROP_HAVE_ENUMERABLE); + has_configurable = (defprop_flags & DUK_DEFPROP_HAVE_CONFIGURABLE); + has_value = (defprop_flags & DUK_DEFPROP_HAVE_VALUE); + has_get = (defprop_flags & DUK_DEFPROP_HAVE_GETTER); + has_set = (defprop_flags & DUK_DEFPROP_HAVE_SETTER); + is_writable = (defprop_flags & DUK_DEFPROP_WRITABLE); + is_enumerable = (defprop_flags & DUK_DEFPROP_ENUMERABLE); + is_configurable = (defprop_flags & DUK_DEFPROP_CONFIGURABLE); + force_flag = (defprop_flags & DUK_DEFPROP_FORCE); + + arr_idx = DUK_HSTRING_GET_ARRIDX_SLOW(key); + + arridx_new_array_length = 0; + pending_write_protect = 0; + arrlen_old_len = 0; + arrlen_new_len = 0; + + DUK_DDD(DUK_DDDPRINT("has_enumerable=%ld is_enumerable=%ld " + "has_configurable=%ld is_configurable=%ld " + "has_writable=%ld is_writable=%ld " + "has_value=%ld value=%!T " + "has_get=%ld get=%p=%!O " + "has_set=%ld set=%p=%!O " + "arr_idx=%ld throw_flag=!%ld", + (long) has_enumerable, + (long) is_enumerable, + (long) has_configurable, + (long) is_configurable, + (long) has_writable, + (long) is_writable, + (long) has_value, + (duk_tval *) (idx_value >= 0 ? duk_get_tval(thr, idx_value) : NULL), + (long) has_get, + (void *) get, + (duk_heaphdr *) get, + (long) has_set, + (void *) set, + (duk_heaphdr *) set, + (long) arr_idx, + (long) throw_flag)); + + /* + * Array exotic behaviors can be implemented at this point. The local variables + * are essentially a 'value copy' of the input descriptor (Desc), which is modified + * by the Array [[DefineOwnProperty]] (E5 Section 15.4.5.1). + */ + + if (!DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)) { + goto skip_array_exotic; + } + + if (key == DUK_HTHREAD_STRING_LENGTH(thr)) { + duk_harray *a; + + /* E5 Section 15.4.5.1, step 3, steps a - i are implemented here, j - n at the end */ + if (!has_value) { + DUK_DDD(DUK_DDDPRINT("exotic array behavior for 'length', but no value in descriptor -> normal behavior")); + goto skip_array_exotic; + } + + DUK_DDD(DUK_DDDPRINT("exotic array behavior for 'length', value present in descriptor -> exotic behavior")); + + /* + * Get old and new length + */ + + a = (duk_harray *) obj; + DUK_HARRAY_ASSERT_VALID(a); + arrlen_old_len = a->length; + + DUK_ASSERT(idx_value >= 0); + arrlen_new_len = duk__to_new_array_length_checked(thr, DUK_GET_TVAL_POSIDX(thr, idx_value)); + duk_push_u32(thr, arrlen_new_len); + duk_replace(thr, idx_value); /* step 3.e: replace 'Desc.[[Value]]' */ + + DUK_DDD(DUK_DDDPRINT("old_len=%ld, new_len=%ld", (long) arrlen_old_len, (long) arrlen_new_len)); + + if (arrlen_new_len >= arrlen_old_len) { + /* standard behavior, step 3.f.i */ + DUK_DDD(DUK_DDDPRINT("new length is same or higher as previous => standard behavior")); + goto skip_array_exotic; + } + DUK_DDD(DUK_DDDPRINT("new length is smaller than previous => exotic post behavior")); + + /* XXX: consolidated algorithm step 15.f -> redundant? */ + if (DUK_HARRAY_LENGTH_NONWRITABLE(a) && !force_flag) { + /* Array .length is always non-configurable; if it's also + * non-writable, don't allow it to be written. + */ + goto fail_not_configurable; + } + + /* steps 3.h and 3.i */ + if (has_writable && !is_writable) { + DUK_DDD(DUK_DDDPRINT("desc writable is false, force it back to true, and flag pending write protect")); + is_writable = 1; + pending_write_protect = 1; + } + + /* remaining actual steps are carried out if standard DefineOwnProperty succeeds */ + } else if (arr_idx != DUK__NO_ARRAY_INDEX) { + /* XXX: any chance of unifying this with the 'length' key handling? */ + + /* E5 Section 15.4.5.1, step 4 */ + duk_uint32_t old_len; + duk_harray *a; + + a = (duk_harray *) obj; + DUK_HARRAY_ASSERT_VALID(a); + + old_len = a->length; + + if (arr_idx >= old_len) { + DUK_DDD(DUK_DDDPRINT("defineProperty requires array length update " + "(arr_idx=%ld, old_len=%ld)", + (long) arr_idx, + (long) old_len)); + + if (DUK_HARRAY_LENGTH_NONWRITABLE(a) && !force_flag) { + /* Array .length is always non-configurable, so + * if it's also non-writable, don't allow a value + * write. With force flag allow writing. + */ + goto fail_not_configurable; + } + + /* actual update happens once write has been completed without + * error below. + */ + DUK_ASSERT(arr_idx != 0xffffffffUL); + arridx_new_array_length = arr_idx + 1; + } else { + DUK_DDD(DUK_DDDPRINT("defineProperty does not require length update " + "(arr_idx=%ld, old_len=%ld) -> standard behavior", + (long) arr_idx, + (long) old_len)); + } + } +skip_array_exotic: + + /* XXX: There is currently no support for writing buffer object + * indexed elements here. Attempt to do so will succeed and + * write a concrete property into the buffer object. This should + * be fixed at some point but because buffers are a custom feature + * anyway, this is relatively unimportant. + */ + + /* + * Actual Object.defineProperty() default algorithm. + */ + + /* + * First check whether property exists; if not, simple case. This covers + * steps 1-4. + */ + + if (!duk__get_own_propdesc_raw(thr, obj, key, arr_idx, &curr, DUK_GETDESC_FLAG_PUSH_VALUE)) { + DUK_DDD(DUK_DDDPRINT("property does not exist")); + + if (!DUK_HOBJECT_HAS_EXTENSIBLE(obj) && !force_flag) { + goto fail_not_extensible; + } + +#if defined(DUK_USE_ROM_OBJECTS) + /* ROM objects are never extensible but force flag may + * allow us to come here anyway. + */ + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj) || !DUK_HOBJECT_HAS_EXTENSIBLE(obj)); + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)) { + DUK_D(DUK_DPRINT("attempt to define property on a read-only target object")); + goto fail_not_configurable; + } +#endif + + /* XXX: share final setting code for value and flags? difficult because + * refcount code is different. Share entry allocation? But can't allocate + * until array index checked. + */ + + /* steps 4.a and 4.b are tricky */ + if (has_set || has_get) { + duk_int_t e_idx; + + DUK_DDD(DUK_DDDPRINT("create new accessor property")); + + DUK_ASSERT(has_set || set == NULL); + DUK_ASSERT(has_get || get == NULL); + DUK_ASSERT(!has_value); + DUK_ASSERT(!has_writable); + + new_flags = DUK_PROPDESC_FLAG_ACCESSOR; /* defaults, E5 Section 8.6.1, Table 7 */ + if (has_enumerable && is_enumerable) { + new_flags |= DUK_PROPDESC_FLAG_ENUMERABLE; + } + if (has_configurable && is_configurable) { + new_flags |= DUK_PROPDESC_FLAG_CONFIGURABLE; + } + + if (arr_idx != DUK__NO_ARRAY_INDEX && DUK_HOBJECT_HAS_ARRAY_PART(obj)) { + DUK_DDD(DUK_DDDPRINT("accessor cannot go to array part, abandon array")); + duk__abandon_array_part(thr, obj); + } + + /* write to entry part */ + e_idx = duk__hobject_alloc_entry_checked(thr, obj, key); + DUK_ASSERT(e_idx >= 0); + + DUK_HOBJECT_E_SET_VALUE_GETTER(thr->heap, obj, e_idx, get); + DUK_HOBJECT_E_SET_VALUE_SETTER(thr->heap, obj, e_idx, set); + DUK_HOBJECT_INCREF_ALLOWNULL(thr, get); + DUK_HOBJECT_INCREF_ALLOWNULL(thr, set); + + DUK_HOBJECT_E_SET_FLAGS(thr->heap, obj, e_idx, new_flags); + goto success_exotics; + } else { + duk_int_t e_idx; + duk_tval *tv2; + + DUK_DDD(DUK_DDDPRINT("create new data property")); + + DUK_ASSERT(!has_set); + DUK_ASSERT(!has_get); + + new_flags = 0; /* defaults, E5 Section 8.6.1, Table 7 */ + if (has_writable && is_writable) { + new_flags |= DUK_PROPDESC_FLAG_WRITABLE; + } + if (has_enumerable && is_enumerable) { + new_flags |= DUK_PROPDESC_FLAG_ENUMERABLE; + } + if (has_configurable && is_configurable) { + new_flags |= DUK_PROPDESC_FLAG_CONFIGURABLE; + } + if (has_value) { + duk_tval *tv_tmp = duk_require_tval(thr, idx_value); + DUK_TVAL_SET_TVAL(&tv, tv_tmp); + } else { + DUK_TVAL_SET_UNDEFINED(&tv); /* default value */ + } + + if (arr_idx != DUK__NO_ARRAY_INDEX && DUK_HOBJECT_HAS_ARRAY_PART(obj)) { + if (new_flags == DUK_PROPDESC_FLAGS_WEC) { + DUK_DDD(DUK_DDDPRINT( + "new data property attributes match array defaults, attempt to write to array part")); + tv2 = duk__obtain_arridx_slot(thr, arr_idx, obj); + if (tv2 == NULL) { + DUK_DDD(DUK_DDDPRINT("failed writing to array part, abandoned array")); + } else { + DUK_DDD(DUK_DDDPRINT("success in writing to array part")); + DUK_ASSERT(DUK_HOBJECT_HAS_ARRAY_PART(obj)); + DUK_ASSERT(DUK_TVAL_IS_UNUSED(tv2)); + DUK_TVAL_SET_TVAL(tv2, &tv); + DUK_TVAL_INCREF(thr, tv2); + goto success_exotics; + } + } else { + DUK_DDD(DUK_DDDPRINT("new data property cannot go to array part, abandon array")); + duk__abandon_array_part(thr, obj); + } + /* fall through */ + } + + /* write to entry part */ + e_idx = duk__hobject_alloc_entry_checked(thr, obj, key); + DUK_ASSERT(e_idx >= 0); + tv2 = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, obj, e_idx); + DUK_TVAL_SET_TVAL(tv2, &tv); + DUK_TVAL_INCREF(thr, tv2); + + DUK_HOBJECT_E_SET_FLAGS(thr->heap, obj, e_idx, new_flags); + goto success_exotics; + } + DUK_UNREACHABLE(); + } + + /* we currently assume virtual properties are not configurable (as none of them are) */ + DUK_ASSERT((curr.e_idx >= 0 || curr.a_idx >= 0) || !(curr.flags & DUK_PROPDESC_FLAG_CONFIGURABLE)); + + /* [obj key desc value get set curr_value] */ + + /* + * Property already exists. Steps 5-6 detect whether any changes need + * to be made. + */ + + if (has_enumerable) { + if (is_enumerable) { + if (!(curr.flags & DUK_PROPDESC_FLAG_ENUMERABLE)) { + goto need_check; + } + } else { + if (curr.flags & DUK_PROPDESC_FLAG_ENUMERABLE) { + goto need_check; + } + } + } + if (has_configurable) { + if (is_configurable) { + if (!(curr.flags & DUK_PROPDESC_FLAG_CONFIGURABLE)) { + goto need_check; + } + } else { + if (curr.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) { + goto need_check; + } + } + } + if (has_value) { + duk_tval *tmp1; + duk_tval *tmp2; + + /* attempt to change from accessor to data property */ + if (curr.flags & DUK_PROPDESC_FLAG_ACCESSOR) { + goto need_check; + } + + tmp1 = duk_require_tval(thr, -1); /* curr value */ + tmp2 = duk_require_tval(thr, idx_value); /* new value */ + if (!duk_js_samevalue(tmp1, tmp2)) { + goto need_check; + } + } + if (has_writable) { + /* attempt to change from accessor to data property */ + if (curr.flags & DUK_PROPDESC_FLAG_ACCESSOR) { + goto need_check; + } + + if (is_writable) { + if (!(curr.flags & DUK_PROPDESC_FLAG_WRITABLE)) { + goto need_check; + } + } else { + if (curr.flags & DUK_PROPDESC_FLAG_WRITABLE) { + goto need_check; + } + } + } + if (has_set) { + if (curr.flags & DUK_PROPDESC_FLAG_ACCESSOR) { + if (set != curr.set) { + goto need_check; + } + } else { + goto need_check; + } + } + if (has_get) { + if (curr.flags & DUK_PROPDESC_FLAG_ACCESSOR) { + if (get != curr.get) { + goto need_check; + } + } else { + goto need_check; + } + } + + /* property exists, either 'desc' is empty, or all values + * match (SameValue) + */ + goto success_no_exotics; + +need_check: + + /* + * Some change(s) need to be made. Steps 7-11. + */ + + /* shared checks for all descriptor types */ + if (!(curr.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && !force_flag) { + if (has_configurable && is_configurable) { + goto fail_not_configurable; + } + if (has_enumerable) { + if (curr.flags & DUK_PROPDESC_FLAG_ENUMERABLE) { + if (!is_enumerable) { + goto fail_not_configurable; + } + } else { + if (is_enumerable) { + goto fail_not_configurable; + } + } + } + } + + /* Virtual properties don't have backing so they can't mostly be + * edited. Some virtual properties are, however, writable: for + * example, virtual index properties of buffer objects and Array + * instance .length. These are not configurable so the checks + * above mostly cover attempts to change them, except when the + * duk_def_prop() call is used with DUK_DEFPROP_FORCE; even in + * that case we can't forcibly change the property attributes + * because they don't have concrete backing. + */ + + /* XXX: for ROM objects too it'd be best if value modify was + * allowed if the value matches SameValue. + */ + /* Reject attempt to change a read-only object. */ +#if defined(DUK_USE_ROM_OBJECTS) + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)) { + DUK_DD(DUK_DDPRINT("attempt to define property on read-only target object")); + goto fail_not_configurable; + } +#endif + + /* descriptor type specific checks */ + if (has_set || has_get) { + /* IsAccessorDescriptor(desc) == true */ + DUK_ASSERT(!has_writable); + DUK_ASSERT(!has_value); + + if (curr.flags & DUK_PROPDESC_FLAG_ACCESSOR) { + /* curr and desc are accessors */ + if (!(curr.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && !force_flag) { + if (has_set && set != curr.set) { + goto fail_not_configurable; + } + if (has_get && get != curr.get) { + goto fail_not_configurable; + } + } + } else { + duk_bool_t rc; + duk_tval *tv1; + + /* curr is data, desc is accessor */ + if (!(curr.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && !force_flag) { + goto fail_not_configurable; + } + + DUK_DDD(DUK_DDDPRINT("convert property to accessor property")); + if (curr.a_idx >= 0) { + DUK_DDD( + DUK_DDDPRINT("property to convert is stored in an array entry, abandon array and re-lookup")); + duk__abandon_array_part(thr, obj); + duk_pop_unsafe(thr); /* remove old value */ + rc = duk__get_own_propdesc_raw(thr, obj, key, arr_idx, &curr, DUK_GETDESC_FLAG_PUSH_VALUE); + DUK_UNREF(rc); + DUK_ASSERT(rc != 0); + DUK_ASSERT(curr.e_idx >= 0 && curr.a_idx < 0); + } + if (curr.e_idx < 0) { + DUK_ASSERT(curr.a_idx < 0 && curr.e_idx < 0); + goto fail_virtual; /* safeguard for virtual property */ + } + + DUK_ASSERT(curr.e_idx >= 0); + DUK_ASSERT(!DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, obj, curr.e_idx)); + + tv1 = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, obj, curr.e_idx); + DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ(thr, tv1); /* XXX: just decref */ + + DUK_HOBJECT_E_SET_VALUE_GETTER(thr->heap, obj, curr.e_idx, NULL); + DUK_HOBJECT_E_SET_VALUE_SETTER(thr->heap, obj, curr.e_idx, NULL); + DUK_HOBJECT_E_SLOT_CLEAR_WRITABLE(thr->heap, obj, curr.e_idx); + DUK_HOBJECT_E_SLOT_SET_ACCESSOR(thr->heap, obj, curr.e_idx); + + DUK_DDD(DUK_DDDPRINT("flags after data->accessor conversion: 0x%02lx", + (unsigned long) DUK_HOBJECT_E_GET_FLAGS(thr->heap, obj, curr.e_idx))); + /* Update curr.flags; faster than a re-lookup. */ + curr.flags &= ~DUK_PROPDESC_FLAG_WRITABLE; + curr.flags |= DUK_PROPDESC_FLAG_ACCESSOR; + } + } else if (has_value || has_writable) { + /* IsDataDescriptor(desc) == true */ + DUK_ASSERT(!has_set); + DUK_ASSERT(!has_get); + + if (curr.flags & DUK_PROPDESC_FLAG_ACCESSOR) { + duk_hobject *tmp; + + /* curr is accessor, desc is data */ + if (!(curr.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && !force_flag) { + goto fail_not_configurable; + } + + /* curr is accessor -> cannot be in array part. */ + DUK_ASSERT(curr.a_idx < 0); + if (curr.e_idx < 0) { + goto fail_virtual; /* safeguard; no virtual accessors now */ + } + + DUK_DDD(DUK_DDDPRINT("convert property to data property")); + + DUK_ASSERT(DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, obj, curr.e_idx)); + tmp = DUK_HOBJECT_E_GET_VALUE_GETTER(thr->heap, obj, curr.e_idx); + DUK_UNREF(tmp); + DUK_HOBJECT_E_SET_VALUE_GETTER(thr->heap, obj, curr.e_idx, NULL); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, tmp); + tmp = DUK_HOBJECT_E_GET_VALUE_SETTER(thr->heap, obj, curr.e_idx); + DUK_UNREF(tmp); + DUK_HOBJECT_E_SET_VALUE_SETTER(thr->heap, obj, curr.e_idx, NULL); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, tmp); + + DUK_TVAL_SET_UNDEFINED(DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, obj, curr.e_idx)); + DUK_HOBJECT_E_SLOT_CLEAR_WRITABLE(thr->heap, obj, curr.e_idx); + DUK_HOBJECT_E_SLOT_CLEAR_ACCESSOR(thr->heap, obj, curr.e_idx); + + DUK_DDD(DUK_DDDPRINT("flags after accessor->data conversion: 0x%02lx", + (unsigned long) DUK_HOBJECT_E_GET_FLAGS(thr->heap, obj, curr.e_idx))); + + /* Update curr.flags; faster than a re-lookup. */ + curr.flags &= ~(DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_ACCESSOR); + } else { + /* curr and desc are data */ + if (!(curr.flags & DUK_PROPDESC_FLAG_CONFIGURABLE) && !force_flag) { + if (!(curr.flags & DUK_PROPDESC_FLAG_WRITABLE) && has_writable && is_writable) { + goto fail_not_configurable; + } + /* Note: changing from writable to non-writable is OK */ + if (!(curr.flags & DUK_PROPDESC_FLAG_WRITABLE) && has_value) { + duk_tval *tmp1 = duk_require_tval(thr, -1); /* curr value */ + duk_tval *tmp2 = duk_require_tval(thr, idx_value); /* new value */ + if (!duk_js_samevalue(tmp1, tmp2)) { + goto fail_not_configurable; + } + } + } + } + } else { + /* IsGenericDescriptor(desc) == true; this means in practice that 'desc' + * only has [[Enumerable]] or [[Configurable]] flag updates, which are + * allowed at this point. + */ + + DUK_ASSERT(!has_value && !has_writable && !has_get && !has_set); + } + + /* + * Start doing property attributes updates. Steps 12-13. + * + * Start by computing new attribute flags without writing yet. + * Property type conversion is done above if necessary. + */ + + new_flags = curr.flags; + + if (has_enumerable) { + if (is_enumerable) { + new_flags |= DUK_PROPDESC_FLAG_ENUMERABLE; + } else { + new_flags &= ~DUK_PROPDESC_FLAG_ENUMERABLE; + } + } + if (has_configurable) { + if (is_configurable) { + new_flags |= DUK_PROPDESC_FLAG_CONFIGURABLE; + } else { + new_flags &= ~DUK_PROPDESC_FLAG_CONFIGURABLE; + } + } + if (has_writable) { + if (is_writable) { + new_flags |= DUK_PROPDESC_FLAG_WRITABLE; + } else { + new_flags &= ~DUK_PROPDESC_FLAG_WRITABLE; + } + } + + /* XXX: write protect after flag? -> any chance of handling it here? */ + + DUK_DDD(DUK_DDDPRINT("new flags that we want to write: 0x%02lx", (unsigned long) new_flags)); + + /* + * Check whether we need to abandon an array part (if it exists) + */ + + if (curr.a_idx >= 0) { + duk_bool_t rc; + + DUK_ASSERT(curr.e_idx < 0); + + if (new_flags == DUK_PROPDESC_FLAGS_WEC) { + duk_tval *tv1, *tv2; + + DUK_DDD(DUK_DDDPRINT("array index, new property attributes match array defaults, update in-place")); + + DUK_ASSERT(curr.flags == DUK_PROPDESC_FLAGS_WEC); /* must have been, since in array part */ + DUK_ASSERT(!has_set); + DUK_ASSERT(!has_get); + DUK_ASSERT( + idx_value >= + 0); /* must be: if attributes match and we get here the value must differ (otherwise no change) */ + + tv2 = duk_require_tval(thr, idx_value); + tv1 = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, curr.a_idx); + DUK_TVAL_SET_TVAL_UPDREF(thr, tv1, tv2); /* side effects; may invalidate a_idx */ + goto success_exotics; + } + + DUK_DDD( + DUK_DDDPRINT("array index, new property attributes do not match array defaults, abandon array and re-lookup")); + duk__abandon_array_part(thr, obj); + duk_pop_unsafe(thr); /* remove old value */ + rc = duk__get_own_propdesc_raw(thr, obj, key, arr_idx, &curr, DUK_GETDESC_FLAG_PUSH_VALUE); + DUK_UNREF(rc); + DUK_ASSERT(rc != 0); + DUK_ASSERT(curr.e_idx >= 0 && curr.a_idx < 0); + } + + DUK_DDD(DUK_DDDPRINT("updating existing property in entry part")); + + /* Array case is handled comprehensively above: either in entry + * part or a virtual property. + */ + DUK_ASSERT(curr.a_idx < 0); + + DUK_DDD(DUK_DDDPRINT("update existing property attributes")); + if (curr.e_idx >= 0) { + DUK_HOBJECT_E_SET_FLAGS(thr->heap, obj, curr.e_idx, new_flags); + } else { + /* For Array .length the only allowed transition is for .length + * to become non-writable. + */ + if (key == DUK_HTHREAD_STRING_LENGTH(thr) && DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)) { + duk_harray *a; + a = (duk_harray *) obj; + DUK_DD(DUK_DDPRINT("Object.defineProperty() attribute update for duk_harray .length -> %02lx", + (unsigned long) new_flags)); + DUK_HARRAY_ASSERT_VALID(a); + if ((new_flags & DUK_PROPDESC_FLAGS_EC) != (curr.flags & DUK_PROPDESC_FLAGS_EC)) { + DUK_D(DUK_DPRINT("Object.defineProperty() attempt to change virtual array .length enumerable or " + "configurable attribute, fail")); + goto fail_virtual; + } + if (new_flags & DUK_PROPDESC_FLAG_WRITABLE) { + DUK_HARRAY_SET_LENGTH_WRITABLE(a); + } else { + DUK_HARRAY_SET_LENGTH_NONWRITABLE(a); + } + } + } + + if (has_set) { + duk_hobject *tmp; + + /* Virtual properties are non-configurable but with a 'force' + * flag we might come here so check explicitly for virtual. + */ + if (curr.e_idx < 0) { + goto fail_virtual; + } + + DUK_DDD(DUK_DDDPRINT("update existing property setter")); + DUK_ASSERT(DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, obj, curr.e_idx)); + + tmp = DUK_HOBJECT_E_GET_VALUE_SETTER(thr->heap, obj, curr.e_idx); + DUK_UNREF(tmp); + DUK_HOBJECT_E_SET_VALUE_SETTER(thr->heap, obj, curr.e_idx, set); + DUK_HOBJECT_INCREF_ALLOWNULL(thr, set); + DUK_HOBJECT_DECREF_ALLOWNULL(thr, tmp); /* side effects; may invalidate e_idx */ + } + if (has_get) { + duk_hobject *tmp; + + if (curr.e_idx < 0) { + goto fail_virtual; + } + + DUK_DDD(DUK_DDDPRINT("update existing property getter")); + DUK_ASSERT(DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, obj, curr.e_idx)); + + tmp = DUK_HOBJECT_E_GET_VALUE_GETTER(thr->heap, obj, curr.e_idx); + DUK_UNREF(tmp); + DUK_HOBJECT_E_SET_VALUE_GETTER(thr->heap, obj, curr.e_idx, get); + DUK_HOBJECT_INCREF_ALLOWNULL(thr, get); + DUK_HOBJECT_DECREF_ALLOWNULL(thr, tmp); /* side effects; may invalidate e_idx */ + } + if (has_value) { + duk_tval *tv1, *tv2; + + DUK_DDD(DUK_DDDPRINT("update existing property value")); + + if (curr.e_idx >= 0) { + DUK_ASSERT(!DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, obj, curr.e_idx)); + tv2 = duk_require_tval(thr, idx_value); + tv1 = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, obj, curr.e_idx); + DUK_TVAL_SET_TVAL_UPDREF(thr, tv1, tv2); /* side effects; may invalidate e_idx */ + } else { + DUK_ASSERT(curr.a_idx < 0); /* array part case handled comprehensively previously */ + + DUK_DD(DUK_DDPRINT("Object.defineProperty(), value update for virtual property")); + /* XXX: Uint8Array and other typed array virtual writes not currently + * handled. + */ + if (key == DUK_HTHREAD_STRING_LENGTH(thr) && DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)) { + duk_harray *a; + a = (duk_harray *) obj; + DUK_DD(DUK_DDPRINT("Object.defineProperty() value update for duk_harray .length -> %ld", + (long) arrlen_new_len)); + DUK_HARRAY_ASSERT_VALID(a); + a->length = arrlen_new_len; + } else { + goto fail_virtual; /* should not happen */ + } + } + } + + /* + * Standard algorithm succeeded without errors, check for exotic post-behaviors. + * + * Arguments exotic behavior in E5 Section 10.6 occurs after the standard + * [[DefineOwnProperty]] has completed successfully. + * + * Array exotic behavior in E5 Section 15.4.5.1 is implemented partly + * prior to the default [[DefineOwnProperty]], but: + * - for an array index key (e.g. "10") the final 'length' update occurs here + * - for 'length' key the element deletion and 'length' update occurs here + */ + +success_exotics: + + /* curr.a_idx or curr.e_idx may have been invalidated by side effects + * above. + */ + + /* [obj key desc value get set curr_value] */ + + if (DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)) { + duk_harray *a; + + a = (duk_harray *) obj; + DUK_HARRAY_ASSERT_VALID(a); + + if (arridx_new_array_length > 0) { + /* + * Note: zero works as a "no update" marker because the new length + * can never be zero after a new property is written. + */ + + /* E5 Section 15.4.5.1, steps 4.e.i - 4.e.ii */ + + DUK_DDD(DUK_DDDPRINT("defineProperty successful, pending array length update to: %ld", + (long) arridx_new_array_length)); + + a->length = arridx_new_array_length; + } + + if (key == DUK_HTHREAD_STRING_LENGTH(thr) && arrlen_new_len < arrlen_old_len) { + /* + * E5 Section 15.4.5.1, steps 3.k - 3.n. The order at the end combines + * the error case 3.l.iii and the success case 3.m-3.n. + */ + + /* XXX: investigate whether write protect can be handled above, if we + * just update length here while ignoring its protected status + */ + + duk_uint32_t result_len; + duk_bool_t rc; + + DUK_DDD(DUK_DDDPRINT("defineProperty successful, key is 'length', exotic array behavior, " + "doing array element deletion and length update")); + + rc = + duk__handle_put_array_length_smaller(thr, obj, arrlen_old_len, arrlen_new_len, force_flag, &result_len); + + /* update length (curr points to length, and we assume it's still valid) */ + DUK_ASSERT(result_len >= arrlen_new_len && result_len <= arrlen_old_len); + + a->length = result_len; + + if (pending_write_protect) { + DUK_DDD(DUK_DDDPRINT("setting array length non-writable (pending writability update)")); + DUK_HARRAY_SET_LENGTH_NONWRITABLE(a); + } + + /* XXX: shrink array allocation or entries compaction here? */ + if (!rc) { + DUK_DD(DUK_DDPRINT("array length write only partially successful")); + goto fail_not_configurable; + } + } + } else if (arr_idx != DUK__NO_ARRAY_INDEX && DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(obj)) { + duk_hobject *map; + duk_hobject *varenv; + + DUK_ASSERT(arridx_new_array_length == 0); + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARRAY(obj)); /* traits are separate; in particular, arguments not an array */ + + map = NULL; + varenv = NULL; + if (!duk__lookup_arguments_map(thr, obj, key, &curr, &map, &varenv)) { + goto success_no_exotics; + } + DUK_ASSERT(map != NULL); + DUK_ASSERT(varenv != NULL); + + /* [obj key desc value get set curr_value varname] */ + + if (has_set || has_get) { + /* = IsAccessorDescriptor(Desc) */ + DUK_DDD(DUK_DDDPRINT("defineProperty successful, key mapped to arguments 'map' " + "changed to an accessor, delete arguments binding")); + + (void) duk_hobject_delprop_raw(thr, map, key, 0); /* ignore result */ + } else { + /* Note: this order matters (final value before deleting map entry must be done) */ + DUK_DDD(DUK_DDDPRINT("defineProperty successful, key mapped to arguments 'map', " + "check for value update / binding deletion")); + + if (has_value) { + duk_hstring *varname; + + DUK_DDD(DUK_DDDPRINT("defineProperty successful, key mapped to arguments 'map', " + "update bound value (variable/argument)")); + + varname = duk_require_hstring(thr, -1); + DUK_ASSERT(varname != NULL); + + DUK_DDD(DUK_DDDPRINT("arguments object automatic putvar for a bound variable; " + "key=%!O, varname=%!O, value=%!T", + (duk_heaphdr *) key, + (duk_heaphdr *) varname, + (duk_tval *) duk_require_tval(thr, idx_value))); + + /* strict flag for putvar comes from our caller (currently: fixed) */ + duk_js_putvar_envrec(thr, varenv, varname, duk_require_tval(thr, idx_value), 1 /*throw_flag*/); + } + if (has_writable && !is_writable) { + DUK_DDD(DUK_DDDPRINT("defineProperty successful, key mapped to arguments 'map', " + "changed to non-writable, delete arguments binding")); + + (void) duk_hobject_delprop_raw(thr, map, key, 0); /* ignore result */ + } + } + + /* 'varname' is in stack in this else branch, leaving an unbalanced stack below, + * but this doesn't matter now. + */ + } + +success_no_exotics: + /* Some code paths use NORZ macros for simplicity, ensure refzero + * handling is completed. + */ + DUK_REFZERO_CHECK_SLOW(thr); + return 1; + +fail_not_extensible: + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_EXTENSIBLE); + DUK_WO_NORETURN(return 0;); + } + return 0; + +fail_virtual: /* just use the same "not configurable" error message" */ +fail_not_configurable: + if (throw_flag) { + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CONFIGURABLE); + DUK_WO_NORETURN(return 0;); + } + return 0; +} + +/* + * Object.prototype.hasOwnProperty() and Object.prototype.propertyIsEnumerable(). + */ + +DUK_INTERNAL duk_bool_t duk_hobject_object_ownprop_helper(duk_hthread *thr, duk_small_uint_t required_desc_flags) { + duk_hstring *h_v; + duk_hobject *h_obj; + duk_propdesc desc; + duk_bool_t ret; + + /* coercion order matters */ + h_v = duk_to_hstring_acceptsymbol(thr, 0); + DUK_ASSERT(h_v != NULL); + + h_obj = duk_push_this_coercible_to_object(thr); + DUK_ASSERT(h_obj != NULL); + + ret = duk_hobject_get_own_propdesc(thr, h_obj, h_v, &desc, 0 /*flags*/); /* don't push value */ + + duk_push_boolean(thr, ret && ((desc.flags & required_desc_flags) == required_desc_flags)); + return 1; +} + +/* + * Object.seal() and Object.freeze() (E5 Sections 15.2.3.8 and 15.2.3.9) + * + * Since the algorithms are similar, a helper provides both functions. + * Freezing is essentially sealing + making plain properties non-writable. + * + * Note: virtual (non-concrete) properties which are non-configurable but + * writable would pose some problems, but such properties do not currently + * exist (all virtual properties are non-configurable and non-writable). + * If they did exist, the non-configurability does NOT prevent them from + * becoming non-writable. However, this change should be recorded somehow + * so that it would turn up (e.g. when getting the property descriptor), + * requiring some additional flags in the object. + */ + +DUK_INTERNAL void duk_hobject_object_seal_freeze_helper(duk_hthread *thr, duk_hobject *obj, duk_bool_t is_freeze) { + duk_uint_fast32_t i; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(obj != NULL); + + DUK_ASSERT_VALSTACK_SPACE(thr, DUK__VALSTACK_SPACE); + +#if defined(DUK_USE_ROM_OBJECTS) + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) obj)) { + DUK_DD(DUK_DDPRINT("attempt to seal/freeze a readonly object, reject")); + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CONFIGURABLE); + DUK_WO_NORETURN(return;); + } +#endif + + /* + * Abandon array part because all properties must become non-configurable. + * Note that this is now done regardless of whether this is always the case + * (skips check, but performance problem if caller would do this many times + * for the same object; not likely). + */ + + duk__abandon_array_part(thr, obj); + DUK_ASSERT(DUK_HOBJECT_GET_ASIZE(obj) == 0); + + for (i = 0; i < DUK_HOBJECT_GET_ENEXT(obj); i++) { + duk_uint8_t *fp; + + /* since duk__abandon_array_part() causes a resize, there should be no gaps in keys */ + DUK_ASSERT(DUK_HOBJECT_E_GET_KEY(thr->heap, obj, i) != NULL); + + /* avoid multiple computations of flags address; bypasses macros */ + fp = DUK_HOBJECT_E_GET_FLAGS_PTR(thr->heap, obj, i); + if (is_freeze && !((*fp) & DUK_PROPDESC_FLAG_ACCESSOR)) { + *fp &= ~(DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_CONFIGURABLE); + } else { + *fp &= ~DUK_PROPDESC_FLAG_CONFIGURABLE; + } + } + + DUK_HOBJECT_CLEAR_EXTENSIBLE(obj); + + /* no need to compact since we already did that in duk__abandon_array_part() + * (regardless of whether an array part existed or not. + */ + + return; +} + +/* + * Object.isSealed() and Object.isFrozen() (E5 Sections 15.2.3.11, 15.2.3.13) + * + * Since the algorithms are similar, a helper provides both functions. + * Freezing is essentially sealing + making plain properties non-writable. + * + * Note: all virtual (non-concrete) properties are currently non-configurable + * and non-writable (and there are no accessor virtual properties), so they don't + * need to be considered here now. + */ + +DUK_INTERNAL duk_bool_t duk_hobject_object_is_sealed_frozen_helper(duk_hthread *thr, duk_hobject *obj, duk_bool_t is_frozen) { + duk_uint_fast32_t i; + + DUK_ASSERT(obj != NULL); + DUK_UNREF(thr); + + /* Note: no allocation pressure, no need to check refcounts etc */ + + /* must not be extensible */ + if (DUK_HOBJECT_HAS_EXTENSIBLE(obj)) { + return 0; + } + + /* all virtual properties are non-configurable and non-writable */ + + /* entry part must not contain any configurable properties, or + * writable properties (if is_frozen). + */ + for (i = 0; i < DUK_HOBJECT_GET_ENEXT(obj); i++) { + duk_small_uint_t flags; + + if (!DUK_HOBJECT_E_GET_KEY(thr->heap, obj, i)) { + continue; + } + + /* avoid multiple computations of flags address; bypasses macros */ + flags = (duk_small_uint_t) DUK_HOBJECT_E_GET_FLAGS(thr->heap, obj, i); + + if (flags & DUK_PROPDESC_FLAG_CONFIGURABLE) { + return 0; + } + if (is_frozen && !(flags & DUK_PROPDESC_FLAG_ACCESSOR) && (flags & DUK_PROPDESC_FLAG_WRITABLE)) { + return 0; + } + } + + /* array part must not contain any non-unused properties, as they would + * be configurable and writable. + */ + for (i = 0; i < DUK_HOBJECT_GET_ASIZE(obj); i++) { + duk_tval *tv = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, obj, i); + if (!DUK_TVAL_IS_UNUSED(tv)) { + return 0; + } + } + + return 1; +} + +/* + * Object.preventExtensions() and Object.isExtensible() (E5 Sections 15.2.3.10, 15.2.3.13) + * + * Not needed, implemented by macros DUK_HOBJECT_{HAS,CLEAR,SET}_EXTENSIBLE + * and the Object built-in bindings. + */ + +/* automatic undefs */ +#undef DUK__HASH_DELETED +#undef DUK__HASH_UNUSED +#undef DUK__NO_ARRAY_INDEX +#undef DUK__VALSTACK_PROXY_LOOKUP +#undef DUK__VALSTACK_SPACE +#line 1 "duk_hstring_assert.c" +/* + * duk_hstring assertion helpers. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_ASSERTIONS) + +DUK_INTERNAL void duk_hstring_assert_valid(duk_hstring *h) { + DUK_ASSERT(h != NULL); +} + +#endif /* DUK_USE_ASSERTIONS */ +#line 1 "duk_hstring_misc.c" +/* + * Misc support functions + */ + +/* #include duk_internal.h -> already included */ + +/* + * duk_hstring charCodeAt, with and without surrogate awareness + */ + +DUK_INTERNAL duk_ucodepoint_t duk_hstring_char_code_at_raw(duk_hthread *thr, + duk_hstring *h, + duk_uint_t pos, + duk_bool_t surrogate_aware) { + duk_uint32_t boff; + const duk_uint8_t *p, *p_start, *p_end; + duk_ucodepoint_t cp1; + duk_ucodepoint_t cp2; + + /* Caller must check character offset to be inside the string. */ + DUK_ASSERT(thr != NULL); + DUK_ASSERT(h != NULL); + DUK_ASSERT_DISABLE(pos >= 0); /* unsigned */ + DUK_ASSERT(pos < (duk_uint_t) DUK_HSTRING_GET_CHARLEN(h)); + + boff = (duk_uint32_t) duk_heap_strcache_offset_char2byte(thr, h, (duk_uint32_t) pos); + DUK_DDD(DUK_DDDPRINT("charCodeAt: pos=%ld -> boff=%ld, str=%!O", (long) pos, (long) boff, (duk_heaphdr *) h)); + DUK_ASSERT_DISABLE(boff >= 0); + DUK_ASSERT(boff < DUK_HSTRING_GET_BYTELEN(h)); + + p_start = DUK_HSTRING_GET_DATA(h); + p_end = p_start + DUK_HSTRING_GET_BYTELEN(h); + p = p_start + boff; + DUK_DDD(DUK_DDDPRINT("p_start=%p, p_end=%p, p=%p", (const void *) p_start, (const void *) p_end, (const void *) p)); + + /* For invalid UTF-8 (never happens for standard ECMAScript strings) + * return U+FFFD replacement character. + */ + if (duk_unicode_decode_xutf8(thr, &p, p_start, p_end, &cp1)) { + if (surrogate_aware && cp1 >= 0xd800UL && cp1 <= 0xdbffUL) { + /* The decode helper is memory safe even if 'cp1' was + * decoded at the end of the string and 'p' is no longer + * within string memory range. + */ + cp2 = 0; /* If call fails, this is left untouched and won't match cp2 check. */ + (void) duk_unicode_decode_xutf8(thr, &p, p_start, p_end, &cp2); + if (cp2 >= 0xdc00UL && cp2 <= 0xdfffUL) { + cp1 = (duk_ucodepoint_t) (((cp1 - 0xd800UL) << 10) + (cp2 - 0xdc00UL) + 0x10000UL); + } + } + } else { + cp1 = DUK_UNICODE_CP_REPLACEMENT_CHARACTER; + } + + return cp1; +} + +/* + * duk_hstring charlen, when lazy charlen disabled + */ + +#if !defined(DUK_USE_HSTRING_LAZY_CLEN) +#if !defined(DUK_USE_HSTRING_CLEN) +#error non-lazy duk_hstring charlen but DUK_USE_HSTRING_CLEN not set +#endif +DUK_INTERNAL void duk_hstring_init_charlen(duk_hstring *h) { + duk_uint32_t clen; + + DUK_ASSERT(h != NULL); + DUK_ASSERT(!DUK_HSTRING_HAS_ASCII(h)); + DUK_ASSERT(!DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) h)); + + clen = duk_unicode_unvalidated_utf8_length(DUK_HSTRING_GET_DATA(h), DUK_HSTRING_GET_BYTELEN(h)); +#if defined(DUK_USE_STRLEN16) + DUK_ASSERT(clen <= 0xffffUL); /* Bytelength checked during interning. */ + h->clen16 = (duk_uint16_t) clen; +#else + h->clen = (duk_uint32_t) clen; +#endif + if (DUK_LIKELY(clen == DUK_HSTRING_GET_BYTELEN(h))) { + DUK_HSTRING_SET_ASCII(h); + } +} + +DUK_INTERNAL DUK_HOT duk_size_t duk_hstring_get_charlen(duk_hstring *h) { +#if defined(DUK_USE_STRLEN16) + return h->clen16; +#else + return h->clen; +#endif +} +#endif /* !DUK_USE_HSTRING_LAZY_CLEN */ + +/* + * duk_hstring charlen, when lazy charlen enabled + */ + +#if defined(DUK_USE_HSTRING_LAZY_CLEN) +#if defined(DUK_USE_HSTRING_CLEN) +DUK_LOCAL DUK_COLD duk_size_t duk__hstring_get_charlen_slowpath(duk_hstring *h) { + duk_size_t res; + + DUK_ASSERT(h->clen == 0); /* Checked by caller. */ + +#if defined(DUK_USE_ROM_STRINGS) + /* ROM strings have precomputed clen, but if the computed clen is zero + * we can still come here and can't write anything. + */ + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) h)) { + return 0; + } +#endif + + res = duk_unicode_unvalidated_utf8_length(DUK_HSTRING_GET_DATA(h), DUK_HSTRING_GET_BYTELEN(h)); +#if defined(DUK_USE_STRLEN16) + DUK_ASSERT(res <= 0xffffUL); /* Bytelength checked during interning. */ + h->clen16 = (duk_uint16_t) res; +#else + h->clen = (duk_uint32_t) res; +#endif + if (DUK_LIKELY(res == DUK_HSTRING_GET_BYTELEN(h))) { + DUK_HSTRING_SET_ASCII(h); + } + return res; +} +#else /* DUK_USE_HSTRING_CLEN */ +DUK_LOCAL duk_size_t duk__hstring_get_charlen_slowpath(duk_hstring *h) { + if (DUK_LIKELY(DUK_HSTRING_HAS_ASCII(h))) { + /* Most practical strings will go here. */ + return DUK_HSTRING_GET_BYTELEN(h); + } else { + /* ASCII flag is lazy, so set it here. */ + duk_size_t res; + + /* XXX: here we could use the strcache to speed up the + * computation (matters for 'i < str.length' loops). + */ + + res = duk_unicode_unvalidated_utf8_length(DUK_HSTRING_GET_DATA(h), DUK_HSTRING_GET_BYTELEN(h)); + +#if defined(DUK_USE_ROM_STRINGS) + if (DUK_HEAPHDR_HAS_READONLY((duk_heaphdr *) h)) { + /* For ROM strings, can't write anything; ASCII flag + * is preset so we don't need to update it. + */ + return res; + } +#endif + if (DUK_LIKELY(res == DUK_HSTRING_GET_BYTELEN(h))) { + DUK_HSTRING_SET_ASCII(h); + } + return res; + } +} +#endif /* DUK_USE_HSTRING_CLEN */ + +#if defined(DUK_USE_HSTRING_CLEN) +DUK_INTERNAL DUK_HOT duk_size_t duk_hstring_get_charlen(duk_hstring *h) { +#if defined(DUK_USE_STRLEN16) + if (DUK_LIKELY(h->clen16 != 0)) { + return h->clen16; + } +#else + if (DUK_LIKELY(h->clen != 0)) { + return h->clen; + } +#endif + return duk__hstring_get_charlen_slowpath(h); +} +#else /* DUK_USE_HSTRING_CLEN */ +DUK_INTERNAL DUK_HOT duk_size_t duk_hstring_get_charlen(duk_hstring *h) { + /* Always use slow path. */ + return duk__hstring_get_charlen_slowpath(h); +} +#endif /* DUK_USE_HSTRING_CLEN */ +#endif /* DUK_USE_HSTRING_LAZY_CLEN */ + +/* + * Compare duk_hstring to an ASCII cstring. + */ + +DUK_INTERNAL duk_bool_t duk_hstring_equals_ascii_cstring(duk_hstring *h, const char *cstr) { + duk_size_t len; + + DUK_ASSERT(h != NULL); + DUK_ASSERT(cstr != NULL); + + len = DUK_STRLEN(cstr); + if (len != DUK_HSTRING_GET_BYTELEN(h)) { + return 0; + } + if (duk_memcmp((const void *) cstr, (const void *) DUK_HSTRING_GET_DATA(h), len) == 0) { + return 1; + } + return 0; +} +#line 1 "duk_hthread_alloc.c" +/* + * duk_hthread allocation and freeing. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Allocate initial stacks for a thread. Note that 'thr' must be reachable + * as a garbage collection may be triggered by the allocation attempts. + * Returns zero (without leaking memory) if init fails. + */ + +DUK_INTERNAL duk_bool_t duk_hthread_init_stacks(duk_heap *heap, duk_hthread *thr) { + duk_size_t alloc_size; + duk_size_t i; + + DUK_ASSERT(heap != NULL); + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->valstack == NULL); + DUK_ASSERT(thr->valstack_end == NULL); + DUK_ASSERT(thr->valstack_alloc_end == NULL); + DUK_ASSERT(thr->valstack_bottom == NULL); + DUK_ASSERT(thr->valstack_top == NULL); + DUK_ASSERT(thr->callstack_curr == NULL); + + /* valstack */ + DUK_ASSERT(DUK_VALSTACK_API_ENTRY_MINIMUM <= DUK_VALSTACK_INITIAL_SIZE); + alloc_size = sizeof(duk_tval) * DUK_VALSTACK_INITIAL_SIZE; + thr->valstack = (duk_tval *) DUK_ALLOC(heap, alloc_size); + if (!thr->valstack) { + goto fail; + } + duk_memzero(thr->valstack, alloc_size); + thr->valstack_end = thr->valstack + DUK_VALSTACK_API_ENTRY_MINIMUM; + thr->valstack_alloc_end = thr->valstack + DUK_VALSTACK_INITIAL_SIZE; + thr->valstack_bottom = thr->valstack; + thr->valstack_top = thr->valstack; + + for (i = 0; i < DUK_VALSTACK_INITIAL_SIZE; i++) { + DUK_TVAL_SET_UNDEFINED(&thr->valstack[i]); + } + + return 1; + +fail: + DUK_FREE(heap, thr->valstack); + DUK_ASSERT(thr->callstack_curr == NULL); + + thr->valstack = NULL; + return 0; +} + +/* For indirect allocs. */ + +DUK_INTERNAL void *duk_hthread_get_valstack_ptr(duk_heap *heap, void *ud) { + duk_hthread *thr = (duk_hthread *) ud; + DUK_UNREF(heap); + return (void *) thr->valstack; +} +#line 1 "duk_hthread_builtins.c" +/* + * Initialize built-in objects. Current thread must have a valstack + * and initialization errors may longjmp, so a setjmp() catch point + * must exist. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Encoding constants, must match genbuiltins.py + */ + +#define DUK__PROP_FLAGS_BITS 3 +#define DUK__LENGTH_PROP_BITS 3 +#define DUK__NARGS_BITS 3 +#define DUK__PROP_TYPE_BITS 3 + +#define DUK__NARGS_VARARGS_MARKER 0x07 + +#define DUK__PROP_TYPE_DOUBLE 0 +#define DUK__PROP_TYPE_STRING 1 +#define DUK__PROP_TYPE_STRIDX 2 +#define DUK__PROP_TYPE_BUILTIN 3 +#define DUK__PROP_TYPE_UNDEFINED 4 +#define DUK__PROP_TYPE_BOOLEAN_TRUE 5 +#define DUK__PROP_TYPE_BOOLEAN_FALSE 6 +#define DUK__PROP_TYPE_ACCESSOR 7 + +/* + * Create built-in objects by parsing an init bitstream generated + * by genbuiltins.py. + */ + +#if defined(DUK_USE_ROM_OBJECTS) +#if defined(DUK_USE_ROM_GLOBAL_CLONE) || defined(DUK_USE_ROM_GLOBAL_INHERIT) +DUK_LOCAL void duk__duplicate_ram_global_object(duk_hthread *thr) { + duk_hobject *h_global; +#if defined(DUK_USE_ROM_GLOBAL_CLONE) + duk_hobject *h_oldglobal; + duk_uint8_t *props; + duk_size_t alloc_size; +#endif + duk_hobject *h_objenv; + + /* XXX: refactor into internal helper, duk_clone_hobject() */ + +#if defined(DUK_USE_ROM_GLOBAL_INHERIT) + /* Inherit from ROM-based global object: less RAM usage, less transparent. */ + h_global = duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_GLOBAL), + DUK_BIDX_GLOBAL); + DUK_ASSERT(h_global != NULL); +#elif defined(DUK_USE_ROM_GLOBAL_CLONE) + /* Clone the properties of the ROM-based global object to create a + * fully RAM-based global object. Uses more memory than the inherit + * model but more compliant. + */ + h_global = duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_GLOBAL), + DUK_BIDX_OBJECT_PROTOTYPE); + DUK_ASSERT(h_global != NULL); + h_oldglobal = thr->builtins[DUK_BIDX_GLOBAL]; + DUK_ASSERT(h_oldglobal != NULL); + + /* Copy the property table verbatim; this handles attributes etc. + * For ROM objects it's not necessary (or possible) to update + * refcounts so leave them as is. + */ + alloc_size = DUK_HOBJECT_P_ALLOC_SIZE(h_oldglobal); + DUK_ASSERT(alloc_size > 0); + props = DUK_ALLOC_CHECKED(thr, alloc_size); + DUK_ASSERT(props != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_PROPS(thr->heap, h_oldglobal) != NULL); + duk_memcpy((void *) props, (const void *) DUK_HOBJECT_GET_PROPS(thr->heap, h_oldglobal), alloc_size); + + /* XXX: keep property attributes or tweak them here? + * Properties will now be non-configurable even when they're + * normally configurable for the global object. + */ + + DUK_ASSERT(DUK_HOBJECT_GET_PROPS(thr->heap, h_global) == NULL); + DUK_HOBJECT_SET_PROPS(thr->heap, h_global, props); + DUK_HOBJECT_SET_ESIZE(h_global, DUK_HOBJECT_GET_ESIZE(h_oldglobal)); + DUK_HOBJECT_SET_ENEXT(h_global, DUK_HOBJECT_GET_ENEXT(h_oldglobal)); + DUK_HOBJECT_SET_ASIZE(h_global, DUK_HOBJECT_GET_ASIZE(h_oldglobal)); + DUK_HOBJECT_SET_HSIZE(h_global, DUK_HOBJECT_GET_HSIZE(h_oldglobal)); +#else +#error internal error in config defines +#endif + + duk_hobject_compact_props(thr, h_global); + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL] != NULL); + DUK_ASSERT( + !DUK_HEAPHDR_NEEDS_REFCOUNT_UPDATE((duk_heaphdr *) thr->builtins[DUK_BIDX_GLOBAL])); /* no need to decref: ROM object */ + thr->builtins[DUK_BIDX_GLOBAL] = h_global; + DUK_HOBJECT_INCREF(thr, h_global); + DUK_D(DUK_DPRINT("duplicated global object: %!O", h_global)); + + /* Create a fresh object environment for the global scope. This is + * needed so that the global scope points to the newly created RAM-based + * global object. + */ + h_objenv = + (duk_hobject *) duk_hobjenv_alloc(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJENV)); + DUK_ASSERT(h_objenv != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, h_objenv) == NULL); + duk_push_hobject(thr, h_objenv); + + DUK_ASSERT(h_global != NULL); + ((duk_hobjenv *) h_objenv)->target = h_global; + DUK_HOBJECT_INCREF(thr, h_global); + DUK_ASSERT(((duk_hobjenv *) h_objenv)->has_this == 0); + + DUK_ASSERT(thr->builtins[DUK_BIDX_GLOBAL_ENV] != NULL); + DUK_ASSERT(!DUK_HEAPHDR_NEEDS_REFCOUNT_UPDATE( + (duk_heaphdr *) thr->builtins[DUK_BIDX_GLOBAL_ENV])); /* no need to decref: ROM object */ + thr->builtins[DUK_BIDX_GLOBAL_ENV] = h_objenv; + DUK_HOBJECT_INCREF(thr, h_objenv); + DUK_D(DUK_DPRINT("duplicated global env: %!O", h_objenv)); + + DUK_HOBJENV_ASSERT_VALID((duk_hobjenv *) h_objenv); + + duk_pop_2(thr); /* Pop global object and global env. */ +} +#endif /* DUK_USE_ROM_GLOBAL_CLONE || DUK_USE_ROM_GLOBAL_INHERIT */ + +DUK_INTERNAL void duk_hthread_create_builtin_objects(duk_hthread *thr) { + /* Setup builtins from ROM objects. All heaps/threads will share + * the same readonly objects. + */ + duk_small_uint_t i; + + for (i = 0; i < DUK_NUM_BUILTINS; i++) { + duk_hobject *h; + h = (duk_hobject *) DUK_LOSE_CONST(duk_rom_builtins_bidx[i]); + DUK_ASSERT(h != NULL); + thr->builtins[i] = h; + } + +#if defined(DUK_USE_ROM_GLOBAL_CLONE) || defined(DUK_USE_ROM_GLOBAL_INHERIT) + /* By default the global object is read-only which is often much + * more of an issue than having read-only built-in objects (like + * RegExp, Date, etc). Use a RAM-based copy of the global object + * and the global environment object for convenience. + */ + duk__duplicate_ram_global_object(thr); +#endif +} +#else /* DUK_USE_ROM_OBJECTS */ +DUK_LOCAL void duk__push_stridx(duk_hthread *thr, duk_bitdecoder_ctx *bd) { + duk_small_uint_t n; + + n = (duk_small_uint_t) duk_bd_decode_varuint(bd); + DUK_ASSERT_DISABLE(n >= 0); /* unsigned */ + DUK_ASSERT(n < DUK_HEAP_NUM_STRINGS); + duk_push_hstring_stridx(thr, n); +} +DUK_LOCAL void duk__push_string(duk_hthread *thr, duk_bitdecoder_ctx *bd) { + /* XXX: built-ins data could provide a maximum length that is + * actually needed; bitpacked max length is now 256 bytes. + */ + duk_uint8_t tmp[DUK_BD_BITPACKED_STRING_MAXLEN]; + duk_small_uint_t len; + + len = duk_bd_decode_bitpacked_string(bd, tmp); + duk_push_lstring(thr, (const char *) tmp, (duk_size_t) len); +} +DUK_LOCAL void duk__push_stridx_or_string(duk_hthread *thr, duk_bitdecoder_ctx *bd) { + duk_small_uint_t n; + + n = (duk_small_uint_t) duk_bd_decode_varuint(bd); + if (n == 0) { + duk__push_string(thr, bd); + } else { + n--; + DUK_ASSERT(n < DUK_HEAP_NUM_STRINGS); + duk_push_hstring_stridx(thr, n); + } +} +DUK_LOCAL void duk__push_double(duk_hthread *thr, duk_bitdecoder_ctx *bd) { + duk_double_union du; + duk_small_uint_t i; + + for (i = 0; i < 8; i++) { + /* Encoding endianness must match target memory layout, + * build scripts and genbuiltins.py must ensure this. + */ + du.uc[i] = (duk_uint8_t) duk_bd_decode(bd, 8); + } + + duk_push_number(thr, du.d); /* push operation normalizes NaNs */ +} + +DUK_INTERNAL void duk_hthread_create_builtin_objects(duk_hthread *thr) { + duk_bitdecoder_ctx bd_ctx; + duk_bitdecoder_ctx *bd = &bd_ctx; /* convenience */ + duk_hobject *h; + duk_small_uint_t i, j; + + DUK_D(DUK_DPRINT("INITBUILTINS BEGIN: DUK_NUM_BUILTINS=%d, DUK_NUM_BUILTINS_ALL=%d", + (int) DUK_NUM_BUILTINS, + (int) DUK_NUM_ALL_BUILTINS)); + + duk_memzero(&bd_ctx, sizeof(bd_ctx)); + bd->data = (const duk_uint8_t *) duk_builtins_data; + bd->length = (duk_size_t) DUK_BUILTINS_DATA_LENGTH; + + /* + * First create all built-in bare objects on the empty valstack. + * + * Built-ins in the index range [0,DUK_NUM_BUILTINS-1] have value + * stack indices matching their eventual thr->builtins[] index. + * + * Built-ins in the index range [DUK_NUM_BUILTINS,DUK_NUM_ALL_BUILTINS] + * will exist on the value stack during init but won't be placed + * into thr->builtins[]. These are objects referenced in some way + * from thr->builtins[] roots but which don't need to be indexed by + * Duktape through thr->builtins[] (e.g. user custom objects). + * + * Internal prototypes will be incorrect (NULL) at this stage. + */ + + duk_require_stack(thr, DUK_NUM_ALL_BUILTINS); + + DUK_DD(DUK_DDPRINT("create empty built-ins")); + DUK_ASSERT_TOP(thr, 0); + for (i = 0; i < DUK_NUM_ALL_BUILTINS; i++) { + duk_small_uint_t class_num; + duk_small_int_t len = -1; /* must be signed */ + + class_num = (duk_small_uint_t) duk_bd_decode_varuint(bd); + len = (duk_small_int_t) duk_bd_decode_flagged_signed(bd, DUK__LENGTH_PROP_BITS, (duk_int32_t) -1 /*def_value*/); + + if (class_num == DUK_HOBJECT_CLASS_FUNCTION) { + duk_small_uint_t natidx; + duk_small_int_t c_nargs; /* must hold DUK_VARARGS */ + duk_c_function c_func; + duk_int16_t magic; + + DUK_DDD(DUK_DDDPRINT("len=%ld", (long) len)); + DUK_ASSERT(len >= 0); + + natidx = (duk_small_uint_t) duk_bd_decode_varuint(bd); + DUK_ASSERT(natidx != 0); + c_func = duk_bi_native_functions[natidx]; + DUK_ASSERT(c_func != NULL); + + c_nargs = (duk_small_int_t) duk_bd_decode_flagged_signed(bd, DUK__NARGS_BITS, len /*def_value*/); + if (c_nargs == DUK__NARGS_VARARGS_MARKER) { + c_nargs = DUK_VARARGS; + } + + /* XXX: set magic directly here? (it could share the c_nargs arg) */ + (void) duk_push_c_function_builtin(thr, c_func, c_nargs); + h = duk_known_hobject(thr, -1); + + /* Currently all built-in native functions are strict. + * duk_push_c_function() now sets strict flag, so + * assert for it. + */ + DUK_ASSERT(DUK_HOBJECT_HAS_STRICT(h)); + + /* XXX: function properties */ + + duk__push_stridx_or_string(thr, bd); +#if defined(DUK_USE_FUNC_NAME_PROPERTY) + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_NAME, DUK_PROPDESC_FLAGS_C); +#else + duk_pop(thr); /* Not very ideal but good enough for now. */ +#endif + + /* Almost all global level Function objects are constructable + * but not all: Function.prototype is a non-constructable, + * callable Function. + */ + if (duk_bd_decode_flag(bd)) { + DUK_ASSERT(DUK_HOBJECT_HAS_CONSTRUCTABLE(h)); + } else { + DUK_HOBJECT_CLEAR_CONSTRUCTABLE(h); + } + + /* Cast converts magic to 16-bit signed value */ + magic = (duk_int16_t) duk_bd_decode_varuint(bd); + ((duk_hnatfunc *) h)->magic = magic; + } else if (class_num == DUK_HOBJECT_CLASS_ARRAY) { + duk_push_array(thr); + } else if (class_num == DUK_HOBJECT_CLASS_OBJENV) { + duk_hobjenv *env; + duk_hobject *global; + + DUK_ASSERT(i == DUK_BIDX_GLOBAL_ENV); + DUK_ASSERT(DUK_BIDX_GLOBAL_ENV > DUK_BIDX_GLOBAL); + + env = duk_hobjenv_alloc(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJENV)); + DUK_ASSERT(env->target == NULL); + duk_push_hobject(thr, (duk_hobject *) env); + + global = duk_known_hobject(thr, DUK_BIDX_GLOBAL); + DUK_ASSERT(global != NULL); + env->target = global; + DUK_HOBJECT_INCREF(thr, global); + DUK_ASSERT(env->has_this == 0); + + DUK_HOBJENV_ASSERT_VALID(env); + } else { + DUK_ASSERT(class_num != DUK_HOBJECT_CLASS_DECENV); + + (void) duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_EXTENSIBLE, + -1); /* no prototype or class yet */ + } + + h = duk_known_hobject(thr, -1); + DUK_HOBJECT_SET_CLASS_NUMBER(h, class_num); + + if (i < DUK_NUM_BUILTINS) { + thr->builtins[i] = h; + DUK_HOBJECT_INCREF(thr, &h->hdr); + } + + if (len >= 0) { + /* In ES2015+ built-in function object .length property + * has property attributes C (configurable only): + * http://www.ecma-international.org/ecma-262/7.0/#sec-ecmascript-standard-built-in-objects + * + * Array.prototype remains an Array instance in ES2015+ + * and its length has attributes W (writable only). + * Because .length is now virtual for duk_harray, it is + * not encoded explicitly in init data. + */ + + DUK_ASSERT(class_num != DUK_HOBJECT_CLASS_ARRAY); /* .length is virtual */ + duk_push_int(thr, len); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_C); + } + + /* enable exotic behaviors last */ + + if (class_num == DUK_HOBJECT_CLASS_ARRAY) { + DUK_ASSERT(DUK_HOBJECT_HAS_EXOTIC_ARRAY(h)); /* set by duk_push_array() */ + } + if (class_num == DUK_HOBJECT_CLASS_STRING) { + DUK_HOBJECT_SET_EXOTIC_STRINGOBJ(h); + } + + /* some assertions */ + + DUK_ASSERT(DUK_HOBJECT_HAS_EXTENSIBLE(h)); + /* DUK_HOBJECT_FLAG_CONSTRUCTABLE varies */ + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(h)); + DUK_ASSERT(!DUK_HOBJECT_HAS_COMPFUNC(h)); + /* DUK_HOBJECT_FLAG_NATFUNC varies */ + DUK_ASSERT(!DUK_HOBJECT_IS_THREAD(h)); + DUK_ASSERT(!DUK_HOBJECT_IS_PROXY(h)); + DUK_ASSERT(!DUK_HOBJECT_HAS_ARRAY_PART(h) || class_num == DUK_HOBJECT_CLASS_ARRAY); + /* DUK_HOBJECT_FLAG_STRICT varies */ + DUK_ASSERT(!DUK_HOBJECT_HAS_NATFUNC(h) || /* all native functions have NEWENV */ + DUK_HOBJECT_HAS_NEWENV(h)); + DUK_ASSERT(!DUK_HOBJECT_HAS_NAMEBINDING(h)); + DUK_ASSERT(!DUK_HOBJECT_HAS_CREATEARGS(h)); + /* DUK_HOBJECT_FLAG_EXOTIC_ARRAY varies */ + /* DUK_HOBJECT_FLAG_EXOTIC_STRINGOBJ varies */ + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(h)); + + DUK_DDD(DUK_DDDPRINT("created built-in %ld, class=%ld, length=%ld", (long) i, (long) class_num, (long) len)); + } + + /* + * Then decode the builtins init data (see genbuiltins.py) to + * init objects. Internal prototypes are set at this stage, + * with thr->builtins[] populated. + */ + + DUK_DD(DUK_DDPRINT("initialize built-in object properties")); + for (i = 0; i < DUK_NUM_ALL_BUILTINS; i++) { + duk_small_uint_t t; + duk_small_uint_t num; + + DUK_DDD(DUK_DDDPRINT("initializing built-in object at index %ld", (long) i)); + h = duk_known_hobject(thr, (duk_idx_t) i); + + t = (duk_small_uint_t) duk_bd_decode_varuint(bd); + if (t > 0) { + t--; + DUK_DDD(DUK_DDDPRINT("set internal prototype: built-in %ld", (long) t)); + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, h, duk_known_hobject(thr, (duk_idx_t) t)); + } else if (DUK_HOBJECT_IS_NATFUNC(h)) { + /* Standard native built-ins cannot inherit from + * %NativeFunctionPrototype%, they are required to + * inherit from Function.prototype directly. + */ + DUK_ASSERT(thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE] != NULL); + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, h, thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); + } + + t = (duk_small_uint_t) duk_bd_decode_varuint(bd); + if (t > 0) { + /* 'prototype' property for all built-in objects (which have it) has attributes: + * [[Writable]] = false, + * [[Enumerable]] = false, + * [[Configurable]] = false + */ + t--; + DUK_DDD(DUK_DDDPRINT("set external prototype: built-in %ld", (long) t)); + duk_dup(thr, (duk_idx_t) t); + duk_xdef_prop_stridx(thr, (duk_idx_t) i, DUK_STRIDX_PROTOTYPE, DUK_PROPDESC_FLAGS_NONE); + } + + t = (duk_small_uint_t) duk_bd_decode_varuint(bd); + if (t > 0) { + /* 'constructor' property for all built-in objects (which have it) has attributes: + * [[Writable]] = true, + * [[Enumerable]] = false, + * [[Configurable]] = true + */ + t--; + DUK_DDD(DUK_DDDPRINT("set external constructor: built-in %ld", (long) t)); + duk_dup(thr, (duk_idx_t) t); + duk_xdef_prop_stridx(thr, (duk_idx_t) i, DUK_STRIDX_CONSTRUCTOR, DUK_PROPDESC_FLAGS_WC); + } + + /* normal valued properties */ + num = (duk_small_uint_t) duk_bd_decode_varuint(bd); + DUK_DDD(DUK_DDDPRINT("built-in object %ld, %ld normal valued properties", (long) i, (long) num)); + for (j = 0; j < num; j++) { + duk_small_uint_t defprop_flags; + + duk__push_stridx_or_string(thr, bd); + + /* + * Property attribute defaults are defined in E5 Section 15 (first + * few pages); there is a default for all properties and a special + * default for 'length' properties. Variation from the defaults is + * signaled using a single flag bit in the bitstream. + */ + + defprop_flags = (duk_small_uint_t) duk_bd_decode_flagged(bd, + DUK__PROP_FLAGS_BITS, + (duk_uint32_t) DUK_PROPDESC_FLAGS_WC); + defprop_flags |= DUK_DEFPROP_FORCE | DUK_DEFPROP_HAVE_VALUE | DUK_DEFPROP_HAVE_WRITABLE | + DUK_DEFPROP_HAVE_ENUMERABLE | + DUK_DEFPROP_HAVE_CONFIGURABLE; /* Defaults for data properties. */ + + /* The writable, enumerable, configurable flags in prop_flags + * match both duk_def_prop() and internal property flags. + */ + DUK_ASSERT(DUK_PROPDESC_FLAG_WRITABLE == DUK_DEFPROP_WRITABLE); + DUK_ASSERT(DUK_PROPDESC_FLAG_ENUMERABLE == DUK_DEFPROP_ENUMERABLE); + DUK_ASSERT(DUK_PROPDESC_FLAG_CONFIGURABLE == DUK_DEFPROP_CONFIGURABLE); + + t = (duk_small_uint_t) duk_bd_decode(bd, DUK__PROP_TYPE_BITS); + + DUK_DDD(DUK_DDDPRINT("built-in %ld, normal-valued property %ld, key %!T, flags 0x%02lx, type %ld", + (long) i, + (long) j, + duk_get_tval(thr, -1), + (unsigned long) defprop_flags, + (long) t)); + + switch (t) { + case DUK__PROP_TYPE_DOUBLE: { + duk__push_double(thr, bd); + break; + } + case DUK__PROP_TYPE_STRING: { + duk__push_string(thr, bd); + break; + } + case DUK__PROP_TYPE_STRIDX: { + duk__push_stridx(thr, bd); + break; + } + case DUK__PROP_TYPE_BUILTIN: { + duk_small_uint_t bidx; + + bidx = (duk_small_uint_t) duk_bd_decode_varuint(bd); + duk_dup(thr, (duk_idx_t) bidx); + break; + } + case DUK__PROP_TYPE_UNDEFINED: { + duk_push_undefined(thr); + break; + } + case DUK__PROP_TYPE_BOOLEAN_TRUE: { + duk_push_true(thr); + break; + } + case DUK__PROP_TYPE_BOOLEAN_FALSE: { + duk_push_false(thr); + break; + } + case DUK__PROP_TYPE_ACCESSOR: { + duk_small_uint_t natidx_getter = (duk_small_uint_t) duk_bd_decode_varuint(bd); + duk_small_uint_t natidx_setter = (duk_small_uint_t) duk_bd_decode_varuint(bd); + duk_small_uint_t accessor_magic = (duk_small_uint_t) duk_bd_decode_varuint(bd); + duk_c_function c_func_getter; + duk_c_function c_func_setter; + + DUK_DDD(DUK_DDDPRINT( + "built-in accessor property: objidx=%ld, key=%!T, getteridx=%ld, setteridx=%ld, flags=0x%04lx", + (long) i, + duk_get_tval(thr, -1), + (long) natidx_getter, + (long) natidx_setter, + (unsigned long) defprop_flags)); + + c_func_getter = duk_bi_native_functions[natidx_getter]; + if (c_func_getter != NULL) { + duk_push_c_function_builtin_noconstruct(thr, c_func_getter, 0); /* always 0 args */ + duk_set_magic(thr, -1, (duk_int_t) accessor_magic); + defprop_flags |= DUK_DEFPROP_HAVE_GETTER; + } + c_func_setter = duk_bi_native_functions[natidx_setter]; + if (c_func_setter != NULL) { + duk_push_c_function_builtin_noconstruct(thr, c_func_setter, 1); /* always 1 arg */ + duk_set_magic(thr, -1, (duk_int_t) accessor_magic); + defprop_flags |= DUK_DEFPROP_HAVE_SETTER; + } + + /* Writable flag doesn't make sense for an accessor. */ + DUK_ASSERT((defprop_flags & DUK_PROPDESC_FLAG_WRITABLE) == 0); /* genbuiltins.py ensures */ + + defprop_flags &= ~(DUK_DEFPROP_HAVE_VALUE | DUK_DEFPROP_HAVE_WRITABLE); + defprop_flags |= DUK_DEFPROP_HAVE_ENUMERABLE | DUK_DEFPROP_HAVE_CONFIGURABLE; + break; + } + default: { + /* exhaustive */ + DUK_UNREACHABLE(); + } + } + + duk_def_prop(thr, (duk_idx_t) i, defprop_flags); + DUK_ASSERT_TOP(thr, DUK_NUM_ALL_BUILTINS); + } + + /* native function properties */ + num = (duk_small_uint_t) duk_bd_decode_varuint(bd); + DUK_DDD(DUK_DDDPRINT("built-in object %ld, %ld function valued properties", (long) i, (long) num)); + for (j = 0; j < num; j++) { + duk_hstring *h_key; + duk_small_uint_t natidx; + duk_int_t c_nargs; /* must hold DUK_VARARGS */ + duk_small_uint_t c_length; + duk_int16_t magic; + duk_c_function c_func; + duk_hnatfunc *h_func; +#if defined(DUK_USE_LIGHTFUNC_BUILTINS) + duk_small_int_t lightfunc_eligible; +#endif + duk_small_uint_t defprop_flags; + + duk__push_stridx_or_string(thr, bd); + h_key = duk_known_hstring(thr, -1); + DUK_UNREF(h_key); + natidx = (duk_small_uint_t) duk_bd_decode_varuint(bd); + + c_length = (duk_small_uint_t) duk_bd_decode(bd, DUK__LENGTH_PROP_BITS); + c_nargs = (duk_int_t) duk_bd_decode_flagged(bd, DUK__NARGS_BITS, (duk_uint32_t) c_length /*def_value*/); + if (c_nargs == DUK__NARGS_VARARGS_MARKER) { + c_nargs = DUK_VARARGS; + } + + c_func = duk_bi_native_functions[natidx]; + + DUK_DDD( + DUK_DDDPRINT("built-in %ld, function-valued property %ld, key %!O, natidx %ld, length %ld, nargs %ld", + (long) i, + (long) j, + (duk_heaphdr *) h_key, + (long) natidx, + (long) c_length, + (c_nargs == DUK_VARARGS ? (long) -1 : (long) c_nargs))); + + /* Cast converts magic to 16-bit signed value */ + magic = (duk_int16_t) duk_bd_decode_varuint(bd); + +#if defined(DUK_USE_LIGHTFUNC_BUILTINS) + lightfunc_eligible = + ((c_nargs >= DUK_LFUNC_NARGS_MIN && c_nargs <= DUK_LFUNC_NARGS_MAX) || (c_nargs == DUK_VARARGS)) && + (c_length <= DUK_LFUNC_LENGTH_MAX) && (magic >= DUK_LFUNC_MAGIC_MIN && magic <= DUK_LFUNC_MAGIC_MAX); + + /* These functions have trouble working as lightfuncs. + * Some of them have specific asserts and some may have + * additional properties (e.g. 'require.id' may be written). + */ + if (c_func == duk_bi_global_object_eval) { + lightfunc_eligible = 0; + } +#if defined(DUK_USE_COROUTINE_SUPPORT) + if (c_func == duk_bi_thread_yield || c_func == duk_bi_thread_resume) { + lightfunc_eligible = 0; + } +#endif + if (c_func == duk_bi_function_prototype_call || c_func == duk_bi_function_prototype_apply || + c_func == duk_bi_reflect_apply || c_func == duk_bi_reflect_construct) { + lightfunc_eligible = 0; + } + + if (lightfunc_eligible) { + duk_tval tv_lfunc; + duk_small_uint_t lf_nargs = + (duk_small_uint_t) (c_nargs == DUK_VARARGS ? DUK_LFUNC_NARGS_VARARGS : c_nargs); + duk_small_uint_t lf_flags = DUK_LFUNC_FLAGS_PACK(magic, c_length, lf_nargs); + DUK_TVAL_SET_LIGHTFUNC(&tv_lfunc, c_func, lf_flags); + duk_push_tval(thr, &tv_lfunc); + DUK_D(DUK_DPRINT("built-in function eligible as light function: i=%d, j=%d c_length=%ld, " + "c_nargs=%ld, magic=%ld -> %!iT", + (int) i, + (int) j, + (long) c_length, + (long) c_nargs, + (long) magic, + duk_get_tval(thr, -1))); + goto lightfunc_skip; + } + + DUK_D(DUK_DPRINT( + "built-in function NOT ELIGIBLE as light function: i=%d, j=%d c_length=%ld, c_nargs=%ld, magic=%ld", + (int) i, + (int) j, + (long) c_length, + (long) c_nargs, + (long) magic)); +#endif /* DUK_USE_LIGHTFUNC_BUILTINS */ + + /* [ (builtin objects) name ] */ + + duk_push_c_function_builtin_noconstruct(thr, c_func, c_nargs); + h_func = duk_known_hnatfunc(thr, -1); + DUK_UNREF(h_func); + + /* XXX: add into init data? */ + + /* Special call handling, not described in init data. */ + if (c_func == duk_bi_global_object_eval || c_func == duk_bi_function_prototype_call || + c_func == duk_bi_function_prototype_apply || c_func == duk_bi_reflect_apply || + c_func == duk_bi_reflect_construct) { + DUK_HOBJECT_SET_SPECIAL_CALL((duk_hobject *) h_func); + } + + /* Currently all built-in native functions are strict. + * This doesn't matter for many functions, but e.g. + * String.prototype.charAt (and other string functions) + * rely on being strict so that their 'this' binding is + * not automatically coerced. + */ + DUK_HOBJECT_SET_STRICT((duk_hobject *) h_func); + + /* No built-in functions are constructable except the top + * level ones (Number, etc). + */ + DUK_ASSERT(!DUK_HOBJECT_HAS_CONSTRUCTABLE((duk_hobject *) h_func)); + + /* XXX: any way to avoid decoding magic bit; there are quite + * many function properties and relatively few with magic values. + */ + h_func->magic = magic; + + /* [ (builtin objects) name func ] */ + + duk_push_uint(thr, c_length); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_C); + + duk_dup_m2(thr); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_NAME, DUK_PROPDESC_FLAGS_C); + + /* XXX: other properties of function instances; 'arguments', 'caller'. */ + + DUK_DD(DUK_DDPRINT("built-in object %ld, function property %ld -> %!T", + (long) i, + (long) j, + (duk_tval *) duk_get_tval(thr, -1))); + + /* [ (builtin objects) name func ] */ + + /* + * The default property attributes are correct for all + * function valued properties of built-in objects now. + */ + +#if defined(DUK_USE_LIGHTFUNC_BUILTINS) + lightfunc_skip: +#endif + + defprop_flags = (duk_small_uint_t) duk_bd_decode_flagged(bd, + DUK__PROP_FLAGS_BITS, + (duk_uint32_t) DUK_PROPDESC_FLAGS_WC); + defprop_flags |= DUK_DEFPROP_FORCE | DUK_DEFPROP_HAVE_VALUE | DUK_DEFPROP_HAVE_WRITABLE | + DUK_DEFPROP_HAVE_ENUMERABLE | DUK_DEFPROP_HAVE_CONFIGURABLE; + DUK_ASSERT(DUK_PROPDESC_FLAG_WRITABLE == DUK_DEFPROP_WRITABLE); + DUK_ASSERT(DUK_PROPDESC_FLAG_ENUMERABLE == DUK_DEFPROP_ENUMERABLE); + DUK_ASSERT(DUK_PROPDESC_FLAG_CONFIGURABLE == DUK_DEFPROP_CONFIGURABLE); + + duk_def_prop(thr, (duk_idx_t) i, defprop_flags); + + /* [ (builtin objects) ] */ + } + } + + /* + * Special post-tweaks, for cases not covered by the init data format. + * + * - Set Date.prototype.toGMTString to Date.prototype.toUTCString. + * toGMTString is required to have the same Function object as + * toUTCString in E5 Section B.2.6. Note that while Smjs respects + * this, V8 does not (the Function objects are distinct). + * + * - Make DoubleError non-extensible. + * + * - Add info about most important effective compile options to Duktape. + * + * - Possibly remove some properties (values or methods) which are not + * desirable with current feature options but are not currently + * conditional in init data. + */ + +#if defined(DUK_USE_DATE_BUILTIN) + duk_get_prop_stridx_short(thr, DUK_BIDX_DATE_PROTOTYPE, DUK_STRIDX_TO_UTC_STRING); + duk_xdef_prop_stridx_short(thr, DUK_BIDX_DATE_PROTOTYPE, DUK_STRIDX_TO_GMT_STRING, DUK_PROPDESC_FLAGS_WC); +#endif + + h = duk_known_hobject(thr, DUK_BIDX_DOUBLE_ERROR); + DUK_HOBJECT_CLEAR_EXTENSIBLE(h); + +#if !defined(DUK_USE_ES6_OBJECT_PROTO_PROPERTY) + DUK_DD(DUK_DDPRINT("delete Object.prototype.__proto__ built-in which is not enabled in features")); + (void) duk_hobject_delprop_raw(thr, + thr->builtins[DUK_BIDX_OBJECT_PROTOTYPE], + DUK_HTHREAD_STRING___PROTO__(thr), + DUK_DELPROP_FLAG_THROW); +#endif + +#if !defined(DUK_USE_ES6_OBJECT_SETPROTOTYPEOF) + DUK_DD(DUK_DDPRINT("delete Object.setPrototypeOf built-in which is not enabled in features")); + (void) duk_hobject_delprop_raw(thr, + thr->builtins[DUK_BIDX_OBJECT_CONSTRUCTOR], + DUK_HTHREAD_STRING_SET_PROTOTYPE_OF(thr), + DUK_DELPROP_FLAG_THROW); +#endif + + /* XXX: relocate */ + duk_push_string(thr, + /* Endianness indicator */ +#if defined(DUK_USE_INTEGER_LE) + "l" +#elif defined(DUK_USE_INTEGER_BE) + "b" +#elif defined(DUK_USE_INTEGER_ME) /* integer mixed endian not really used now */ + "m" +#else + "?" +#endif +#if defined(DUK_USE_DOUBLE_LE) + "l" +#elif defined(DUK_USE_DOUBLE_BE) + "b" +#elif defined(DUK_USE_DOUBLE_ME) + "m" +#else + "?" +#endif + " " + /* Packed or unpacked tval */ +#if defined(DUK_USE_PACKED_TVAL) + "p" +#else + "u" +#endif +#if defined(DUK_USE_FASTINT) + "f" +#endif + " " + /* Low memory/performance options */ +#if defined(DUK_USE_STRTAB_PTRCOMP) + "s" +#endif +#if !defined(DUK_USE_HEAPPTR16) && !defined(DUK_DATAPTR16) && !defined(DUK_FUNCPTR16) + "n" +#endif +#if defined(DUK_USE_HEAPPTR16) + "h" +#endif +#if defined(DUK_USE_DATAPTR16) + "d" +#endif +#if defined(DUK_USE_FUNCPTR16) + "f" +#endif +#if defined(DUK_USE_REFCOUNT16) + "R" +#endif +#if defined(DUK_USE_STRHASH16) + "H" +#endif +#if defined(DUK_USE_STRLEN16) + "S" +#endif +#if defined(DUK_USE_BUFLEN16) + "B" +#endif +#if defined(DUK_USE_OBJSIZES16) + "O" +#endif +#if defined(DUK_USE_LIGHTFUNC_BUILTINS) + "L" +#endif +#if defined(DUK_USE_ROM_STRINGS) || defined(DUK_USE_ROM_OBJECTS) + /* XXX: This won't be shown in practice now + * because this code is not run when builtins + * are in ROM. + */ + "Z" +#endif +#if defined(DUK_USE_LITCACHE_SIZE) + "l" +#endif + " " + /* Object property allocation layout */ +#if defined(DUK_USE_HOBJECT_LAYOUT_1) + "p1" +#elif defined(DUK_USE_HOBJECT_LAYOUT_2) + "p2" +#elif defined(DUK_USE_HOBJECT_LAYOUT_3) + "p3" +#else + "p?" +#endif + " " + /* Alignment guarantee */ +#if (DUK_USE_ALIGN_BY == 4) + "a4" +#elif (DUK_USE_ALIGN_BY == 8) + "a8" +#elif (DUK_USE_ALIGN_BY == 1) + "a1" +#else +#error invalid DUK_USE_ALIGN_BY +#endif + " " + /* Architecture, OS, and compiler strings */ + DUK_USE_ARCH_STRING " " DUK_USE_OS_STRING " " DUK_USE_COMPILER_STRING); + duk_xdef_prop_stridx_short(thr, DUK_BIDX_DUKTAPE, DUK_STRIDX_ENV, DUK_PROPDESC_FLAGS_WC); + + /* + * Since built-ins are not often extended, compact them. + */ + + DUK_DD(DUK_DDPRINT("compact built-ins")); + for (i = 0; i < DUK_NUM_ALL_BUILTINS; i++) { + duk_hobject_compact_props(thr, duk_known_hobject(thr, (duk_idx_t) i)); + } + + DUK_D(DUK_DPRINT("INITBUILTINS END")); + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 1) + for (i = 0; i < DUK_NUM_ALL_BUILTINS; i++) { + DUK_DD(DUK_DDPRINT("built-in object %ld after initialization and compacting: %!@iO", + (long) i, + (duk_heaphdr *) duk_require_hobject(thr, (duk_idx_t) i))); + } +#endif + + /* + * Pop built-ins from stack: they are now INCREF'd and + * reachable from the builtins[] array or indirectly + * through builtins[]. + */ + + duk_set_top(thr, 0); + DUK_ASSERT_TOP(thr, 0); +} +#endif /* DUK_USE_ROM_OBJECTS */ + +DUK_INTERNAL void duk_hthread_copy_builtin_objects(duk_hthread *thr_from, duk_hthread *thr_to) { + duk_small_uint_t i; + + for (i = 0; i < DUK_NUM_BUILTINS; i++) { + thr_to->builtins[i] = thr_from->builtins[i]; + DUK_HOBJECT_INCREF_ALLOWNULL(thr_to, thr_to->builtins[i]); /* side effect free */ + } +} + +/* automatic undefs */ +#undef DUK__LENGTH_PROP_BITS +#undef DUK__NARGS_BITS +#undef DUK__NARGS_VARARGS_MARKER +#undef DUK__PROP_FLAGS_BITS +#undef DUK__PROP_TYPE_ACCESSOR +#undef DUK__PROP_TYPE_BITS +#undef DUK__PROP_TYPE_BOOLEAN_FALSE +#undef DUK__PROP_TYPE_BOOLEAN_TRUE +#undef DUK__PROP_TYPE_BUILTIN +#undef DUK__PROP_TYPE_DOUBLE +#undef DUK__PROP_TYPE_STRIDX +#undef DUK__PROP_TYPE_STRING +#undef DUK__PROP_TYPE_UNDEFINED +#line 1 "duk_hthread_misc.c" +/* + * Thread support. + */ + +/* #include duk_internal.h -> already included */ + +DUK_INTERNAL void duk_hthread_terminate(duk_hthread *thr) { + DUK_ASSERT(thr != NULL); + + while (thr->callstack_curr != NULL) { + duk_hthread_activation_unwind_norz(thr); + } + + thr->valstack_bottom = thr->valstack; + duk_set_top(thr, 0); /* unwinds valstack, updating refcounts */ + + thr->state = DUK_HTHREAD_STATE_TERMINATED; + + /* Here we could remove references to built-ins, but it may not be + * worth the effort because built-ins are quite likely to be shared + * with another (unterminated) thread, and terminated threads are also + * usually garbage collected quite quickly. + * + * We could also shrink the value stack here, but that also may not + * be worth the effort for the same reason. + */ + + DUK_REFZERO_CHECK_SLOW(thr); +} + +#if defined(DUK_USE_DEBUGGER_SUPPORT) +DUK_INTERNAL duk_uint_fast32_t duk_hthread_get_act_curr_pc(duk_hthread *thr, duk_activation *act) { + duk_instr_t *bcode; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(act != NULL); + DUK_UNREF(thr); + + /* XXX: store 'bcode' pointer to activation for faster lookup? */ + if (act->func && DUK_HOBJECT_IS_COMPFUNC(act->func)) { + bcode = DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, (duk_hcompfunc *) (act->func)); + return (duk_uint_fast32_t) (act->curr_pc - bcode); + } + return 0; +} +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + +DUK_INTERNAL duk_uint_fast32_t duk_hthread_get_act_prev_pc(duk_hthread *thr, duk_activation *act) { + duk_instr_t *bcode; + duk_uint_fast32_t ret; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(act != NULL); + DUK_UNREF(thr); + + if (act->func && DUK_HOBJECT_IS_COMPFUNC(act->func)) { + bcode = DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, (duk_hcompfunc *) (act->func)); + ret = (duk_uint_fast32_t) (act->curr_pc - bcode); + if (ret > 0) { + ret--; + } + return ret; + } + return 0; +} + +/* Write bytecode executor's curr_pc back to topmost activation (if any). */ +DUK_INTERNAL void duk_hthread_sync_currpc(duk_hthread *thr) { + duk_activation *act; + + DUK_ASSERT(thr != NULL); + + if (thr->ptr_curr_pc != NULL) { + /* ptr_curr_pc != NULL only when bytecode executor is active. */ + DUK_ASSERT(thr->callstack_top > 0); + DUK_ASSERT(thr->callstack_curr != NULL); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + act->curr_pc = *thr->ptr_curr_pc; + } +} + +DUK_INTERNAL void duk_hthread_sync_and_null_currpc(duk_hthread *thr) { + duk_activation *act; + + DUK_ASSERT(thr != NULL); + + if (thr->ptr_curr_pc != NULL) { + /* ptr_curr_pc != NULL only when bytecode executor is active. */ + DUK_ASSERT(thr->callstack_top > 0); + DUK_ASSERT(thr->callstack_curr != NULL); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + act->curr_pc = *thr->ptr_curr_pc; + thr->ptr_curr_pc = NULL; + } +} +#line 1 "duk_hthread_stacks.c" +/* + * Thread stack (mainly call stack) primitives: allocation of activations, + * unwinding catchers and activations, etc. + * + * Value stack handling is a part of the API implementation. + */ + +/* #include duk_internal.h -> already included */ + +/* Unwind the topmost catcher of the current activation (caller must check that + * both exist) without side effects. + */ +DUK_INTERNAL void duk_hthread_catcher_unwind_norz(duk_hthread *thr, duk_activation *act) { + duk_catcher *cat; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(act != NULL); + DUK_ASSERT(act->cat != NULL); /* caller must check */ + cat = act->cat; + DUK_ASSERT(cat != NULL); + + DUK_DDD(DUK_DDDPRINT("unwinding catch stack entry %p (lexenv check is done)", (void *) cat)); + + if (DUK_CAT_HAS_LEXENV_ACTIVE(cat)) { + duk_hobject *env; + + env = act->lex_env; /* current lex_env of the activation (created for catcher) */ + DUK_ASSERT(env != NULL); /* must be, since env was created when catcher was created */ + act->lex_env = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, env); /* prototype is lex_env before catcher created */ + DUK_HOBJECT_INCREF(thr, act->lex_env); + DUK_HOBJECT_DECREF_NORZ(thr, env); + + /* There is no need to decref anything else than 'env': if 'env' + * becomes unreachable, refzero will handle decref'ing its prototype. + */ + } + + act->cat = cat->parent; + duk_hthread_catcher_free(thr, cat); +} + +/* Same as above, but caller is certain no catcher-related lexenv may exist. */ +DUK_INTERNAL void duk_hthread_catcher_unwind_nolexenv_norz(duk_hthread *thr, duk_activation *act) { + duk_catcher *cat; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(act != NULL); + DUK_ASSERT(act->cat != NULL); /* caller must check */ + cat = act->cat; + DUK_ASSERT(cat != NULL); + + DUK_DDD(DUK_DDDPRINT("unwinding catch stack entry %p (lexenv check is not done)", (void *) cat)); + + DUK_ASSERT(!DUK_CAT_HAS_LEXENV_ACTIVE(cat)); + + act->cat = cat->parent; + duk_hthread_catcher_free(thr, cat); +} + +DUK_LOCAL +#if defined(DUK_USE_CACHE_CATCHER) +DUK_NOINLINE +#endif +duk_catcher *duk__hthread_catcher_alloc_slow(duk_hthread *thr) { + duk_catcher *cat; + + cat = (duk_catcher *) DUK_ALLOC_CHECKED(thr, sizeof(duk_catcher)); + DUK_ASSERT(cat != NULL); + return cat; +} + +#if defined(DUK_USE_CACHE_CATCHER) +DUK_INTERNAL DUK_INLINE duk_catcher *duk_hthread_catcher_alloc(duk_hthread *thr) { + duk_catcher *cat; + + DUK_ASSERT(thr != NULL); + + cat = thr->heap->catcher_free; + if (DUK_LIKELY(cat != NULL)) { + thr->heap->catcher_free = cat->parent; + return cat; + } + + return duk__hthread_catcher_alloc_slow(thr); +} +#else /* DUK_USE_CACHE_CATCHER */ +DUK_INTERNAL duk_catcher *duk_hthread_catcher_alloc(duk_hthread *thr) { + return duk__hthread_catcher_alloc_slow(thr); +} +#endif /* DUK_USE_CACHE_CATCHER */ + +DUK_INTERNAL void duk_hthread_catcher_free(duk_hthread *thr, duk_catcher *cat) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(cat != NULL); + +#if defined(DUK_USE_CACHE_CATCHER) + /* Unconditional caching for now; freed in mark-and-sweep. */ + cat->parent = thr->heap->catcher_free; + thr->heap->catcher_free = cat; +#else + DUK_FREE_CHECKED(thr, (void *) cat); +#endif +} + +DUK_LOCAL +#if defined(DUK_USE_CACHE_ACTIVATION) +DUK_NOINLINE +#endif +duk_activation *duk__hthread_activation_alloc_slow(duk_hthread *thr) { + duk_activation *act; + + act = (duk_activation *) DUK_ALLOC_CHECKED(thr, sizeof(duk_activation)); + DUK_ASSERT(act != NULL); + return act; +} + +#if defined(DUK_USE_CACHE_ACTIVATION) +DUK_INTERNAL DUK_INLINE duk_activation *duk_hthread_activation_alloc(duk_hthread *thr) { + duk_activation *act; + + DUK_ASSERT(thr != NULL); + + act = thr->heap->activation_free; + if (DUK_LIKELY(act != NULL)) { + thr->heap->activation_free = act->parent; + return act; + } + + return duk__hthread_activation_alloc_slow(thr); +} +#else /* DUK_USE_CACHE_ACTIVATION */ +DUK_INTERNAL duk_activation *duk_hthread_activation_alloc(duk_hthread *thr) { + return duk__hthread_activation_alloc_slow(thr); +} +#endif /* DUK_USE_CACHE_ACTIVATION */ + +DUK_INTERNAL void duk_hthread_activation_free(duk_hthread *thr, duk_activation *act) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(act != NULL); + +#if defined(DUK_USE_CACHE_ACTIVATION) + /* Unconditional caching for now; freed in mark-and-sweep. */ + act->parent = thr->heap->activation_free; + thr->heap->activation_free = act; +#else + DUK_FREE_CHECKED(thr, (void *) act); +#endif +} + +/* Internal helper: process the unwind for the topmost activation of a thread, + * but leave the duk_activation in place for possible tailcall reuse. + */ +DUK_LOCAL void duk__activation_unwind_nofree_norz(duk_hthread *thr) { +#if defined(DUK_USE_DEBUGGER_SUPPORT) + duk_heap *heap; +#endif + duk_activation *act; + duk_hobject *func; + duk_hobject *tmp; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->callstack_curr != NULL); /* caller must check */ + DUK_ASSERT(thr->callstack_top > 0); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + /* With lightfuncs, act 'func' may be NULL. */ + + /* With duk_activation records allocated separately, 'act' is a stable + * pointer and not affected by side effects. + */ + +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) + /* + * Restore 'caller' property for non-strict callee functions. + */ + + func = DUK_ACT_GET_FUNC(act); + if (func != NULL && !DUK_HOBJECT_HAS_STRICT(func)) { + duk_tval *tv_caller; + duk_tval tv_tmp; + duk_hobject *h_tmp; + + tv_caller = duk_hobject_find_entry_tval_ptr_stridx(thr->heap, func, DUK_STRIDX_CALLER); + + /* The act->prev_caller should only be set if the entry for 'caller' + * exists (as it is only set in that case, and the property is not + * configurable), but handle all the cases anyway. + */ + + if (tv_caller) { + DUK_TVAL_SET_TVAL(&tv_tmp, tv_caller); + if (act->prev_caller) { + /* Just transfer the refcount from act->prev_caller to tv_caller, + * so no need for a refcount update. This is the expected case. + */ + DUK_TVAL_SET_OBJECT(tv_caller, act->prev_caller); + act->prev_caller = NULL; + } else { + DUK_TVAL_SET_NULL(tv_caller); /* no incref needed */ + DUK_ASSERT(act->prev_caller == NULL); + } + DUK_TVAL_DECREF_NORZ(thr, &tv_tmp); + } else { + h_tmp = act->prev_caller; + if (h_tmp) { + act->prev_caller = NULL; + DUK_HOBJECT_DECREF_NORZ(thr, h_tmp); + } + } + DUK_ASSERT(act->prev_caller == NULL); + } +#endif + + /* + * Unwind debugger state. If we unwind while stepping + * (for any step type), pause execution. This is the + * only place explicitly handling a step out. + */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + heap = thr->heap; + if (heap->dbg_pause_act == thr->callstack_curr) { + if (heap->dbg_pause_flags & DUK_PAUSE_FLAG_FUNC_EXIT) { + DUK_D(DUK_DPRINT("PAUSE TRIGGERED by function exit")); + duk_debug_set_paused(heap); + } else { + DUK_D(DUK_DPRINT("unwound past dbg_pause_act, set to NULL")); + heap->dbg_pause_act = NULL; /* avoid stale pointers */ + } + DUK_ASSERT(heap->dbg_pause_act == NULL); + } +#endif + + /* + * Unwind catchers. + * + * Since there are no references in the catcher structure, + * unwinding is quite simple. The only thing we need to + * look out for is popping a possible lexical environment + * established for an active catch clause. + */ + + while (act->cat != NULL) { + duk_hthread_catcher_unwind_norz(thr, act); + } + + /* + * Close environment record(s) if they exist. + * + * Only variable environments are closed. If lex_env != var_env, it + * cannot currently contain any register bound declarations. + * + * Only environments created for a NEWENV function are closed. If an + * environment is created for e.g. an eval call, it must not be closed. + */ + + func = DUK_ACT_GET_FUNC(act); + if (func != NULL && !DUK_HOBJECT_HAS_NEWENV(func)) { + DUK_DDD(DUK_DDDPRINT("skip closing environments, envs not owned by this activation")); + goto skip_env_close; + } + /* func is NULL for lightfunc */ + + /* Catch sites are required to clean up their environments + * in FINALLY part before propagating, so this should + * always hold here. + */ + DUK_ASSERT(act->lex_env == act->var_env); + + /* XXX: Closing the environment record copies values from registers + * into the scope object. It's side effect free as such, but may + * currently run out of memory which causes an error throw. This is + * an actual sandboxing problem for error unwinds, and needs to be + * fixed e.g. by preallocating the scope property slots. + */ + if (act->var_env != NULL) { + DUK_DDD(DUK_DDDPRINT("closing var_env record %p -> %!O", (void *) act->var_env, (duk_heaphdr *) act->var_env)); + duk_js_close_environment_record(thr, act->var_env); + } + +skip_env_close: + + /* + * Update preventcount + */ + + if (act->flags & DUK_ACT_FLAG_PREVENT_YIELD) { + DUK_ASSERT(thr->callstack_preventcount >= 1); + thr->callstack_preventcount--; + } + + /* + * Reference count updates, using NORZ macros so we don't + * need to handle side effects. + * + * duk_activation pointers like act->var_env are intentionally + * left as garbage and not NULLed. Without side effects they + * can't be used when the values are dangling/garbage. + */ + + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, act->var_env); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, act->lex_env); + tmp = DUK_ACT_GET_FUNC(act); + DUK_HOBJECT_DECREF_NORZ_ALLOWNULL(thr, tmp); + DUK_UNREF(tmp); +} + +/* Unwind topmost duk_activation of a thread, caller must ensure that an + * activation exists. The call is side effect free, except that scope + * closure may currently throw an out-of-memory error. + */ +DUK_INTERNAL void duk_hthread_activation_unwind_norz(duk_hthread *thr) { + duk_activation *act; + + duk__activation_unwind_nofree_norz(thr); + + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(thr->callstack_top > 0); + act = thr->callstack_curr; + thr->callstack_curr = act->parent; + thr->callstack_top--; + + /* Ideally we'd restore value stack reserve here to caller's value. + * This doesn't work for current unwind call sites however, because + * the current (unwound) value stack top may be above the reserve. + * Thus value stack reserve is restored by the call sites. + */ + + /* XXX: inline for performance builds? */ + duk_hthread_activation_free(thr, act); + + /* We could clear the book-keeping variables like retval_byteoff for + * the topmost activation, but don't do so now as it's not necessary. + */ +} + +DUK_INTERNAL void duk_hthread_activation_unwind_reuse_norz(duk_hthread *thr) { + duk__activation_unwind_nofree_norz(thr); +} + +/* Get duk_activation for given callstack level or NULL if level is invalid + * or deeper than the call stack. Level -1 refers to current activation, -2 + * to its caller, etc. Starting from Duktape 2.2 finding the activation is + * a linked list scan which gets more expensive the deeper the lookup is. + */ +DUK_INTERNAL duk_activation *duk_hthread_get_activation_for_level(duk_hthread *thr, duk_int_t level) { + duk_activation *act; + + if (level >= 0) { + return NULL; + } + act = thr->callstack_curr; + for (;;) { + if (act == NULL) { + return act; + } + if (level == -1) { + return act; + } + level++; + act = act->parent; + } + /* never here */ +} + +#if defined(DUK_USE_FINALIZER_TORTURE) +DUK_INTERNAL void duk_hthread_valstack_torture_realloc(duk_hthread *thr) { + duk_size_t alloc_size; + duk_tval *new_ptr; + duk_ptrdiff_t alloc_end_off; + duk_ptrdiff_t end_off; + duk_ptrdiff_t bottom_off; + duk_ptrdiff_t top_off; + + if (thr->valstack == NULL) { + DUK_D(DUK_DPRINT("skip valstack torture realloc, valstack is NULL")); + return; + } + + alloc_end_off = (duk_ptrdiff_t) ((duk_uint8_t *) thr->valstack_alloc_end - (duk_uint8_t *) thr->valstack); + end_off = (duk_ptrdiff_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack); + bottom_off = (duk_ptrdiff_t) ((duk_uint8_t *) thr->valstack_bottom - (duk_uint8_t *) thr->valstack); + top_off = (duk_ptrdiff_t) ((duk_uint8_t *) thr->valstack_top - (duk_uint8_t *) thr->valstack); + alloc_size = (duk_size_t) alloc_end_off; + if (alloc_size == 0) { + DUK_D(DUK_DPRINT("skip valstack torture realloc, alloc_size is zero")); + return; + } + + /* Use DUK_ALLOC_RAW() to avoid side effects. */ + new_ptr = (duk_tval *) DUK_ALLOC_RAW(thr->heap, alloc_size); + if (new_ptr != NULL) { + duk_memcpy((void *) new_ptr, (const void *) thr->valstack, alloc_size); + duk_memset((void *) thr->valstack, 0x55, alloc_size); + DUK_FREE_CHECKED(thr, (void *) thr->valstack); + thr->valstack = new_ptr; + thr->valstack_alloc_end = (duk_tval *) ((duk_uint8_t *) new_ptr + alloc_end_off); + thr->valstack_end = (duk_tval *) ((duk_uint8_t *) new_ptr + end_off); + thr->valstack_bottom = (duk_tval *) ((duk_uint8_t *) new_ptr + bottom_off); + thr->valstack_top = (duk_tval *) ((duk_uint8_t *) new_ptr + top_off); + } else { + DUK_D(DUK_DPRINT("failed to realloc valstack for torture, ignore")); + } +} +#endif /* DUK_USE_FINALIZER_TORTURE */ +#line 1 "duk_js_arith.c" +/* + * Shared helpers for arithmetic operations + */ + +/* #include duk_internal.h -> already included */ + +/* ECMAScript modulus ('%') does not match IEEE 754 "remainder" operation + * (implemented by remainder() in C99) but does seem to match ANSI C fmod(). + * Compare E5 Section 11.5.3 and "man fmod". + */ +DUK_INTERNAL double duk_js_arith_mod(double d1, double d2) { +#if defined(DUK_USE_POW_WORKAROUNDS) + /* Specific fixes to common fmod() implementation issues: + * - test-bug-mingw-math-issues.js + */ + if (DUK_ISINF(d2)) { + if (DUK_ISINF(d1)) { + return DUK_DOUBLE_NAN; + } else { + return d1; + } + } else if (duk_double_equals(d1, 0.0)) { + /* d1 +/-0 is returned as is (preserving sign) except when + * d2 is zero or NaN. + */ + if (duk_double_equals(d2, 0.0) || DUK_ISNAN(d2)) { + return DUK_DOUBLE_NAN; + } else { + return d1; + } + } +#else + /* Some ISO C assumptions. */ + DUK_ASSERT(duk_double_equals(DUK_FMOD(1.0, DUK_DOUBLE_INFINITY), 1.0)); + DUK_ASSERT(duk_double_equals(DUK_FMOD(-1.0, DUK_DOUBLE_INFINITY), -1.0)); + DUK_ASSERT(duk_double_equals(DUK_FMOD(1.0, -DUK_DOUBLE_INFINITY), 1.0)); + DUK_ASSERT(duk_double_equals(DUK_FMOD(-1.0, -DUK_DOUBLE_INFINITY), -1.0)); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(DUK_DOUBLE_INFINITY, DUK_DOUBLE_INFINITY))); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(DUK_DOUBLE_INFINITY, -DUK_DOUBLE_INFINITY))); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(-DUK_DOUBLE_INFINITY, DUK_DOUBLE_INFINITY))); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(-DUK_DOUBLE_INFINITY, -DUK_DOUBLE_INFINITY))); + DUK_ASSERT(duk_double_equals(DUK_FMOD(0.0, 1.0), 0.0) && DUK_SIGNBIT(DUK_FMOD(0.0, 1.0)) == 0); + DUK_ASSERT(duk_double_equals(DUK_FMOD(-0.0, 1.0), 0.0) && DUK_SIGNBIT(DUK_FMOD(-0.0, 1.0)) != 0); + DUK_ASSERT(duk_double_equals(DUK_FMOD(0.0, DUK_DOUBLE_INFINITY), 0.0) && + DUK_SIGNBIT(DUK_FMOD(0.0, DUK_DOUBLE_INFINITY)) == 0); + DUK_ASSERT(duk_double_equals(DUK_FMOD(-0.0, DUK_DOUBLE_INFINITY), 0.0) && + DUK_SIGNBIT(DUK_FMOD(-0.0, DUK_DOUBLE_INFINITY)) != 0); + DUK_ASSERT(duk_double_equals(DUK_FMOD(0.0, -DUK_DOUBLE_INFINITY), 0.0) && + DUK_SIGNBIT(DUK_FMOD(0.0, DUK_DOUBLE_INFINITY)) == 0); + DUK_ASSERT(duk_double_equals(DUK_FMOD(-0.0, -DUK_DOUBLE_INFINITY), 0.0) && + DUK_SIGNBIT(DUK_FMOD(-0.0, -DUK_DOUBLE_INFINITY)) != 0); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(0.0, 0.0))); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(-0.0, 0.0))); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(0.0, -0.0))); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(-0.0, -0.0))); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(0.0, DUK_DOUBLE_NAN))); + DUK_ASSERT(DUK_ISNAN(DUK_FMOD(-0.0, DUK_DOUBLE_NAN))); +#endif + + return (duk_double_t) DUK_FMOD((double) d1, (double) d2); +} + +/* Shared helper for Math.pow() and exponentiation operator. */ +DUK_INTERNAL double duk_js_arith_pow(double x, double y) { + /* The ANSI C pow() semantics differ from ECMAScript. + * + * E.g. when x==1 and y is +/- infinite, the ECMAScript required + * result is NaN, while at least Linux pow() returns 1. + */ + + duk_small_int_t cx, cy, sx; + + DUK_UNREF(cx); + DUK_UNREF(sx); + cy = (duk_small_int_t) DUK_FPCLASSIFY(y); + + if (cy == DUK_FP_NAN) { + goto ret_nan; + } + if (duk_double_equals(DUK_FABS(x), 1.0) && cy == DUK_FP_INFINITE) { + goto ret_nan; + } + +#if defined(DUK_USE_POW_WORKAROUNDS) + /* Specific fixes to common pow() implementation issues: + * - test-bug-netbsd-math-pow.js: NetBSD 6.0 on x86 (at least) + * - test-bug-mingw-math-issues.js + */ + cx = (duk_small_int_t) DUK_FPCLASSIFY(x); + if (cx == DUK_FP_ZERO && y < 0.0) { + sx = (duk_small_int_t) DUK_SIGNBIT(x); + if (sx == 0) { + /* Math.pow(+0,y) should be Infinity when y<0. NetBSD pow() + * returns -Infinity instead when y is <0 and finite. The + * if-clause also catches y == -Infinity (which works even + * without the fix). + */ + return DUK_DOUBLE_INFINITY; + } else { + /* Math.pow(-0,y) where y<0 should be: + * - -Infinity if y<0 and an odd integer + * - Infinity if y<0 but not an odd integer + * NetBSD pow() returns -Infinity for all finite y<0. The + * if-clause also catches y == -Infinity (which works even + * without the fix). + */ + + /* fmod() return value has same sign as input (negative) so + * the result here will be in the range ]-2,0], -1 indicates + * odd. If x is -Infinity, NaN is returned and the odd check + * always concludes "not odd" which results in desired outcome. + */ + double tmp = DUK_FMOD(y, 2); + if (tmp == -1.0) { + return -DUK_DOUBLE_INFINITY; + } else { + /* Not odd, or y == -Infinity */ + return DUK_DOUBLE_INFINITY; + } + } + } else if (cx == DUK_FP_NAN) { + if (duk_double_equals(y, 0.0)) { + /* NaN ** +/- 0 should always be 1, but is NaN on + * at least some Cygwin/MinGW versions. + */ + return 1.0; + } + } +#else + /* Some ISO C assumptions. */ + DUK_ASSERT(duk_double_equals(DUK_POW(DUK_DOUBLE_NAN, 0.0), 1.0)); + DUK_ASSERT(DUK_ISINF(DUK_POW(0.0, -1.0)) && DUK_SIGNBIT(DUK_POW(0.0, -1.0)) == 0); + DUK_ASSERT(DUK_ISINF(DUK_POW(-0.0, -2.0)) && DUK_SIGNBIT(DUK_POW(-0.0, -2.0)) == 0); + DUK_ASSERT(DUK_ISINF(DUK_POW(-0.0, -3.0)) && DUK_SIGNBIT(DUK_POW(-0.0, -3.0)) != 0); +#endif + + return DUK_POW(x, y); + +ret_nan: + return DUK_DOUBLE_NAN; +} +#line 1 "duk_js_call.c" +/* + * Call handling. + * + * duk_handle_call_unprotected(): + * + * - Unprotected call to ECMAScript or Duktape/C function, from native + * code or bytecode executor. + * + * - Also handles Ecma-to-Ecma calls which reuses a currently running + * executor instance to avoid native recursion. Call setup is done + * normally, but just before calling the bytecode executor a special + * return code is used to indicate that a calling executor is reused. + * + * - Also handles tailcalls, i.e. reuse of current duk_activation. + * + * - Also handles setup for initial Duktape.Thread.resume(). + * + * duk_handle_safe_call(): + * + * - Protected C call within current activation. + * + * setjmp() and local variables have a nasty interaction, see execution.rst; + * non-volatile locals modified after setjmp() call are not guaranteed to + * keep their value and can cause compiler or compiler version specific + * difficult to replicate issues. + * + * See 'execution.rst'. + */ + +/* #include duk_internal.h -> already included */ + +/* XXX: heap->error_not_allowed for success path too? */ + +/* + * Limit check helpers. + */ + +/* Check native stack space if DUK_USE_NATIVE_STACK_CHECK() defined. */ +DUK_INTERNAL void duk_native_stack_check(duk_hthread *thr) { +#if defined(DUK_USE_NATIVE_STACK_CHECK) + if (DUK_USE_NATIVE_STACK_CHECK() != 0) { + DUK_ERROR_RANGE(thr, DUK_STR_NATIVE_STACK_LIMIT); + } +#else + DUK_UNREF(thr); +#endif +} + +/* Allow headroom for calls during error augmentation (see GH-191). + * We allow space for 10 additional recursions, with one extra + * for, e.g. a print() call at the deepest level, and an extra + * +1 for protected call wrapping. + */ +#define DUK__AUGMENT_CALL_RELAX_COUNT (10 + 2) + +/* Stack space required by call handling entry. */ +#define DUK__CALL_HANDLING_REQUIRE_STACK 8 + +DUK_LOCAL DUK_NOINLINE void duk__call_c_recursion_limit_check_slowpath(duk_hthread *thr) { + /* When augmenting an error, the effective limit is a bit higher. + * Check for it only if the fast path check fails. + */ +#if defined(DUK_USE_AUGMENT_ERROR_THROW) || defined(DUK_USE_AUGMENT_ERROR_CREATE) + if (thr->heap->augmenting_error) { + if (thr->heap->call_recursion_depth < thr->heap->call_recursion_limit + DUK__AUGMENT_CALL_RELAX_COUNT) { + DUK_D(DUK_DPRINT("C recursion limit reached but augmenting error and within relaxed limit")); + return; + } + } +#endif + + DUK_D(DUK_DPRINT("call prevented because C recursion limit reached")); + DUK_ERROR_RANGE(thr, DUK_STR_NATIVE_STACK_LIMIT); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL DUK_ALWAYS_INLINE void duk__call_c_recursion_limit_check(duk_hthread *thr) { + DUK_ASSERT(thr->heap->call_recursion_depth >= 0); + DUK_ASSERT(thr->heap->call_recursion_depth <= thr->heap->call_recursion_limit); + + duk_native_stack_check(thr); + + /* This check is forcibly inlined because it's very cheap and almost + * always passes. The slow path is forcibly noinline. + */ + if (DUK_LIKELY(thr->heap->call_recursion_depth < thr->heap->call_recursion_limit)) { + return; + } + + duk__call_c_recursion_limit_check_slowpath(thr); +} + +DUK_LOCAL DUK_NOINLINE void duk__call_callstack_limit_check_slowpath(duk_hthread *thr) { + /* When augmenting an error, the effective limit is a bit higher. + * Check for it only if the fast path check fails. + */ +#if defined(DUK_USE_AUGMENT_ERROR_THROW) || defined(DUK_USE_AUGMENT_ERROR_CREATE) + if (thr->heap->augmenting_error) { + if (thr->callstack_top < DUK_USE_CALLSTACK_LIMIT + DUK__AUGMENT_CALL_RELAX_COUNT) { + DUK_D(DUK_DPRINT("call stack limit reached but augmenting error and within relaxed limit")); + return; + } + } +#endif + + /* XXX: error message is a bit misleading: we reached a recursion + * limit which is also essentially the same as a C callstack limit + * (except perhaps with some relaxed threading assumptions). + */ + DUK_D(DUK_DPRINT("call prevented because call stack limit reached")); + DUK_ERROR_RANGE(thr, DUK_STR_CALLSTACK_LIMIT); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL DUK_ALWAYS_INLINE void duk__call_callstack_limit_check(duk_hthread *thr) { + /* This check is forcibly inlined because it's very cheap and almost + * always passes. The slow path is forcibly noinline. + */ + if (DUK_LIKELY(thr->callstack_top < DUK_USE_CALLSTACK_LIMIT)) { + return; + } + + duk__call_callstack_limit_check_slowpath(thr); +} + +/* + * Interrupt counter fixup (for development only). + */ + +#if defined(DUK_USE_INTERRUPT_COUNTER) && defined(DUK_USE_DEBUG) +DUK_LOCAL void duk__interrupt_fixup(duk_hthread *thr, duk_hthread *entry_curr_thread) { + /* Currently the bytecode executor and executor interrupt + * instruction counts are off because we don't execute the + * interrupt handler when we're about to exit from the initial + * user call into Duktape. + * + * If we were to execute the interrupt handler here, the counts + * would match. You can enable this block manually to check + * that this is the case. + */ + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + +#if defined(DUK_USE_INTERRUPT_DEBUG_FIXUP) + if (entry_curr_thread == NULL) { + thr->interrupt_init = thr->interrupt_init - thr->interrupt_counter; + thr->heap->inst_count_interrupt += thr->interrupt_init; + DUK_DD(DUK_DDPRINT("debug test: updated interrupt count on exit to " + "user code, instruction counts: executor=%ld, interrupt=%ld", + (long) thr->heap->inst_count_exec, + (long) thr->heap->inst_count_interrupt)); + DUK_ASSERT(thr->heap->inst_count_exec == thr->heap->inst_count_interrupt); + } +#else + DUK_UNREF(thr); + DUK_UNREF(entry_curr_thread); +#endif +} +#endif + +/* + * Arguments object creation. + * + * Creating arguments objects involves many small details, see E5 Section + * 10.6 for the specific requirements. Much of the arguments object exotic + * behavior is implemented in duk_hobject_props.c, and is enabled by the + * object flag DUK_HOBJECT_FLAG_EXOTIC_ARGUMENTS. + */ + +DUK_LOCAL void duk__create_arguments_object(duk_hthread *thr, duk_hobject *func, duk_hobject *varenv, duk_idx_t idx_args) { + duk_hobject *arg; /* 'arguments' */ + duk_hobject *formals; /* formals for 'func' (may be NULL if func is a C function) */ + duk_idx_t i_arg; + duk_idx_t i_map; + duk_idx_t i_mappednames; + duk_idx_t i_formals; + duk_idx_t i_argbase; + duk_idx_t n_formals; + duk_idx_t idx; + duk_idx_t num_stack_args; + duk_bool_t need_map; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(func != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_NONBOUND_FUNCTION(func)); + DUK_ASSERT(varenv != NULL); + + /* [ ... func this arg1(@idx_args) ... argN envobj ] + * [ arg1(@idx_args) ... argN envobj ] (for tailcalls) + */ + + need_map = 0; + + i_argbase = idx_args; + num_stack_args = duk_get_top(thr) - i_argbase - 1; + DUK_ASSERT(i_argbase >= 0); + DUK_ASSERT(num_stack_args >= 0); + + formals = (duk_hobject *) duk_hobject_get_formals(thr, (duk_hobject *) func); + if (formals) { + n_formals = (duk_idx_t) ((duk_harray *) formals)->length; + duk_push_hobject(thr, formals); + } else { + /* This shouldn't happen without tampering of internal + * properties: if a function accesses 'arguments', _Formals + * is kept. Check for the case anyway in case internal + * properties have been modified manually. + */ + DUK_D(DUK_DPRINT("_Formals is undefined when creating arguments, use n_formals == 0")); + n_formals = 0; + duk_push_undefined(thr); + } + i_formals = duk_require_top_index(thr); + + DUK_ASSERT(n_formals >= 0); + DUK_ASSERT(formals != NULL || n_formals == 0); + + DUK_DDD( + DUK_DDDPRINT("func=%!O, formals=%!O, n_formals=%ld", (duk_heaphdr *) func, (duk_heaphdr *) formals, (long) n_formals)); + + /* [ ... formals ] */ + + /* + * Create required objects: + * - 'arguments' object: array-like, but not an array + * - 'map' object: internal object, tied to 'arguments' (bare) + * - 'mappedNames' object: temporary value used during construction (bare) + */ + + arg = duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | DUK_HOBJECT_FLAG_ARRAY_PART | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_ARGUMENTS), + DUK_BIDX_OBJECT_PROTOTYPE); + DUK_ASSERT(arg != NULL); + (void) duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJECT), + -1); /* no prototype */ + (void) duk_push_object_helper(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_FLAG_FASTREFS | + DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJECT), + -1); /* no prototype */ + i_arg = duk_get_top(thr) - 3; + i_map = i_arg + 1; + i_mappednames = i_arg + 2; + DUK_ASSERT(!duk_is_bare_object(thr, -3)); /* arguments */ + DUK_ASSERT(duk_is_bare_object(thr, -2)); /* map */ + DUK_ASSERT(duk_is_bare_object(thr, -1)); /* mappedNames */ + + /* [ ... formals arguments map mappedNames ] */ + + DUK_DDD(DUK_DDDPRINT("created arguments related objects: " + "arguments at index %ld -> %!O " + "map at index %ld -> %!O " + "mappednames at index %ld -> %!O", + (long) i_arg, + (duk_heaphdr *) duk_get_hobject(thr, i_arg), + (long) i_map, + (duk_heaphdr *) duk_get_hobject(thr, i_map), + (long) i_mappednames, + (duk_heaphdr *) duk_get_hobject(thr, i_mappednames))); + + /* + * Init arguments properties, map, etc. + */ + + duk_push_int(thr, num_stack_args); + duk_xdef_prop_stridx(thr, i_arg, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_WC); + + /* + * Init argument related properties. + */ + + /* step 11 */ + idx = num_stack_args - 1; + while (idx >= 0) { + DUK_DDD( + DUK_DDDPRINT("arg idx %ld, argbase=%ld, argidx=%ld", (long) idx, (long) i_argbase, (long) (i_argbase + idx))); + + DUK_DDD(DUK_DDDPRINT("define arguments[%ld]=arg", (long) idx)); + duk_dup(thr, i_argbase + idx); + duk_xdef_prop_index_wec(thr, i_arg, (duk_uarridx_t) idx); + DUK_DDD(DUK_DDDPRINT("defined arguments[%ld]=arg", (long) idx)); + + /* step 11.c is relevant only if non-strict (checked in 11.c.ii) */ + if (!DUK_HOBJECT_HAS_STRICT(func) && idx < n_formals) { + DUK_ASSERT(formals != NULL); + + DUK_DDD(DUK_DDDPRINT("strict function, index within formals (%ld < %ld)", (long) idx, (long) n_formals)); + + duk_get_prop_index(thr, i_formals, (duk_uarridx_t) idx); + DUK_ASSERT(duk_is_string(thr, -1)); + + duk_dup_top(thr); /* [ ... name name ] */ + + if (!duk_has_prop(thr, i_mappednames)) { + /* steps 11.c.ii.1 - 11.c.ii.4, but our internal book-keeping + * differs from the reference model + */ + + /* [ ... name ] */ + + need_map = 1; + + DUK_DDD( + DUK_DDDPRINT("set mappednames[%s]=%ld", (const char *) duk_get_string(thr, -1), (long) idx)); + duk_dup_top(thr); /* name */ + (void) duk_push_uint_to_hstring(thr, (duk_uint_t) idx); /* index */ + duk_xdef_prop_wec(thr, i_mappednames); /* out of spec, must be configurable */ + + DUK_DDD(DUK_DDDPRINT("set map[%ld]=%s", (long) idx, duk_get_string(thr, -1))); + duk_dup_top(thr); /* name */ + duk_xdef_prop_index_wec(thr, i_map, (duk_uarridx_t) idx); /* out of spec, must be configurable */ + } else { + /* duk_has_prop() popped the second 'name' */ + } + + /* [ ... name ] */ + duk_pop(thr); /* pop 'name' */ + } + + idx--; + } + + DUK_DDD(DUK_DDDPRINT("actual arguments processed")); + + /* step 12 */ + if (need_map) { + DUK_DDD(DUK_DDDPRINT("adding 'map' and 'varenv' to arguments object")); + + /* should never happen for a strict callee */ + DUK_ASSERT(!DUK_HOBJECT_HAS_STRICT(func)); + + duk_dup(thr, i_map); + duk_xdef_prop_stridx(thr, i_arg, DUK_STRIDX_INT_MAP, DUK_PROPDESC_FLAGS_NONE); /* out of spec, don't care */ + + /* The variable environment for magic variable bindings needs to be + * given by the caller and recorded in the arguments object. + * + * See E5 Section 10.6, the creation of setters/getters. + * + * The variable environment also provides access to the callee, so + * an explicit (internal) callee property is not needed. + */ + + duk_push_hobject(thr, varenv); + duk_xdef_prop_stridx(thr, i_arg, DUK_STRIDX_INT_VARENV, DUK_PROPDESC_FLAGS_NONE); /* out of spec, don't care */ + } + + /* steps 13-14 */ + if (DUK_HOBJECT_HAS_STRICT(func)) { + /* Callee/caller are throwers and are not deletable etc. They + * could be implemented as virtual properties, but currently + * there is no support for virtual properties which are accessors + * (only plain virtual properties). This would not be difficult + * to change in duk_hobject_props, but we can make the throwers + * normal, concrete properties just as easily. + * + * Note that the specification requires that the *same* thrower + * built-in object is used here! See E5 Section 10.6 main + * algoritm, step 14, and Section 13.2.3 which describes the + * thrower. See test case test-arguments-throwers.js. + */ + + DUK_DDD(DUK_DDDPRINT("strict function, setting caller/callee to throwers")); + + /* In ES2017 .caller is no longer set at all. */ + duk_xdef_prop_stridx_thrower(thr, i_arg, DUK_STRIDX_CALLEE); + } else { + DUK_DDD(DUK_DDDPRINT("non-strict function, setting callee to actual value")); + duk_push_hobject(thr, func); + duk_xdef_prop_stridx(thr, i_arg, DUK_STRIDX_CALLEE, DUK_PROPDESC_FLAGS_WC); + } + + /* set exotic behavior only after we're done */ + if (need_map) { + /* Exotic behaviors are only enabled for arguments objects + * which have a parameter map (see E5 Section 10.6 main + * algorithm, step 12). + * + * In particular, a non-strict arguments object with no + * mapped formals does *NOT* get exotic behavior, even + * for e.g. "caller" property. This seems counterintuitive + * but seems to be the case. + */ + + /* cannot be strict (never mapped variables) */ + DUK_ASSERT(!DUK_HOBJECT_HAS_STRICT(func)); + + DUK_DDD(DUK_DDDPRINT("enabling exotic behavior for arguments object")); + DUK_HOBJECT_SET_EXOTIC_ARGUMENTS(arg); + } else { + DUK_DDD(DUK_DDDPRINT("not enabling exotic behavior for arguments object")); + } + + DUK_DDD(DUK_DDDPRINT("final arguments related objects: " + "arguments at index %ld -> %!O " + "map at index %ld -> %!O " + "mappednames at index %ld -> %!O", + (long) i_arg, + (duk_heaphdr *) duk_get_hobject(thr, i_arg), + (long) i_map, + (duk_heaphdr *) duk_get_hobject(thr, i_map), + (long) i_mappednames, + (duk_heaphdr *) duk_get_hobject(thr, i_mappednames))); + + /* [ args(n) envobj formals arguments map mappednames ] */ + + duk_pop_2(thr); + duk_remove_m2(thr); + + /* [ args(n) envobj arguments ] */ +} + +/* Helper for creating the arguments object and adding it to the env record + * on top of the value stack. + */ +DUK_LOCAL void duk__handle_createargs_for_call(duk_hthread *thr, duk_hobject *func, duk_hobject *env, duk_idx_t idx_args) { + DUK_DDD(DUK_DDDPRINT("creating arguments object for function call")); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(func != NULL); + DUK_ASSERT(env != NULL); + DUK_ASSERT(DUK_HOBJECT_HAS_CREATEARGS(func)); + + /* [ ... arg1 ... argN envobj ] */ + + duk__create_arguments_object(thr, func, env, idx_args); + + /* [ ... arg1 ... argN envobj argobj ] */ + + duk_xdef_prop_stridx_short(thr, + -2, + DUK_STRIDX_LC_ARGUMENTS, + DUK_HOBJECT_HAS_STRICT(func) ? DUK_PROPDESC_FLAGS_E : /* strict: non-deletable, non-writable */ + DUK_PROPDESC_FLAGS_WE); /* non-strict: non-deletable, writable */ + /* [ ... arg1 ... argN envobj ] */ +} + +/* + * Helpers for constructor call handling. + * + * There are two [[Construct]] operations in the specification: + * + * - E5 Section 13.2.2: for Function objects + * - E5 Section 15.3.4.5.2: for "bound" Function objects + * + * The chain of bound functions is resolved in Section 15.3.4.5.2, + * with arguments "piling up" until the [[Construct]] internal + * method is called on the final, actual Function object. Note + * that the "prototype" property is looked up *only* from the + * final object, *before* calling the constructor. + * + * Since Duktape 2.2 bound functions are represented with the + * duk_hboundfunc internal type, and bound function chains are + * collapsed when a bound function is created. As a result, the + * direct target of a duk_hboundfunc is always non-bound and the + * this/argument lists have been resolved. + * + * When constructing new Array instances, an unnecessary object is + * created and discarded now: the standard [[Construct]] creates an + * object, and calls the Array constructor. The Array constructor + * returns an Array instance, which is used as the result value for + * the "new" operation; the object created before the Array constructor + * call is discarded. + * + * This would be easy to fix, e.g. by knowing that the Array constructor + * will always create a replacement object and skip creating the fallback + * object in that case. + */ + +/* Update default instance prototype for constructor call. */ +DUK_LOCAL void duk__update_default_instance_proto(duk_hthread *thr, duk_idx_t idx_func) { + duk_hobject *proto; + duk_hobject *fallback; + + DUK_ASSERT(duk_is_constructable(thr, idx_func)); + + duk_get_prop_stridx_short(thr, idx_func, DUK_STRIDX_PROTOTYPE); + proto = duk_get_hobject(thr, -1); + if (proto == NULL) { + DUK_DDD(DUK_DDDPRINT("constructor has no 'prototype' property, or value not an object " + "-> leave standard Object prototype as fallback prototype")); + } else { + DUK_DDD(DUK_DDDPRINT("constructor has 'prototype' property with object value " + "-> set fallback prototype to that value: %!iO", + (duk_heaphdr *) proto)); + /* Original fallback (default instance) is untouched when + * resolving bound functions etc. + */ + fallback = duk_known_hobject(thr, idx_func + 1); + DUK_ASSERT(fallback != NULL); + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, fallback, proto); + } + duk_pop(thr); +} + +/* Postprocess: return value special handling, error augmentation. */ +DUK_INTERNAL void duk_call_construct_postprocess(duk_hthread *thr, duk_small_uint_t proxy_invariant) { + /* Use either fallback (default instance) or retval depending + * on retval type. Needs to be called before unwind because + * the default instance is read from the current (immutable) + * 'this' binding. + * + * For Proxy 'construct' calls the return value must be an + * Object (we accept object-like values like buffers and + * lightfuncs too). If not, TypeError. + */ + if (duk_check_type_mask(thr, -1, DUK_TYPE_MASK_OBJECT | DUK_TYPE_MASK_BUFFER | DUK_TYPE_MASK_LIGHTFUNC)) { + DUK_DDD(DUK_DDDPRINT("replacement value")); + } else { + if (DUK_UNLIKELY(proxy_invariant != 0U)) { + /* Proxy 'construct' return value invariant violated. */ + DUK_ERROR_TYPE_INVALID_TRAP_RESULT(thr); + DUK_WO_NORETURN(return;); + } + /* XXX: direct value stack access */ + duk_pop(thr); + duk_push_this(thr); + } + +#if defined(DUK_USE_AUGMENT_ERROR_CREATE) + /* Augment created errors upon creation, not when they are thrown or + * rethrown. __FILE__ and __LINE__ are not desirable here; the call + * stack reflects the caller which is correct. Skip topmost, unwound + * activation when creating a traceback. If thr->ptr_curr_pc was != + * NULL we'd need to sync the current PC so that the traceback comes + * out right; however it is always synced here so just assert for it. + */ + DUK_ASSERT(thr->ptr_curr_pc == NULL); + duk_err_augment_error_create(thr, thr, NULL, 0, DUK_AUGMENT_FLAG_NOBLAME_FILELINE | DUK_AUGMENT_FLAG_SKIP_ONE); +#endif +} + +/* + * Helper for handling a bound function when a call is being made. + * + * Assumes that bound function chains have been "collapsed" so that either + * the target is non-bound or there is one bound function that points to a + * nonbound target. + * + * Prepends the bound arguments to the value stack (at idx_func + 2). + * The 'this' binding is also updated if necessary (at idx_func + 1). + * Note that for constructor calls the 'this' binding is never updated by + * [[BoundThis]]. + */ + +DUK_LOCAL void duk__handle_bound_chain_for_call(duk_hthread *thr, duk_idx_t idx_func, duk_bool_t is_constructor_call) { + duk_tval *tv_func; + duk_hobject *func; + duk_idx_t len; + + DUK_ASSERT(thr != NULL); + + /* On entry, item at idx_func is a bound, non-lightweight function, + * but we don't rely on that below. + */ + + DUK_ASSERT(duk_get_top(thr) >= idx_func + 2); + + tv_func = duk_require_tval(thr, idx_func); + DUK_ASSERT(tv_func != NULL); + + if (DUK_TVAL_IS_OBJECT(tv_func)) { + func = DUK_TVAL_GET_OBJECT(tv_func); + + /* XXX: separate helper function, out of fast path? */ + if (DUK_HOBJECT_HAS_BOUNDFUNC(func)) { + duk_hboundfunc *h_bound; + duk_tval *tv_args; + duk_tval *tv_gap; + + h_bound = (duk_hboundfunc *) (void *) func; + tv_args = h_bound->args; + len = h_bound->nargs; + DUK_ASSERT(len == 0 || tv_args != NULL); + + DUK_DDD(DUK_DDDPRINT("bound function encountered, ptr=%p: %!T", + (void *) DUK_TVAL_GET_OBJECT(tv_func), + tv_func)); + + /* [ ... func this arg1 ... argN ] */ + + if (is_constructor_call) { + /* See: tests/ecmascript/test-spec-bound-constructor.js */ + DUK_DDD(DUK_DDDPRINT("constructor call: don't update this binding")); + } else { + /* XXX: duk_replace_tval */ + duk_push_tval(thr, &h_bound->this_binding); + duk_replace(thr, idx_func + 1); /* idx_this = idx_func + 1 */ + } + + /* [ ... func this arg1 ... argN ] */ + + duk_require_stack(thr, len); + + tv_gap = duk_reserve_gap(thr, idx_func + 2, len); + duk_copy_tvals_incref(thr, tv_gap, tv_args, (duk_size_t) len); + + /* [ ... func this arg1 ... argN ] */ + + duk_push_tval(thr, &h_bound->target); + duk_replace(thr, idx_func); /* replace in stack */ + + DUK_DDD(DUK_DDDPRINT("bound function handled, idx_func=%ld, curr func=%!T", + (long) idx_func, + duk_get_tval(thr, idx_func))); + } + } else if (DUK_TVAL_IS_LIGHTFUNC(tv_func)) { + /* Lightweight function: never bound, so terminate. */ + ; + } else { + /* Shouldn't happen, so ugly error is enough. */ + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return;); + } + + DUK_ASSERT(duk_get_top(thr) >= idx_func + 2); + + DUK_DDD(DUK_DDDPRINT("final non-bound function is: %!T", duk_get_tval(thr, idx_func))); + +#if defined(DUK_USE_ASSERTIONS) + tv_func = duk_require_tval(thr, idx_func); + DUK_ASSERT(DUK_TVAL_IS_LIGHTFUNC(tv_func) || DUK_TVAL_IS_OBJECT(tv_func)); + if (DUK_TVAL_IS_OBJECT(tv_func)) { + func = DUK_TVAL_GET_OBJECT(tv_func); + DUK_ASSERT(func != NULL); + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(func)); + DUK_ASSERT(DUK_HOBJECT_HAS_COMPFUNC(func) || DUK_HOBJECT_HAS_NATFUNC(func) || DUK_HOBJECT_IS_PROXY(func)); + } +#endif +} + +/* + * Helper for inline handling of .call(), .apply(), and .construct(). + */ + +DUK_LOCAL duk_bool_t duk__handle_specialfuncs_for_call(duk_hthread *thr, + duk_idx_t idx_func, + duk_hobject *func, + duk_small_uint_t *call_flags, + duk_bool_t first) { +#if defined(DUK_USE_ASSERTIONS) + duk_c_function natfunc; +#endif + duk_tval *tv_args; + + DUK_ASSERT(func != NULL); + DUK_ASSERT((*call_flags & DUK_CALL_FLAG_CONSTRUCT) == 0); /* Caller. */ + +#if defined(DUK_USE_ASSERTIONS) + natfunc = ((duk_hnatfunc *) func)->func; + DUK_ASSERT(natfunc != NULL); +#endif + + /* On every round of function resolution at least target function and + * 'this' binding are set. We can assume that here, and must guarantee + * it on exit. Value stack reserve is extended for bound function and + * .apply() unpacking so we don't need to extend it here when we need a + * few slots. + */ + DUK_ASSERT(duk_get_top(thr) >= idx_func + 2); + + /* Handle native 'eval' specially. A direct eval check is only made + * for the first resolution attempt; e.g. a bound eval call is -not- + * a direct eval call. + */ + if (DUK_UNLIKELY(((duk_hnatfunc *) func)->magic == 15)) { + /* For now no special handling except for direct eval + * detection. + */ + DUK_ASSERT(((duk_hnatfunc *) func)->func == duk_bi_global_object_eval); + if (first && (*call_flags & DUK_CALL_FLAG_CALLED_AS_EVAL)) { + *call_flags = (*call_flags & ~DUK_CALL_FLAG_CALLED_AS_EVAL) | DUK_CALL_FLAG_DIRECT_EVAL; + } + DUK_ASSERT(duk_get_top(thr) >= idx_func + 2); + return 1; /* stop resolving */ + } + + /* Handle special functions based on the DUK_HOBJECT_FLAG_SPECIAL_CALL + * flag; their magic value is used for switch-case. + * + * NOTE: duk_unpack_array_like() reserves value stack space + * for the result values (unlike most other value stack calls). + */ + switch (((duk_hnatfunc *) func)->magic) { + case 0: { /* 0=Function.prototype.call() */ + /* Value stack: + * idx_func + 0: Function.prototype.call() [removed] + * idx_func + 1: this binding for .call (target function) + * idx_func + 2: 1st argument to .call, desired 'this' binding + * idx_func + 3: 2nd argument to .call, desired 1st argument for ultimate target + * ... + * + * Remove idx_func + 0 to get: + * idx_func + 0: target function + * idx_func + 1: this binding + * idx_func + 2: call arguments + * ... + */ + DUK_ASSERT(natfunc == duk_bi_function_prototype_call); + duk_remove_unsafe(thr, idx_func); + tv_args = thr->valstack_bottom + idx_func + 2; + if (thr->valstack_top < tv_args) { + DUK_ASSERT(tv_args <= thr->valstack_end); + thr->valstack_top = tv_args; /* at least target function and 'this' binding present */ + } + break; + } + case 1: { /* 1=Function.prototype.apply() */ + /* Value stack: + * idx_func + 0: Function.prototype.apply() [removed] + * idx_func + 1: this binding for .apply (target function) + * idx_func + 2: 1st argument to .apply, desired 'this' binding + * idx_func + 3: 2nd argument to .apply, argArray + * [anything after this MUST be ignored] + * + * Remove idx_func + 0 and unpack the argArray to get: + * idx_func + 0: target function + * idx_func + 1: this binding + * idx_func + 2: call arguments + * ... + */ + DUK_ASSERT(natfunc == duk_bi_function_prototype_apply); + duk_remove_unsafe(thr, idx_func); + goto apply_shared; + } +#if defined(DUK_USE_REFLECT_BUILTIN) + case 2: { /* 2=Reflect.apply() */ + /* Value stack: + * idx_func + 0: Reflect.apply() [removed] + * idx_func + 1: this binding for .apply (ignored, usually Reflect) [removed] + * idx_func + 2: 1st argument to .apply, target function + * idx_func + 3: 2nd argument to .apply, desired 'this' binding + * idx_func + 4: 3rd argument to .apply, argArray + * [anything after this MUST be ignored] + * + * Remove idx_func + 0 and idx_func + 1, and unpack the argArray to get: + * idx_func + 0: target function + * idx_func + 1: this binding + * idx_func + 2: call arguments + * ... + */ + DUK_ASSERT(natfunc == duk_bi_reflect_apply); + duk_remove_n_unsafe(thr, idx_func, 2); + goto apply_shared; + } + case 3: { /* 3=Reflect.construct() */ + /* Value stack: + * idx_func + 0: Reflect.construct() [removed] + * idx_func + 1: this binding for .construct (ignored, usually Reflect) [removed] + * idx_func + 2: 1st argument to .construct, target function + * idx_func + 3: 2nd argument to .construct, argArray + * idx_func + 4: 3rd argument to .construct, newTarget + * [anything after this MUST be ignored] + * + * Remove idx_func + 0 and idx_func + 1, unpack the argArray, + * and insert default instance (prototype not yet updated), to get: + * idx_func + 0: target function + * idx_func + 1: this binding (default instance) + * idx_func + 2: constructor call arguments + * ... + * + * Call flags must be updated to reflect the fact that we're + * now dealing with a constructor call, and e.g. the 'this' + * binding cannot be overwritten if the target is bound. + * + * newTarget is checked but not yet passed onwards. + */ + + duk_idx_t top; + + DUK_ASSERT(natfunc == duk_bi_reflect_construct); + *call_flags |= DUK_CALL_FLAG_CONSTRUCT; + duk_remove_n_unsafe(thr, idx_func, 2); + top = duk_get_top(thr); + if (!duk_is_constructable(thr, idx_func)) { + /* Target constructability must be checked before + * unpacking argArray (which may cause side effects). + * Just return; caller will throw the error. + */ + duk_set_top_unsafe(thr, idx_func + 2); /* satisfy asserts */ + break; + } + duk_push_object(thr); + duk_insert(thr, idx_func + 1); /* default instance */ + + /* [ ... func default_instance argArray newTarget? ] */ + + top = duk_get_top(thr); + if (top < idx_func + 3) { + /* argArray is a mandatory argument for Reflect.construct(). */ + DUK_ERROR_TYPE_INVALID_ARGS(thr); + DUK_WO_NORETURN(return 0;); + } + if (top > idx_func + 3) { + if (!duk_strict_equals(thr, idx_func, idx_func + 3)) { + /* XXX: [[Construct]] newTarget currently unsupported */ + DUK_ERROR_UNSUPPORTED(thr); + DUK_WO_NORETURN(return 0;); + } + duk_set_top_unsafe(thr, idx_func + 3); /* remove any args beyond argArray */ + } + DUK_ASSERT(duk_get_top(thr) == idx_func + 3); + DUK_ASSERT(duk_is_valid_index(thr, idx_func + 2)); + (void) duk_unpack_array_like(thr, + idx_func + 2); /* XXX: should also remove target to be symmetric with duk_pack()? */ + duk_remove(thr, idx_func + 2); + DUK_ASSERT(duk_get_top(thr) >= idx_func + 2); + break; + } +#endif /* DUK_USE_REFLECT_BUILTIN */ + default: { + DUK_ASSERT(0); + DUK_UNREACHABLE(); + } + } + + DUK_ASSERT(duk_get_top(thr) >= idx_func + 2); + return 0; /* keep resolving */ + +apply_shared: + tv_args = thr->valstack_bottom + idx_func + 2; + if (thr->valstack_top <= tv_args) { + DUK_ASSERT(tv_args <= thr->valstack_end); + thr->valstack_top = tv_args; /* at least target func and 'this' binding present */ + /* No need to check for argArray. */ + } else { + DUK_ASSERT(duk_get_top(thr) >= idx_func + 3); /* idx_func + 2 covered above */ + if (thr->valstack_top > tv_args + 1) { + duk_set_top_unsafe(thr, idx_func + 3); /* remove any args beyond argArray */ + } + DUK_ASSERT(duk_is_valid_index(thr, idx_func + 2)); + if (!duk_is_callable(thr, idx_func)) { + /* Avoid unpack side effects if the target isn't callable. + * Calling code will throw the actual error. + */ + } else { + (void) duk_unpack_array_like(thr, idx_func + 2); + duk_remove(thr, idx_func + 2); + } + } + DUK_ASSERT(duk_get_top(thr) >= idx_func + 2); + return 0; /* keep resolving */ +} + +/* + * Helper for Proxy handling. + */ + +#if defined(DUK_USE_ES6_PROXY) +DUK_LOCAL void duk__handle_proxy_for_call(duk_hthread *thr, duk_idx_t idx_func, duk_hproxy *h_proxy, duk_small_uint_t *call_flags) { + duk_bool_t rc; + + /* Value stack: + * idx_func + 0: Proxy object + * idx_func + 1: this binding for call + * idx_func + 2: 1st argument for call + * idx_func + 3: 2nd argument for call + * ... + * + * If Proxy doesn't have a trap for the call ('apply' or 'construct'), + * replace Proxy object with target object. + * + * If we're dealing with a normal call and the Proxy has an 'apply' + * trap, manipulate value stack to: + * + * idx_func + 0: trap + * idx_func + 1: Proxy's handler + * idx_func + 2: Proxy's target + * idx_func + 3: this binding for call (from idx_func + 1) + * idx_func + 4: call arguments packed to an array + * + * If we're dealing with a constructor call and the Proxy has a + * 'construct' trap, manipulate value stack to: + * + * idx_func + 0: trap + * idx_func + 1: Proxy's handler + * idx_func + 2: Proxy's target + * idx_func + 3: call arguments packed to an array + * idx_func + 4: newTarget == Proxy object here + * + * As we don't yet have proper newTarget support, the newTarget at + * idx_func + 3 is just the original constructor being called, i.e. + * the Proxy object (not the target). Note that the default instance + * (original 'this' binding) is dropped and ignored. + */ + + duk_push_hobject(thr, h_proxy->handler); + rc = duk_get_prop_stridx_short(thr, -1, (*call_flags & DUK_CALL_FLAG_CONSTRUCT) ? DUK_STRIDX_CONSTRUCT : DUK_STRIDX_APPLY); + if (rc == 0) { + /* Not found, continue to target. If this is a construct + * call, update default instance prototype using the Proxy, + * not the target. + */ + if (*call_flags & DUK_CALL_FLAG_CONSTRUCT) { + if (!(*call_flags & DUK_CALL_FLAG_DEFAULT_INSTANCE_UPDATED)) { + *call_flags |= DUK_CALL_FLAG_DEFAULT_INSTANCE_UPDATED; + duk__update_default_instance_proto(thr, idx_func); + } + } + duk_pop_2(thr); + duk_push_hobject(thr, h_proxy->target); + duk_replace(thr, idx_func); + return; + } + + /* Here we must be careful not to replace idx_func while + * h_proxy is still needed, otherwise h_proxy may become + * dangling. This could be improved e.g. using a + * duk_pack_slice() with a freeform slice. + */ + + /* Here: + * idx_func + 0: Proxy object + * idx_func + 1: this binding for call + * idx_func + 2: 1st argument for call + * idx_func + 3: 2nd argument for call + * ... + * idx_func + N: handler + * idx_func + N + 1: trap + */ + + duk_insert(thr, idx_func + 1); + duk_insert(thr, idx_func + 2); + duk_push_hobject(thr, h_proxy->target); + duk_insert(thr, idx_func + 3); + duk_pack(thr, duk_get_top(thr) - (idx_func + 5)); + DUK_ASSERT(!duk_is_bare_object(thr, -1)); + + /* Here: + * idx_func + 0: Proxy object + * idx_func + 1: trap + * idx_func + 2: Proxy's handler + * idx_func + 3: Proxy's target + * idx_func + 4: this binding for call + * idx_func + 5: arguments array + */ + DUK_ASSERT(duk_get_top(thr) == idx_func + 6); + + if (*call_flags & DUK_CALL_FLAG_CONSTRUCT) { + *call_flags |= DUK_CALL_FLAG_CONSTRUCT_PROXY; /* Enable 'construct' trap return invariant check. */ + *call_flags &= ~(DUK_CALL_FLAG_CONSTRUCT); /* Resume as non-constructor call to the trap. */ + + /* 'apply' args: target, thisArg, argArray + * 'construct' args: target, argArray, newTarget + */ + duk_remove(thr, idx_func + 4); + duk_push_hobject(thr, (duk_hobject *) h_proxy); + } + + /* Finalize value stack layout by removing Proxy reference. */ + duk_remove(thr, idx_func); + h_proxy = NULL; /* invalidated */ + DUK_ASSERT(duk_get_top(thr) == idx_func + 5); +} +#endif /* DUK_USE_ES6_PROXY */ + +/* + * Helper for setting up var_env and lex_env of an activation, + * assuming it does NOT have the DUK_HOBJECT_FLAG_NEWENV flag. + */ + +DUK_LOCAL void duk__handle_oldenv_for_call(duk_hthread *thr, duk_hobject *func, duk_activation *act) { + duk_hcompfunc *f; + duk_hobject *h_lex; + duk_hobject *h_var; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(func != NULL); + DUK_ASSERT(act != NULL); + DUK_ASSERT(!DUK_HOBJECT_HAS_NEWENV(func)); + DUK_ASSERT(!DUK_HOBJECT_HAS_CREATEARGS(func)); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(func)); + DUK_UNREF(thr); + + f = (duk_hcompfunc *) func; + h_lex = DUK_HCOMPFUNC_GET_LEXENV(thr->heap, f); + h_var = DUK_HCOMPFUNC_GET_VARENV(thr->heap, f); + DUK_ASSERT(h_lex != NULL); /* Always true for closures (not for templates) */ + DUK_ASSERT(h_var != NULL); + act->lex_env = h_lex; + act->var_env = h_var; + DUK_HOBJECT_INCREF(thr, h_lex); + DUK_HOBJECT_INCREF(thr, h_var); +} + +/* + * Helper for updating callee 'caller' property. + */ + +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) +DUK_LOCAL void duk__update_func_caller_prop(duk_hthread *thr, duk_hobject *func) { + duk_tval *tv_caller; + duk_hobject *h_tmp; + duk_activation *act_callee; + duk_activation *act_caller; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(func != NULL); + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(func)); /* bound chain resolved */ + DUK_ASSERT(thr->callstack_top >= 1); + + if (DUK_HOBJECT_HAS_STRICT(func)) { + /* Strict functions don't get their 'caller' updated. */ + return; + } + + DUK_ASSERT(thr->callstack_top > 0); + act_callee = thr->callstack_curr; + DUK_ASSERT(act_callee != NULL); + act_caller = (thr->callstack_top >= 2 ? act_callee->parent : NULL); + + /* XXX: check .caller writability? */ + + /* Backup 'caller' property and update its value. */ + tv_caller = duk_hobject_find_entry_tval_ptr_stridx(thr->heap, func, DUK_STRIDX_CALLER); + if (tv_caller) { + /* If caller is global/eval code, 'caller' should be set to + * 'null'. + * + * XXX: there is no exotic flag to infer this correctly now. + * The NEWENV flag is used now which works as intended for + * everything (global code, non-strict eval code, and functions) + * except strict eval code. Bound functions are never an issue + * because 'func' has been resolved to a non-bound function. + */ + + if (act_caller != NULL) { + /* act_caller->func may be NULL in some finalization cases, + * just treat like we don't know the caller. + */ + if (act_caller->func && !DUK_HOBJECT_HAS_NEWENV(act_caller->func)) { + /* Setting to NULL causes 'caller' to be set to + * 'null' as desired. + */ + act_caller = NULL; + } + } + + if (DUK_TVAL_IS_OBJECT(tv_caller)) { + h_tmp = DUK_TVAL_GET_OBJECT(tv_caller); + DUK_ASSERT(h_tmp != NULL); + act_callee->prev_caller = h_tmp; + + /* Previous value doesn't need refcount changes because its ownership + * is transferred to prev_caller. + */ + + if (act_caller != NULL) { + DUK_ASSERT(act_caller->func != NULL); + DUK_TVAL_SET_OBJECT(tv_caller, act_caller->func); + DUK_TVAL_INCREF(thr, tv_caller); + } else { + DUK_TVAL_SET_NULL(tv_caller); /* no incref */ + } + } else { + /* 'caller' must only take on 'null' or function value */ + DUK_ASSERT(!DUK_TVAL_IS_HEAP_ALLOCATED(tv_caller)); + DUK_ASSERT(act_callee->prev_caller == NULL); + if (act_caller != NULL && act_caller->func) { + /* Tolerate act_caller->func == NULL which happens in + * some finalization cases; treat like unknown caller. + */ + DUK_TVAL_SET_OBJECT(tv_caller, act_caller->func); + DUK_TVAL_INCREF(thr, tv_caller); + } else { + DUK_TVAL_SET_NULL(tv_caller); /* no incref */ + } + } + } +} +#endif /* DUK_USE_NONSTD_FUNC_CALLER_PROPERTY */ + +/* + * Shared helpers for resolving the final, non-bound target function of the + * call and the effective 'this' binding. Resolves bound functions and + * applies .call(), .apply(), and .construct() inline. + * + * Proxy traps are also handled inline so that if the target is a Proxy with + * a 'call' or 'construct' trap, the trap handler is called with a modified + * argument list. + * + * Once the bound function / .call() / .apply() / .construct() sequence has + * been resolved, the value at idx_func + 1 may need coercion described in + * E5 Section 10.4.3. + * + * A call that begins as a non-constructor call may be converted into a + * constructor call during the resolution process if Reflect.construct() + * is invoked. This is handled by updating the caller's call_flags. + * + * For global and eval code (E5 Sections 10.4.1 and 10.4.2), we assume + * that the caller has provided the correct 'this' binding explicitly + * when calling, i.e.: + * + * - global code: this=global object + * - direct eval: this=copy from eval() caller's this binding + * - other eval: this=global object + * + * The 'this' coercion may cause a recursive function call with arbitrary + * side effects, because ToObject() may be called. + */ + +DUK_LOCAL DUK_INLINE void duk__coerce_nonstrict_this_binding(duk_hthread *thr, duk_idx_t idx_this) { + duk_tval *tv_this; + duk_hobject *obj_global; + + tv_this = thr->valstack_bottom + idx_this; + switch (DUK_TVAL_GET_TAG(tv_this)) { + case DUK_TAG_OBJECT: + DUK_DDD(DUK_DDDPRINT("this binding: non-strict, object -> use directly")); + break; + case DUK_TAG_UNDEFINED: + case DUK_TAG_NULL: + DUK_DDD(DUK_DDDPRINT("this binding: non-strict, undefined/null -> use global object")); + obj_global = thr->builtins[DUK_BIDX_GLOBAL]; + /* XXX: avoid this check somehow */ + if (DUK_LIKELY(obj_global != NULL)) { + DUK_ASSERT(!DUK_TVAL_IS_HEAP_ALLOCATED(tv_this)); /* no need to decref previous value */ + DUK_TVAL_SET_OBJECT(tv_this, obj_global); + DUK_HOBJECT_INCREF(thr, obj_global); + } else { + /* This may only happen if built-ins are being "torn down". + * This behavior is out of specification scope. + */ + DUK_D(DUK_DPRINT("this binding: wanted to use global object, but it is NULL -> using undefined instead")); + DUK_ASSERT(!DUK_TVAL_IS_HEAP_ALLOCATED(tv_this)); /* no need to decref previous value */ + DUK_TVAL_SET_UNDEFINED(tv_this); /* nothing to incref */ + } + break; + default: + /* Plain buffers and lightfuncs are object coerced. Lightfuncs + * very rarely come here however, because the call target would + * need to be a non-strict non-lightfunc (lightfuncs are considered + * strict) with an explicit lightfunc 'this' binding. + */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv_this)); + DUK_DDD(DUK_DDDPRINT("this binding: non-strict, not object/undefined/null -> use ToObject(value)")); + duk_to_object(thr, idx_this); /* may have side effects */ + break; + } +} + +DUK_LOCAL DUK_ALWAYS_INLINE duk_bool_t duk__resolve_target_fastpath_check(duk_hthread *thr, + duk_idx_t idx_func, + duk_hobject **out_func, + duk_small_uint_t call_flags) { +#if defined(DUK_USE_PREFER_SIZE) + DUK_UNREF(thr); + DUK_UNREF(idx_func); + DUK_UNREF(out_func); + DUK_UNREF(call_flags); +#else /* DUK_USE_PREFER_SIZE */ + duk_tval *tv_func; + duk_hobject *func; + + if (DUK_UNLIKELY(call_flags & DUK_CALL_FLAG_CONSTRUCT)) { + return 0; + } + + tv_func = DUK_GET_TVAL_POSIDX(thr, idx_func); + DUK_ASSERT(tv_func != NULL); + + if (DUK_LIKELY(DUK_TVAL_IS_OBJECT(tv_func))) { + func = DUK_TVAL_GET_OBJECT(tv_func); + if (DUK_HOBJECT_IS_CALLABLE(func) && !DUK_HOBJECT_HAS_BOUNDFUNC(func) && !DUK_HOBJECT_HAS_SPECIAL_CALL(func)) { + *out_func = func; + + if (DUK_HOBJECT_HAS_STRICT(func)) { + /* Strict function: no 'this' coercion. */ + return 1; + } + + duk__coerce_nonstrict_this_binding(thr, idx_func + 1); + return 1; + } + } else if (DUK_TVAL_IS_LIGHTFUNC(tv_func)) { + *out_func = NULL; + + /* Lightfuncs are considered strict, so 'this' binding is + * used as is. They're never bound, always constructable, + * and never special functions. + */ + return 1; + } +#endif /* DUK_USE_PREFER_SIZE */ + return 0; /* let slow path deal with it */ +} + +DUK_LOCAL duk_hobject *duk__resolve_target_func_and_this_binding(duk_hthread *thr, + duk_idx_t idx_func, + duk_small_uint_t *call_flags) { + duk_tval *tv_func; + duk_hobject *func; + duk_bool_t first; + + DUK_ASSERT(duk_get_top(thr) >= idx_func + 2); + + for (first = 1;; first = 0) { + DUK_ASSERT(duk_get_top(thr) >= idx_func + 2); + + tv_func = DUK_GET_TVAL_POSIDX(thr, idx_func); + DUK_ASSERT(tv_func != NULL); + + DUK_DD(DUK_DDPRINT("target func: %!iT", tv_func)); + + if (DUK_TVAL_IS_OBJECT(tv_func)) { + func = DUK_TVAL_GET_OBJECT(tv_func); + + if (*call_flags & DUK_CALL_FLAG_CONSTRUCT) { + if (DUK_UNLIKELY(!DUK_HOBJECT_HAS_CONSTRUCTABLE(func))) { + goto not_constructable; + } + } else { + if (DUK_UNLIKELY(!DUK_HOBJECT_IS_CALLABLE(func))) { + goto not_callable; + } + } + + if (DUK_LIKELY(!DUK_HOBJECT_HAS_BOUNDFUNC(func) && !DUK_HOBJECT_HAS_SPECIAL_CALL(func) && + !DUK_HOBJECT_HAS_EXOTIC_PROXYOBJ(func))) { + /* Common case, so test for using a single bitfield test. + * Break out to handle this coercion etc. + */ + break; + } + + /* XXX: could set specialcall for boundfuncs too, simplify check above */ + + if (DUK_HOBJECT_HAS_BOUNDFUNC(func)) { + DUK_ASSERT(!DUK_HOBJECT_HAS_SPECIAL_CALL(func)); + DUK_ASSERT(!DUK_HOBJECT_IS_NATFUNC(func)); + + /* Callable/constructable flags are the same + * for the bound function and its target, so + * we don't need to check them here, we can + * check them from the target only. + */ + duk__handle_bound_chain_for_call(thr, idx_func, *call_flags & DUK_CALL_FLAG_CONSTRUCT); + + DUK_ASSERT(DUK_TVAL_IS_OBJECT(duk_require_tval(thr, idx_func)) || + DUK_TVAL_IS_LIGHTFUNC(duk_require_tval(thr, idx_func))); + } else { + DUK_ASSERT(DUK_HOBJECT_HAS_SPECIAL_CALL(func)); + +#if defined(DUK_USE_ES6_PROXY) + if (DUK_HOBJECT_HAS_EXOTIC_PROXYOBJ(func)) { + /* If no trap, resume processing from Proxy trap. + * If trap exists, helper converts call into a trap + * call; this may change a constructor call into a + * normal (non-constructor) trap call. We must + * continue processing even when a trap is found as + * the trap may be bound. + */ + duk__handle_proxy_for_call(thr, idx_func, (duk_hproxy *) func, call_flags); + } else +#endif + { + DUK_ASSERT(DUK_HOBJECT_IS_NATFUNC(func)); + DUK_ASSERT(DUK_HOBJECT_HAS_CALLABLE(func)); + DUK_ASSERT(!DUK_HOBJECT_HAS_CONSTRUCTABLE(func)); + /* Constructable check already done above. */ + + if (duk__handle_specialfuncs_for_call(thr, idx_func, func, call_flags, first) != 0) { + /* Encountered native eval call, normal call + * context. Break out, handle this coercion etc. + */ + break; + } + } + } + /* Retry loop. */ + } else if (DUK_TVAL_IS_LIGHTFUNC(tv_func)) { + /* Lightfuncs are: + * - Always strict, so no 'this' coercion. + * - Always callable. + * - Always constructable. + * - Never specialfuncs. + */ + func = NULL; + goto finished; + } else { + goto not_callable; + } + } + + DUK_ASSERT(func != NULL); + + if (!DUK_HOBJECT_HAS_STRICT(func)) { + /* Non-strict target needs 'this' coercion. + * This has potential side effects invalidating + * 'tv_func'. + */ + duk__coerce_nonstrict_this_binding(thr, idx_func + 1); + } + if (*call_flags & DUK_CALL_FLAG_CONSTRUCT) { + if (!(*call_flags & DUK_CALL_FLAG_DEFAULT_INSTANCE_UPDATED)) { + *call_flags |= DUK_CALL_FLAG_DEFAULT_INSTANCE_UPDATED; + duk__update_default_instance_proto(thr, idx_func); + } + } + +finished : +#if defined(DUK_USE_ASSERTIONS) +{ + duk_tval *tv_tmp; + + tv_tmp = duk_get_tval(thr, idx_func); + DUK_ASSERT(tv_tmp != NULL); + + DUK_ASSERT((DUK_TVAL_IS_OBJECT(tv_tmp) && DUK_HOBJECT_IS_CALLABLE(DUK_TVAL_GET_OBJECT(tv_tmp))) || + DUK_TVAL_IS_LIGHTFUNC(tv_tmp)); + DUK_ASSERT(func == NULL || !DUK_HOBJECT_HAS_BOUNDFUNC(func)); + DUK_ASSERT(func == NULL || (DUK_HOBJECT_IS_COMPFUNC(func) || DUK_HOBJECT_IS_NATFUNC(func))); + DUK_ASSERT(func == NULL || (DUK_HOBJECT_HAS_CONSTRUCTABLE(func) || (*call_flags & DUK_CALL_FLAG_CONSTRUCT) == 0)); +} +#endif + + return func; + +not_callable: + DUK_ASSERT(tv_func != NULL); + +#if defined(DUK_USE_VERBOSE_ERRORS) + /* GETPROPC delayed error handling: when target is not callable, + * GETPROPC replaces idx_func+0 with a non-callable wrapper object + * with a hidden Symbol to signify it's to be handled here. If + * found, unwrap the original Error and throw it as is here. The + * hidden Symbol is only checked as an own property, not inherited + * (which would be dangerous). + */ + if (DUK_TVAL_IS_OBJECT(tv_func)) { + duk_tval *tv_wrap = + duk_hobject_find_entry_tval_ptr_stridx(thr->heap, DUK_TVAL_GET_OBJECT(tv_func), DUK_STRIDX_INT_TARGET); + if (tv_wrap != NULL) { + DUK_DD(DUK_DDPRINT("delayed error from GETPROPC: %!T", tv_wrap)); + duk_push_tval(thr, tv_wrap); + (void) duk_throw(thr); + DUK_WO_NORETURN(return NULL;); + } + } +#endif + +#if defined(DUK_USE_VERBOSE_ERRORS) +#if defined(DUK_USE_PARANOID_ERRORS) + DUK_ERROR_FMT1(thr, DUK_ERR_TYPE_ERROR, "%s not callable", duk_get_type_name(thr, idx_func)); +#else + DUK_ERROR_FMT1(thr, DUK_ERR_TYPE_ERROR, "%s not callable", duk_push_string_tval_readable(thr, tv_func)); +#endif +#else + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CALLABLE); +#endif + DUK_WO_NORETURN(return NULL;); + +not_constructable: + /* For now GETPROPC delayed error not needed for constructor calls. */ +#if defined(DUK_USE_VERBOSE_ERRORS) +#if defined(DUK_USE_PARANOID_ERRORS) + DUK_ERROR_FMT1(thr, DUK_ERR_TYPE_ERROR, "%s not constructable", duk_get_type_name(thr, idx_func)); +#else + DUK_ERROR_FMT1(thr, DUK_ERR_TYPE_ERROR, "%s not constructable", duk_push_string_tval_readable(thr, tv_func)); +#endif +#else + DUK_ERROR_TYPE(thr, DUK_STR_NOT_CONSTRUCTABLE); +#endif + DUK_WO_NORETURN(return NULL;); +} + +/* + * Manipulate value stack so that exactly 'num_stack_rets' return + * values are at 'idx_retbase' in every case, assuming there are + * 'rc' return values on top of stack. + * + * This is a bit tricky, because the called C function operates in + * the same activation record and may have e.g. popped the stack + * empty (below idx_retbase). + */ + +DUK_LOCAL void duk__safe_call_adjust_valstack(duk_hthread *thr, + duk_idx_t idx_retbase, + duk_idx_t num_stack_rets, + duk_idx_t num_actual_rets) { + duk_idx_t idx_rcbase; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(idx_retbase >= 0); + DUK_ASSERT(num_stack_rets >= 0); + DUK_ASSERT(num_actual_rets >= 0); + + idx_rcbase = duk_get_top(thr) - num_actual_rets; /* base of known return values */ + if (DUK_UNLIKELY(idx_rcbase < 0)) { + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_CFUNC_RC); + DUK_WO_NORETURN(return;); + } + + DUK_DDD(DUK_DDDPRINT("adjust valstack after func call: " + "num_stack_rets=%ld, num_actual_rets=%ld, stack_top=%ld, idx_retbase=%ld, idx_rcbase=%ld", + (long) num_stack_rets, + (long) num_actual_rets, + (long) duk_get_top(thr), + (long) idx_retbase, + (long) idx_rcbase)); + + DUK_ASSERT(idx_rcbase >= 0); /* caller must check */ + + /* Space for num_stack_rets was reserved before the safe call. + * Because value stack reserve cannot shrink except in call returns, + * the reserve is still in place. Adjust valstack, carefully + * ensuring we don't overstep the reserve. + */ + + /* Match idx_rcbase with idx_retbase so that the return values + * start at the correct index. + */ + if (idx_rcbase > idx_retbase) { + duk_idx_t count = idx_rcbase - idx_retbase; + + DUK_DDD(DUK_DDDPRINT("elements at/after idx_retbase have enough to cover func retvals " + "(idx_retbase=%ld, idx_rcbase=%ld)", + (long) idx_retbase, + (long) idx_rcbase)); + + /* Remove values between irc_rcbase (start of intended return + * values) and idx_retbase to lower return values to idx_retbase. + */ + DUK_ASSERT(count > 0); + duk_remove_n(thr, idx_retbase, count); /* may be NORZ */ + } else { + duk_idx_t count = idx_retbase - idx_rcbase; + + DUK_DDD(DUK_DDDPRINT("not enough elements at/after idx_retbase to cover func retvals " + "(idx_retbase=%ld, idx_rcbase=%ld)", + (long) idx_retbase, + (long) idx_rcbase)); + + /* Insert 'undefined' at idx_rcbase (start of intended return + * values) to lift return values to idx_retbase. + */ + DUK_ASSERT(count >= 0); + DUK_ASSERT(thr->valstack_end - thr->valstack_top >= count); /* reserve cannot shrink */ + duk_insert_undefined_n(thr, idx_rcbase, count); + } + + /* Chop extra retvals away / extend with undefined. */ + duk_set_top_unsafe(thr, idx_retbase + num_stack_rets); +} + +/* + * Activation setup for tailcalls and non-tailcalls. + */ + +#if defined(DUK_USE_TAILCALL) +DUK_LOCAL duk_small_uint_t duk__call_setup_act_attempt_tailcall(duk_hthread *thr, + duk_small_uint_t call_flags, + duk_idx_t idx_func, + duk_hobject *func, + duk_size_t entry_valstack_bottom_byteoff, + duk_size_t entry_valstack_end_byteoff, + duk_idx_t *out_nargs, + duk_idx_t *out_nregs, + duk_size_t *out_vs_min_bytes, + duk_activation **out_act) { + duk_activation *act; + duk_tval *tv1, *tv2; + duk_idx_t idx_args; + duk_small_uint_t flags1, flags2; +#if defined(DUK_USE_DEBUGGER_SUPPORT) + duk_activation *prev_pause_act; +#endif + + DUK_UNREF(entry_valstack_end_byteoff); + + /* Tailcall cannot be flagged to resume calls, and a + * previous frame must exist. + */ + DUK_ASSERT(thr->callstack_top >= 1); + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + *out_act = act; + + if (func == NULL || !DUK_HOBJECT_IS_COMPFUNC(func)) { + DUK_DDD(DUK_DDDPRINT("tail call prevented by target not being ecma function")); + return 0; + } + if (act->flags & DUK_ACT_FLAG_PREVENT_YIELD) { + DUK_DDD(DUK_DDDPRINT("tail call prevented by current activation having DUK_ACT_FLAG_PREVENT_YIELD")); + return 0; + } + /* Tailcall is only allowed if current and candidate + * function have identical return value handling. There + * are three possible return value handling cases: + * 1. Normal function call, no special return value handling. + * 2. Constructor call, return value replacement object check. + * 3. Proxy 'construct' trap call, return value invariant check. + */ + flags1 = (duk_small_uint_t) ((act->flags & DUK_ACT_FLAG_CONSTRUCT) ? 1 : 0) +#if defined(DUK_USE_ES6_PROXY) + | (duk_small_uint_t) ((act->flags & DUK_ACT_FLAG_CONSTRUCT_PROXY) ? 2 : 0) +#endif + ; + flags2 = (duk_small_uint_t) ((call_flags & DUK_CALL_FLAG_CONSTRUCT) ? 1 : 0) +#if defined(DUK_USE_ES6_PROXY) + | (duk_small_uint_t) ((call_flags & DUK_CALL_FLAG_CONSTRUCT_PROXY) ? 2 : 0); +#endif + ; + if (flags1 != flags2) { + DUK_DDD(DUK_DDDPRINT("tail call prevented by incompatible return value handling")); + return 0; + } + DUK_ASSERT(((act->flags & DUK_ACT_FLAG_CONSTRUCT) && (call_flags & DUK_CALL_FLAG_CONSTRUCT)) || + (!(act->flags & DUK_ACT_FLAG_CONSTRUCT) && !(call_flags & DUK_CALL_FLAG_CONSTRUCT))); + DUK_ASSERT(((act->flags & DUK_ACT_FLAG_CONSTRUCT_PROXY) && (call_flags & DUK_CALL_FLAG_CONSTRUCT_PROXY)) || + (!(act->flags & DUK_ACT_FLAG_CONSTRUCT_PROXY) && !(call_flags & DUK_CALL_FLAG_CONSTRUCT_PROXY))); + if (DUK_HOBJECT_HAS_NOTAIL(func)) { + /* See: test-bug-tailcall-preventyield-assert.c. */ + DUK_DDD(DUK_DDDPRINT("tail call prevented by function having a notail flag")); + return 0; + } + + /* + * Tailcall handling + * + * Although the callstack entry is reused, we need to explicitly unwind + * the current activation (or simulate an unwind). In particular, the + * current activation must be closed, otherwise something like + * test-bug-reduce-judofyr.js results. Also catchers need to be unwound + * because there may be non-error-catching label entries in valid tail calls. + * + * Special attention is needed for debugger and pause behavior when + * reusing an activation. + * - Disable StepOut processing for the activation unwind because + * we reuse the activation, see: + * https://github.com/svaarala/duktape/issues/1684. + * - Disable line change pause flag permanently if act == dbg_pause_act + * (if set) because it would no longer be relevant, see: + * https://github.com/svaarala/duktape/issues/1726, + * https://github.com/svaarala/duktape/issues/1786. + * - Check for function entry (e.g. StepInto) pause flag here, because + * the executor pause check won't trigger due to shared activation, see: + * https://github.com/svaarala/duktape/issues/1726. + */ + + DUK_DDD(DUK_DDDPRINT("is tail call, reusing activation at callstack top, at index %ld", (long) (thr->callstack_top - 1))); + + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(func)); + DUK_ASSERT(!DUK_HOBJECT_HAS_NATFUNC(func)); + DUK_ASSERT(DUK_HOBJECT_HAS_COMPFUNC(func)); + DUK_ASSERT((act->flags & DUK_ACT_FLAG_PREVENT_YIELD) == 0); + DUK_ASSERT(call_flags & DUK_CALL_FLAG_ALLOW_ECMATOECMA); + + /* Unwind the topmost callstack entry before reusing it. This + * also unwinds the catchers related to the topmost entry. + */ + DUK_ASSERT(thr->callstack_top > 0); + DUK_ASSERT(thr->callstack_curr != NULL); +#if defined(DUK_USE_DEBUGGER_SUPPORT) + if (act == thr->heap->dbg_pause_act) { + thr->heap->dbg_pause_flags &= ~DUK_PAUSE_FLAG_LINE_CHANGE; + } + + prev_pause_act = thr->heap->dbg_pause_act; + thr->heap->dbg_pause_act = NULL; + if (thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_FUNC_ENTRY) { + DUK_D(DUK_DPRINT("PAUSE TRIGGERED by function entry (tailcall)")); + duk_debug_set_paused(thr->heap); + } +#endif + duk_hthread_activation_unwind_reuse_norz(thr); +#if defined(DUK_USE_DEBUGGER_SUPPORT) + thr->heap->dbg_pause_act = prev_pause_act; +#endif + DUK_ASSERT(act == thr->callstack_curr); + + /* XXX: We could restore the caller's value stack reserve + * here, as if we did an actual unwind-and-call. Without + * the restoration, value stack reserve may remain higher + * than would otherwise be possible until we return to a + * non-tailcall. + */ + + /* Then reuse the unwound activation. */ + act->cat = NULL; + act->var_env = NULL; + act->lex_env = NULL; + DUK_ASSERT(func != NULL); + DUK_ASSERT(DUK_HOBJECT_HAS_COMPFUNC(func)); + act->func = func; /* don't want an intermediate exposed state with func == NULL */ +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) + act->prev_caller = NULL; +#endif + /* don't want an intermediate exposed state with invalid pc */ + act->curr_pc = DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, (duk_hcompfunc *) func); +#if defined(DUK_USE_DEBUGGER_SUPPORT) + act->prev_line = 0; +#endif + DUK_TVAL_SET_OBJECT(&act->tv_func, func); /* borrowed, no refcount */ + DUK_HOBJECT_INCREF(thr, func); + + act->flags = DUK_ACT_FLAG_TAILCALLED; + if (DUK_HOBJECT_HAS_STRICT(func)) { + act->flags |= DUK_ACT_FLAG_STRICT; + } + if (call_flags & DUK_CALL_FLAG_CONSTRUCT) { + act->flags |= DUK_ACT_FLAG_CONSTRUCT; + } +#if defined(DUK_USE_ES6_PROXY) + if (call_flags & DUK_CALL_FLAG_CONSTRUCT_PROXY) { + act->flags |= DUK_ACT_FLAG_CONSTRUCT_PROXY; + } +#endif + + DUK_ASSERT(DUK_ACT_GET_FUNC(act) == func); /* already updated */ + DUK_ASSERT(act->var_env == NULL); + DUK_ASSERT(act->lex_env == NULL); + act->bottom_byteoff = entry_valstack_bottom_byteoff; /* tail call -> reuse current "frame" */ +#if 0 + /* Topmost activation retval_byteoff is considered garbage, no need to init. */ + act->retval_byteoff = 0; +#endif + /* Filled in when final reserve is known, dummy value doesn't matter + * even in error unwind because reserve_byteoff is only used when + * returning to -this- activation. + */ + act->reserve_byteoff = 0; + + /* + * Manipulate valstack so that args are on the current bottom and the + * previous caller's 'this' binding (which is the value preceding the + * current bottom) is replaced with the new 'this' binding: + * + * [ ... this_old | (crud) func this_new arg1 ... argN ] + * --> [ ... this_new | arg1 ... argN ] + * + * For tail calling to work properly, the valstack bottom must not grow + * here; otherwise crud would accumulate on the valstack. + */ + + tv1 = thr->valstack_bottom - 1; + tv2 = thr->valstack_bottom + idx_func + 1; + DUK_ASSERT(tv1 >= thr->valstack && tv1 < thr->valstack_top); /* tv1 is -below- valstack_bottom */ + DUK_ASSERT(tv2 >= thr->valstack_bottom && tv2 < thr->valstack_top); + DUK_TVAL_SET_TVAL_UPDREF(thr, tv1, tv2); /* side effects */ + + idx_args = idx_func + 2; + duk_remove_n(thr, 0, idx_args); /* may be NORZ */ + + idx_func = 0; + DUK_UNREF(idx_func); /* really 'not applicable' anymore, should not be referenced after this */ + idx_args = 0; + + *out_nargs = ((duk_hcompfunc *) func)->nargs; + *out_nregs = ((duk_hcompfunc *) func)->nregs; + DUK_ASSERT(*out_nregs >= 0); + DUK_ASSERT(*out_nregs >= *out_nargs); + *out_vs_min_bytes = + entry_valstack_bottom_byteoff + sizeof(duk_tval) * ((duk_size_t) *out_nregs + DUK_VALSTACK_INTERNAL_EXTRA); + +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) +#if defined(DUK_USE_TAILCALL) +#error incorrect options: tail calls enabled with function caller property +#endif + /* XXX: This doesn't actually work properly for tail calls, so + * tail calls are disabled when DUK_USE_NONSTD_FUNC_CALLER_PROPERTY + * is in use. + */ + duk__update_func_caller_prop(thr, func); +#endif + + /* [ ... this_new | arg1 ... argN ] */ + + return 1; +} +#endif /* DUK_USE_TAILCALL */ + +DUK_LOCAL void duk__call_setup_act_not_tailcall(duk_hthread *thr, + duk_small_uint_t call_flags, + duk_idx_t idx_func, + duk_hobject *func, + duk_size_t entry_valstack_bottom_byteoff, + duk_size_t entry_valstack_end_byteoff, + duk_idx_t *out_nargs, + duk_idx_t *out_nregs, + duk_size_t *out_vs_min_bytes, + duk_activation **out_act) { + duk_activation *act; + duk_activation *new_act; + + DUK_UNREF(entry_valstack_end_byteoff); + + DUK_DDD(DUK_DDDPRINT("not a tail call, pushing a new activation to callstack, to index %ld", (long) (thr->callstack_top))); + + duk__call_callstack_limit_check(thr); + new_act = duk_hthread_activation_alloc(thr); + DUK_ASSERT(new_act != NULL); + + act = thr->callstack_curr; + if (act != NULL) { + /* + * Update return value stack index of current activation (if any). + * + * Although it might seem this is not necessary (bytecode executor + * does this for ECMAScript-to-ECMAScript calls; other calls are + * handled here), this turns out to be necessary for handling yield + * and resume. For them, an ECMAScript-to-native call happens, and + * the ECMAScript call's retval_byteoff must be set for things to work. + */ + + act->retval_byteoff = entry_valstack_bottom_byteoff + (duk_size_t) idx_func * sizeof(duk_tval); + } + + new_act->parent = act; + thr->callstack_curr = new_act; + thr->callstack_top++; + act = new_act; + *out_act = act; + + DUK_ASSERT(thr->valstack_top > thr->valstack_bottom); /* at least effective 'this' */ + DUK_ASSERT(func == NULL || !DUK_HOBJECT_HAS_BOUNDFUNC(func)); + + act->cat = NULL; + + act->flags = 0; + if (call_flags & DUK_CALL_FLAG_CONSTRUCT) { + act->flags |= DUK_ACT_FLAG_CONSTRUCT; + } +#if defined(DUK_USE_ES6_PROXY) + if (call_flags & DUK_CALL_FLAG_CONSTRUCT_PROXY) { + act->flags |= DUK_ACT_FLAG_CONSTRUCT_PROXY; + } +#endif + if (call_flags & DUK_CALL_FLAG_DIRECT_EVAL) { + act->flags |= DUK_ACT_FLAG_DIRECT_EVAL; + } + + /* start of arguments: idx_func + 2. */ + act->func = func; /* NULL for lightfunc */ + if (DUK_LIKELY(func != NULL)) { + DUK_TVAL_SET_OBJECT(&act->tv_func, func); /* borrowed, no refcount */ + if (DUK_HOBJECT_HAS_STRICT(func)) { + act->flags |= DUK_ACT_FLAG_STRICT; + } + if (DUK_HOBJECT_IS_COMPFUNC(func)) { + *out_nargs = ((duk_hcompfunc *) func)->nargs; + *out_nregs = ((duk_hcompfunc *) func)->nregs; + DUK_ASSERT(*out_nregs >= 0); + DUK_ASSERT(*out_nregs >= *out_nargs); + *out_vs_min_bytes = + entry_valstack_bottom_byteoff + + sizeof(duk_tval) * ((duk_size_t) idx_func + 2U + (duk_size_t) *out_nregs + DUK_VALSTACK_INTERNAL_EXTRA); + } else { + /* True because of call target lookup checks. */ + DUK_ASSERT(DUK_HOBJECT_IS_NATFUNC(func)); + + *out_nargs = ((duk_hnatfunc *) func)->nargs; + *out_nregs = *out_nargs; + if (*out_nargs >= 0) { + *out_vs_min_bytes = + entry_valstack_bottom_byteoff + + sizeof(duk_tval) * ((duk_size_t) idx_func + 2U + (duk_size_t) *out_nregs + + DUK_VALSTACK_API_ENTRY_MINIMUM + DUK_VALSTACK_INTERNAL_EXTRA); + } else { + /* Vararg function. */ + duk_size_t valstack_top_byteoff = + (duk_size_t) ((duk_uint8_t *) thr->valstack_top - ((duk_uint8_t *) thr->valstack)); + *out_vs_min_bytes = valstack_top_byteoff + sizeof(duk_tval) * (DUK_VALSTACK_API_ENTRY_MINIMUM + + DUK_VALSTACK_INTERNAL_EXTRA); + } + } + } else { + duk_small_uint_t lf_flags; + duk_tval *tv_func; + + act->flags |= DUK_ACT_FLAG_STRICT; + + tv_func = DUK_GET_TVAL_POSIDX(thr, idx_func); + DUK_ASSERT(DUK_TVAL_IS_LIGHTFUNC(tv_func)); + DUK_TVAL_SET_TVAL(&act->tv_func, tv_func); /* borrowed, no refcount */ + + lf_flags = DUK_TVAL_GET_LIGHTFUNC_FLAGS(tv_func); + *out_nargs = DUK_LFUNC_FLAGS_GET_NARGS(lf_flags); + if (*out_nargs != DUK_LFUNC_NARGS_VARARGS) { + *out_vs_min_bytes = entry_valstack_bottom_byteoff + + sizeof(duk_tval) * ((duk_size_t) idx_func + 2U + (duk_size_t) *out_nargs + + DUK_VALSTACK_API_ENTRY_MINIMUM + DUK_VALSTACK_INTERNAL_EXTRA); + } else { + duk_size_t valstack_top_byteoff = + (duk_size_t) ((duk_uint8_t *) thr->valstack_top - ((duk_uint8_t *) thr->valstack)); + *out_vs_min_bytes = valstack_top_byteoff + + sizeof(duk_tval) * (DUK_VALSTACK_API_ENTRY_MINIMUM + DUK_VALSTACK_INTERNAL_EXTRA); + *out_nargs = -1; /* vararg */ + } + *out_nregs = *out_nargs; + } + + act->var_env = NULL; + act->lex_env = NULL; +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) + act->prev_caller = NULL; +#endif + act->curr_pc = NULL; +#if defined(DUK_USE_DEBUGGER_SUPPORT) + act->prev_line = 0; +#endif + act->bottom_byteoff = entry_valstack_bottom_byteoff + sizeof(duk_tval) * ((duk_size_t) idx_func + 2U); +#if 0 + act->retval_byteoff = 0; /* topmost activation retval_byteoff is considered garbage, no need to init */ +#endif + /* Filled in when final reserve is known, dummy value doesn't matter + * even in error unwind because reserve_byteoff is only used when + * returning to -this- activation. + */ + act->reserve_byteoff = 0; /* filled in by caller */ + + /* XXX: Is this INCREF necessary? 'func' is always a borrowed + * reference reachable through the value stack? If changed, stack + * unwind code also needs to be fixed to match. + */ + DUK_HOBJECT_INCREF_ALLOWNULL(thr, func); /* act->func */ + +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) + if (func) { + duk__update_func_caller_prop(thr, func); + } +#endif +} + +/* + * Environment setup. + */ + +DUK_LOCAL void duk__call_env_setup(duk_hthread *thr, duk_hobject *func, duk_activation *act, duk_idx_t idx_args) { + duk_hobject *env; + + DUK_ASSERT(func == NULL || !DUK_HOBJECT_HAS_BOUNDFUNC(func)); /* bound function has already been resolved */ + + if (DUK_LIKELY(func != NULL)) { + if (DUK_LIKELY(DUK_HOBJECT_HAS_NEWENV(func))) { + DUK_STATS_INC(thr->heap, stats_envrec_newenv); + if (DUK_LIKELY(!DUK_HOBJECT_HAS_CREATEARGS(func))) { + /* Use a new environment but there's no 'arguments' object; + * delayed environment initialization. This is the most + * common case. + */ + DUK_ASSERT(act->lex_env == NULL); + DUK_ASSERT(act->var_env == NULL); + } else { + /* Use a new environment and there's an 'arguments' object. + * We need to initialize it right now. + */ + + /* third arg: absolute index (to entire valstack) of bottom_byteoff of new activation */ + env = duk_create_activation_environment_record(thr, func, act->bottom_byteoff); + DUK_ASSERT(env != NULL); + + /* [ ... func this arg1 ... argN envobj ] */ + + DUK_ASSERT(DUK_HOBJECT_HAS_CREATEARGS(func)); + duk__handle_createargs_for_call(thr, func, env, idx_args); + + /* [ ... func this arg1 ... argN envobj ] */ + + act->lex_env = env; + act->var_env = env; + DUK_HOBJECT_INCREF(thr, env); + DUK_HOBJECT_INCREF(thr, env); /* XXX: incref by count (2) directly */ + duk_pop(thr); + } + } else { + /* Use existing env (e.g. for non-strict eval); cannot have + * an own 'arguments' object (but can refer to an existing one). + */ + + DUK_ASSERT(!DUK_HOBJECT_HAS_CREATEARGS(func)); + + DUK_STATS_INC(thr->heap, stats_envrec_oldenv); + duk__handle_oldenv_for_call(thr, func, act); + + DUK_ASSERT(act->lex_env != NULL); + DUK_ASSERT(act->var_env != NULL); + } + } else { + /* Lightfuncs are always native functions and have "newenv". */ + DUK_ASSERT(act->lex_env == NULL); + DUK_ASSERT(act->var_env == NULL); + DUK_STATS_INC(thr->heap, stats_envrec_newenv); + } +} + +/* + * Misc shared helpers. + */ + +/* Check thread state, update current thread. */ +DUK_LOCAL void duk__call_thread_state_update(duk_hthread *thr) { + DUK_ASSERT(thr != NULL); + + if (DUK_LIKELY(thr == thr->heap->curr_thread)) { + if (DUK_UNLIKELY(thr->state != DUK_HTHREAD_STATE_RUNNING)) { + /* Should actually never happen, but check anyway. */ + goto thread_state_error; + } + } else { + DUK_ASSERT(thr->heap->curr_thread == NULL || thr->heap->curr_thread->state == DUK_HTHREAD_STATE_RUNNING); + if (DUK_UNLIKELY(thr->state != DUK_HTHREAD_STATE_INACTIVE)) { + goto thread_state_error; + } + DUK_HEAP_SWITCH_THREAD(thr->heap, thr); + thr->state = DUK_HTHREAD_STATE_RUNNING; + + /* Multiple threads may be simultaneously in the RUNNING + * state, but not in the same "resume chain". + */ + } + DUK_ASSERT(thr->heap->curr_thread == thr); + DUK_ASSERT(thr->state == DUK_HTHREAD_STATE_RUNNING); + return; + +thread_state_error: + DUK_ERROR_FMT1(thr, DUK_ERR_TYPE_ERROR, "invalid thread state (%ld)", (long) thr->state); + DUK_WO_NORETURN(return;); +} + +/* + * Main unprotected call handler, handles: + * + * - All combinations of native/ECMAScript caller and native/ECMAScript + * target. + * + * - Optimized ECMAScript-to-ECMAScript call where call handling only + * sets up a new duk_activation but reuses an existing bytecode executor + * (the caller) without native recursion. + * + * - Tailcalls, where an activation is reused without increasing call + * stack (duk_activation) depth. + * + * - Setup for an initial Duktape.Thread.resume(). + * + * The call handler doesn't provide any protection guarantees, protected calls + * must be implemented e.g. by wrapping the call in a duk_safe_call(). + * Call setup may fail at any stage, even when the new activation is in + * place; the only guarantee is that the state is consistent for unwinding. + */ + +DUK_LOCAL duk_int_t duk__handle_call_raw(duk_hthread *thr, duk_idx_t idx_func, duk_small_uint_t call_flags) { +#if defined(DUK_USE_ASSERTIONS) + duk_activation *entry_act; + duk_size_t entry_callstack_top; +#endif + duk_size_t entry_valstack_bottom_byteoff; + duk_size_t entry_valstack_end_byteoff; + duk_int_t entry_call_recursion_depth; + duk_hthread *entry_curr_thread; + duk_uint_fast8_t entry_thread_state; + duk_instr_t **entry_ptr_curr_pc; + duk_idx_t idx_args; + duk_idx_t nargs; /* # argument registers target function wants (< 0 => "as is") */ + duk_idx_t nregs; /* # total registers target function wants on entry (< 0 => "as is") */ + duk_size_t vs_min_bytes; /* minimum value stack size (bytes) for handling call */ + duk_hobject *func; /* 'func' on stack (borrowed reference) */ + duk_activation *act; + duk_ret_t rc; + duk_small_uint_t use_tailcall; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + /* Asserts for heap->curr_thread omitted: it may be NULL, 'thr', or + * any other thread (e.g. when heap thread is used to run finalizers). + */ + DUK_CTX_ASSERT_VALID(thr); + DUK_ASSERT(duk_is_valid_index(thr, idx_func)); + DUK_ASSERT(idx_func >= 0); + + DUK_STATS_INC(thr->heap, stats_call_all); + + /* If a tail call: + * - an ECMAScript activation must be on top of the callstack + * - there cannot be any catch stack entries that would catch + * a return + */ +#if defined(DUK_USE_ASSERTIONS) + if (call_flags & DUK_CALL_FLAG_TAILCALL) { + duk_activation *tmp_act; + duk_catcher *tmp_cat; + + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr) != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr))); + + /* No entry in the catch stack which would actually catch a + * throw can refer to the callstack entry being reused. + * There *can* be catch stack entries referring to the current + * callstack entry as long as they don't catch (e.g. label sites). + */ + + tmp_act = thr->callstack_curr; + for (tmp_cat = tmp_act->cat; tmp_cat != NULL; tmp_cat = tmp_cat->parent) { + DUK_ASSERT(DUK_CAT_GET_TYPE(tmp_cat) == DUK_CAT_TYPE_LABEL); /* a non-catching entry */ + } + } +#endif /* DUK_USE_ASSERTIONS */ + + /* + * Store entry state. + */ + +#if defined(DUK_USE_ASSERTIONS) + entry_act = thr->callstack_curr; + entry_callstack_top = thr->callstack_top; +#endif + entry_valstack_bottom_byteoff = (duk_size_t) ((duk_uint8_t *) thr->valstack_bottom - (duk_uint8_t *) thr->valstack); + entry_valstack_end_byteoff = (duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack); + entry_call_recursion_depth = thr->heap->call_recursion_depth; + entry_curr_thread = thr->heap->curr_thread; /* may be NULL if first call */ + entry_thread_state = thr->state; + entry_ptr_curr_pc = thr->ptr_curr_pc; /* may be NULL */ + + /* If thr->ptr_curr_pc is set, sync curr_pc to act->pc. Then NULL + * thr->ptr_curr_pc so that it's not accidentally used with an incorrect + * activation when side effects occur. + */ + duk_hthread_sync_and_null_currpc(thr); + DUK_ASSERT(thr->ptr_curr_pc == NULL); + + DUK_DD(DUK_DDPRINT("duk__handle_call_raw: thr=%p, idx_func=%ld, " + "call_flags=0x%08lx (constructor=%ld), " + "valstack_top=%ld, idx_func=%ld, idx_args=%ld, rec_depth=%ld/%ld, " + "entry_valstack_bottom_byteoff=%ld, entry_valstack_end_byteoff=%ld, " + "entry_call_recursion_depth=%ld, " + "entry_curr_thread=%p, entry_thread_state=%ld", + (void *) thr, + (long) idx_func, + (unsigned long) call_flags, + (long) ((call_flags & DUK_CALL_FLAG_CONSTRUCT) != 0 ? 1 : 0), + (long) duk_get_top(thr), + (long) idx_func, + (long) (idx_func + 2), + (long) thr->heap->call_recursion_depth, + (long) thr->heap->call_recursion_limit, + (long) entry_valstack_bottom_byteoff, + (long) entry_valstack_end_byteoff, + (long) entry_call_recursion_depth, + (void *) entry_curr_thread, + (long) entry_thread_state)); + + /* + * Thread state check and book-keeping. + */ + + duk__call_thread_state_update(thr); + + /* + * Increase call recursion depth as early as possible so that if we + * enter a recursive call for any reason there's a backstop to native + * recursion. This can happen e.g. for almost any property read + * because it may cause a getter call or a Proxy trap (GC and finalizers + * are not an issue because they are not recursive). If we end up + * doing an Ecma-to-Ecma call, revert the increase. (See GH-2032.) + * + * For similar reasons, ensure there is a known value stack spare + * even before we actually prepare the value stack for the target + * function. If this isn't done, early recursion may consume the + * value stack space. + * + * XXX: Should bump yield preventcount early, for the same reason. + */ + + duk__call_c_recursion_limit_check(thr); + thr->heap->call_recursion_depth++; + duk_require_stack(thr, DUK__CALL_HANDLING_REQUIRE_STACK); + + /* + * Resolve final target function; handle bound functions and special + * functions like .call() and .apply(). Also figure out the effective + * 'this' binding, which replaces the current value at idx_func + 1. + */ + + if (DUK_LIKELY(duk__resolve_target_fastpath_check(thr, idx_func, &func, call_flags) != 0U)) { + DUK_DDD(DUK_DDDPRINT("fast path target resolve")); + } else { + DUK_DDD(DUK_DDDPRINT("slow path target resolve")); + func = duk__resolve_target_func_and_this_binding(thr, idx_func, &call_flags); + } + DUK_ASSERT(duk_get_top(thr) - idx_func >= 2); /* at least func and this present */ + + DUK_ASSERT(func == NULL || !DUK_HOBJECT_HAS_BOUNDFUNC(func)); + DUK_ASSERT(func == NULL || (DUK_HOBJECT_IS_COMPFUNC(func) || DUK_HOBJECT_IS_NATFUNC(func))); + + /* [ ... func this arg1 ... argN ] */ + + /* + * Setup a preliminary activation and figure out nargs/nregs and + * value stack minimum size. + * + * Don't touch valstack_bottom or valstack_top yet so that Duktape API + * calls work normally. + * + * Because 'act' is not zeroed, all fields must be filled in. + */ + + /* Should not be necessary, but initialize to silence warnings. */ + act = NULL; + nargs = 0; + nregs = 0; + vs_min_bytes = 0; + +#if defined(DUK_USE_TAILCALL) + use_tailcall = (call_flags & DUK_CALL_FLAG_TAILCALL); + if (use_tailcall) { + use_tailcall = duk__call_setup_act_attempt_tailcall(thr, + call_flags, + idx_func, + func, + entry_valstack_bottom_byteoff, + entry_valstack_end_byteoff, + &nargs, + &nregs, + &vs_min_bytes, + &act); + } +#else + DUK_ASSERT((call_flags & DUK_CALL_FLAG_TAILCALL) == 0); /* compiler ensures this */ + use_tailcall = 0; +#endif + + if (use_tailcall) { + idx_args = 0; + DUK_STATS_INC(thr->heap, stats_call_tailcall); + } else { + duk__call_setup_act_not_tailcall(thr, + call_flags, + idx_func, + func, + entry_valstack_bottom_byteoff, + entry_valstack_end_byteoff, + &nargs, + &nregs, + &vs_min_bytes, + &act); + idx_args = idx_func + 2; + } + /* After this point idx_func is no longer valid for tailcalls. */ + + DUK_ASSERT(act != NULL); + + /* [ ... func this arg1 ... argN ] */ + + /* + * Grow value stack to required size before env setup. This + * must happen before env setup to handle some corner cases + * correctly, e.g. test-bug-scope-segv-gh2448.js. + */ + + duk_valstack_grow_check_throw(thr, vs_min_bytes); + act->reserve_byteoff = (duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack); + + /* + * Environment record creation and 'arguments' object creation. + * Named function expression name binding is handled by the + * compiler; the compiled function's parent env will contain + * the (immutable) binding already. + * + * This handling is now identical for C and ECMAScript functions. + * C functions always have the 'NEWENV' flag set, so their + * environment record initialization is delayed (which is good). + * + * Delayed creation (on demand) is handled in duk_js_var.c. + */ + + duk__call_env_setup(thr, func, act, idx_args); + + /* [ ... func this arg1 ... argN ] */ + + /* + * Setup value stack: clamp to 'nargs', fill up to 'nregs', + * ensure value stack size matches target requirements, and + * switch value stack bottom. Valstack top is kept. + */ + + if (use_tailcall) { + DUK_ASSERT(nregs >= 0); + DUK_ASSERT(nregs >= nargs); + duk_set_top_and_wipe(thr, nregs, nargs); + } else { + if (nregs >= 0) { + DUK_ASSERT(nregs >= nargs); + duk_set_top_and_wipe(thr, idx_func + 2 + nregs, idx_func + 2 + nargs); + } else { + ; + } + thr->valstack_bottom = thr->valstack_bottom + idx_func + 2; + } + DUK_ASSERT(thr->valstack_bottom >= thr->valstack); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT(thr->valstack_end >= thr->valstack_top); + + /* + * Make the actual call. For Ecma-to-Ecma calls detect that + * setup is complete, then return with a status code that allows + * the caller to reuse the running executor. + */ + + if (func != NULL && DUK_HOBJECT_IS_COMPFUNC(func)) { + /* + * ECMAScript call. + */ + + DUK_ASSERT(func != NULL); + DUK_ASSERT(DUK_HOBJECT_HAS_COMPFUNC(func)); + act->curr_pc = DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, (duk_hcompfunc *) func); + + if (call_flags & DUK_CALL_FLAG_ALLOW_ECMATOECMA) { + DUK_DD(DUK_DDPRINT("avoid native call, use existing executor")); + DUK_STATS_INC(thr->heap, stats_call_ecmatoecma); + DUK_ASSERT((act->flags & DUK_ACT_FLAG_PREVENT_YIELD) == 0); + DUK_REFZERO_CHECK_FAST(thr); + DUK_ASSERT(thr->ptr_curr_pc == NULL); + thr->heap->call_recursion_depth--; /* No recursion increase for this case. */ + return 1; /* 1=reuse executor */ + } + DUK_ASSERT(use_tailcall == 0); + + /* duk_hthread_activation_unwind_norz() will decrease this on unwind */ + DUK_ASSERT((act->flags & DUK_ACT_FLAG_PREVENT_YIELD) == 0); + act->flags |= DUK_ACT_FLAG_PREVENT_YIELD; + thr->callstack_preventcount++; + + /* [ ... func this | arg1 ... argN ] ('this' must precede new bottom) */ + + /* + * Bytecode executor call. + * + * Execute bytecode, handling any recursive function calls and + * thread resumptions. Returns when execution would return from + * the entry level activation. When the executor returns, a + * single return value is left on the stack top. + * + * The only possible longjmp() is an error (DUK_LJ_TYPE_THROW), + * other types are handled internally by the executor. + */ + + /* thr->ptr_curr_pc is set by bytecode executor early on entry */ + DUK_ASSERT(thr->ptr_curr_pc == NULL); + DUK_DDD(DUK_DDDPRINT("entering bytecode execution")); + duk_js_execute_bytecode(thr); + DUK_DDD(DUK_DDDPRINT("returned from bytecode execution")); + } else { + /* + * Native call. + */ + + DUK_ASSERT(func == NULL || ((duk_hnatfunc *) func)->func != NULL); + DUK_ASSERT(use_tailcall == 0); + + /* [ ... func this | arg1 ... argN ] ('this' must precede new bottom) */ + + /* duk_hthread_activation_unwind_norz() will decrease this on unwind */ + DUK_ASSERT((act->flags & DUK_ACT_FLAG_PREVENT_YIELD) == 0); + act->flags |= DUK_ACT_FLAG_PREVENT_YIELD; + thr->callstack_preventcount++; + + /* For native calls must be NULL so we don't sync back */ + DUK_ASSERT(thr->ptr_curr_pc == NULL); + + /* XXX: native funcptr could come out of call setup. */ + if (func) { + rc = ((duk_hnatfunc *) func)->func(thr); + } else { + duk_tval *tv_func; + duk_c_function funcptr; + + tv_func = &act->tv_func; + DUK_ASSERT(DUK_TVAL_IS_LIGHTFUNC(tv_func)); + funcptr = DUK_TVAL_GET_LIGHTFUNC_FUNCPTR(tv_func); + rc = funcptr(thr); + } + + /* Automatic error throwing, retval check. */ + + if (rc == 0) { + DUK_ASSERT(thr->valstack < thr->valstack_end); + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top)); + thr->valstack_top++; + } else if (rc == 1) { + ; + } else if (rc < 0) { + duk_error_throw_from_negative_rc(thr, rc); + DUK_WO_NORETURN(return 0;); + } else { + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_CFUNC_RC); + DUK_WO_NORETURN(return 0;); + } + } + DUK_ASSERT(thr->ptr_curr_pc == NULL); + DUK_ASSERT(use_tailcall == 0); + + /* + * Constructor call post processing. + */ + +#if defined(DUK_USE_ES6_PROXY) + if (call_flags & (DUK_CALL_FLAG_CONSTRUCT | DUK_CALL_FLAG_CONSTRUCT_PROXY)) { + duk_call_construct_postprocess(thr, call_flags & DUK_CALL_FLAG_CONSTRUCT_PROXY); + } +#else + if (call_flags & DUK_CALL_FLAG_CONSTRUCT) { + duk_call_construct_postprocess(thr, 0); + } +#endif + + /* + * Unwind, restore valstack bottom and other book-keeping. + */ + + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(thr->callstack_curr->parent == entry_act); + DUK_ASSERT(thr->callstack_top == entry_callstack_top + 1); + duk_hthread_activation_unwind_norz(thr); + DUK_ASSERT(thr->callstack_curr == entry_act); + DUK_ASSERT(thr->callstack_top == entry_callstack_top); + + thr->valstack_bottom = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + entry_valstack_bottom_byteoff); + /* keep current valstack_top */ + DUK_ASSERT(thr->valstack_bottom >= thr->valstack); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT(thr->valstack_end >= thr->valstack_top); + DUK_ASSERT(thr->valstack_top - thr->valstack_bottom >= idx_func + 1); + + /* Return value handling. */ + + /* [ ... func this (crud) retval ] */ + + { + duk_tval *tv_ret; + duk_tval *tv_funret; + + tv_ret = thr->valstack_bottom + idx_func; + tv_funret = thr->valstack_top - 1; +#if defined(DUK_USE_FASTINT) + /* Explicit check for fastint downgrade. */ + DUK_TVAL_CHKFAST_INPLACE_FAST(tv_funret); +#endif + DUK_TVAL_SET_TVAL_UPDREF(thr, tv_ret, tv_funret); /* side effects */ + } + + duk_set_top_unsafe(thr, idx_func + 1); + + /* [ ... retval ] */ + + /* Restore caller's value stack reserve (cannot fail). */ + DUK_ASSERT((duk_uint8_t *) thr->valstack + entry_valstack_end_byteoff >= (duk_uint8_t *) thr->valstack_top); + DUK_ASSERT((duk_uint8_t *) thr->valstack + entry_valstack_end_byteoff <= (duk_uint8_t *) thr->valstack_alloc_end); + thr->valstack_end = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + entry_valstack_end_byteoff); + + /* XXX: Trial value stack shrink would be OK here, but we'd need + * to prevent side effects of the potential realloc. + */ + + /* Restore entry thread executor curr_pc stack frame pointer. */ + thr->ptr_curr_pc = entry_ptr_curr_pc; + + DUK_HEAP_SWITCH_THREAD(thr->heap, entry_curr_thread); /* may be NULL */ + thr->state = (duk_uint8_t) entry_thread_state; + + /* Disabled assert: triggered with some torture tests. */ +#if 0 + DUK_ASSERT((thr->state == DUK_HTHREAD_STATE_INACTIVE && thr->heap->curr_thread == NULL) || /* first call */ + (thr->state == DUK_HTHREAD_STATE_INACTIVE && thr->heap->curr_thread != NULL) || /* other call */ + (thr->state == DUK_HTHREAD_STATE_RUNNING && thr->heap->curr_thread == thr)); /* current thread */ +#endif + + thr->heap->call_recursion_depth = entry_call_recursion_depth; + + /* If the debugger is active we need to force an interrupt so that + * debugger breakpoints are rechecked. This is important for function + * calls caused by side effects (e.g. when doing a DUK_OP_GETPROP), see + * GH-303. Only needed for success path, error path always causes a + * breakpoint recheck in the executor. It would be enough to set this + * only when returning to an ECMAScript activation, but setting the flag + * on every return should have no ill effect. + */ +#if defined(DUK_USE_DEBUGGER_SUPPORT) + if (duk_debug_is_attached(thr->heap)) { + DUK_DD(DUK_DDPRINT("returning with debugger enabled, force interrupt")); + DUK_ASSERT(thr->interrupt_counter <= thr->interrupt_init); + thr->interrupt_init -= thr->interrupt_counter; + thr->interrupt_counter = 0; + thr->heap->dbg_force_restart = 1; + } +#endif + +#if defined(DUK_USE_INTERRUPT_COUNTER) && defined(DUK_USE_DEBUG) + duk__interrupt_fixup(thr, entry_curr_thread); +#endif + + /* Restored by success path. */ + DUK_ASSERT(thr->heap->call_recursion_depth == entry_call_recursion_depth); + DUK_ASSERT(thr->ptr_curr_pc == entry_ptr_curr_pc); + DUK_ASSERT_LJSTATE_UNSET(thr->heap); + + DUK_REFZERO_CHECK_FAST(thr); + + return 0; /* 0=call handled inline */ +} + +DUK_INTERNAL duk_int_t duk_handle_call_unprotected_nargs(duk_hthread *thr, duk_idx_t nargs, duk_small_uint_t call_flags) { + duk_idx_t idx_func; + DUK_ASSERT(duk_get_top(thr) >= nargs + 2); + idx_func = duk_get_top(thr) - (nargs + 2); + DUK_ASSERT(idx_func >= 0); + return duk_handle_call_unprotected(thr, idx_func, call_flags); +} + +DUK_INTERNAL duk_int_t duk_handle_call_unprotected(duk_hthread *thr, duk_idx_t idx_func, duk_small_uint_t call_flags) { + DUK_ASSERT(duk_is_valid_index(thr, idx_func)); + DUK_ASSERT(idx_func >= 0); + return duk__handle_call_raw(thr, idx_func, call_flags); +} + +/* + * duk_handle_safe_call(): make a "C protected call" within the + * current activation. + * + * The allowed thread states for making a call are the same as for + * duk_handle_call_protected(). + * + * Even though this call is protected, errors are thrown for insane arguments + * and may result in a fatal error unless there's another protected call which + * catches such errors. + * + * The error handling path should be error free, even for out-of-memory + * errors, to ensure safe sandboxing. (As of Duktape 2.2.0 this is not + * yet the case for environment closing which may run out of memory, see + * XXX notes below.) + */ + +DUK_LOCAL void duk__handle_safe_call_inner(duk_hthread *thr, + duk_safe_call_function func, + void *udata, +#if defined(DUK_USE_ASSERTIONS) + duk_size_t entry_valstack_bottom_byteoff, + duk_size_t entry_callstack_top, +#endif + duk_hthread *entry_curr_thread, + duk_uint_fast8_t entry_thread_state, + duk_idx_t idx_retbase, + duk_idx_t num_stack_rets) { + duk_ret_t rc; + + DUK_ASSERT(thr != NULL); + DUK_CTX_ASSERT_VALID(thr); + + /* + * Thread state check and book-keeping. + */ + + duk__call_thread_state_update(thr); + + /* + * Recursion limit check. + */ + + duk__call_c_recursion_limit_check(thr); + thr->heap->call_recursion_depth++; + + /* + * Make the C call. + */ + + rc = func(thr, udata); + + DUK_DDD(DUK_DDDPRINT("safe_call, func rc=%ld", (long) rc)); + + /* + * Valstack manipulation for results. + */ + + /* we're running inside the caller's activation, so no change in call/catch stack or valstack bottom */ + DUK_ASSERT(thr->callstack_top == entry_callstack_top); + DUK_ASSERT(thr->valstack_bottom >= thr->valstack); + DUK_ASSERT((duk_size_t) ((duk_uint8_t *) thr->valstack_bottom - (duk_uint8_t *) thr->valstack) == + entry_valstack_bottom_byteoff); + DUK_ASSERT(thr->valstack_top >= thr->valstack_bottom); + DUK_ASSERT(thr->valstack_end >= thr->valstack_top); + + if (DUK_UNLIKELY(rc < 0)) { + duk_error_throw_from_negative_rc(thr, rc); + DUK_WO_NORETURN(return;); + } + DUK_ASSERT(rc >= 0); + + duk__safe_call_adjust_valstack(thr, idx_retbase, num_stack_rets, rc); /* throws for insane rc */ + + DUK_HEAP_SWITCH_THREAD(thr->heap, entry_curr_thread); /* may be NULL */ + thr->state = (duk_uint8_t) entry_thread_state; +} + +DUK_LOCAL void duk__handle_safe_call_error(duk_hthread *thr, + duk_activation *entry_act, +#if defined(DUK_USE_ASSERTIONS) + duk_size_t entry_callstack_top, +#endif + duk_hthread *entry_curr_thread, + duk_uint_fast8_t entry_thread_state, + duk_idx_t idx_retbase, + duk_idx_t num_stack_rets, + duk_size_t entry_valstack_bottom_byteoff, + duk_jmpbuf *old_jmpbuf_ptr) { + DUK_ASSERT(thr != NULL); + DUK_CTX_ASSERT_VALID(thr); + + /* + * Error during call. The error value is at heap->lj.value1. + * + * The very first thing we do is restore the previous setjmp catcher. + * This means that any error in error handling will propagate outwards + * instead of causing a setjmp() re-entry above. + */ + + DUK_DDD(DUK_DDDPRINT("error caught during protected duk_handle_safe_call()")); + + /* Other longjmp types are handled by executor before propagating + * the error here. + */ + DUK_ASSERT(thr->heap->lj.type == DUK_LJ_TYPE_THROW); + DUK_ASSERT_LJSTATE_SET(thr->heap); + + /* Either pointer may be NULL (at entry), so don't assert. */ + thr->heap->lj.jmpbuf_ptr = old_jmpbuf_ptr; + + /* XXX: callstack unwind may now throw an error when closing + * scopes; this is a sandboxing issue, described in: + * https://github.com/svaarala/duktape/issues/476 + */ + /* XXX: "unwind to" primitive? */ + + DUK_ASSERT(thr->callstack_top >= entry_callstack_top); + while (thr->callstack_curr != entry_act) { + DUK_ASSERT(thr->callstack_curr != NULL); + duk_hthread_activation_unwind_norz(thr); + } + DUK_ASSERT(thr->callstack_top == entry_callstack_top); + + /* Switch active thread before any side effects to avoid a + * dangling curr_thread pointer. + */ + DUK_HEAP_SWITCH_THREAD(thr->heap, entry_curr_thread); /* may be NULL */ + thr->state = (duk_uint8_t) entry_thread_state; + + DUK_ASSERT(thr->heap->curr_thread == entry_curr_thread); + DUK_ASSERT(thr->state == entry_thread_state); + + /* Restore valstack bottom. */ + thr->valstack_bottom = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + entry_valstack_bottom_byteoff); + + /* [ ... | (crud) ] */ + + /* XXX: ensure space in valstack (now relies on internal reserve)? */ + duk_push_tval(thr, &thr->heap->lj.value1); + + /* [ ... | (crud) errobj ] */ + + DUK_ASSERT(duk_get_top(thr) >= 1); /* at least errobj must be on stack */ + + duk__safe_call_adjust_valstack(thr, idx_retbase, num_stack_rets, 1); /* 1 = num actual 'return values' */ + + /* [ ... | ] or [ ... | errobj (M * undefined)] where M = num_stack_rets - 1 */ + + /* Reset longjmp state. */ + thr->heap->lj.type = DUK_LJ_TYPE_UNKNOWN; + thr->heap->lj.iserror = 0; + DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ(thr, &thr->heap->lj.value1); + DUK_TVAL_SET_UNDEFINED_UPDREF_NORZ(thr, &thr->heap->lj.value2); + + /* Error handling complete, remove side effect protections. Caller + * will process pending finalizers. + */ +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(thr->heap->error_not_allowed == 1); + thr->heap->error_not_allowed = 0; +#endif + DUK_ASSERT(thr->heap->pf_prevent_count > 0); + thr->heap->pf_prevent_count--; + DUK_DD(DUK_DDPRINT("safe call error handled, pf_prevent_count updated to %ld", (long) thr->heap->pf_prevent_count)); + + /* thr->ptr_curr_pc is restored by + * duk__handle_safe_call_shared_unwind() which is also used for + * success path. + */ +} + +DUK_LOCAL void duk__handle_safe_call_shared_unwind(duk_hthread *thr, + duk_idx_t idx_retbase, + duk_idx_t num_stack_rets, +#if defined(DUK_USE_ASSERTIONS) + duk_size_t entry_callstack_top, +#endif + duk_int_t entry_call_recursion_depth, + duk_hthread *entry_curr_thread, + duk_instr_t **entry_ptr_curr_pc) { + DUK_ASSERT(thr != NULL); + DUK_CTX_ASSERT_VALID(thr); + DUK_UNREF(idx_retbase); + DUK_UNREF(num_stack_rets); + DUK_UNREF(entry_curr_thread); + + DUK_ASSERT(thr->callstack_top == entry_callstack_top); + + /* Restore entry thread executor curr_pc stack frame pointer. + * XXX: would be enough to do in error path only, should nest + * cleanly in success path. + */ + thr->ptr_curr_pc = entry_ptr_curr_pc; + + thr->heap->call_recursion_depth = entry_call_recursion_depth; + + /* stack discipline consistency check */ + DUK_ASSERT(duk_get_top(thr) == idx_retbase + num_stack_rets); + + /* A debugger forced interrupt check is not needed here, as + * problematic safe calls are not caused by side effects. + */ + +#if defined(DUK_USE_INTERRUPT_COUNTER) && defined(DUK_USE_DEBUG) + duk__interrupt_fixup(thr, entry_curr_thread); +#endif +} + +DUK_INTERNAL duk_int_t duk_handle_safe_call(duk_hthread *thr, + duk_safe_call_function func, + void *udata, + duk_idx_t num_stack_args, + duk_idx_t num_stack_rets) { + duk_activation *entry_act; + duk_size_t entry_valstack_bottom_byteoff; +#if defined(DUK_USE_ASSERTIONS) + duk_size_t entry_valstack_end_byteoff; + duk_size_t entry_callstack_top; + duk_size_t entry_callstack_preventcount; +#endif + duk_int_t entry_call_recursion_depth; + duk_hthread *entry_curr_thread; + duk_uint_fast8_t entry_thread_state; + duk_instr_t **entry_ptr_curr_pc; + duk_jmpbuf *old_jmpbuf_ptr = NULL; + duk_jmpbuf our_jmpbuf; + duk_idx_t idx_retbase; + duk_int_t retval; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(duk_get_top(thr) >= num_stack_args); /* Caller ensures. */ + + DUK_STATS_INC(thr->heap, stats_safecall_all); + + /* Value stack reserve handling: safe call assumes caller has reserved + * space for nrets (assuming optimal unwind processing). Value stack + * reserve is not stored/restored as for normal calls because a safe + * call conceptually happens in the same activation. + */ + + /* Careful with indices like '-x'; if 'x' is zero, it refers to bottom */ + entry_act = thr->callstack_curr; + entry_valstack_bottom_byteoff = (duk_size_t) ((duk_uint8_t *) thr->valstack_bottom - (duk_uint8_t *) thr->valstack); +#if defined(DUK_USE_ASSERTIONS) + entry_valstack_end_byteoff = (duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack); + entry_callstack_top = thr->callstack_top; + entry_callstack_preventcount = thr->callstack_preventcount; +#endif + entry_call_recursion_depth = thr->heap->call_recursion_depth; + entry_curr_thread = thr->heap->curr_thread; /* may be NULL if first call */ + entry_thread_state = thr->state; + entry_ptr_curr_pc = thr->ptr_curr_pc; /* may be NULL */ + idx_retbase = duk_get_top(thr) - num_stack_args; /* not a valid stack index if num_stack_args == 0 */ + DUK_ASSERT(idx_retbase >= 0); + + DUK_ASSERT((duk_idx_t) (thr->valstack_top - thr->valstack_bottom) >= num_stack_args); /* Caller ensures. */ + DUK_ASSERT((duk_idx_t) (thr->valstack_end - (thr->valstack_bottom + idx_retbase)) >= num_stack_rets); /* Caller ensures. */ + + /* Cannot portably debug print a function pointer, hence 'func' not printed! */ + DUK_DD(DUK_DDPRINT("duk_handle_safe_call: thr=%p, num_stack_args=%ld, num_stack_rets=%ld, " + "valstack_top=%ld, idx_retbase=%ld, rec_depth=%ld/%ld, " + "entry_act=%p, entry_valstack_bottom_byteoff=%ld, entry_call_recursion_depth=%ld, " + "entry_curr_thread=%p, entry_thread_state=%ld", + (void *) thr, + (long) num_stack_args, + (long) num_stack_rets, + (long) duk_get_top(thr), + (long) idx_retbase, + (long) thr->heap->call_recursion_depth, + (long) thr->heap->call_recursion_limit, + (void *) entry_act, + (long) entry_valstack_bottom_byteoff, + (long) entry_call_recursion_depth, + (void *) entry_curr_thread, + (long) entry_thread_state)); + + /* Setjmp catchpoint setup. */ + old_jmpbuf_ptr = thr->heap->lj.jmpbuf_ptr; + thr->heap->lj.jmpbuf_ptr = &our_jmpbuf; + + /* Prevent yields for the duration of the safe call. This only + * matters if the executor makes safe calls to functions that + * yield, this doesn't currently happen. + */ + thr->callstack_preventcount++; + +#if defined(DUK_USE_CPP_EXCEPTIONS) + try { +#else + DUK_ASSERT(thr->heap->lj.jmpbuf_ptr == &our_jmpbuf); + if (DUK_SETJMP(our_jmpbuf.jb) == 0) { + /* Success path. */ +#endif + DUK_DDD(DUK_DDDPRINT("safe_call setjmp catchpoint setup complete")); + + duk__handle_safe_call_inner(thr, + func, + udata, +#if defined(DUK_USE_ASSERTIONS) + entry_valstack_bottom_byteoff, + entry_callstack_top, +#endif + entry_curr_thread, + entry_thread_state, + idx_retbase, + num_stack_rets); + + DUK_STATS_INC(thr->heap, stats_safecall_nothrow); + + /* Either pointer may be NULL (at entry), so don't assert */ + thr->heap->lj.jmpbuf_ptr = old_jmpbuf_ptr; + + /* If calls happen inside the safe call, these are restored by + * whatever calls are made. Reserve cannot decrease. + */ + DUK_ASSERT(thr->callstack_curr == entry_act); + DUK_ASSERT((duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack) >= + entry_valstack_end_byteoff); + + retval = DUK_EXEC_SUCCESS; +#if defined(DUK_USE_CPP_EXCEPTIONS) + } catch (duk_internal_exception &exc) { + DUK_UNREF(exc); +#else + } else { + /* Error path. */ +#endif + DUK_ASSERT((duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack) >= + entry_valstack_end_byteoff); + + DUK_STATS_INC(thr->heap, stats_safecall_throw); + + duk__handle_safe_call_error(thr, + entry_act, +#if defined(DUK_USE_ASSERTIONS) + entry_callstack_top, +#endif + entry_curr_thread, + entry_thread_state, + idx_retbase, + num_stack_rets, + entry_valstack_bottom_byteoff, + old_jmpbuf_ptr); + + retval = DUK_EXEC_ERROR; + } +#if defined(DUK_USE_CPP_EXCEPTIONS) + catch (duk_fatal_exception &exc) { + DUK_D(DUK_DPRINT("rethrow duk_fatal_exception")); + DUK_UNREF(exc); + throw; + } catch (std::exception &exc) { + const char *what = exc.what(); + DUK_ASSERT((duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack) >= + entry_valstack_end_byteoff); + DUK_STATS_INC(thr->heap, stats_safecall_throw); + if (!what) { + what = "unknown"; + } + DUK_D(DUK_DPRINT("unexpected c++ std::exception (perhaps thrown by user code)")); + try { + DUK_ERROR_FMT1(thr, + DUK_ERR_TYPE_ERROR, + "caught invalid c++ std::exception '%s' (perhaps thrown by user code)", + what); + DUK_WO_NORETURN(return 0;); + } catch (duk_internal_exception exc) { + DUK_D(DUK_DPRINT("caught api error thrown from unexpected c++ std::exception")); + DUK_UNREF(exc); + duk__handle_safe_call_error(thr, + entry_act, +#if defined(DUK_USE_ASSERTIONS) + entry_callstack_top, +#endif + entry_curr_thread, + entry_thread_state, + idx_retbase, + num_stack_rets, + entry_valstack_bottom_byteoff, + old_jmpbuf_ptr); + retval = DUK_EXEC_ERROR; + } + } catch (...) { + DUK_D(DUK_DPRINT("unexpected c++ exception (perhaps thrown by user code)")); + DUK_ASSERT((duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack) >= + entry_valstack_end_byteoff); + DUK_STATS_INC(thr->heap, stats_safecall_throw); + try { + DUK_ERROR_TYPE(thr, "caught invalid c++ exception (perhaps thrown by user code)"); + DUK_WO_NORETURN(return 0;); + } catch (duk_internal_exception exc) { + DUK_D(DUK_DPRINT("caught api error thrown from unexpected c++ exception")); + DUK_UNREF(exc); + duk__handle_safe_call_error(thr, + entry_act, +#if defined(DUK_USE_ASSERTIONS) + entry_callstack_top, +#endif + entry_curr_thread, + entry_thread_state, + idx_retbase, + num_stack_rets, + entry_valstack_bottom_byteoff, + old_jmpbuf_ptr); + retval = DUK_EXEC_ERROR; + } + } +#endif + + DUK_ASSERT(thr->heap->lj.jmpbuf_ptr == old_jmpbuf_ptr); /* success/error path both do this */ + + DUK_ASSERT_LJSTATE_UNSET(thr->heap); + + DUK_ASSERT((duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack) >= entry_valstack_end_byteoff); + duk__handle_safe_call_shared_unwind(thr, + idx_retbase, + num_stack_rets, +#if defined(DUK_USE_ASSERTIONS) + entry_callstack_top, +#endif + entry_call_recursion_depth, + entry_curr_thread, + entry_ptr_curr_pc); + + /* Restore preventcount. */ + thr->callstack_preventcount--; + DUK_ASSERT(thr->callstack_preventcount == entry_callstack_preventcount); + + /* Final asserts. */ + DUK_ASSERT(thr->callstack_curr == entry_act); + DUK_ASSERT((duk_size_t) ((duk_uint8_t *) thr->valstack_bottom - (duk_uint8_t *) thr->valstack) == + entry_valstack_bottom_byteoff); + DUK_ASSERT((duk_size_t) ((duk_uint8_t *) thr->valstack_end - (duk_uint8_t *) thr->valstack) >= entry_valstack_end_byteoff); + DUK_ASSERT(thr->callstack_top == entry_callstack_top); + DUK_ASSERT(thr->heap->call_recursion_depth == entry_call_recursion_depth); + DUK_ASSERT(thr->heap->curr_thread == entry_curr_thread); + DUK_ASSERT(thr->state == entry_thread_state); + DUK_ASSERT(thr->ptr_curr_pc == entry_ptr_curr_pc); + DUK_ASSERT(duk_get_top(thr) == idx_retbase + num_stack_rets); + DUK_ASSERT_LJSTATE_UNSET(thr->heap); + + /* Pending side effects. */ + DUK_REFZERO_CHECK_FAST(thr); + + return retval; +} + +/* + * Property-based call (foo.noSuch()) error setup: replace target function + * on stack top with a hidden Symbol tagged non-callable wrapper object + * holding the error. The error gets thrown in call handling at the + * proper spot to follow ECMAScript semantics. + */ + +#if defined(DUK_USE_VERBOSE_ERRORS) +DUK_INTERNAL DUK_NOINLINE DUK_COLD void duk_call_setup_propcall_error(duk_hthread *thr, duk_tval *tv_base, duk_tval *tv_key) { + const char *str_targ, *str_key, *str_base; + duk_idx_t entry_top; + + entry_top = duk_get_top(thr); + + /* [ target ] */ + + /* Must stabilize pointers first. tv_targ is already on stack top. */ + duk_push_tval(thr, tv_base); + duk_push_tval(thr, tv_key); + + DUK_GC_TORTURE(thr->heap); + + duk_push_bare_object(thr); + + /* [ target base key {} ] */ + + /* We only push a wrapped error, replacing the call target (at + * idx_func) with the error to ensure side effects come out + * correctly: + * - Property read + * - Call argument evaluation + * - Callability check and error thrown + * + * A hidden Symbol on the wrapper object pushed above is used by + * call handling to figure out the error is to be thrown as is. + * It is CRITICAL that the hidden Symbol can never occur on a + * user visible object that may get thrown. + */ + +#if defined(DUK_USE_PARANOID_ERRORS) + str_targ = duk_get_type_name(thr, -4); + str_key = duk_get_type_name(thr, -2); + str_base = duk_get_type_name(thr, -3); + duk_push_error_object(thr, + DUK_ERR_TYPE_ERROR | DUK_ERRCODE_FLAG_NOBLAME_FILELINE, + "%s not callable (property %s of %s)", + str_targ, + str_key, + str_base); + duk_xdef_prop_stridx(thr, -2, DUK_STRIDX_INT_TARGET, DUK_PROPDESC_FLAGS_NONE); /* Marker property, reuse _Target. */ + /* [ target base key { _Target: error } ] */ + duk_replace(thr, entry_top - 1); +#else + str_targ = duk_push_string_readable(thr, -4); + str_key = duk_push_string_readable(thr, -3); + str_base = duk_push_string_readable(thr, -5); + duk_push_error_object(thr, + DUK_ERR_TYPE_ERROR | DUK_ERRCODE_FLAG_NOBLAME_FILELINE, + "%s not callable (property %s of %s)", + str_targ, + str_key, + str_base); + /* [ target base key {} str_targ str_key str_base error ] */ + duk_xdef_prop_stridx(thr, -5, DUK_STRIDX_INT_TARGET, DUK_PROPDESC_FLAGS_NONE); /* Marker property, reuse _Target. */ + /* [ target base key { _Target: error } str_targ str_key str_base ] */ + duk_swap(thr, -4, entry_top - 1); + /* [ { _Target: error } base key target str_targ str_key str_base ] */ +#endif + + /* [ { _Target: error } */ + duk_set_top(thr, entry_top); + + /* [ { _Target: error } */ + DUK_ASSERT(!duk_is_callable(thr, -1)); /* Critical so that call handling will throw the error. */ +} +#endif /* DUK_USE_VERBOSE_ERRORS */ + +/* automatic undefs */ +#undef DUK__AUGMENT_CALL_RELAX_COUNT +#undef DUK__CALL_HANDLING_REQUIRE_STACK +#line 1 "duk_js_compiler.c" +/* + * ECMAScript compiler. + * + * Parses an input string and generates a function template result. + * Compilation may happen in multiple contexts (global code, eval + * code, function code). + * + * The parser uses a traditional top-down recursive parsing for the + * statement level, and an operator precedence based top-down approach + * for the expression level. The attempt is to minimize the C stack + * depth. Bytecode is generated directly without an intermediate + * representation (tree), at the cost of needing two (and sometimes + * three) passes over each function. + * + * The top-down recursive parser functions are named "duk__parse_XXX". + * + * Recursion limits are in key functions to prevent arbitrary C recursion: + * function body parsing, statement parsing, and expression parsing. + * + * See doc/compiler.rst for discussion on the design. + * + * A few typing notes: + * + * - duk_regconst_t: signed, highest bit set (< 0) means constant, + * some call sites use -1 for "none" (equivalent to constant 0x7fffffff) + * - PC values: duk_int_t, negative values used as markers + */ + +/* #include duk_internal.h -> already included */ + +/* If highest bit of a register number is set, it refers to a constant instead. + * When interpreted as a signed value, this means const values are always + * negative (when interpreted as two's complement). For example DUK__ISREG_TEMP() + * uses this approach to avoid an explicit DUK__ISREG() check (the condition is + * logically "'x' is a register AND 'x' >= temp_first"). + */ +#define DUK__CONST_MARKER DUK_REGCONST_CONST_MARKER +#define DUK__REMOVECONST(x) ((x) & ~DUK__CONST_MARKER) +#define DUK__ISREG(x) ((x) >= 0) +#define DUK__ISCONST(x) ((x) < 0) +#define DUK__ISREG_TEMP(comp_ctx, x) \ + ((duk_int32_t) (x) >= \ + (duk_int32_t) ((comp_ctx)->curr_func.temp_first)) /* Check for x >= temp_first && x >= 0 by comparing as signed. */ +#define DUK__ISREG_NOTTEMP(comp_ctx, x) \ + ((duk_uint32_t) (x) < \ + (duk_uint32_t) ((comp_ctx)->curr_func.temp_first)) /* Check for x >= 0 && x < temp_first by interpreting as unsigned. */ +#define DUK__GETTEMP(comp_ctx) ((comp_ctx)->curr_func.temp_next) +#define DUK__SETTEMP(comp_ctx, x) ((comp_ctx)->curr_func.temp_next = (x)) /* dangerous: must only lower (temp_max not updated) */ +#define DUK__SETTEMP_CHECKMAX(comp_ctx, x) duk__settemp_checkmax((comp_ctx), (x)) +#define DUK__ALLOCTEMP(comp_ctx) duk__alloctemp((comp_ctx)) +#define DUK__ALLOCTEMPS(comp_ctx, count) duk__alloctemps((comp_ctx), (count)) + +/* Init value set size for array and object literals. */ +#define DUK__MAX_ARRAY_INIT_VALUES 20 +#define DUK__MAX_OBJECT_INIT_PAIRS 10 + +/* XXX: hack, remove when const lookup is not O(n) */ +#define DUK__GETCONST_MAX_CONSTS_CHECK 256 + +/* These limits are based on bytecode limits. Max temps is limited + * by duk_hcompfunc nargs/nregs fields being 16 bits. + */ +#define DUK__MAX_CONSTS DUK_BC_BC_MAX +#define DUK__MAX_FUNCS DUK_BC_BC_MAX +#define DUK__MAX_TEMPS 0xffffL + +/* Initial bytecode size allocation. */ +#if defined(DUK_USE_PREFER_SIZE) +#define DUK__BC_INITIAL_INSTS 16 +#else +#define DUK__BC_INITIAL_INSTS 256 +#endif + +#define DUK__RECURSION_INCREASE(comp_ctx, thr) \ + do { \ + DUK_DDD(DUK_DDDPRINT("RECURSION INCREASE: %s:%ld", (const char *) DUK_FILE_MACRO, (long) DUK_LINE_MACRO)); \ + duk__comp_recursion_increase((comp_ctx)); \ + } while (0) + +#define DUK__RECURSION_DECREASE(comp_ctx, thr) \ + do { \ + DUK_DDD(DUK_DDDPRINT("RECURSION DECREASE: %s:%ld", (const char *) DUK_FILE_MACRO, (long) DUK_LINE_MACRO)); \ + duk__comp_recursion_decrease((comp_ctx)); \ + } while (0) + +/* Value stack slot limits: these are quite approximate right now, and + * because they overlap in control flow, some could be eliminated. + */ +#define DUK__COMPILE_ENTRY_SLOTS 8 +#define DUK__FUNCTION_INIT_REQUIRE_SLOTS 16 +#define DUK__FUNCTION_BODY_REQUIRE_SLOTS 16 +#define DUK__PARSE_STATEMENTS_SLOTS 16 +#define DUK__PARSE_EXPR_SLOTS 16 + +/* Temporary structure used to pass a stack allocated region through + * duk_safe_call(). + */ +typedef struct { + duk_small_uint_t flags; + duk_compiler_ctx comp_ctx_alloc; + duk_lexer_point lex_pt_alloc; +} duk__compiler_stkstate; + +/* + * Prototypes + */ + +/* lexing */ +DUK_LOCAL_DECL void duk__advance_helper(duk_compiler_ctx *comp_ctx, duk_small_int_t expect); +DUK_LOCAL_DECL void duk__advance_expect(duk_compiler_ctx *comp_ctx, duk_small_int_t expect); +DUK_LOCAL_DECL void duk__advance(duk_compiler_ctx *ctx); + +/* function helpers */ +DUK_LOCAL_DECL void duk__init_func_valstack_slots(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL void duk__reset_func_for_pass2(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL void duk__init_varmap_and_prologue_for_pass2(duk_compiler_ctx *comp_ctx, duk_regconst_t *out_stmt_value_reg); +DUK_LOCAL_DECL void duk__convert_to_func_template(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL duk_int_t duk__cleanup_varmap(duk_compiler_ctx *comp_ctx); + +/* code emission */ +DUK_LOCAL_DECL duk_int_t duk__get_current_pc(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL duk_compiler_instr *duk__get_instr_ptr(duk_compiler_ctx *comp_ctx, duk_int_t pc); +DUK_LOCAL_DECL void duk__emit(duk_compiler_ctx *comp_ctx, duk_instr_t ins); +DUK_LOCAL_DECL void duk__emit_op_only(duk_compiler_ctx *comp_ctx, duk_small_uint_t op); +DUK_LOCAL_DECL void duk__emit_a_b_c(duk_compiler_ctx *comp_ctx, + duk_small_uint_t op_flags, + duk_regconst_t a, + duk_regconst_t b, + duk_regconst_t c); +DUK_LOCAL_DECL void duk__emit_a_b(duk_compiler_ctx *comp_ctx, duk_small_uint_t op_flags, duk_regconst_t a, duk_regconst_t b); +DUK_LOCAL_DECL void duk__emit_b_c(duk_compiler_ctx *comp_ctx, duk_small_uint_t op_flags, duk_regconst_t b, duk_regconst_t c); +#if 0 /* unused */ +DUK_LOCAL_DECL void duk__emit_a(duk_compiler_ctx *comp_ctx, duk_small_uint_t op_flags, duk_regconst_t a); +DUK_LOCAL_DECL void duk__emit_b(duk_compiler_ctx *comp_ctx, duk_small_uint_t op_flags, duk_regconst_t b); +#endif +DUK_LOCAL_DECL void duk__emit_a_bc(duk_compiler_ctx *comp_ctx, duk_small_uint_t op_flags, duk_regconst_t a, duk_regconst_t bc); +DUK_LOCAL_DECL void duk__emit_bc(duk_compiler_ctx *comp_ctx, duk_small_uint_t op, duk_regconst_t bc); +DUK_LOCAL_DECL void duk__emit_abc(duk_compiler_ctx *comp_ctx, duk_small_uint_t op, duk_regconst_t abc); +DUK_LOCAL_DECL void duk__emit_load_int32(duk_compiler_ctx *comp_ctx, duk_regconst_t reg, duk_int32_t val); +DUK_LOCAL_DECL void duk__emit_load_int32_noshuffle(duk_compiler_ctx *comp_ctx, duk_regconst_t reg, duk_int32_t val); +DUK_LOCAL_DECL void duk__emit_jump(duk_compiler_ctx *comp_ctx, duk_int_t target_pc); +DUK_LOCAL_DECL duk_int_t duk__emit_jump_empty(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL void duk__insert_jump_entry(duk_compiler_ctx *comp_ctx, duk_int_t jump_pc); +DUK_LOCAL_DECL void duk__patch_jump(duk_compiler_ctx *comp_ctx, duk_int_t jump_pc, duk_int_t target_pc); +DUK_LOCAL_DECL void duk__patch_jump_here(duk_compiler_ctx *comp_ctx, duk_int_t jump_pc); +DUK_LOCAL_DECL void duk__patch_trycatch(duk_compiler_ctx *comp_ctx, + duk_int_t ldconst_pc, + duk_int_t trycatch_pc, + duk_regconst_t reg_catch, + duk_regconst_t const_varname, + duk_small_uint_t flags); +DUK_LOCAL_DECL void duk__emit_if_false_skip(duk_compiler_ctx *comp_ctx, duk_regconst_t regconst); +DUK_LOCAL_DECL void duk__emit_if_true_skip(duk_compiler_ctx *comp_ctx, duk_regconst_t regconst); +DUK_LOCAL_DECL void duk__emit_invalid(duk_compiler_ctx *comp_ctx); + +/* ivalue/ispec helpers */ +DUK_LOCAL_DECL void duk__ivalue_regconst(duk_ivalue *x, duk_regconst_t regconst); +DUK_LOCAL_DECL void duk__ivalue_plain_fromstack(duk_compiler_ctx *comp_ctx, duk_ivalue *x); +DUK_LOCAL_DECL void duk__ivalue_var_fromstack(duk_compiler_ctx *comp_ctx, duk_ivalue *x); +DUK_LOCAL_DECL void duk__ivalue_var_hstring(duk_compiler_ctx *comp_ctx, duk_ivalue *x, duk_hstring *h); +DUK_LOCAL_DECL void duk__copy_ispec(duk_compiler_ctx *comp_ctx, duk_ispec *src, duk_ispec *dst); +DUK_LOCAL_DECL void duk__copy_ivalue(duk_compiler_ctx *comp_ctx, duk_ivalue *src, duk_ivalue *dst); +DUK_LOCAL_DECL duk_regconst_t duk__alloctemps(duk_compiler_ctx *comp_ctx, duk_small_int_t num); +DUK_LOCAL_DECL duk_regconst_t duk__alloctemp(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL void duk__settemp_checkmax(duk_compiler_ctx *comp_ctx, duk_regconst_t temp_next); +DUK_LOCAL_DECL duk_regconst_t duk__getconst(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL +duk_regconst_t duk__ispec_toregconst_raw(duk_compiler_ctx *comp_ctx, + duk_ispec *x, + duk_regconst_t forced_reg, + duk_small_uint_t flags); +DUK_LOCAL_DECL void duk__ispec_toforcedreg(duk_compiler_ctx *comp_ctx, duk_ispec *x, duk_regconst_t forced_reg); +DUK_LOCAL_DECL void duk__ivalue_toplain_raw(duk_compiler_ctx *comp_ctx, duk_ivalue *x, duk_regconst_t forced_reg); +DUK_LOCAL_DECL void duk__ivalue_toplain(duk_compiler_ctx *comp_ctx, duk_ivalue *x); +DUK_LOCAL_DECL void duk__ivalue_toplain_ignore(duk_compiler_ctx *comp_ctx, duk_ivalue *x); +DUK_LOCAL_DECL +duk_regconst_t duk__ivalue_toregconst_raw(duk_compiler_ctx *comp_ctx, + duk_ivalue *x, + duk_regconst_t forced_reg, + duk_small_uint_t flags); +DUK_LOCAL_DECL duk_regconst_t duk__ivalue_toreg(duk_compiler_ctx *comp_ctx, duk_ivalue *x); +#if 0 /* unused */ +DUK_LOCAL_DECL duk_regconst_t duk__ivalue_totemp(duk_compiler_ctx *comp_ctx, duk_ivalue *x); +#endif +DUK_LOCAL_DECL void duk__ivalue_toforcedreg(duk_compiler_ctx *comp_ctx, duk_ivalue *x, duk_int_t forced_reg); +DUK_LOCAL_DECL duk_regconst_t duk__ivalue_toregconst(duk_compiler_ctx *comp_ctx, duk_ivalue *x); +DUK_LOCAL_DECL duk_regconst_t duk__ivalue_totempconst(duk_compiler_ctx *comp_ctx, duk_ivalue *x); + +/* identifier handling */ +DUK_LOCAL_DECL duk_regconst_t duk__lookup_active_register_binding(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL duk_bool_t duk__lookup_lhs(duk_compiler_ctx *ctx, duk_regconst_t *out_reg_varbind, duk_regconst_t *out_rc_varname); + +/* label handling */ +DUK_LOCAL_DECL void duk__add_label(duk_compiler_ctx *comp_ctx, duk_hstring *h_label, duk_int_t pc_label, duk_int_t label_id); +DUK_LOCAL_DECL void duk__update_label_flags(duk_compiler_ctx *comp_ctx, duk_int_t label_id, duk_small_uint_t flags); +DUK_LOCAL_DECL void duk__lookup_active_label(duk_compiler_ctx *comp_ctx, + duk_hstring *h_label, + duk_bool_t is_break, + duk_int_t *out_label_id, + duk_int_t *out_label_catch_depth, + duk_int_t *out_label_pc, + duk_bool_t *out_is_closest); +DUK_LOCAL_DECL void duk__reset_labels_to_length(duk_compiler_ctx *comp_ctx, duk_size_t len); + +/* top-down expression parser */ +DUK_LOCAL_DECL void duk__expr_nud(duk_compiler_ctx *comp_ctx, duk_ivalue *res); +DUK_LOCAL_DECL void duk__expr_led(duk_compiler_ctx *comp_ctx, duk_ivalue *left, duk_ivalue *res); +DUK_LOCAL_DECL duk_small_uint_t duk__expr_lbp(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL duk_bool_t duk__expr_is_empty(duk_compiler_ctx *comp_ctx); + +/* exprtop is the top level variant which resets nud/led counts */ +DUK_LOCAL_DECL void duk__expr(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +DUK_LOCAL_DECL void duk__exprtop(duk_compiler_ctx *ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); + +/* convenience helpers */ +#if 0 /* unused */ +DUK_LOCAL_DECL duk_regconst_t duk__expr_toreg(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +#endif +#if 0 /* unused */ +DUK_LOCAL_DECL duk_regconst_t duk__expr_totemp(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +#endif +DUK_LOCAL_DECL void duk__expr_toforcedreg(duk_compiler_ctx *comp_ctx, + duk_ivalue *res, + duk_small_uint_t rbp_flags, + duk_regconst_t forced_reg); +DUK_LOCAL_DECL duk_regconst_t duk__expr_toregconst(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +#if 0 /* unused */ +DUK_LOCAL_DECL duk_regconst_t duk__expr_totempconst(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +#endif +DUK_LOCAL_DECL void duk__expr_toplain(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +DUK_LOCAL_DECL void duk__expr_toplain_ignore(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +DUK_LOCAL_DECL duk_regconst_t duk__exprtop_toreg(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +#if 0 /* unused */ +DUK_LOCAL_DECL duk_regconst_t duk__exprtop_totemp(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +#endif +DUK_LOCAL_DECL void duk__exprtop_toforcedreg(duk_compiler_ctx *comp_ctx, + duk_ivalue *res, + duk_small_uint_t rbp_flags, + duk_regconst_t forced_reg); +DUK_LOCAL_DECL duk_regconst_t duk__exprtop_toregconst(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +#if 0 /* unused */ +DUK_LOCAL_DECL void duk__exprtop_toplain_ignore(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags); +#endif + +/* expression parsing helpers */ +DUK_LOCAL_DECL duk_int_t duk__parse_arguments(duk_compiler_ctx *comp_ctx, duk_ivalue *res); +DUK_LOCAL_DECL void duk__nud_array_literal(duk_compiler_ctx *comp_ctx, duk_ivalue *res); +DUK_LOCAL_DECL void duk__nud_object_literal(duk_compiler_ctx *comp_ctx, duk_ivalue *res); + +/* statement parsing */ +DUK_LOCAL_DECL void duk__parse_var_decl(duk_compiler_ctx *comp_ctx, + duk_ivalue *res, + duk_small_uint_t expr_flags, + duk_regconst_t *out_reg_varbind, + duk_regconst_t *out_rc_varname); +DUK_LOCAL_DECL void duk__parse_var_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t expr_flags); +DUK_LOCAL_DECL void duk__parse_for_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_int_t pc_label_site); +DUK_LOCAL_DECL void duk__parse_switch_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_int_t pc_label_site); +DUK_LOCAL_DECL void duk__parse_if_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res); +DUK_LOCAL_DECL void duk__parse_do_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_int_t pc_label_site); +DUK_LOCAL_DECL void duk__parse_while_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_int_t pc_label_site); +DUK_LOCAL_DECL void duk__parse_break_or_continue_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res); +DUK_LOCAL_DECL void duk__parse_return_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res); +DUK_LOCAL_DECL void duk__parse_throw_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res); +DUK_LOCAL_DECL void duk__parse_try_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res); +DUK_LOCAL_DECL void duk__parse_with_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res); +DUK_LOCAL_DECL void duk__parse_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_bool_t allow_source_elem); +DUK_LOCAL_DECL duk_int_t duk__stmt_label_site(duk_compiler_ctx *comp_ctx, duk_int_t label_id); +DUK_LOCAL_DECL void duk__parse_stmts(duk_compiler_ctx *comp_ctx, + duk_bool_t allow_source_elem, + duk_bool_t expect_eof, + duk_bool_t regexp_after); + +DUK_LOCAL_DECL void duk__parse_func_body(duk_compiler_ctx *comp_ctx, + duk_bool_t expect_eof, + duk_bool_t implicit_return_value, + duk_bool_t regexp_after, + duk_small_int_t expect_token); +DUK_LOCAL_DECL void duk__parse_func_formals(duk_compiler_ctx *comp_ctx); +DUK_LOCAL_DECL void duk__parse_func_like_raw(duk_compiler_ctx *comp_ctx, duk_small_uint_t flags); +DUK_LOCAL_DECL duk_int_t duk__parse_func_like_fnum(duk_compiler_ctx *comp_ctx, duk_small_uint_t flags); + +#define DUK__FUNC_FLAG_DECL (1 << 0) /* Parsing a function declaration. */ +#define DUK__FUNC_FLAG_GETSET (1 << 1) /* Parsing an object literal getter/setter. */ +#define DUK__FUNC_FLAG_METDEF (1 << 2) /* Parsing an object literal method definition shorthand. */ +#define DUK__FUNC_FLAG_PUSHNAME_PASS1 (1 << 3) /* Push function name when creating template (first pass only). */ +#define DUK__FUNC_FLAG_USE_PREVTOKEN (1 << 4) /* Use prev_token to start function parsing (workaround for object literal). */ + +/* + * Parser control values for tokens. The token table is ordered by the + * DUK_TOK_XXX defines. + * + * The binding powers are for lbp() use (i.e. for use in led() context). + * Binding powers are positive for typing convenience, and bits at the + * top should be reserved for flags. Binding power step must be higher + * than 1 so that binding power "lbp - 1" can be used for right associative + * operators. Currently a step of 2 is used (which frees one more bit for + * flags). + */ + +/* XXX: actually single step levels would work just fine, clean up */ + +/* binding power "levels" (see doc/compiler.rst) */ +#define DUK__BP_INVALID 0 /* always terminates led() */ +#define DUK__BP_EOF 2 +#define DUK__BP_CLOSING 4 /* token closes expression, e.g. ')', ']' */ +#define DUK__BP_FOR_EXPR DUK__BP_CLOSING /* bp to use when parsing a top level Expression */ +#define DUK__BP_COMMA 6 +#define DUK__BP_ASSIGNMENT 8 +#define DUK__BP_CONDITIONAL 10 +#define DUK__BP_LOR 12 +#define DUK__BP_LAND 14 +#define DUK__BP_BOR 16 +#define DUK__BP_BXOR 18 +#define DUK__BP_BAND 20 +#define DUK__BP_EQUALITY 22 +#define DUK__BP_RELATIONAL 24 +#define DUK__BP_SHIFT 26 +#define DUK__BP_ADDITIVE 28 +#define DUK__BP_MULTIPLICATIVE 30 +#define DUK__BP_EXPONENTIATION 32 +#define DUK__BP_POSTFIX 34 +#define DUK__BP_CALL 36 +#define DUK__BP_MEMBER 38 + +#define DUK__TOKEN_LBP_BP_MASK 0x1f +#define DUK__TOKEN_LBP_FLAG_NO_REGEXP (1 << 5) /* regexp literal must not follow this token */ +#define DUK__TOKEN_LBP_FLAG_TERMINATES (1 << 6) /* terminates expression; e.g. post-increment/-decrement */ +#define DUK__TOKEN_LBP_FLAG_UNUSED (1 << 7) /* unused */ + +#define DUK__TOKEN_LBP_GET_BP(x) ((duk_small_uint_t) (((x) &DUK__TOKEN_LBP_BP_MASK) * 2)) + +#define DUK__MK_LBP(bp) ((bp) >> 1) /* bp is assumed to be even */ +#define DUK__MK_LBP_FLAGS(bp, flags) (((bp) >> 1) | (flags)) + +DUK_LOCAL const duk_uint8_t duk__token_lbp[] = { + DUK__MK_LBP(DUK__BP_EOF), /* DUK_TOK_EOF */ + DUK__MK_LBP_FLAGS(DUK__BP_INVALID, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_IDENTIFIER */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_BREAK */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_CASE */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_CATCH */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_CONTINUE */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_DEBUGGER */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_DEFAULT */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_DELETE */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_DO */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_ELSE */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_FINALLY */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_FOR */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_FUNCTION */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_IF */ + DUK__MK_LBP(DUK__BP_RELATIONAL), /* DUK_TOK_IN */ + DUK__MK_LBP(DUK__BP_RELATIONAL), /* DUK_TOK_INSTANCEOF */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_NEW */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_RETURN */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_SWITCH */ + DUK__MK_LBP_FLAGS(DUK__BP_INVALID, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_THIS */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_THROW */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_TRY */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_TYPEOF */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_VAR */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_CONST */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_VOID */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_WHILE */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_WITH */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_CLASS */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_ENUM */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_EXPORT */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_EXTENDS */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_IMPORT */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_SUPER */ + DUK__MK_LBP_FLAGS(DUK__BP_INVALID, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_NULL */ + DUK__MK_LBP_FLAGS(DUK__BP_INVALID, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_TRUE */ + DUK__MK_LBP_FLAGS(DUK__BP_INVALID, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_FALSE */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_GET */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_SET */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_IMPLEMENTS */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_INTERFACE */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_LET */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_PACKAGE */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_PRIVATE */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_PROTECTED */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_PUBLIC */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_STATIC */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_YIELD */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_LCURLY */ + DUK__MK_LBP_FLAGS(DUK__BP_INVALID, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_RCURLY */ + DUK__MK_LBP(DUK__BP_MEMBER), /* DUK_TOK_LBRACKET */ + DUK__MK_LBP_FLAGS(DUK__BP_CLOSING, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_RBRACKET */ + DUK__MK_LBP(DUK__BP_CALL), /* DUK_TOK_LPAREN */ + DUK__MK_LBP_FLAGS(DUK__BP_CLOSING, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_RPAREN */ + DUK__MK_LBP(DUK__BP_MEMBER), /* DUK_TOK_PERIOD */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_SEMICOLON */ + DUK__MK_LBP(DUK__BP_COMMA), /* DUK_TOK_COMMA */ + DUK__MK_LBP(DUK__BP_RELATIONAL), /* DUK_TOK_LT */ + DUK__MK_LBP(DUK__BP_RELATIONAL), /* DUK_TOK_GT */ + DUK__MK_LBP(DUK__BP_RELATIONAL), /* DUK_TOK_LE */ + DUK__MK_LBP(DUK__BP_RELATIONAL), /* DUK_TOK_GE */ + DUK__MK_LBP(DUK__BP_EQUALITY), /* DUK_TOK_EQ */ + DUK__MK_LBP(DUK__BP_EQUALITY), /* DUK_TOK_NEQ */ + DUK__MK_LBP(DUK__BP_EQUALITY), /* DUK_TOK_SEQ */ + DUK__MK_LBP(DUK__BP_EQUALITY), /* DUK_TOK_SNEQ */ + DUK__MK_LBP(DUK__BP_ADDITIVE), /* DUK_TOK_ADD */ + DUK__MK_LBP(DUK__BP_ADDITIVE), /* DUK_TOK_SUB */ + DUK__MK_LBP(DUK__BP_MULTIPLICATIVE), /* DUK_TOK_MUL */ + DUK__MK_LBP(DUK__BP_MULTIPLICATIVE), /* DUK_TOK_DIV */ + DUK__MK_LBP(DUK__BP_MULTIPLICATIVE), /* DUK_TOK_MOD */ + DUK__MK_LBP(DUK__BP_EXPONENTIATION), /* DUK_TOK_EXP */ + DUK__MK_LBP_FLAGS(DUK__BP_POSTFIX, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_INCREMENT */ + DUK__MK_LBP_FLAGS(DUK__BP_POSTFIX, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_DECREMENT */ + DUK__MK_LBP(DUK__BP_SHIFT), /* DUK_TOK_ALSHIFT */ + DUK__MK_LBP(DUK__BP_SHIFT), /* DUK_TOK_ARSHIFT */ + DUK__MK_LBP(DUK__BP_SHIFT), /* DUK_TOK_RSHIFT */ + DUK__MK_LBP(DUK__BP_BAND), /* DUK_TOK_BAND */ + DUK__MK_LBP(DUK__BP_BOR), /* DUK_TOK_BOR */ + DUK__MK_LBP(DUK__BP_BXOR), /* DUK_TOK_BXOR */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_LNOT */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_BNOT */ + DUK__MK_LBP(DUK__BP_LAND), /* DUK_TOK_LAND */ + DUK__MK_LBP(DUK__BP_LOR), /* DUK_TOK_LOR */ + DUK__MK_LBP(DUK__BP_CONDITIONAL), /* DUK_TOK_QUESTION */ + DUK__MK_LBP(DUK__BP_INVALID), /* DUK_TOK_COLON */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_EQUALSIGN */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_ADD_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_SUB_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_MUL_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_DIV_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_MOD_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_EXP_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_ALSHIFT_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_ARSHIFT_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_RSHIFT_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_BAND_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_BOR_EQ */ + DUK__MK_LBP(DUK__BP_ASSIGNMENT), /* DUK_TOK_BXOR_EQ */ + DUK__MK_LBP_FLAGS(DUK__BP_INVALID, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_NUMBER */ + DUK__MK_LBP_FLAGS(DUK__BP_INVALID, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_STRING */ + DUK__MK_LBP_FLAGS(DUK__BP_INVALID, DUK__TOKEN_LBP_FLAG_NO_REGEXP), /* DUK_TOK_REGEXP */ +}; + +/* + * Misc helpers + */ + +DUK_LOCAL void duk__comp_recursion_increase(duk_compiler_ctx *comp_ctx) { + DUK_ASSERT(comp_ctx != NULL); + DUK_ASSERT(comp_ctx->recursion_depth >= 0); + if (comp_ctx->recursion_depth >= comp_ctx->recursion_limit) { + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_COMPILER_RECURSION_LIMIT); + DUK_WO_NORETURN(return;); + } + comp_ctx->recursion_depth++; +} + +DUK_LOCAL void duk__comp_recursion_decrease(duk_compiler_ctx *comp_ctx) { + DUK_ASSERT(comp_ctx != NULL); + DUK_ASSERT(comp_ctx->recursion_depth > 0); + comp_ctx->recursion_depth--; +} + +DUK_LOCAL duk_bool_t duk__hstring_is_eval_or_arguments(duk_compiler_ctx *comp_ctx, duk_hstring *h) { + DUK_UNREF(comp_ctx); + DUK_ASSERT(h != NULL); + return DUK_HSTRING_HAS_EVAL_OR_ARGUMENTS(h); +} + +DUK_LOCAL duk_bool_t duk__hstring_is_eval_or_arguments_in_strict_mode(duk_compiler_ctx *comp_ctx, duk_hstring *h) { + DUK_ASSERT(h != NULL); + return (comp_ctx->curr_func.is_strict && DUK_HSTRING_HAS_EVAL_OR_ARGUMENTS(h)); +} + +/* + * Parser duk__advance() token eating functions + */ + +/* XXX: valstack handling is awkward. Add a valstack helper which + * avoids dup():ing; valstack_copy(src, dst)? + */ + +DUK_LOCAL void duk__advance_helper(duk_compiler_ctx *comp_ctx, duk_small_int_t expect) { + duk_hthread *thr = comp_ctx->thr; + duk_bool_t regexp; + + DUK_ASSERT_DISABLE(comp_ctx->curr_token.t >= 0); /* unsigned */ + DUK_ASSERT(comp_ctx->curr_token.t <= DUK_TOK_MAXVAL); /* MAXVAL is inclusive */ + + /* + * Use current token to decide whether a RegExp can follow. + * + * We can use either 't' or 't_nores'; the latter would not + * recognize keywords. Some keywords can be followed by a + * RegExp (e.g. "return"), so using 't' is better. This is + * not trivial, see doc/compiler.rst. + */ + + regexp = 1; + if (duk__token_lbp[comp_ctx->curr_token.t] & DUK__TOKEN_LBP_FLAG_NO_REGEXP) { + regexp = 0; + } + if (comp_ctx->curr_func.reject_regexp_in_adv) { + comp_ctx->curr_func.reject_regexp_in_adv = 0; + regexp = 0; + } + if (comp_ctx->curr_func.allow_regexp_in_adv) { + comp_ctx->curr_func.allow_regexp_in_adv = 0; + regexp = 1; + } + + if (expect >= 0 && comp_ctx->curr_token.t != (duk_small_uint_t) expect) { + DUK_D(DUK_DPRINT("parse error: expect=%ld, got=%ld", (long) expect, (long) comp_ctx->curr_token.t)); + DUK_ERROR_SYNTAX(thr, DUK_STR_PARSE_ERROR); + DUK_WO_NORETURN(return;); + } + + /* make current token the previous; need to fiddle with valstack "backing store" */ + duk_memcpy(&comp_ctx->prev_token, &comp_ctx->curr_token, sizeof(duk_token)); + duk_copy(thr, comp_ctx->tok11_idx, comp_ctx->tok21_idx); + duk_copy(thr, comp_ctx->tok12_idx, comp_ctx->tok22_idx); + + /* parse new token */ + duk_lexer_parse_js_input_element(&comp_ctx->lex, &comp_ctx->curr_token, comp_ctx->curr_func.is_strict, regexp); + + DUK_DDD(DUK_DDDPRINT("advance: curr: tok=%ld/%ld,%ld,term=%ld,%!T,%!T " + "prev: tok=%ld/%ld,%ld,term=%ld,%!T,%!T", + (long) comp_ctx->curr_token.t, + (long) comp_ctx->curr_token.t_nores, + (long) comp_ctx->curr_token.start_line, + (long) comp_ctx->curr_token.lineterm, + (duk_tval *) duk_get_tval(thr, comp_ctx->tok11_idx), + (duk_tval *) duk_get_tval(thr, comp_ctx->tok12_idx), + (long) comp_ctx->prev_token.t, + (long) comp_ctx->prev_token.t_nores, + (long) comp_ctx->prev_token.start_line, + (long) comp_ctx->prev_token.lineterm, + (duk_tval *) duk_get_tval(thr, comp_ctx->tok21_idx), + (duk_tval *) duk_get_tval(thr, comp_ctx->tok22_idx))); +} + +/* advance, expecting current token to be a specific token; parse next token in regexp context */ +DUK_LOCAL void duk__advance_expect(duk_compiler_ctx *comp_ctx, duk_small_int_t expect) { + duk__advance_helper(comp_ctx, expect); +} + +/* advance, whatever the current token is; parse next token in regexp context */ +DUK_LOCAL void duk__advance(duk_compiler_ctx *comp_ctx) { + duk__advance_helper(comp_ctx, -1); +} + +/* + * Helpers for duk_compiler_func. + */ + +/* init function state: inits valstack allocations */ +DUK_LOCAL void duk__init_func_valstack_slots(duk_compiler_ctx *comp_ctx) { + duk_compiler_func *func = &comp_ctx->curr_func; + duk_hthread *thr = comp_ctx->thr; + duk_idx_t entry_top; + + entry_top = duk_get_top(thr); + + duk_memzero(func, sizeof(*func)); /* intentional overlap with earlier memzero */ +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + func->h_name = NULL; + func->h_consts = NULL; + func->h_funcs = NULL; + func->h_decls = NULL; + func->h_labelnames = NULL; + func->h_labelinfos = NULL; + func->h_argnames = NULL; + func->h_varmap = NULL; +#endif + + duk_require_stack(thr, DUK__FUNCTION_INIT_REQUIRE_SLOTS); + + DUK_BW_INIT_PUSHBUF(thr, &func->bw_code, DUK__BC_INITIAL_INSTS * sizeof(duk_compiler_instr)); + /* code_idx = entry_top + 0 */ + + duk_push_bare_array(thr); + func->consts_idx = entry_top + 1; + func->h_consts = DUK_GET_HOBJECT_POSIDX(thr, entry_top + 1); + DUK_ASSERT(func->h_consts != NULL); + + duk_push_bare_array(thr); + func->funcs_idx = entry_top + 2; + func->h_funcs = DUK_GET_HOBJECT_POSIDX(thr, entry_top + 2); + DUK_ASSERT(func->h_funcs != NULL); + DUK_ASSERT(func->fnum_next == 0); + + duk_push_bare_array(thr); + func->decls_idx = entry_top + 3; + func->h_decls = DUK_GET_HOBJECT_POSIDX(thr, entry_top + 3); + DUK_ASSERT(func->h_decls != NULL); + + duk_push_bare_array(thr); + func->labelnames_idx = entry_top + 4; + func->h_labelnames = DUK_GET_HOBJECT_POSIDX(thr, entry_top + 4); + DUK_ASSERT(func->h_labelnames != NULL); + + duk_push_dynamic_buffer(thr, 0); + func->labelinfos_idx = entry_top + 5; + func->h_labelinfos = (duk_hbuffer_dynamic *) duk_known_hbuffer(thr, entry_top + 5); + DUK_ASSERT(func->h_labelinfos != NULL); + DUK_ASSERT(DUK_HBUFFER_HAS_DYNAMIC(func->h_labelinfos) && !DUK_HBUFFER_HAS_EXTERNAL(func->h_labelinfos)); + + duk_push_bare_array(thr); + func->argnames_idx = entry_top + 6; + func->h_argnames = DUK_GET_HOBJECT_POSIDX(thr, entry_top + 6); + DUK_ASSERT(func->h_argnames != NULL); + + duk_push_bare_object(thr); + func->varmap_idx = entry_top + 7; + func->h_varmap = DUK_GET_HOBJECT_POSIDX(thr, entry_top + 7); + DUK_ASSERT(func->h_varmap != NULL); +} + +/* reset function state (prepare for pass 2) */ +DUK_LOCAL void duk__reset_func_for_pass2(duk_compiler_ctx *comp_ctx) { + duk_compiler_func *func = &comp_ctx->curr_func; + duk_hthread *thr = comp_ctx->thr; + + /* reset bytecode buffer but keep current size; pass 2 will + * require same amount or more. + */ + DUK_BW_RESET_SIZE(thr, &func->bw_code); + + duk_set_length(thr, func->consts_idx, 0); + /* keep func->h_funcs; inner functions are not reparsed to avoid O(depth^2) parsing */ + func->fnum_next = 0; + /* duk_set_length(thr, func->funcs_idx, 0); */ + duk_set_length(thr, func->labelnames_idx, 0); + duk_hbuffer_reset(thr, func->h_labelinfos); + /* keep func->h_argnames; it is fixed for all passes */ + + /* truncated in case pass 3 needed */ + duk_push_bare_object(thr); + duk_replace(thr, func->varmap_idx); + func->h_varmap = DUK_GET_HOBJECT_POSIDX(thr, func->varmap_idx); + DUK_ASSERT(func->h_varmap != NULL); +} + +/* cleanup varmap from any null entries, compact it, etc; returns number + * of final entries after cleanup. + */ +DUK_LOCAL duk_int_t duk__cleanup_varmap(duk_compiler_ctx *comp_ctx) { + duk_hthread *thr = comp_ctx->thr; + duk_hobject *h_varmap; + duk_hstring *h_key; + duk_tval *tv; + duk_uint32_t i, e_next; + duk_int_t ret; + + /* [ ... varmap ] */ + + h_varmap = DUK_GET_HOBJECT_NEGIDX(thr, -1); + DUK_ASSERT(h_varmap != NULL); + + ret = 0; + e_next = DUK_HOBJECT_GET_ENEXT(h_varmap); + for (i = 0; i < e_next; i++) { + h_key = DUK_HOBJECT_E_GET_KEY(thr->heap, h_varmap, i); + if (!h_key) { + continue; + } + + DUK_ASSERT(!DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, h_varmap, i)); + + /* The entries can either be register numbers or 'null' values. + * Thus, no need to DECREF them and get side effects. DECREF'ing + * the keys (strings) can cause memory to be freed but no side + * effects as strings don't have finalizers. This is why we can + * rely on the object properties not changing from underneath us. + */ + + tv = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, h_varmap, i); + if (!DUK_TVAL_IS_NUMBER(tv)) { + DUK_ASSERT(!DUK_TVAL_IS_HEAP_ALLOCATED(tv)); + DUK_HOBJECT_E_SET_KEY(thr->heap, h_varmap, i, NULL); + DUK_HSTRING_DECREF(thr, h_key); + /* when key is NULL, value is garbage so no need to set */ + } else { + ret++; + } + } + + duk_compact_m1(thr); + + return ret; +} + +/* Convert duk_compiler_func into a function template, leaving the result + * on top of stack. + */ +/* XXX: awkward and bloated asm -- use faster internal accesses */ +DUK_LOCAL void duk__convert_to_func_template(duk_compiler_ctx *comp_ctx) { + duk_compiler_func *func = &comp_ctx->curr_func; + duk_hthread *thr = comp_ctx->thr; + duk_hcompfunc *h_res; + duk_hbuffer_fixed *h_data; + duk_size_t consts_count; + duk_size_t funcs_count; + duk_size_t code_count; + duk_size_t code_size; + duk_size_t data_size; + duk_size_t i; + duk_tval *p_const; + duk_hobject **p_func; + duk_instr_t *p_instr; + duk_compiler_instr *q_instr; + duk_tval *tv; + duk_bool_t keep_varmap; + duk_bool_t keep_formals; +#if !defined(DUK_USE_DEBUGGER_SUPPORT) + duk_size_t formals_length; +#endif + + DUK_DDD(DUK_DDDPRINT("converting duk_compiler_func to function/template")); + + /* + * Push result object and init its flags + */ + + /* Valstack should suffice here, required on function valstack init */ + + h_res = duk_push_hcompfunc(thr); + DUK_ASSERT(h_res != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) h_res) == thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, (duk_hobject *) h_res, NULL); /* Function templates are "bare objects". */ + + if (func->is_function) { + DUK_DDD(DUK_DDDPRINT("function -> set NEWENV")); + DUK_HOBJECT_SET_NEWENV((duk_hobject *) h_res); + + if (!func->is_arguments_shadowed) { + /* arguments object would be accessible; note that shadowing + * bindings are arguments or function declarations, neither + * of which are deletable, so this is safe. + */ + + if (func->id_access_arguments || func->may_direct_eval) { + DUK_DDD(DUK_DDDPRINT("function may access 'arguments' object directly or " + "indirectly -> set CREATEARGS")); + DUK_HOBJECT_SET_CREATEARGS((duk_hobject *) h_res); + } + } + } else if (func->is_eval && func->is_strict) { + DUK_DDD(DUK_DDDPRINT("strict eval code -> set NEWENV")); + DUK_HOBJECT_SET_NEWENV((duk_hobject *) h_res); + } else { + /* non-strict eval: env is caller's env or global env (direct vs. indirect call) + * global code: env is is global env + */ + DUK_DDD(DUK_DDDPRINT("non-strict eval code or global code -> no NEWENV")); + DUK_ASSERT(!DUK_HOBJECT_HAS_NEWENV((duk_hobject *) h_res)); + } + +#if defined(DUK_USE_FUNC_NAME_PROPERTY) + if (func->is_function && func->is_namebinding && func->h_name != NULL) { + /* Object literal set/get functions have a name (property + * name) but must not have a lexical name binding, see + * test-bug-getset-func-name.js. + */ + DUK_DDD(DUK_DDDPRINT("function expression with a name -> set NAMEBINDING")); + DUK_HOBJECT_SET_NAMEBINDING((duk_hobject *) h_res); + } +#endif + + if (func->is_strict) { + DUK_DDD(DUK_DDDPRINT("function is strict -> set STRICT")); + DUK_HOBJECT_SET_STRICT((duk_hobject *) h_res); + } + + if (func->is_notail) { + DUK_DDD(DUK_DDDPRINT("function is notail -> set NOTAIL")); + DUK_HOBJECT_SET_NOTAIL((duk_hobject *) h_res); + } + + if (func->is_constructable) { + DUK_DDD(DUK_DDDPRINT("function is constructable -> set CONSTRUCTABLE")); + DUK_HOBJECT_SET_CONSTRUCTABLE((duk_hobject *) h_res); + } + + /* + * Build function fixed size 'data' buffer, which contains bytecode, + * constants, and inner function references. + * + * During the building phase 'data' is reachable but incomplete. + * Only incref's occur during building (no refzero or GC happens), + * so the building process is atomic. + */ + + consts_count = duk_hobject_get_length(thr, func->h_consts); + funcs_count = duk_hobject_get_length(thr, func->h_funcs) / 3; + code_count = DUK_BW_GET_SIZE(thr, &func->bw_code) / sizeof(duk_compiler_instr); + code_size = code_count * sizeof(duk_instr_t); + + data_size = consts_count * sizeof(duk_tval) + funcs_count * sizeof(duk_hobject *) + code_size; + + DUK_DDD(DUK_DDDPRINT("consts_count=%ld, funcs_count=%ld, code_size=%ld -> " + "data_size=%ld*%ld + %ld*%ld + %ld = %ld", + (long) consts_count, + (long) funcs_count, + (long) code_size, + (long) consts_count, + (long) sizeof(duk_tval), + (long) funcs_count, + (long) sizeof(duk_hobject *), + (long) code_size, + (long) data_size)); + + duk_push_fixed_buffer_nozero(thr, data_size); + h_data = (duk_hbuffer_fixed *) (void *) duk_known_hbuffer(thr, -1); + + DUK_HCOMPFUNC_SET_DATA(thr->heap, h_res, (duk_hbuffer *) h_data); + DUK_HEAPHDR_INCREF(thr, h_data); + + p_const = (duk_tval *) (void *) DUK_HBUFFER_FIXED_GET_DATA_PTR(thr->heap, h_data); + for (i = 0; i < consts_count; i++) { + DUK_ASSERT(i <= DUK_UARRIDX_MAX); /* const limits */ + tv = duk_hobject_find_array_entry_tval_ptr(thr->heap, func->h_consts, (duk_uarridx_t) i); + DUK_ASSERT(tv != NULL); + DUK_TVAL_SET_TVAL(p_const, tv); + p_const++; + DUK_TVAL_INCREF(thr, tv); /* may be a string constant */ + + DUK_DDD(DUK_DDDPRINT("constant: %!T", (duk_tval *) tv)); + } + + p_func = (duk_hobject **) p_const; + DUK_HCOMPFUNC_SET_FUNCS(thr->heap, h_res, p_func); + for (i = 0; i < funcs_count; i++) { + duk_hobject *h; + DUK_ASSERT(i * 3 <= DUK_UARRIDX_MAX); /* func limits */ + tv = duk_hobject_find_array_entry_tval_ptr(thr->heap, func->h_funcs, (duk_uarridx_t) (i * 3)); + DUK_ASSERT(tv != NULL); + DUK_ASSERT(DUK_TVAL_IS_OBJECT(tv)); + h = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(h)); + *p_func++ = h; + DUK_HOBJECT_INCREF(thr, h); + + DUK_DDD(DUK_DDDPRINT("inner function: %p -> %!iO", (void *) h, (duk_heaphdr *) h)); + } + + p_instr = (duk_instr_t *) p_func; + DUK_HCOMPFUNC_SET_BYTECODE(thr->heap, h_res, p_instr); + + /* copy bytecode instructions one at a time */ + q_instr = (duk_compiler_instr *) (void *) DUK_BW_GET_BASEPTR(thr, &func->bw_code); + for (i = 0; i < code_count; i++) { + p_instr[i] = q_instr[i].ins; + } + /* Note: 'q_instr' is still used below */ + + DUK_ASSERT((duk_uint8_t *) (p_instr + code_count) == DUK_HBUFFER_FIXED_GET_DATA_PTR(thr->heap, h_data) + data_size); + + duk_pop(thr); /* 'data' (and everything in it) is reachable through h_res now */ + + /* + * Init non-property result fields + * + * 'nregs' controls how large a register frame is allocated. + * + * 'nargs' controls how many formal arguments are written to registers: + * r0, ... r(nargs-1). The remaining registers are initialized to + * undefined. + */ + + DUK_ASSERT(func->temp_max >= 0); + h_res->nregs = (duk_uint16_t) func->temp_max; + h_res->nargs = (duk_uint16_t) duk_hobject_get_length(thr, func->h_argnames); + DUK_ASSERT(h_res->nregs >= h_res->nargs); /* pass2 allocation handles this */ +#if defined(DUK_USE_DEBUGGER_SUPPORT) + h_res->start_line = (duk_uint32_t) func->min_line; + h_res->end_line = (duk_uint32_t) func->max_line; +#endif + + /* + * Init object properties + * + * Properties should be added in decreasing order of access frequency. + * (Not very critical for function templates.) + */ + + DUK_DDD(DUK_DDDPRINT("init function properties")); + + /* [ ... res ] */ + + /* _Varmap: omitted if function is guaranteed not to do a slow path + * identifier access that might be caught by locally declared variables. + * The varmap can also be omitted if it turns out empty of actual + * register mappings after a cleanup. When debugging is enabled, we + * always need the varmap to be able to lookup variables at any point. + */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + DUK_DD(DUK_DDPRINT("keeping _Varmap because debugger support is enabled")); + keep_varmap = 1; +#else + if (func->id_access_slow_own || /* directly uses slow accesses that may match own variables */ + func->id_access_arguments || /* accesses 'arguments' directly */ + func->may_direct_eval || /* may indirectly slow access through a direct eval */ + funcs_count > + 0) { /* has inner functions which may slow access (XXX: this can be optimized by looking at the inner functions) */ + DUK_DD(DUK_DDPRINT("keeping _Varmap because of direct eval, slow path access that may match local variables, or " + "presence of inner functions")); + keep_varmap = 1; + } else { + DUK_DD(DUK_DDPRINT("dropping _Varmap")); + keep_varmap = 0; + } +#endif + + if (keep_varmap) { + duk_int_t num_used; + duk_dup(thr, func->varmap_idx); + num_used = duk__cleanup_varmap(comp_ctx); + DUK_DDD(DUK_DDDPRINT("cleaned up varmap: %!T (num_used=%ld)", (duk_tval *) duk_get_tval(thr, -1), (long) num_used)); + + if (num_used > 0) { + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_VARMAP, DUK_PROPDESC_FLAGS_NONE); + } else { + DUK_DD(DUK_DDPRINT("varmap is empty after cleanup -> no need to add")); + duk_pop(thr); + } + } + + /* _Formals: omitted if function is guaranteed not to need a (non-strict) + * arguments object, and _Formals.length matches nargs exactly. + * + * Non-arrow functions can't see an outer function's 'argument' binding + * (because they have their own), but arrow functions can. When arrow + * functions are added, this condition would need to be added: + * inner_arrow_funcs_count > 0 inner arrow functions may access 'arguments' + */ +#if defined(DUK_USE_DEBUGGER_SUPPORT) + DUK_DD(DUK_DDPRINT("keeping _Formals because debugger support is enabled")); + keep_formals = 1; +#else + formals_length = duk_get_length(thr, func->argnames_idx); + if (formals_length != (duk_size_t) h_res->nargs) { + /* Nargs not enough for closure .length: keep _Formals regardless + * of its length. Shouldn't happen in practice at the moment. + */ + DUK_DD(DUK_DDPRINT("keeping _Formals because _Formals.length != nargs")); + keep_formals = 1; + } else if ((func->id_access_arguments || func->may_direct_eval) && (formals_length > 0)) { + /* Direct eval (may access 'arguments') or accesses 'arguments' + * explicitly: keep _Formals unless it is zero length. + */ + DUK_DD(DUK_DDPRINT( + "keeping _Formals because of direct eval or explicit access to 'arguments', and _Formals.length != 0")); + keep_formals = 1; + } else { + DUK_DD(DUK_DDPRINT("omitting _Formals, nargs matches _Formals.length, so no properties added")); + keep_formals = 0; + } +#endif + + if (keep_formals) { + duk_dup(thr, func->argnames_idx); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_FORMALS, DUK_PROPDESC_FLAGS_NONE); + } + + /* name */ +#if defined(DUK_USE_FUNC_NAME_PROPERTY) + if (func->h_name) { + duk_push_hstring(thr, func->h_name); + DUK_DD(DUK_DDPRINT("setting function template .name to %!T", duk_get_tval(thr, -1))); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_NAME, DUK_PROPDESC_FLAGS_NONE); + } +#endif /* DUK_USE_FUNC_NAME_PROPERTY */ + + /* _Source */ +#if defined(DUK_USE_NONSTD_FUNC_SOURCE_PROPERTY) + if (0) { + /* XXX: Currently function source code is not stored, as it is not + * required by the standard. Source code should not be stored by + * default (user should enable it explicitly), and the source should + * probably be compressed with a trivial text compressor; average + * compression of 20-30% is quite easy to achieve even with a trivial + * compressor (RLE + backwards lookup). + * + * Debugging needs source code to be useful: sometimes input code is + * not found in files as it may be generated and then eval()'d, given + * by dynamic C code, etc. + * + * Other issues: + * + * - Need tokenizer indices for start and end to substring + * - Always normalize function declaration part? + * - If we keep _Formals, only need to store body + */ + + /* + * For global or eval code this is straightforward. For functions + * created with the Function constructor we only get the source for + * the body and must manufacture the "function ..." part. + * + * For instance, for constructed functions (v8): + * + * > a = new Function("foo", "bar", "print(foo)"); + * [Function] + * > a.toString() + * 'function anonymous(foo,bar) {\nprint(foo)\n}' + * + * Similarly for e.g. getters (v8): + * + * > x = { get a(foo,bar) { print(foo); } } + * { a: [Getter] } + * > Object.getOwnPropertyDescriptor(x, 'a').get.toString() + * 'function a(foo,bar) { print(foo); }' + */ + +#if 0 + duk_push_literal(thr, "XXX"); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_SOURCE, DUK_PROPDESC_FLAGS_NONE); +#endif + } +#endif /* DUK_USE_NONSTD_FUNC_SOURCE_PROPERTY */ + + /* _Pc2line */ +#if defined(DUK_USE_PC2LINE) + if (1) { + /* + * Size-optimized pc->line mapping. + */ + + DUK_ASSERT(code_count <= DUK_COMPILER_MAX_BYTECODE_LENGTH); + duk_hobject_pc2line_pack(thr, q_instr, (duk_uint_fast32_t) code_count); /* -> pushes fixed buffer */ + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_PC2LINE, DUK_PROPDESC_FLAGS_NONE); + + /* XXX: if assertions enabled, walk through all valid PCs + * and check line mapping. + */ + } +#endif /* DUK_USE_PC2LINE */ + + /* fileName */ +#if defined(DUK_USE_FUNC_FILENAME_PROPERTY) + if (comp_ctx->h_filename) { + /* + * Source filename (or equivalent), for identifying thrown errors. + */ + + duk_push_hstring(thr, comp_ctx->h_filename); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_FILE_NAME, DUK_PROPDESC_FLAGS_NONE); + } +#endif + + DUK_DD(DUK_DDPRINT("converted function: %!ixT", (duk_tval *) duk_get_tval(thr, -1))); + + /* + * Compact the function template. + */ + + duk_compact_m1(thr); + + /* + * Debug dumping + */ + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) + { + duk_hcompfunc *h; + duk_instr_t *p, *p_start, *p_end; + + h = (duk_hcompfunc *) duk_get_hobject(thr, -1); + p_start = (duk_instr_t *) DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, h); + p_end = (duk_instr_t *) DUK_HCOMPFUNC_GET_CODE_END(thr->heap, h); + + p = p_start; + while (p < p_end) { + DUK_DDD(DUK_DDDPRINT("BC %04ld: %!I ; 0x%08lx op=%ld (%!X) a=%ld b=%ld c=%ld", + (long) (p - p_start), + (duk_instr_t) (*p), + (unsigned long) (*p), + (long) DUK_DEC_OP(*p), + (long) DUK_DEC_OP(*p), + (long) DUK_DEC_A(*p), + (long) DUK_DEC_B(*p), + (long) DUK_DEC_C(*p))); + p++; + } + } +#endif +} + +/* + * Code emission helpers + * + * Some emission helpers understand the range of target and source reg/const + * values and automatically emit shuffling code if necessary. This is the + * case when the slot in question (A, B, C) is used in the standard way and + * for opcodes the emission helpers explicitly understand (like DUK_OP_MPUTOBJ). + * + * The standard way is that: + * - slot A is a target register + * - slot B is a source register/constant + * - slot C is a source register/constant + * + * If a slot is used in a non-standard way the caller must indicate this + * somehow. If a slot is used as a target instead of a source (or vice + * versa), this can be indicated with a flag to trigger proper shuffling + * (e.g. DUK__EMIT_FLAG_B_IS_TARGET). If the value in the slot is not + * register/const related at all, the caller must ensure that the raw value + * fits into the corresponding slot so as to not trigger shuffling. The + * caller must set a "no shuffle" flag to ensure compilation fails if + * shuffling were to be triggered because of an internal error. + * + * For slots B and C the raw slot size is 9 bits but one bit is reserved for + * the reg/const indicator. To use the full 9-bit range for a raw value, + * shuffling must be disabled with the DUK__EMIT_FLAG_NO_SHUFFLE_{B,C} flag. + * Shuffling is only done for A, B, and C slots, not the larger BC or ABC slots. + * + * There is call handling specific understanding in the A-B-C emitter to + * convert call setup and call instructions into indirect ones if necessary. + */ + +/* Code emission flags, passed in the 'opcode' field. Opcode + flags + * fit into 16 bits for now, so use duk_small_uint_t. + */ +#define DUK__EMIT_FLAG_NO_SHUFFLE_A (1 << 8) +#define DUK__EMIT_FLAG_NO_SHUFFLE_B (1 << 9) +#define DUK__EMIT_FLAG_NO_SHUFFLE_C (1 << 10) +#define DUK__EMIT_FLAG_A_IS_SOURCE (1 << 11) /* slot A is a source (default: target) */ +#define DUK__EMIT_FLAG_B_IS_TARGET (1 << 12) /* slot B is a target (default: source) */ +#define DUK__EMIT_FLAG_C_IS_TARGET (1 << 13) /* slot C is a target (default: source) */ +#define DUK__EMIT_FLAG_BC_REGCONST (1 << 14) /* slots B and C are reg/const */ +#define DUK__EMIT_FLAG_RESERVE_JUMPSLOT (1 << 15) /* reserve a jumpslot after instr before target spilling, used for NEXTENUM */ + +/* XXX: macro smaller than call? */ +DUK_LOCAL duk_int_t duk__get_current_pc(duk_compiler_ctx *comp_ctx) { + duk_compiler_func *func; + func = &comp_ctx->curr_func; + return (duk_int_t) (DUK_BW_GET_SIZE(comp_ctx->thr, &func->bw_code) / sizeof(duk_compiler_instr)); +} + +DUK_LOCAL duk_compiler_instr *duk__get_instr_ptr(duk_compiler_ctx *comp_ctx, duk_int_t pc) { + DUK_ASSERT(pc >= 0); + DUK_ASSERT((duk_size_t) pc < + (duk_size_t) (DUK_BW_GET_SIZE(comp_ctx->thr, &comp_ctx->curr_func.bw_code) / sizeof(duk_compiler_instr))); + return ((duk_compiler_instr *) (void *) DUK_BW_GET_BASEPTR(comp_ctx->thr, &comp_ctx->curr_func.bw_code)) + pc; +} + +/* emit instruction; could return PC but that's not needed in the majority + * of cases. + */ +DUK_LOCAL void duk__emit(duk_compiler_ctx *comp_ctx, duk_instr_t ins) { +#if defined(DUK_USE_PC2LINE) + duk_int_t line; +#endif + duk_compiler_instr *instr; + + DUK_DDD(DUK_DDDPRINT("duk__emit: 0x%08lx curr_token.start_line=%ld prev_token.start_line=%ld pc=%ld --> %!I", + (unsigned long) ins, + (long) comp_ctx->curr_token.start_line, + (long) comp_ctx->prev_token.start_line, + (long) duk__get_current_pc(comp_ctx), + (duk_instr_t) ins)); + + instr = (duk_compiler_instr *) (void *) DUK_BW_ENSURE_GETPTR(comp_ctx->thr, + &comp_ctx->curr_func.bw_code, + sizeof(duk_compiler_instr)); + DUK_BW_ADD_PTR(comp_ctx->thr, &comp_ctx->curr_func.bw_code, sizeof(duk_compiler_instr)); + +#if defined(DUK_USE_PC2LINE) + /* The line number tracking is a bit inconsistent right now, which + * affects debugger accuracy. Mostly call sites emit opcodes when + * they have parsed a token (say a terminating semicolon) and called + * duk__advance(). In this case the line number of the previous + * token is the most accurate one (except in prologue where + * prev_token.start_line is 0). This is probably not 100% correct + * right now. + */ + /* approximation, close enough */ + line = comp_ctx->prev_token.start_line; + if (line == 0) { + line = comp_ctx->curr_token.start_line; + } +#endif + + instr->ins = ins; +#if defined(DUK_USE_PC2LINE) + instr->line = (duk_uint32_t) line; +#endif +#if defined(DUK_USE_DEBUGGER_SUPPORT) + if (line < comp_ctx->curr_func.min_line) { + comp_ctx->curr_func.min_line = line; + } + if (line > comp_ctx->curr_func.max_line) { + comp_ctx->curr_func.max_line = line; + } +#endif + + /* Limit checks for bytecode byte size and line number. */ + if (DUK_UNLIKELY(DUK_BW_GET_SIZE(comp_ctx->thr, &comp_ctx->curr_func.bw_code) > DUK_USE_ESBC_MAX_BYTES)) { + goto fail_bc_limit; + } +#if defined(DUK_USE_PC2LINE) && defined(DUK_USE_ESBC_LIMITS) +#if defined(DUK_USE_BUFLEN16) + /* Buffer length is bounded to 0xffff automatically, avoid compile warning. */ + if (DUK_UNLIKELY(line > DUK_USE_ESBC_MAX_LINENUMBER)) { + goto fail_bc_limit; + } +#else + if (DUK_UNLIKELY(line > DUK_USE_ESBC_MAX_LINENUMBER)) { + goto fail_bc_limit; + } +#endif +#endif + + return; + +fail_bc_limit: + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_BYTECODE_LIMIT); + DUK_WO_NORETURN(return;); +} + +/* Update function min/max line from current token. Needed to improve + * function line range information for debugging, so that e.g. opening + * curly brace is covered by line range even when no opcodes are emitted + * for the line containing the brace. + */ +DUK_LOCAL void duk__update_lineinfo_currtoken(duk_compiler_ctx *comp_ctx) { +#if defined(DUK_USE_DEBUGGER_SUPPORT) + duk_int_t line; + + line = comp_ctx->curr_token.start_line; + if (line == 0) { + return; + } + if (line < comp_ctx->curr_func.min_line) { + comp_ctx->curr_func.min_line = line; + } + if (line > comp_ctx->curr_func.max_line) { + comp_ctx->curr_func.max_line = line; + } +#else + DUK_UNREF(comp_ctx); +#endif +} + +DUK_LOCAL void duk__emit_op_only(duk_compiler_ctx *comp_ctx, duk_small_uint_t op) { + duk__emit(comp_ctx, DUK_ENC_OP_ABC(op, 0)); +} + +/* Important main primitive. */ +DUK_LOCAL void duk__emit_a_b_c(duk_compiler_ctx *comp_ctx, + duk_small_uint_t op_flags, + duk_regconst_t a, + duk_regconst_t b, + duk_regconst_t c) { + duk_instr_t ins = 0; + duk_int_t a_out = -1; + duk_int_t b_out = -1; + duk_int_t c_out = -1; + duk_int_t tmp; + duk_small_uint_t op = op_flags & 0xffU; + + DUK_DDD(DUK_DDDPRINT("emit: op_flags=%04lx, a=%ld, b=%ld, c=%ld", (unsigned long) op_flags, (long) a, (long) b, (long) c)); + + /* We could rely on max temp/const checks: if they don't exceed BC + * limit, nothing here can either (just asserts would be enough). + * Currently we check for the limits, which provides additional + * protection against creating invalid bytecode due to compiler + * bugs. + */ + + DUK_ASSERT_DISABLE((op_flags & 0xff) >= DUK_BC_OP_MIN); /* unsigned */ + DUK_ASSERT((op_flags & 0xff) <= DUK_BC_OP_MAX); + DUK_ASSERT(DUK__ISREG(a)); + DUK_ASSERT(b != -1); /* Not 'none'. */ + DUK_ASSERT(c != -1); /* Not 'none'. */ + + /* Input shuffling happens before the actual operation, while output + * shuffling happens afterwards. Output shuffling decisions are still + * made at the same time to reduce branch clutter; output shuffle decisions + * are recorded into X_out variables. + */ + + /* Slot A: currently no support for reg/const. */ + +#if defined(DUK_USE_SHUFFLE_TORTURE) + if (a <= DUK_BC_A_MAX && (op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_A)) { +#else + if (a <= DUK_BC_A_MAX) { +#endif + ; + } else if (op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_A) { + DUK_D(DUK_DPRINT("out of regs: 'a' (reg) needs shuffling but shuffle prohibited, a: %ld", (long) a)); + goto error_outofregs; + } else if (a <= DUK_BC_BC_MAX) { + comp_ctx->curr_func.needs_shuffle = 1; + tmp = comp_ctx->curr_func.shuffle1; + if (op_flags & DUK__EMIT_FLAG_A_IS_SOURCE) { + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_LDREG, tmp, a)); + } else { + /* Output shuffle needed after main operation */ + a_out = a; + + /* The DUK_OP_CSVAR output shuffle assumes shuffle registers are + * consecutive. + */ + DUK_ASSERT((comp_ctx->curr_func.shuffle1 == 0 && comp_ctx->curr_func.shuffle2 == 0) || + (comp_ctx->curr_func.shuffle2 == comp_ctx->curr_func.shuffle1 + 1)); + if (op == DUK_OP_CSVAR) { + /* For CSVAR the limit is one smaller because output shuffle + * must be able to express 'a + 1' in BC. + */ + if (a + 1 > DUK_BC_BC_MAX) { + goto error_outofregs; + } + } + } + a = tmp; + } else { + DUK_D(DUK_DPRINT("out of regs: 'a' (reg) needs shuffling but does not fit into BC, a: %ld", (long) a)); + goto error_outofregs; + } + + /* Slot B: reg/const support, mapped to bit 0 of opcode. */ + + if ((b & DUK__CONST_MARKER) != 0) { + DUK_ASSERT((op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_B) == 0); + DUK_ASSERT((op_flags & DUK__EMIT_FLAG_B_IS_TARGET) == 0); + b = b & ~DUK__CONST_MARKER; +#if defined(DUK_USE_SHUFFLE_TORTURE) + if (0) { +#else + if (b <= 0xff) { +#endif + if (op_flags & DUK__EMIT_FLAG_BC_REGCONST) { + /* Opcode follows B/C reg/const convention. */ + DUK_ASSERT((op & 0x01) == 0); + ins |= DUK_ENC_OP_A_B_C(0x01, 0, 0, 0); /* const flag for B */ + } else { + DUK_D(DUK_DPRINT("B is const, opcode is not B/C reg/const: %x", op_flags)); + } + } else if (b <= DUK_BC_BC_MAX) { + comp_ctx->curr_func.needs_shuffle = 1; + tmp = comp_ctx->curr_func.shuffle2; + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_LDCONST, tmp, b)); + b = tmp; + } else { + DUK_D(DUK_DPRINT("out of regs: 'b' (const) needs shuffling but does not fit into BC, b: %ld", (long) b)); + goto error_outofregs; + } + } else { +#if defined(DUK_USE_SHUFFLE_TORTURE) + if (b <= 0xff && (op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_B)) { +#else + if (b <= 0xff) { +#endif + ; + } else if (op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_B) { + if (b > DUK_BC_B_MAX) { + /* Note: 0xff != DUK_BC_B_MAX */ + DUK_D( + DUK_DPRINT("out of regs: 'b' (reg) needs shuffling but shuffle prohibited, b: %ld", (long) b)); + goto error_outofregs; + } + } else if (b <= DUK_BC_BC_MAX) { + comp_ctx->curr_func.needs_shuffle = 1; + tmp = comp_ctx->curr_func.shuffle2; + if (op_flags & DUK__EMIT_FLAG_B_IS_TARGET) { + /* Output shuffle needed after main operation */ + b_out = b; + } + if (!(op_flags & DUK__EMIT_FLAG_B_IS_TARGET)) { + if (op == DUK_OP_MPUTOBJ || op == DUK_OP_MPUTARR) { + /* Special handling for MPUTOBJ/MPUTARR shuffling. + * For each, slot B identifies the first register of a range + * of registers, so normal shuffling won't work. Instead, + * an indirect version of the opcode is used. + */ + DUK_ASSERT((op_flags & DUK__EMIT_FLAG_B_IS_TARGET) == 0); + duk__emit_load_int32_noshuffle(comp_ctx, tmp, b); + DUK_ASSERT(DUK_OP_MPUTOBJI == DUK_OP_MPUTOBJ + 1); + DUK_ASSERT(DUK_OP_MPUTARRI == DUK_OP_MPUTARR + 1); + op_flags++; /* indirect opcode follows direct */ + } else { + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_LDREG, tmp, b)); + } + } + b = tmp; + } else { + DUK_D(DUK_DPRINT("out of regs: 'b' (reg) needs shuffling but does not fit into BC, b: %ld", (long) b)); + goto error_outofregs; + } + } + + /* Slot C: reg/const support, mapped to bit 1 of opcode. */ + + if ((c & DUK__CONST_MARKER) != 0) { + DUK_ASSERT((op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_C) == 0); + DUK_ASSERT((op_flags & DUK__EMIT_FLAG_C_IS_TARGET) == 0); + c = c & ~DUK__CONST_MARKER; +#if defined(DUK_USE_SHUFFLE_TORTURE) + if (0) { +#else + if (c <= 0xff) { +#endif + if (op_flags & DUK__EMIT_FLAG_BC_REGCONST) { + /* Opcode follows B/C reg/const convention. */ + DUK_ASSERT((op & 0x02) == 0); + ins |= DUK_ENC_OP_A_B_C(0x02, 0, 0, 0); /* const flag for C */ + } else { + DUK_D(DUK_DPRINT("C is const, opcode is not B/C reg/const: %x", op_flags)); + } + } else if (c <= DUK_BC_BC_MAX) { + comp_ctx->curr_func.needs_shuffle = 1; + tmp = comp_ctx->curr_func.shuffle3; + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_LDCONST, tmp, c)); + c = tmp; + } else { + DUK_D(DUK_DPRINT("out of regs: 'c' (const) needs shuffling but does not fit into BC, c: %ld", (long) c)); + goto error_outofregs; + } + } else { +#if defined(DUK_USE_SHUFFLE_TORTURE) + if (c <= 0xff && (op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_C)) { +#else + if (c <= 0xff) { +#endif + ; + } else if (op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_C) { + if (c > DUK_BC_C_MAX) { + /* Note: 0xff != DUK_BC_C_MAX */ + DUK_D( + DUK_DPRINT("out of regs: 'c' (reg) needs shuffling but shuffle prohibited, c: %ld", (long) c)); + goto error_outofregs; + } + } else if (c <= DUK_BC_BC_MAX) { + comp_ctx->curr_func.needs_shuffle = 1; + tmp = comp_ctx->curr_func.shuffle3; + if (op_flags & DUK__EMIT_FLAG_C_IS_TARGET) { + /* Output shuffle needed after main operation */ + c_out = c; + } else { + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_LDREG, tmp, c)); + } + c = tmp; + } else { + DUK_D(DUK_DPRINT("out of regs: 'c' (reg) needs shuffling but does not fit into BC, c: %ld", (long) c)); + goto error_outofregs; + } + } + + /* Main operation */ + + DUK_ASSERT(a >= DUK_BC_A_MIN); + DUK_ASSERT(a <= DUK_BC_A_MAX); + DUK_ASSERT(b >= DUK_BC_B_MIN); + DUK_ASSERT(b <= DUK_BC_B_MAX); + DUK_ASSERT(c >= DUK_BC_C_MIN); + DUK_ASSERT(c <= DUK_BC_C_MAX); + + ins |= DUK_ENC_OP_A_B_C(op_flags & 0xff, a, b, c); + duk__emit(comp_ctx, ins); + + /* NEXTENUM needs a jump slot right after the main instruction. + * When the JUMP is taken, output spilling is not needed so this + * workaround is possible. The jump slot PC is exceptionally + * plumbed through comp_ctx to minimize call sites. + */ + if (op_flags & DUK__EMIT_FLAG_RESERVE_JUMPSLOT) { + comp_ctx->emit_jumpslot_pc = duk__get_current_pc(comp_ctx); + duk__emit_abc(comp_ctx, DUK_OP_JUMP, 0); + } + + /* Output shuffling: only one output register is realistically possible. + * + * (Zero would normally be an OK marker value: if the target register + * was zero, it would never be shuffled. But with DUK_USE_SHUFFLE_TORTURE + * this is no longer true, so use -1 as a marker instead.) + */ + + if (a_out >= 0) { + DUK_ASSERT(b_out < 0); + DUK_ASSERT(c_out < 0); + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_STREG, a, a_out)); + + if (op == DUK_OP_CSVAR) { + /* Special handling for CSVAR shuffling. The variable lookup + * results in a pair in successive + * registers so use two shuffle registers and two output + * loads. (In practice this is dead code because temp/const + * limit is reached first.) + */ + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_STREG, a + 1, a_out + 1)); + } + } else if (b_out >= 0) { + DUK_ASSERT(a_out < 0); + DUK_ASSERT(c_out < 0); + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_STREG, b, b_out)); + } else if (c_out >= 0) { + DUK_ASSERT(b_out < 0); + DUK_ASSERT(c_out < 0); + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_STREG, c, c_out)); + } + + return; + +error_outofregs: + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_REG_LIMIT); + DUK_WO_NORETURN(return;); +} + +/* For many of the helpers below it'd be technically correct to add + * "no shuffle" flags for parameters passed in as zero. For example, + * duk__emit_a_b() should call duk__emit_a_b_c() with C set to 0, and + * DUK__EMIT_FLAG_NO_SHUFFLE_C added to op_flags. However, since the + * C value is 0, it'll never get shuffled so adding the flag is just + * unnecessary additional code. This is unfortunately not true for + * "shuffle torture" mode which needs special handling. + */ + +DUK_LOCAL void duk__emit_a_b(duk_compiler_ctx *comp_ctx, duk_small_uint_t op_flags, duk_regconst_t a, duk_regconst_t b) { +#if defined(DUK_USE_SHUFFLE_TORTURE) + op_flags |= DUK__EMIT_FLAG_NO_SHUFFLE_C; +#endif + duk__emit_a_b_c(comp_ctx, op_flags, a, b, 0); +} + +DUK_LOCAL void duk__emit_b_c(duk_compiler_ctx *comp_ctx, duk_small_uint_t op_flags, duk_regconst_t b, duk_regconst_t c) { +#if defined(DUK_USE_SHUFFLE_TORTURE) + op_flags |= DUK__EMIT_FLAG_NO_SHUFFLE_A; +#endif + duk__emit_a_b_c(comp_ctx, op_flags, 0, b, c); +} + +#if 0 /* unused */ +DUK_LOCAL void duk__emit_a(duk_compiler_ctx *comp_ctx, int op_flags, int a) { +#if defined(DUK_USE_SHUFFLE_TORTURE) + op_flags |= DUK__EMIT_FLAG_NO_SHUFFLE_B | DUK__EMIT_FLAG_NO_SHUFFLE_C; +#endif + duk__emit_a_b_c(comp_ctx, op_flags, a, 0, 0); +} +#endif + +#if 0 /* unused */ +DUK_LOCAL void duk__emit_b(duk_compiler_ctx *comp_ctx, duk_small_uint_t op_flags, duk_regconst_t b) { +#if defined(DUK_USE_SHUFFLE_TORTURE) + op_flags |= DUK__EMIT_FLAG_NO_SHUFFLE_A | DUK__EMIT_FLAG_NO_SHUFFLE_C; +#endif + duk__emit_a_b_c(comp_ctx, op_flags, 0, b, 0); +} +#endif + +DUK_LOCAL void duk__emit_a_bc(duk_compiler_ctx *comp_ctx, duk_small_uint_t op_flags, duk_regconst_t a, duk_regconst_t bc) { + duk_instr_t ins; + duk_int_t tmp; + + /* allow caller to give a const number with the DUK__CONST_MARKER */ + DUK_ASSERT(bc != -1); /* Not 'none'. */ + bc = bc & (~DUK__CONST_MARKER); + + DUK_ASSERT_DISABLE((op_flags & 0xff) >= DUK_BC_OP_MIN); /* unsigned */ + DUK_ASSERT((op_flags & 0xff) <= DUK_BC_OP_MAX); + DUK_ASSERT(bc >= DUK_BC_BC_MIN); + DUK_ASSERT(bc <= DUK_BC_BC_MAX); + DUK_ASSERT((bc & DUK__CONST_MARKER) == 0); + + if (bc <= DUK_BC_BC_MAX) { + ; + } else { + /* No BC shuffling now. */ + goto error_outofregs; + } + +#if defined(DUK_USE_SHUFFLE_TORTURE) + if (a <= DUK_BC_A_MAX && (op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_A)) { +#else + if (a <= DUK_BC_A_MAX) { +#endif + ins = DUK_ENC_OP_A_BC(op_flags & 0xff, a, bc); + duk__emit(comp_ctx, ins); + } else if (op_flags & DUK__EMIT_FLAG_NO_SHUFFLE_A) { + goto error_outofregs; + } else if ((op_flags & 0xf0U) == DUK_OP_CALL0) { + comp_ctx->curr_func.needs_shuffle = 1; + tmp = comp_ctx->curr_func.shuffle1; + duk__emit_load_int32_noshuffle(comp_ctx, tmp, a); + op_flags |= DUK_BC_CALL_FLAG_INDIRECT; + ins = DUK_ENC_OP_A_BC(op_flags & 0xff, tmp, bc); + duk__emit(comp_ctx, ins); + } else if (a <= DUK_BC_BC_MAX) { + comp_ctx->curr_func.needs_shuffle = 1; + tmp = comp_ctx->curr_func.shuffle1; + ins = DUK_ENC_OP_A_BC(op_flags & 0xff, tmp, bc); + if (op_flags & DUK__EMIT_FLAG_A_IS_SOURCE) { + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_LDREG, tmp, a)); + duk__emit(comp_ctx, ins); + } else { + duk__emit(comp_ctx, ins); + duk__emit(comp_ctx, DUK_ENC_OP_A_BC(DUK_OP_STREG, tmp, a)); + } + } else { + goto error_outofregs; + } + return; + +error_outofregs: + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_REG_LIMIT); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__emit_bc(duk_compiler_ctx *comp_ctx, duk_small_uint_t op, duk_regconst_t bc) { +#if defined(DUK_USE_SHUFFLE_TORTURE) + op |= DUK__EMIT_FLAG_NO_SHUFFLE_A; +#endif + duk__emit_a_bc(comp_ctx, op, 0, bc); +} + +DUK_LOCAL void duk__emit_abc(duk_compiler_ctx *comp_ctx, duk_small_uint_t op, duk_regconst_t abc) { + duk_instr_t ins; + + DUK_ASSERT_DISABLE(op >= DUK_BC_OP_MIN); /* unsigned */ + DUK_ASSERT(op <= DUK_BC_OP_MAX); + DUK_ASSERT_DISABLE(abc >= DUK_BC_ABC_MIN); /* unsigned */ + DUK_ASSERT(abc <= DUK_BC_ABC_MAX); + DUK_ASSERT((abc & DUK__CONST_MARKER) == 0); + DUK_ASSERT(abc != -1); /* Not 'none'. */ + + if (abc <= DUK_BC_ABC_MAX) { + ; + } else { + goto error_outofregs; + } + ins = DUK_ENC_OP_ABC(op, abc); + DUK_DDD(DUK_DDDPRINT("duk__emit_abc: 0x%08lx line=%ld pc=%ld op=%ld (%!X) abc=%ld (%!I)", + (unsigned long) ins, + (long) comp_ctx->curr_token.start_line, + (long) duk__get_current_pc(comp_ctx), + (long) op, + (long) op, + (long) abc, + (duk_instr_t) ins)); + duk__emit(comp_ctx, ins); + return; + +error_outofregs: + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_REG_LIMIT); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__emit_load_int32_raw(duk_compiler_ctx *comp_ctx, + duk_regconst_t reg, + duk_int32_t val, + duk_small_uint_t op_flags) { + /* XXX: Shuffling support could be implemented here so that LDINT+LDINTX + * would only shuffle once (instead of twice). The current code works + * though, and has a smaller compiler footprint. + */ + + if ((val >= (duk_int32_t) DUK_BC_BC_MIN - (duk_int32_t) DUK_BC_LDINT_BIAS) && + (val <= (duk_int32_t) DUK_BC_BC_MAX - (duk_int32_t) DUK_BC_LDINT_BIAS)) { + DUK_DDD(DUK_DDDPRINT("emit LDINT to reg %ld for %ld", (long) reg, (long) val)); + duk__emit_a_bc(comp_ctx, DUK_OP_LDINT | op_flags, reg, (duk_regconst_t) (val + (duk_int32_t) DUK_BC_LDINT_BIAS)); + } else { + duk_int32_t hi = val >> DUK_BC_LDINTX_SHIFT; + duk_int32_t lo = val & ((((duk_int32_t) 1) << DUK_BC_LDINTX_SHIFT) - 1); + DUK_ASSERT(lo >= 0); + DUK_DDD(DUK_DDDPRINT("emit LDINT+LDINTX to reg %ld for %ld -> hi %ld, lo %ld", + (long) reg, + (long) val, + (long) hi, + (long) lo)); + duk__emit_a_bc(comp_ctx, DUK_OP_LDINT | op_flags, reg, (duk_regconst_t) (hi + (duk_int32_t) DUK_BC_LDINT_BIAS)); + duk__emit_a_bc(comp_ctx, DUK_OP_LDINTX | op_flags, reg, (duk_regconst_t) lo); + } +} + +DUK_LOCAL void duk__emit_load_int32(duk_compiler_ctx *comp_ctx, duk_regconst_t reg, duk_int32_t val) { + duk__emit_load_int32_raw(comp_ctx, reg, val, 0 /*op_flags*/); +} + +#if defined(DUK_USE_SHUFFLE_TORTURE) +/* Used by duk__emit*() calls so that we don't shuffle the loadints that + * are needed to handle indirect opcodes. + */ +DUK_LOCAL void duk__emit_load_int32_noshuffle(duk_compiler_ctx *comp_ctx, duk_regconst_t reg, duk_int32_t val) { + duk__emit_load_int32_raw(comp_ctx, reg, val, DUK__EMIT_FLAG_NO_SHUFFLE_A /*op_flags*/); +} +#else +DUK_LOCAL void duk__emit_load_int32_noshuffle(duk_compiler_ctx *comp_ctx, duk_regconst_t reg, duk_int32_t val) { + /* When torture not enabled, can just use the same helper because + * 'reg' won't get spilled. + */ + DUK_ASSERT(reg <= DUK_BC_A_MAX); + duk__emit_load_int32(comp_ctx, reg, val); +} +#endif + +DUK_LOCAL void duk__emit_jump(duk_compiler_ctx *comp_ctx, duk_int_t target_pc) { + duk_int_t curr_pc; + duk_int_t offset; + + curr_pc = (duk_int_t) (DUK_BW_GET_SIZE(comp_ctx->thr, &comp_ctx->curr_func.bw_code) / sizeof(duk_compiler_instr)); + offset = (duk_int_t) target_pc - (duk_int_t) curr_pc - 1; + DUK_ASSERT(offset + DUK_BC_JUMP_BIAS >= DUK_BC_ABC_MIN); + DUK_ASSERT(offset + DUK_BC_JUMP_BIAS <= DUK_BC_ABC_MAX); + duk__emit_abc(comp_ctx, DUK_OP_JUMP, (duk_regconst_t) (offset + DUK_BC_JUMP_BIAS)); +} + +DUK_LOCAL duk_int_t duk__emit_jump_empty(duk_compiler_ctx *comp_ctx) { + duk_int_t ret; + + ret = duk__get_current_pc(comp_ctx); /* useful for patching jumps later */ + duk__emit_op_only(comp_ctx, DUK_OP_JUMP); + return ret; +} + +/* Insert an empty jump in the middle of code emitted earlier. This is + * currently needed for compiling for-in. + */ +DUK_LOCAL void duk__insert_jump_entry(duk_compiler_ctx *comp_ctx, duk_int_t jump_pc) { +#if defined(DUK_USE_PC2LINE) + duk_int_t line; +#endif + duk_compiler_instr *instr; + duk_size_t offset; + + DUK_ASSERT(jump_pc >= 0); + offset = (duk_size_t) jump_pc * sizeof(duk_compiler_instr); + instr = (duk_compiler_instr *) (void *) + DUK_BW_INSERT_ENSURE_AREA(comp_ctx->thr, &comp_ctx->curr_func.bw_code, offset, sizeof(duk_compiler_instr)); + +#if defined(DUK_USE_PC2LINE) + line = comp_ctx->curr_token.start_line; /* approximation, close enough */ +#endif + instr->ins = DUK_ENC_OP_ABC(DUK_OP_JUMP, 0); +#if defined(DUK_USE_PC2LINE) + instr->line = (duk_uint32_t) line; +#endif + + DUK_BW_ADD_PTR(comp_ctx->thr, &comp_ctx->curr_func.bw_code, sizeof(duk_compiler_instr)); + if (DUK_UNLIKELY(DUK_BW_GET_SIZE(comp_ctx->thr, &comp_ctx->curr_func.bw_code) > DUK_USE_ESBC_MAX_BYTES)) { + goto fail_bc_limit; + } + return; + +fail_bc_limit: + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_BYTECODE_LIMIT); + DUK_WO_NORETURN(return;); +} + +/* Does not assume that jump_pc contains a DUK_OP_JUMP previously; this is intentional + * to allow e.g. an INVALID opcode be overwritten with a JUMP (label management uses this). + */ +DUK_LOCAL void duk__patch_jump(duk_compiler_ctx *comp_ctx, duk_int_t jump_pc, duk_int_t target_pc) { + duk_compiler_instr *instr; + duk_int_t offset; + + /* allow negative PCs, behave as a no-op */ + if (jump_pc < 0) { + DUK_DDD( + DUK_DDDPRINT("duk__patch_jump(): nop call, jump_pc=%ld (<0), target_pc=%ld", (long) jump_pc, (long) target_pc)); + return; + } + DUK_ASSERT(jump_pc >= 0); + + /* XXX: range assert */ + instr = duk__get_instr_ptr(comp_ctx, jump_pc); + DUK_ASSERT(instr != NULL); + + /* XXX: range assert */ + offset = target_pc - jump_pc - 1; + + instr->ins = DUK_ENC_OP_ABC(DUK_OP_JUMP, offset + DUK_BC_JUMP_BIAS); + DUK_DDD(DUK_DDDPRINT("duk__patch_jump(): jump_pc=%ld, target_pc=%ld, offset=%ld", + (long) jump_pc, + (long) target_pc, + (long) offset)); +} + +DUK_LOCAL void duk__patch_jump_here(duk_compiler_ctx *comp_ctx, duk_int_t jump_pc) { + duk__patch_jump(comp_ctx, jump_pc, duk__get_current_pc(comp_ctx)); +} + +DUK_LOCAL void duk__patch_trycatch(duk_compiler_ctx *comp_ctx, + duk_int_t ldconst_pc, + duk_int_t trycatch_pc, + duk_regconst_t reg_catch, + duk_regconst_t const_varname, + duk_small_uint_t flags) { + duk_compiler_instr *instr; + + DUK_ASSERT(DUK__ISREG(reg_catch)); + + instr = duk__get_instr_ptr(comp_ctx, ldconst_pc); + DUK_ASSERT(DUK_DEC_OP(instr->ins) == DUK_OP_LDCONST); + DUK_ASSERT(instr != NULL); + if (const_varname & DUK__CONST_MARKER) { + /* Have a catch variable. */ + const_varname = const_varname & (~DUK__CONST_MARKER); + if (reg_catch > DUK_BC_BC_MAX || const_varname > DUK_BC_BC_MAX) { + /* Catch attempts to use out-of-range reg/const. Without this + * check Duktape 0.12.0 could generate invalid code which caused + * an assert failure on execution. This error is triggered e.g. + * for functions with a lot of constants and a try-catch statement. + * Shuffling or opcode semantics change is needed to fix the issue. + * See: test-bug-trycatch-many-constants.js. + */ + DUK_D(DUK_DPRINT("failed to patch trycatch: flags=%ld, reg_catch=%ld, const_varname=%ld (0x%08lx)", + (long) flags, + (long) reg_catch, + (long) const_varname, + (long) const_varname)); + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_REG_LIMIT); + DUK_WO_NORETURN(return;); + } + instr->ins |= DUK_ENC_OP_A_BC(0, 0, const_varname); + } else { + /* No catch variable, e.g. a try-finally; replace LDCONST with + * NOP to avoid a bogus LDCONST. + */ + instr->ins = DUK_ENC_OP(DUK_OP_NOP); + } + + instr = duk__get_instr_ptr(comp_ctx, trycatch_pc); + DUK_ASSERT(instr != NULL); + DUK_ASSERT_DISABLE(flags >= DUK_BC_A_MIN); + DUK_ASSERT(flags <= DUK_BC_A_MAX); + instr->ins = DUK_ENC_OP_A_BC(DUK_OP_TRYCATCH, flags, reg_catch); +} + +DUK_LOCAL void duk__emit_if_false_skip(duk_compiler_ctx *comp_ctx, duk_regconst_t regconst) { + duk_small_uint_t op; + + op = DUK__ISREG(regconst) ? DUK_OP_IFFALSE_R : DUK_OP_IFFALSE_C; + duk__emit_bc(comp_ctx, op, regconst); /* helper will remove const flag */ +} + +DUK_LOCAL void duk__emit_if_true_skip(duk_compiler_ctx *comp_ctx, duk_regconst_t regconst) { + duk_small_uint_t op; + + op = DUK__ISREG(regconst) ? DUK_OP_IFTRUE_R : DUK_OP_IFTRUE_C; + duk__emit_bc(comp_ctx, op, regconst); /* helper will remove const flag */ +} + +DUK_LOCAL void duk__emit_invalid(duk_compiler_ctx *comp_ctx) { + duk__emit_op_only(comp_ctx, DUK_OP_INVALID); +} + +/* + * Peephole optimizer for finished bytecode. + * + * Does not remove opcodes; currently only straightens out unconditional + * jump chains which are generated by several control structures. + */ + +DUK_LOCAL void duk__peephole_optimize_bytecode(duk_compiler_ctx *comp_ctx) { + duk_compiler_instr *bc; + duk_small_uint_t iter; + duk_int_t i, n; + duk_int_t count_opt; + + bc = (duk_compiler_instr *) (void *) DUK_BW_GET_BASEPTR(comp_ctx->thr, &comp_ctx->curr_func.bw_code); +#if defined(DUK_USE_BUFLEN16) + /* No need to assert, buffer size maximum is 0xffff. */ +#else + DUK_ASSERT((duk_size_t) DUK_BW_GET_SIZE(comp_ctx->thr, &comp_ctx->curr_func.bw_code) / sizeof(duk_compiler_instr) <= + (duk_size_t) DUK_INT_MAX); /* bytecode limits */ +#endif + n = (duk_int_t) (DUK_BW_GET_SIZE(comp_ctx->thr, &comp_ctx->curr_func.bw_code) / sizeof(duk_compiler_instr)); + + for (iter = 0; iter < DUK_COMPILER_PEEPHOLE_MAXITER; iter++) { + count_opt = 0; + + for (i = 0; i < n; i++) { + duk_instr_t ins; + duk_int_t target_pc1; + duk_int_t target_pc2; + + ins = bc[i].ins; + if (DUK_DEC_OP(ins) != DUK_OP_JUMP) { + continue; + } + + target_pc1 = i + 1 + (duk_int_t) DUK_DEC_ABC(ins) - (duk_int_t) DUK_BC_JUMP_BIAS; + DUK_DDD(DUK_DDDPRINT("consider jump at pc %ld; target_pc=%ld", (long) i, (long) target_pc1)); + DUK_ASSERT(target_pc1 >= 0); + DUK_ASSERT(target_pc1 < n); + + /* Note: if target_pc1 == i, we'll optimize a jump to itself. + * This does not need to be checked for explicitly; the case + * is rare and max iter breaks us out. + */ + + ins = bc[target_pc1].ins; + if (DUK_DEC_OP(ins) != DUK_OP_JUMP) { + continue; + } + + target_pc2 = target_pc1 + 1 + (duk_int_t) DUK_DEC_ABC(ins) - (duk_int_t) DUK_BC_JUMP_BIAS; + + DUK_DDD(DUK_DDDPRINT("optimizing jump at pc %ld; old target is %ld -> new target is %ld", + (long) i, + (long) target_pc1, + (long) target_pc2)); + + bc[i].ins = DUK_ENC_OP_ABC(DUK_OP_JUMP, target_pc2 - (i + 1) + DUK_BC_JUMP_BIAS); + + count_opt++; + } + + DUK_DD(DUK_DDPRINT("optimized %ld jumps on peephole round %ld", (long) count_opt, (long) (iter + 1))); + + if (count_opt == 0) { + break; + } + } +} + +/* + * Intermediate value helpers + */ + +/* Flags for intermediate value coercions. A flag for using a forced reg + * is not needed, the forced_reg argument suffices and generates better + * code (it is checked as it is used). + */ +/* XXX: DUK__IVAL_FLAG_REQUIRE_SHORT is passed but not currently implemented + * by ispec/ivalue operations. + */ +#define DUK__IVAL_FLAG_ALLOW_CONST (1 << 0) /* allow a constant to be returned */ +#define DUK__IVAL_FLAG_REQUIRE_TEMP (1 << 1) /* require a (mutable) temporary as a result (or a const if allowed) */ +#define DUK__IVAL_FLAG_REQUIRE_SHORT (1 << 2) /* require a short (8-bit) reg/const which fits into bytecode B/C slot */ + +/* XXX: some code might benefit from DUK__SETTEMP_IFTEMP(thr,x) */ + +#if 0 /* enable manually for dumping */ +#define DUK__DUMP_ISPEC(compctx, ispec) \ + do { \ + duk__dump_ispec((compctx), (ispec)); \ + } while (0) +#define DUK__DUMP_IVALUE(compctx, ivalue) \ + do { \ + duk__dump_ivalue((compctx), (ivalue)); \ + } while (0) + +DUK_LOCAL void duk__dump_ispec(duk_compiler_ctx *comp_ctx, duk_ispec *x) { + DUK_D(DUK_DPRINT("ispec dump: t=%ld regconst=0x%08lx, valstack_idx=%ld, value=%!T", + (long) x->t, (unsigned long) x->regconst, (long) x->valstack_idx, + duk_get_tval(comp_ctx->thr, x->valstack_idx))); +} +DUK_LOCAL void duk__dump_ivalue(duk_compiler_ctx *comp_ctx, duk_ivalue *x) { + DUK_D(DUK_DPRINT("ivalue dump: t=%ld op=%ld " + "x1={t=%ld regconst=0x%08lx valstack_idx=%ld value=%!T} " + "x2={t=%ld regconst=0x%08lx valstack_idx=%ld value=%!T}", + (long) x->t, (long) x->op, + (long) x->x1.t, (unsigned long) x->x1.regconst, (long) x->x1.valstack_idx, + duk_get_tval(comp_ctx->thr, x->x1.valstack_idx), + (long) x->x2.t, (unsigned long) x->x2.regconst, (long) x->x2.valstack_idx, + duk_get_tval(comp_ctx->thr, x->x2.valstack_idx))); +} +#else +#define DUK__DUMP_ISPEC(comp_ctx, x) \ + do { \ + } while (0) +#define DUK__DUMP_IVALUE(comp_ctx, x) \ + do { \ + } while (0) +#endif + +DUK_LOCAL void duk__ivalue_regconst(duk_ivalue *x, duk_regconst_t regconst) { + x->t = DUK_IVAL_PLAIN; + x->x1.t = DUK_ISPEC_REGCONST; + x->x1.regconst = regconst; +} + +DUK_LOCAL void duk__ivalue_plain_fromstack(duk_compiler_ctx *comp_ctx, duk_ivalue *x) { + x->t = DUK_IVAL_PLAIN; + x->x1.t = DUK_ISPEC_VALUE; + duk_replace(comp_ctx->thr, x->x1.valstack_idx); +} + +DUK_LOCAL void duk__ivalue_var_fromstack(duk_compiler_ctx *comp_ctx, duk_ivalue *x) { + x->t = DUK_IVAL_VAR; + x->x1.t = DUK_ISPEC_VALUE; + duk_replace(comp_ctx->thr, x->x1.valstack_idx); +} + +DUK_LOCAL_DECL void duk__ivalue_var_hstring(duk_compiler_ctx *comp_ctx, duk_ivalue *x, duk_hstring *h) { + DUK_ASSERT(h != NULL); + duk_push_hstring(comp_ctx->thr, h); + duk__ivalue_var_fromstack(comp_ctx, x); +} + +DUK_LOCAL void duk__copy_ispec(duk_compiler_ctx *comp_ctx, duk_ispec *src, duk_ispec *dst) { + dst->t = src->t; + dst->regconst = src->regconst; + duk_copy(comp_ctx->thr, src->valstack_idx, dst->valstack_idx); +} + +DUK_LOCAL void duk__copy_ivalue(duk_compiler_ctx *comp_ctx, duk_ivalue *src, duk_ivalue *dst) { + dst->t = src->t; + dst->op = src->op; + dst->x1.t = src->x1.t; + dst->x1.regconst = src->x1.regconst; + dst->x2.t = src->x2.t; + dst->x2.regconst = src->x2.regconst; + duk_copy(comp_ctx->thr, src->x1.valstack_idx, dst->x1.valstack_idx); + duk_copy(comp_ctx->thr, src->x2.valstack_idx, dst->x2.valstack_idx); +} + +DUK_LOCAL duk_regconst_t duk__alloctemps(duk_compiler_ctx *comp_ctx, duk_small_int_t num) { + duk_regconst_t res; + + res = comp_ctx->curr_func.temp_next; + comp_ctx->curr_func.temp_next += num; + + if (comp_ctx->curr_func.temp_next > DUK__MAX_TEMPS) { /* == DUK__MAX_TEMPS is OK */ + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_TEMP_LIMIT); + DUK_WO_NORETURN(return 0;); + } + + /* maintain highest 'used' temporary, needed to figure out nregs of function */ + if (comp_ctx->curr_func.temp_next > comp_ctx->curr_func.temp_max) { + comp_ctx->curr_func.temp_max = comp_ctx->curr_func.temp_next; + } + + return res; +} + +DUK_LOCAL duk_regconst_t duk__alloctemp(duk_compiler_ctx *comp_ctx) { + return duk__alloctemps(comp_ctx, 1); +} + +DUK_LOCAL void duk__settemp_checkmax(duk_compiler_ctx *comp_ctx, duk_regconst_t temp_next) { + comp_ctx->curr_func.temp_next = temp_next; + if (temp_next > comp_ctx->curr_func.temp_max) { + comp_ctx->curr_func.temp_max = temp_next; + } +} + +/* get const for value at valstack top */ +DUK_LOCAL duk_regconst_t duk__getconst(duk_compiler_ctx *comp_ctx) { + duk_hthread *thr = comp_ctx->thr; + duk_compiler_func *f = &comp_ctx->curr_func; + duk_tval *tv1; + duk_int_t i, n, n_check; + + n = (duk_int_t) duk_get_length(thr, f->consts_idx); + + tv1 = DUK_GET_TVAL_NEGIDX(thr, -1); + DUK_ASSERT(tv1 != NULL); + +#if defined(DUK_USE_FASTINT) + /* Explicit check for fastint downgrade. */ + DUK_TVAL_CHKFAST_INPLACE_SLOW(tv1); +#endif + + /* Sanity workaround for handling functions with a large number of + * constants at least somewhat reasonably. Otherwise checking whether + * we already have the constant would grow very slow (as it is O(N^2)). + */ + n_check = (n > DUK__GETCONST_MAX_CONSTS_CHECK ? DUK__GETCONST_MAX_CONSTS_CHECK : n); + for (i = 0; i < n_check; i++) { + duk_tval *tv2 = DUK_HOBJECT_A_GET_VALUE_PTR(thr->heap, f->h_consts, i); + + /* Strict equality is NOT enough, because we cannot use the same + * constant for e.g. +0 and -0. + */ + if (duk_js_samevalue(tv1, tv2)) { + DUK_DDD(DUK_DDDPRINT("reused existing constant for %!T -> const index %ld", (duk_tval *) tv1, (long) i)); + duk_pop(thr); + return (duk_regconst_t) i | (duk_regconst_t) DUK__CONST_MARKER; + } + } + + if (n > DUK__MAX_CONSTS) { + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_CONST_LIMIT); + DUK_WO_NORETURN(return 0;); + } + + DUK_DDD(DUK_DDDPRINT("allocating new constant for %!T -> const index %ld", (duk_tval *) tv1, (long) n)); + (void) duk_put_prop_index(thr, f->consts_idx, (duk_uarridx_t) n); /* invalidates tv1, tv2 */ + return (duk_regconst_t) n | (duk_regconst_t) DUK__CONST_MARKER; +} + +DUK_LOCAL duk_bool_t duk__const_needs_refcount(duk_compiler_ctx *comp_ctx, duk_regconst_t rc) { +#if defined(DUK_USE_REFERENCE_COUNTING) + duk_compiler_func *f = &comp_ctx->curr_func; + duk_bool_t ret; + + DUK_ASSERT((rc & DUK__CONST_MARKER) == 0); /* caller removes const marker */ + (void) duk_get_prop_index(comp_ctx->thr, f->consts_idx, (duk_uarridx_t) rc); + ret = !duk_is_number(comp_ctx->thr, -1); /* now only number/string, so conservative check */ + duk_pop(comp_ctx->thr); + return ret; +#else + DUK_UNREF(comp_ctx); + DUK_UNREF(rc); + DUK_ASSERT((rc & DUK__CONST_MARKER) == 0); /* caller removes const marker */ + return 0; +#endif +} + +/* Get the value represented by an duk_ispec to a register or constant. + * The caller can control the result by indicating whether or not: + * + * (1) a constant is allowed (sometimes the caller needs the result to + * be in a register) + * + * (2) a temporary register is required (usually when caller requires + * the register to be safely mutable; normally either a bound + * register or a temporary register are both OK) + * + * (3) a forced register target needs to be used + * + * Bytecode may be emitted to generate the necessary value. The return + * value is either a register or a constant. + */ + +DUK_LOCAL +duk_regconst_t duk__ispec_toregconst_raw(duk_compiler_ctx *comp_ctx, + duk_ispec *x, + duk_regconst_t forced_reg, + duk_small_uint_t flags) { + duk_hthread *thr = comp_ctx->thr; + + DUK_DDD(DUK_DDDPRINT("duk__ispec_toregconst_raw(): x={%ld:%ld:%!T}, " + "forced_reg=%ld, flags 0x%08lx: allow_const=%ld require_temp=%ld require_short=%ld", + (long) x->t, + (long) x->regconst, + (duk_tval *) duk_get_tval(thr, x->valstack_idx), + (long) forced_reg, + (unsigned long) flags, + (long) ((flags & DUK__IVAL_FLAG_ALLOW_CONST) ? 1 : 0), + (long) ((flags & DUK__IVAL_FLAG_REQUIRE_TEMP) ? 1 : 0), + (long) ((flags & DUK__IVAL_FLAG_REQUIRE_SHORT) ? 1 : 0))); + + switch (x->t) { + case DUK_ISPEC_VALUE: { + duk_tval *tv; + + tv = DUK_GET_TVAL_POSIDX(thr, x->valstack_idx); + DUK_ASSERT(tv != NULL); + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNDEFINED: { + /* Note: although there is no 'undefined' literal, undefined + * values can occur during compilation as a result of e.g. + * the 'void' operator. + */ + duk_regconst_t dest = (forced_reg >= 0 ? forced_reg : DUK__ALLOCTEMP(comp_ctx)); + duk__emit_bc(comp_ctx, DUK_OP_LDUNDEF, dest); + return dest; + } + case DUK_TAG_NULL: { + duk_regconst_t dest = (forced_reg >= 0 ? forced_reg : DUK__ALLOCTEMP(comp_ctx)); + duk__emit_bc(comp_ctx, DUK_OP_LDNULL, dest); + return dest; + } + case DUK_TAG_BOOLEAN: { + duk_regconst_t dest = (forced_reg >= 0 ? forced_reg : DUK__ALLOCTEMP(comp_ctx)); + duk__emit_bc(comp_ctx, (DUK_TVAL_GET_BOOLEAN(tv) ? DUK_OP_LDTRUE : DUK_OP_LDFALSE), dest); + return dest; + } + case DUK_TAG_POINTER: { + DUK_UNREACHABLE(); + break; + } + case DUK_TAG_STRING: { + duk_hstring *h; + duk_regconst_t dest; + duk_regconst_t constidx; + + h = DUK_TVAL_GET_STRING(tv); + DUK_UNREF(h); + DUK_ASSERT(h != NULL); + +#if 0 /* XXX: to be implemented? */ + /* Use special opcodes to load short strings */ + if (DUK_HSTRING_GET_BYTELEN(h) <= 2) { + /* Encode into a single opcode (18 bits can encode 1-2 bytes + length indicator) */ + } else if (DUK_HSTRING_GET_BYTELEN(h) <= 6) { + /* Encode into a double constant (53 bits can encode 6*8 = 48 bits + 3-bit length */ + } +#endif + duk_dup(thr, x->valstack_idx); + constidx = duk__getconst(comp_ctx); + + if (flags & DUK__IVAL_FLAG_ALLOW_CONST) { + return constidx; + } + + dest = (forced_reg >= 0 ? forced_reg : DUK__ALLOCTEMP(comp_ctx)); + duk__emit_a_bc(comp_ctx, DUK_OP_LDCONST, dest, constidx); + return dest; + } + case DUK_TAG_OBJECT: { + DUK_UNREACHABLE(); + break; + } + case DUK_TAG_BUFFER: { + DUK_UNREACHABLE(); + break; + } + case DUK_TAG_LIGHTFUNC: { + DUK_UNREACHABLE(); + break; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: { + /* number */ + duk_regconst_t dest; + duk_regconst_t constidx; + duk_double_t dval; + duk_int32_t ival; + + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + dval = DUK_TVAL_GET_NUMBER(tv); + + if (!(flags & DUK__IVAL_FLAG_ALLOW_CONST)) { + /* A number can be loaded either through a constant, using + * LDINT, or using LDINT+LDINTX. LDINT is always a size win, + * LDINT+LDINTX is not if the constant is used multiple times. + * Currently always prefer LDINT+LDINTX over a double constant. + */ + + if (duk_is_whole_get_int32_nonegzero(dval, &ival)) { + dest = (forced_reg >= 0 ? forced_reg : DUK__ALLOCTEMP(comp_ctx)); + duk__emit_load_int32(comp_ctx, dest, ival); + return dest; + } + } + + duk_dup(thr, x->valstack_idx); + constidx = duk__getconst(comp_ctx); + + if (flags & DUK__IVAL_FLAG_ALLOW_CONST) { + return constidx; + } else { + dest = (forced_reg >= 0 ? forced_reg : DUK__ALLOCTEMP(comp_ctx)); + duk__emit_a_bc(comp_ctx, DUK_OP_LDCONST, dest, constidx); + return dest; + } + } + } /* end switch */ + goto fail_internal; /* never here */ + } + case DUK_ISPEC_REGCONST: { + if (forced_reg >= 0) { + if (DUK__ISCONST(x->regconst)) { + duk__emit_a_bc(comp_ctx, DUK_OP_LDCONST, forced_reg, x->regconst); + } else if (x->regconst != forced_reg) { + duk__emit_a_bc(comp_ctx, DUK_OP_LDREG, forced_reg, x->regconst); + } else { + ; /* already in correct reg */ + } + return forced_reg; + } + + DUK_ASSERT(forced_reg < 0); + if (DUK__ISCONST(x->regconst)) { + if (!(flags & DUK__IVAL_FLAG_ALLOW_CONST)) { + duk_regconst_t dest = DUK__ALLOCTEMP(comp_ctx); + duk__emit_a_bc(comp_ctx, DUK_OP_LDCONST, dest, x->regconst); + return dest; + } + return x->regconst; + } + + DUK_ASSERT(forced_reg < 0 && !DUK__ISCONST(x->regconst)); + if ((flags & DUK__IVAL_FLAG_REQUIRE_TEMP) && !DUK__ISREG_TEMP(comp_ctx, x->regconst)) { + duk_regconst_t dest = DUK__ALLOCTEMP(comp_ctx); + duk__emit_a_bc(comp_ctx, DUK_OP_LDREG, dest, x->regconst); + return dest; + } + return x->regconst; + } + default: { + break; /* never here */ + } + } + +fail_internal: + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return 0;); +} + +DUK_LOCAL void duk__ispec_toforcedreg(duk_compiler_ctx *comp_ctx, duk_ispec *x, duk_regconst_t forced_reg) { + DUK_ASSERT(forced_reg >= 0); + (void) duk__ispec_toregconst_raw(comp_ctx, x, forced_reg, 0 /*flags*/); +} + +/* Coerce an duk_ivalue to a 'plain' value by generating the necessary + * arithmetic operations, property access, or variable access bytecode. + * The duk_ivalue argument ('x') is converted into a plain value as a + * side effect. + */ +DUK_LOCAL void duk__ivalue_toplain_raw(duk_compiler_ctx *comp_ctx, duk_ivalue *x, duk_regconst_t forced_reg) { + duk_hthread *thr = comp_ctx->thr; + + DUK_DDD(DUK_DDDPRINT("duk__ivalue_toplain_raw(): x={t=%ld,op=%ld,x1={%ld:%ld:%!T},x2={%ld:%ld:%!T}}, " + "forced_reg=%ld", + (long) x->t, + (long) x->op, + (long) x->x1.t, + (long) x->x1.regconst, + (duk_tval *) duk_get_tval(thr, x->x1.valstack_idx), + (long) x->x2.t, + (long) x->x2.regconst, + (duk_tval *) duk_get_tval(thr, x->x2.valstack_idx), + (long) forced_reg)); + + switch (x->t) { + case DUK_IVAL_PLAIN: { + return; + } + /* XXX: support unary arithmetic ivalues (useful?) */ + case DUK_IVAL_ARITH: { + duk_regconst_t arg1; + duk_regconst_t arg2; + duk_regconst_t dest; + duk_tval *tv1; + duk_tval *tv2; + + DUK_DDD(DUK_DDDPRINT("arith to plain conversion")); + + /* inline arithmetic check for constant values */ + /* XXX: use the exactly same arithmetic function here as in executor */ + if (x->x1.t == DUK_ISPEC_VALUE && x->x2.t == DUK_ISPEC_VALUE && x->t == DUK_IVAL_ARITH) { + tv1 = DUK_GET_TVAL_POSIDX(thr, x->x1.valstack_idx); + tv2 = DUK_GET_TVAL_POSIDX(thr, x->x2.valstack_idx); + DUK_ASSERT(tv1 != NULL); + DUK_ASSERT(tv2 != NULL); + + DUK_DDD(DUK_DDDPRINT("arith: tv1=%!T, tv2=%!T", (duk_tval *) tv1, (duk_tval *) tv2)); + + if (DUK_TVAL_IS_NUMBER(tv1) && DUK_TVAL_IS_NUMBER(tv2)) { + duk_double_t d1 = DUK_TVAL_GET_NUMBER(tv1); + duk_double_t d2 = DUK_TVAL_GET_NUMBER(tv2); + duk_double_t d3; + duk_bool_t accept_fold = 1; + + DUK_DDD(DUK_DDDPRINT("arith inline check: d1=%lf, d2=%lf, op=%ld", + (double) d1, + (double) d2, + (long) x->op)); + switch (x->op) { + case DUK_OP_ADD: { + d3 = d1 + d2; + break; + } + case DUK_OP_SUB: { + d3 = d1 - d2; + break; + } + case DUK_OP_MUL: { + d3 = d1 * d2; + break; + } + case DUK_OP_DIV: { + /* Division-by-zero is undefined + * behavior, so rely on a helper. + */ + d3 = duk_double_div(d1, d2); + break; + } + case DUK_OP_EXP: { + d3 = (duk_double_t) duk_js_arith_pow((double) d1, (double) d2); + break; + } + default: { + d3 = 0.0; /* Won't be used, but silence MSVC /W4 warning. */ + accept_fold = 0; + break; + } + } + + if (accept_fold) { + duk_double_union du; + du.d = d3; + DUK_DBLUNION_NORMALIZE_NAN_CHECK(&du); + d3 = du.d; + + x->t = DUK_IVAL_PLAIN; + DUK_ASSERT(x->x1.t == DUK_ISPEC_VALUE); + DUK_TVAL_SET_NUMBER(tv1, d3); /* old value is number: no refcount */ + return; + } + } else if (x->op == DUK_OP_ADD && DUK_TVAL_IS_STRING(tv1) && DUK_TVAL_IS_STRING(tv2)) { + /* Inline string concatenation. No need to check for + * symbols, as all inputs are valid ECMAScript strings. + */ + duk_dup(thr, x->x1.valstack_idx); + duk_dup(thr, x->x2.valstack_idx); + duk_concat(thr, 2); + duk_replace(thr, x->x1.valstack_idx); + x->t = DUK_IVAL_PLAIN; + DUK_ASSERT(x->x1.t == DUK_ISPEC_VALUE); + return; + } + } + + arg1 = duk__ispec_toregconst_raw(comp_ctx, + &x->x1, + -1, + DUK__IVAL_FLAG_ALLOW_CONST | DUK__IVAL_FLAG_REQUIRE_SHORT /*flags*/); + arg2 = duk__ispec_toregconst_raw(comp_ctx, + &x->x2, + -1, + DUK__IVAL_FLAG_ALLOW_CONST | DUK__IVAL_FLAG_REQUIRE_SHORT /*flags*/); + + /* If forced reg, use it as destination. Otherwise try to + * use either coerced ispec if it is a temporary. + */ + if (forced_reg >= 0) { + dest = forced_reg; + } else if (DUK__ISREG_TEMP(comp_ctx, arg1)) { + dest = arg1; + } else if (DUK__ISREG_TEMP(comp_ctx, arg2)) { + dest = arg2; + } else { + dest = DUK__ALLOCTEMP(comp_ctx); + } + + DUK_ASSERT(DUK__ISREG(dest)); + duk__emit_a_b_c(comp_ctx, x->op | DUK__EMIT_FLAG_BC_REGCONST, dest, arg1, arg2); + + duk__ivalue_regconst(x, dest); + return; + } + case DUK_IVAL_PROP: { + /* XXX: very similar to DUK_IVAL_ARITH - merge? */ + duk_regconst_t arg1; + duk_regconst_t arg2; + duk_regconst_t dest; + + /* Need a short reg/const, does not have to be a mutable temp. */ + arg1 = duk__ispec_toregconst_raw(comp_ctx, + &x->x1, + -1, + DUK__IVAL_FLAG_ALLOW_CONST | DUK__IVAL_FLAG_REQUIRE_SHORT /*flags*/); + arg2 = duk__ispec_toregconst_raw(comp_ctx, + &x->x2, + -1, + DUK__IVAL_FLAG_ALLOW_CONST | DUK__IVAL_FLAG_REQUIRE_SHORT /*flags*/); + + /* Pick a destination register. If either base value or key + * happens to be a temp value, reuse it as the destination. + * + * XXX: The temp must be a "mutable" one, i.e. such that no + * other expression is using it anymore. Here this should be + * the case because the value of a property access expression + * is neither the base nor the key, but the lookup result. + */ + + if (forced_reg >= 0) { + dest = forced_reg; + } else if (DUK__ISREG_TEMP(comp_ctx, arg1)) { + dest = arg1; + } else if (DUK__ISREG_TEMP(comp_ctx, arg2)) { + dest = arg2; + } else { + dest = DUK__ALLOCTEMP(comp_ctx); + } + + duk__emit_a_b_c(comp_ctx, DUK_OP_GETPROP | DUK__EMIT_FLAG_BC_REGCONST, dest, arg1, arg2); + + duk__ivalue_regconst(x, dest); + return; + } + case DUK_IVAL_VAR: { + /* x1 must be a string */ + duk_regconst_t dest; + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + DUK_ASSERT(x->x1.t == DUK_ISPEC_VALUE); + + duk_dup(thr, x->x1.valstack_idx); + if (duk__lookup_lhs(comp_ctx, ®_varbind, &rc_varname)) { + duk__ivalue_regconst(x, reg_varbind); + } else { + dest = (forced_reg >= 0 ? forced_reg : DUK__ALLOCTEMP(comp_ctx)); + duk__emit_a_bc(comp_ctx, DUK_OP_GETVAR, dest, rc_varname); + duk__ivalue_regconst(x, dest); + } + return; + } + case DUK_IVAL_NONE: + default: { + DUK_D(DUK_DPRINT("invalid ivalue type: %ld", (long) x->t)); + break; + } + } + + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return;); +} + +/* evaluate to plain value, no forced register (temp/bound reg both ok) */ +DUK_LOCAL void duk__ivalue_toplain(duk_compiler_ctx *comp_ctx, duk_ivalue *x) { + duk__ivalue_toplain_raw(comp_ctx, x, -1 /*forced_reg*/); +} + +/* evaluate to final form (e.g. coerce GETPROP to code), throw away temp */ +DUK_LOCAL void duk__ivalue_toplain_ignore(duk_compiler_ctx *comp_ctx, duk_ivalue *x) { + duk_regconst_t temp; + + /* If duk__ivalue_toplain_raw() allocates a temp, forget it and + * restore next temp state. + */ + temp = DUK__GETTEMP(comp_ctx); + duk__ivalue_toplain_raw(comp_ctx, x, -1 /*forced_reg*/); + DUK__SETTEMP(comp_ctx, temp); +} + +/* Coerce an duk_ivalue to a register or constant; result register may + * be a temp or a bound register. + * + * The duk_ivalue argument ('x') is converted into a regconst as a + * side effect. + */ +DUK_LOCAL +duk_regconst_t duk__ivalue_toregconst_raw(duk_compiler_ctx *comp_ctx, + duk_ivalue *x, + duk_regconst_t forced_reg, + duk_small_uint_t flags) { + duk_hthread *thr = comp_ctx->thr; + duk_regconst_t reg; + DUK_UNREF(thr); + + DUK_DDD(DUK_DDDPRINT("duk__ivalue_toregconst_raw(): x={t=%ld,op=%ld,x1={%ld:%ld:%!T},x2={%ld:%ld:%!T}}, " + "forced_reg=%ld, flags 0x%08lx: allow_const=%ld require_temp=%ld require_short=%ld", + (long) x->t, + (long) x->op, + (long) x->x1.t, + (long) x->x1.regconst, + (duk_tval *) duk_get_tval(thr, x->x1.valstack_idx), + (long) x->x2.t, + (long) x->x2.regconst, + (duk_tval *) duk_get_tval(thr, x->x2.valstack_idx), + (long) forced_reg, + (unsigned long) flags, + (long) ((flags & DUK__IVAL_FLAG_ALLOW_CONST) ? 1 : 0), + (long) ((flags & DUK__IVAL_FLAG_REQUIRE_TEMP) ? 1 : 0), + (long) ((flags & DUK__IVAL_FLAG_REQUIRE_SHORT) ? 1 : 0))); + + /* first coerce to a plain value */ + duk__ivalue_toplain_raw(comp_ctx, x, forced_reg); + DUK_ASSERT(x->t == DUK_IVAL_PLAIN); + + /* then to a register */ + reg = duk__ispec_toregconst_raw(comp_ctx, &x->x1, forced_reg, flags); + duk__ivalue_regconst(x, reg); + + return reg; +} + +DUK_LOCAL duk_regconst_t duk__ivalue_toreg(duk_compiler_ctx *comp_ctx, duk_ivalue *x) { + return duk__ivalue_toregconst_raw(comp_ctx, x, -1, 0 /*flags*/); +} + +#if 0 /* unused */ +DUK_LOCAL duk_regconst_t duk__ivalue_totemp(duk_compiler_ctx *comp_ctx, duk_ivalue *x) { + return duk__ivalue_toregconst_raw(comp_ctx, x, -1, DUK__IVAL_FLAG_REQUIRE_TEMP /*flags*/); +} +#endif + +DUK_LOCAL void duk__ivalue_toforcedreg(duk_compiler_ctx *comp_ctx, duk_ivalue *x, duk_int_t forced_reg) { + DUK_ASSERT(forced_reg >= 0); + (void) duk__ivalue_toregconst_raw(comp_ctx, x, forced_reg, 0 /*flags*/); +} + +DUK_LOCAL duk_regconst_t duk__ivalue_toregconst(duk_compiler_ctx *comp_ctx, duk_ivalue *x) { + return duk__ivalue_toregconst_raw(comp_ctx, x, -1, DUK__IVAL_FLAG_ALLOW_CONST /*flags*/); +} + +DUK_LOCAL duk_regconst_t duk__ivalue_totempconst(duk_compiler_ctx *comp_ctx, duk_ivalue *x) { + return duk__ivalue_toregconst_raw(comp_ctx, x, -1, DUK__IVAL_FLAG_ALLOW_CONST | DUK__IVAL_FLAG_REQUIRE_TEMP /*flags*/); +} + +/* The issues below can be solved with better flags */ + +/* XXX: many operations actually want toforcedtemp() -- brand new temp? */ +/* XXX: need a toplain_ignore() which will only coerce a value to a temp + * register if it might have a side effect. Side-effect free values do not + * need to be coerced. + */ + +/* + * Identifier handling + */ + +DUK_LOCAL duk_regconst_t duk__lookup_active_register_binding(duk_compiler_ctx *comp_ctx) { + duk_hthread *thr = comp_ctx->thr; + duk_hstring *h_varname; + duk_regconst_t ret; + + DUK_DDD(DUK_DDDPRINT("resolving identifier reference to '%!T'", (duk_tval *) duk_get_tval(thr, -1))); + + /* + * Special name handling + */ + + h_varname = duk_known_hstring(thr, -1); + + if (h_varname == DUK_HTHREAD_STRING_LC_ARGUMENTS(thr)) { + DUK_DDD(DUK_DDDPRINT("flagging function as accessing 'arguments'")); + comp_ctx->curr_func.id_access_arguments = 1; + } + + /* + * Inside one or more 'with' statements fall back to slow path always. + * (See e.g. test-stmt-with.js.) + */ + + if (comp_ctx->curr_func.with_depth > 0) { + DUK_DDD(DUK_DDDPRINT("identifier lookup inside a 'with' -> fall back to slow path")); + goto slow_path_own; + } + + /* + * Any catch bindings ("catch (e)") also affect identifier binding. + * + * Currently, the varmap is modified for the duration of the catch + * clause to ensure any identifier accesses with the catch variable + * name will use slow path. + */ + + duk_get_prop(thr, comp_ctx->curr_func.varmap_idx); + if (duk_is_number(thr, -1)) { + ret = duk_to_int(thr, -1); + duk_pop(thr); + } else { + duk_pop(thr); + if (comp_ctx->curr_func.catch_depth > 0 || comp_ctx->curr_func.with_depth > 0) { + DUK_DDD(DUK_DDDPRINT("slow path access from inside a try-catch or with needs _Varmap")); + goto slow_path_own; + } else { + /* In this case we're doing a variable lookup that doesn't + * match our own variables, so _Varmap won't be needed at + * run time. + */ + DUK_DDD(DUK_DDDPRINT("slow path access outside of try-catch and with, no need for _Varmap")); + goto slow_path_notown; + } + } + + DUK_DDD(DUK_DDDPRINT("identifier lookup -> reg %ld", (long) ret)); + return ret; + +slow_path_notown: + DUK_DDD(DUK_DDDPRINT("identifier lookup -> slow path, not own variable")); + + comp_ctx->curr_func.id_access_slow = 1; + return (duk_regconst_t) -1; + +slow_path_own: + DUK_DDD(DUK_DDDPRINT("identifier lookup -> slow path, may be own variable")); + + comp_ctx->curr_func.id_access_slow = 1; + comp_ctx->curr_func.id_access_slow_own = 1; + return (duk_regconst_t) -1; +} + +/* Lookup an identifier name in the current varmap, indicating whether the + * identifier is register-bound and if not, allocating a constant for the + * identifier name. Returns 1 if register-bound, 0 otherwise. Caller can + * also check (out_reg_varbind >= 0) to check whether or not identifier is + * register bound. The caller must NOT use out_rc_varname at all unless + * return code is 0 or out_reg_varbind is < 0; this is becuase out_rc_varname + * is unsigned and doesn't have a "unused" / none value. + */ +DUK_LOCAL duk_bool_t duk__lookup_lhs(duk_compiler_ctx *comp_ctx, duk_regconst_t *out_reg_varbind, duk_regconst_t *out_rc_varname) { + duk_hthread *thr = comp_ctx->thr; + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + /* [ ... varname ] */ + + duk_dup_top(thr); + reg_varbind = duk__lookup_active_register_binding(comp_ctx); + + if (reg_varbind >= 0) { + *out_reg_varbind = reg_varbind; + *out_rc_varname = 0; /* duk_regconst_t is unsigned, so use 0 as dummy value (ignored by caller) */ + duk_pop(thr); + return 1; + } else { + rc_varname = duk__getconst(comp_ctx); + *out_reg_varbind = -1; + *out_rc_varname = rc_varname; + return 0; + } +} + +/* + * Label handling + * + * Labels are initially added with flags prohibiting both break and continue. + * When the statement type is finally uncovered (after potentially multiple + * labels), all the labels are updated to allow/prohibit break and continue. + */ + +DUK_LOCAL void duk__add_label(duk_compiler_ctx *comp_ctx, duk_hstring *h_label, duk_int_t pc_label, duk_int_t label_id) { + duk_hthread *thr = comp_ctx->thr; + duk_size_t n; + duk_size_t new_size; + duk_uint8_t *p; + duk_labelinfo *li_start, *li; + + /* Duplicate (shadowing) labels are not allowed, except for the empty + * labels (which are used as default labels for switch and iteration + * statements). + * + * We could also allow shadowing of non-empty pending labels without any + * other issues than breaking the required label shadowing requirements + * of the E5 specification, see Section 12.12. + */ + + p = (duk_uint8_t *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(thr->heap, comp_ctx->curr_func.h_labelinfos); + li_start = (duk_labelinfo *) (void *) p; + li = (duk_labelinfo *) (void *) (p + DUK_HBUFFER_GET_SIZE(comp_ctx->curr_func.h_labelinfos)); + n = (duk_size_t) (li - li_start); + + while (li > li_start) { + li--; + + if (li->h_label == h_label && h_label != DUK_HTHREAD_STRING_EMPTY_STRING(thr)) { + DUK_ERROR_SYNTAX(thr, DUK_STR_DUPLICATE_LABEL); + DUK_WO_NORETURN(return;); + } + } + + duk_push_hstring(thr, h_label); + DUK_ASSERT(n <= DUK_UARRIDX_MAX); /* label limits */ + (void) duk_put_prop_index(thr, comp_ctx->curr_func.labelnames_idx, (duk_uarridx_t) n); + + new_size = (n + 1) * sizeof(duk_labelinfo); + duk_hbuffer_resize(thr, comp_ctx->curr_func.h_labelinfos, new_size); + /* XXX: slack handling, slow now */ + + /* relookup after possible realloc */ + p = (duk_uint8_t *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(thr->heap, comp_ctx->curr_func.h_labelinfos); + li_start = (duk_labelinfo *) (void *) p; + DUK_UNREF(li_start); /* silence scan-build warning */ + li = (duk_labelinfo *) (void *) (p + DUK_HBUFFER_GET_SIZE(comp_ctx->curr_func.h_labelinfos)); + li--; + + /* Labels can be used for iteration statements but also for other statements, + * in particular a label can be used for a block statement. All cases of a + * named label accept a 'break' so that flag is set here. Iteration statements + * also allow 'continue', so that flag is updated when we figure out the + * statement type. + */ + + li->flags = DUK_LABEL_FLAG_ALLOW_BREAK; + li->label_id = label_id; + li->h_label = h_label; + li->catch_depth = comp_ctx->curr_func.catch_depth; /* catch depth from current func */ + li->pc_label = pc_label; + + DUK_DDD(DUK_DDDPRINT("registered label: flags=0x%08lx, id=%ld, name=%!O, catch_depth=%ld, pc_label=%ld", + (unsigned long) li->flags, + (long) li->label_id, + (duk_heaphdr *) li->h_label, + (long) li->catch_depth, + (long) li->pc_label)); +} + +/* Update all labels with matching label_id. */ +DUK_LOCAL void duk__update_label_flags(duk_compiler_ctx *comp_ctx, duk_int_t label_id, duk_small_uint_t flags) { + duk_uint8_t *p; + duk_labelinfo *li_start, *li; + + p = (duk_uint8_t *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(comp_ctx->thr->heap, comp_ctx->curr_func.h_labelinfos); + li_start = (duk_labelinfo *) (void *) p; + li = (duk_labelinfo *) (void *) (p + DUK_HBUFFER_GET_SIZE(comp_ctx->curr_func.h_labelinfos)); + + /* Match labels starting from latest; once label_id no longer matches, we can + * safely exit without checking the rest of the labels (only the topmost labels + * are ever updated). + */ + while (li > li_start) { + li--; + + if (li->label_id != label_id) { + break; + } + + DUK_DDD(DUK_DDDPRINT("updating (overwriting) label flags for li=%p, label_id=%ld, flags=%ld", + (void *) li, + (long) label_id, + (long) flags)); + + li->flags = flags; + } +} + +/* Lookup active label information. Break/continue distinction is necessary to handle switch + * statement related labels correctly: a switch will only catch a 'break', not a 'continue'. + * + * An explicit label cannot appear multiple times in the active set, but empty labels (unlabelled + * iteration and switch statements) can. A break will match the closest unlabelled or labelled + * statement. A continue will match the closest unlabelled or labelled iteration statement. It is + * a syntax error if a continue matches a labelled switch statement; because an explicit label cannot + * be duplicated, the continue cannot match any valid label outside the switch. + * + * A side effect of these rules is that a LABEL statement related to a switch should never actually + * catch a continue abrupt completion at run-time. Hence an INVALID opcode can be placed in the + * continue slot of the switch's LABEL statement. + */ + +/* XXX: awkward, especially the bunch of separate output values -> output struct? */ +DUK_LOCAL void duk__lookup_active_label(duk_compiler_ctx *comp_ctx, + duk_hstring *h_label, + duk_bool_t is_break, + duk_int_t *out_label_id, + duk_int_t *out_label_catch_depth, + duk_int_t *out_label_pc, + duk_bool_t *out_is_closest) { + duk_hthread *thr = comp_ctx->thr; + duk_uint8_t *p; + duk_labelinfo *li_start, *li_end, *li; + duk_bool_t match = 0; + + DUK_DDD(DUK_DDDPRINT("looking up active label: label='%!O', is_break=%ld", (duk_heaphdr *) h_label, (long) is_break)); + + DUK_UNREF(thr); + + p = (duk_uint8_t *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(thr->heap, comp_ctx->curr_func.h_labelinfos); + li_start = (duk_labelinfo *) (void *) p; + li_end = (duk_labelinfo *) (void *) (p + DUK_HBUFFER_GET_SIZE(comp_ctx->curr_func.h_labelinfos)); + li = li_end; + + /* Match labels starting from latest label because there can be duplicate empty + * labels in the label set. + */ + while (li > li_start) { + li--; + + if (li->h_label != h_label) { + DUK_DDD(DUK_DDDPRINT("labelinfo[%ld] ->'%!O' != %!O", + (long) (li - li_start), + (duk_heaphdr *) li->h_label, + (duk_heaphdr *) h_label)); + continue; + } + + DUK_DDD(DUK_DDDPRINT("labelinfo[%ld] -> '%!O' label name matches (still need to check type)", + (long) (li - li_start), + (duk_heaphdr *) h_label)); + + /* currently all labels accept a break, so no explicit check for it now */ + DUK_ASSERT(li->flags & DUK_LABEL_FLAG_ALLOW_BREAK); + + if (is_break) { + /* break matches always */ + match = 1; + break; + } else if (li->flags & DUK_LABEL_FLAG_ALLOW_CONTINUE) { + /* iteration statements allow continue */ + match = 1; + break; + } else { + /* continue matched this label -- we can only continue if this is the empty + * label, for which duplication is allowed, and thus there is hope of + * finding a match deeper in the label stack. + */ + if (h_label != DUK_HTHREAD_STRING_EMPTY_STRING(thr)) { + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_LABEL); + DUK_WO_NORETURN(return;); + } else { + DUK_DDD(DUK_DDDPRINT("continue matched an empty label which does not " + "allow a continue -> continue lookup deeper in label stack")); + } + } + } + /* XXX: match flag is awkward, rework */ + if (!match) { + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_LABEL); + DUK_WO_NORETURN(return;); + } + + DUK_DDD(DUK_DDDPRINT("label match: %!O -> label_id %ld, catch_depth=%ld, pc_label=%ld", + (duk_heaphdr *) h_label, + (long) li->label_id, + (long) li->catch_depth, + (long) li->pc_label)); + + *out_label_id = li->label_id; + *out_label_catch_depth = li->catch_depth; + *out_label_pc = li->pc_label; + *out_is_closest = (li == li_end - 1); +} + +DUK_LOCAL void duk__reset_labels_to_length(duk_compiler_ctx *comp_ctx, duk_size_t len) { + duk_hthread *thr = comp_ctx->thr; + + duk_set_length(thr, comp_ctx->curr_func.labelnames_idx, len); + duk_hbuffer_resize(thr, comp_ctx->curr_func.h_labelinfos, sizeof(duk_labelinfo) * len); +} + +/* + * Expression parsing: duk__expr_nud(), duk__expr_led(), duk__expr_lbp(), and helpers. + * + * - duk__expr_nud(): ("null denotation"): process prev_token as a "start" of an expression (e.g. literal) + * - duk__expr_led(): ("left denotation"): process prev_token in the "middle" of an expression (e.g. operator) + * - duk__expr_lbp(): ("left-binding power"): return left-binding power of curr_token + */ + +/* object literal key tracking flags */ +#define DUK__OBJ_LIT_KEY_PLAIN (1 << 0) /* key encountered as a plain property */ +#define DUK__OBJ_LIT_KEY_GET (1 << 1) /* key encountered as a getter */ +#define DUK__OBJ_LIT_KEY_SET (1 << 2) /* key encountered as a setter */ + +DUK_LOCAL void duk__nud_array_literal(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_hthread *thr = comp_ctx->thr; + duk_regconst_t reg_obj; /* result reg */ + duk_regconst_t reg_temp; /* temp reg */ + duk_regconst_t temp_start; /* temp reg value for start of loop */ + duk_small_uint_t max_init_values; /* max # of values initialized in one MPUTARR set */ + duk_small_uint_t num_values; /* number of values in current MPUTARR set */ + duk_uarridx_t curr_idx; /* current (next) array index */ + duk_uarridx_t start_idx; /* start array index of current MPUTARR set */ + duk_uarridx_t init_idx; /* last array index explicitly initialized, +1 */ + duk_bool_t require_comma; /* next loop requires a comma */ +#if !defined(DUK_USE_PREFER_SIZE) + duk_int_t pc_newarr; + duk_compiler_instr *instr; +#endif + + /* DUK_TOK_LBRACKET already eaten, current token is right after that */ + DUK_ASSERT(comp_ctx->prev_token.t == DUK_TOK_LBRACKET); + + max_init_values = DUK__MAX_ARRAY_INIT_VALUES; /* XXX: depend on available temps? */ + + reg_obj = DUK__ALLOCTEMP(comp_ctx); +#if !defined(DUK_USE_PREFER_SIZE) + pc_newarr = duk__get_current_pc(comp_ctx); +#endif + duk__emit_bc(comp_ctx, DUK_OP_NEWARR, reg_obj); /* XXX: patch initial size hint afterwards? */ + temp_start = DUK__GETTEMP(comp_ctx); + + /* + * Emit initializers in sets of maximum max_init_values. + * Corner cases such as single value initializers do not have + * special handling now. + * + * Elided elements must not be emitted as 'undefined' values, + * because such values would be enumerable (which is incorrect). + * Also note that trailing elisions must be reflected in the + * length of the final array but cause no elements to be actually + * inserted. + */ + + curr_idx = 0; + init_idx = 0; /* tracks maximum initialized index + 1 */ + start_idx = 0; + require_comma = 0; + + for (;;) { + num_values = 0; + DUK__SETTEMP(comp_ctx, temp_start); + + if (comp_ctx->curr_token.t == DUK_TOK_RBRACKET) { + break; + } + + for (;;) { + if (comp_ctx->curr_token.t == DUK_TOK_RBRACKET) { + /* the outer loop will recheck and exit */ + break; + } + + /* comma check */ + if (require_comma) { + if (comp_ctx->curr_token.t == DUK_TOK_COMMA) { + /* comma after a value, expected */ + duk__advance(comp_ctx); + require_comma = 0; + continue; + } else { + goto syntax_error; + } + } else { + if (comp_ctx->curr_token.t == DUK_TOK_COMMA) { + /* elision - flush */ + curr_idx++; + duk__advance(comp_ctx); + /* if num_values > 0, MPUTARR emitted by outer loop after break */ + break; + } + } + /* else an array initializer element */ + + /* initial index */ + if (num_values == 0) { + start_idx = curr_idx; + reg_temp = DUK__ALLOCTEMP(comp_ctx); + duk__emit_load_int32(comp_ctx, reg_temp, (duk_int32_t) start_idx); + } + + reg_temp = DUK__ALLOCTEMP(comp_ctx); /* alloc temp just in case, to update max temp */ + DUK__SETTEMP(comp_ctx, reg_temp); + duk__expr_toforcedreg(comp_ctx, res, DUK__BP_COMMA /*rbp_flags*/, reg_temp /*forced_reg*/); + DUK__SETTEMP(comp_ctx, reg_temp + 1); + + num_values++; + curr_idx++; + require_comma = 1; + + if (num_values >= max_init_values) { + /* MPUTARR emitted by outer loop */ + break; + } + } + + if (num_values > 0) { + /* - A is a source register (it's not a write target, but used + * to identify the target object) but can be shuffled. + * - B cannot be shuffled normally because it identifies a range + * of registers, the emitter has special handling for this + * (the "no shuffle" flag must not be set). + * - C is a non-register number and cannot be shuffled, but + * never needs to be. + */ + duk__emit_a_b_c(comp_ctx, + DUK_OP_MPUTARR | DUK__EMIT_FLAG_NO_SHUFFLE_C | DUK__EMIT_FLAG_A_IS_SOURCE, + reg_obj, + temp_start, + (duk_regconst_t) (num_values + 1)); + init_idx = start_idx + num_values; + + /* num_values and temp_start reset at top of outer loop */ + } + } + + /* Update initil size for NEWARR, doesn't need to be exact and is + * capped at A field limit. + */ +#if !defined(DUK_USE_PREFER_SIZE) + instr = duk__get_instr_ptr(comp_ctx, pc_newarr); + instr->ins |= DUK_ENC_OP_A(0, curr_idx > DUK_BC_A_MAX ? DUK_BC_A_MAX : curr_idx); +#endif + + DUK_ASSERT(comp_ctx->curr_token.t == DUK_TOK_RBRACKET); + duk__advance(comp_ctx); + + DUK_DDD(DUK_DDDPRINT("array literal done, curridx=%ld, initidx=%ld", (long) curr_idx, (long) init_idx)); + + /* trailing elisions? */ + if (curr_idx > init_idx) { + /* yes, must set array length explicitly */ + DUK_DDD(DUK_DDDPRINT("array literal has trailing elisions which affect its length")); + reg_temp = DUK__ALLOCTEMP(comp_ctx); + duk__emit_load_int32(comp_ctx, reg_temp, (duk_int_t) curr_idx); + duk__emit_a_bc(comp_ctx, DUK_OP_SETALEN | DUK__EMIT_FLAG_A_IS_SOURCE, reg_obj, reg_temp); + } + + DUK__SETTEMP(comp_ctx, temp_start); + + duk__ivalue_regconst(res, reg_obj); + return; + +syntax_error: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_ARRAY_LITERAL); + DUK_WO_NORETURN(return;); +} + +typedef struct { + duk_regconst_t reg_obj; + duk_regconst_t temp_start; + duk_small_uint_t num_pairs; + duk_small_uint_t num_total_pairs; +} duk__objlit_state; + +DUK_LOCAL void duk__objlit_flush_keys(duk_compiler_ctx *comp_ctx, duk__objlit_state *st) { + if (st->num_pairs > 0) { + /* - A is a source register (it's not a write target, but used + * to identify the target object) but can be shuffled. + * - B cannot be shuffled normally because it identifies a range + * of registers, the emitter has special handling for this + * (the "no shuffle" flag must not be set). + * - C is a non-register number and cannot be shuffled, but + * never needs to be. + */ + DUK_ASSERT(st->num_pairs > 0); + duk__emit_a_b_c(comp_ctx, + DUK_OP_MPUTOBJ | DUK__EMIT_FLAG_NO_SHUFFLE_C | DUK__EMIT_FLAG_A_IS_SOURCE, + st->reg_obj, + st->temp_start, + (duk_regconst_t) (st->num_pairs * 2)); + st->num_total_pairs += st->num_pairs; + st->num_pairs = 0; + } + DUK__SETTEMP(comp_ctx, st->temp_start); +} + +DUK_LOCAL duk_bool_t duk__objlit_load_key(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_token *tok, duk_regconst_t reg_temp) { + if (tok->t_nores == DUK_TOK_IDENTIFIER || tok->t_nores == DUK_TOK_STRING) { + /* same handling for identifiers and strings */ + DUK_ASSERT(tok->str1 != NULL); + duk_push_hstring(comp_ctx->thr, tok->str1); + } else if (tok->t == DUK_TOK_NUMBER) { + /* numbers can be loaded as numbers and coerced on the fly */ + duk_push_number(comp_ctx->thr, tok->num); + } else { + return 1; /* error */ + } + + duk__ivalue_plain_fromstack(comp_ctx, res); + DUK__SETTEMP(comp_ctx, reg_temp + 1); + duk__ivalue_toforcedreg(comp_ctx, res, reg_temp); + DUK__SETTEMP(comp_ctx, reg_temp + 1); + return 0; +} + +DUK_LOCAL void duk__nud_object_literal(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_hthread *thr = comp_ctx->thr; + duk__objlit_state st; + duk_regconst_t reg_temp; /* temp reg */ + duk_small_uint_t max_init_pairs; /* max # of key-value pairs initialized in one MPUTOBJ set */ + duk_bool_t first; /* first value: comma must not precede the value */ + duk_bool_t is_set, is_get; /* temps */ +#if !defined(DUK_USE_PREFER_SIZE) + duk_int_t pc_newobj; + duk_compiler_instr *instr; +#endif + + DUK_ASSERT(comp_ctx->prev_token.t == DUK_TOK_LCURLY); + + max_init_pairs = DUK__MAX_OBJECT_INIT_PAIRS; /* XXX: depend on available temps? */ + + st.reg_obj = DUK__ALLOCTEMP(comp_ctx); /* target object */ + st.temp_start = DUK__GETTEMP(comp_ctx); /* start of MPUTOBJ argument list */ + st.num_pairs = 0; /* number of key/value pairs emitted for current MPUTOBJ set */ + st.num_total_pairs = 0; /* number of key/value pairs emitted overall */ + +#if !defined(DUK_USE_PREFER_SIZE) + pc_newobj = duk__get_current_pc(comp_ctx); +#endif + duk__emit_bc(comp_ctx, DUK_OP_NEWOBJ, st.reg_obj); + + /* + * Emit initializers in sets of maximum max_init_pairs keys. + * Setter/getter is handled separately and terminates the + * current set of initializer values. Corner cases such as + * single value initializers do not have special handling now. + */ + + first = 1; + for (;;) { + /* + * ES5 and ES2015+ provide a lot of different PropertyDefinition + * formats, see http://www.ecma-international.org/ecma-262/6.0/#sec-object-initializer. + * + * PropertyName can be IdentifierName (includes reserved words), a string + * literal, or a number literal. Note that IdentifierName allows 'get' and + * 'set' too, so we need to look ahead to the next token to distinguish: + * + * { get : 1 } + * + * and + * + * { get foo() { return 1 } } + * { get get() { return 1 } } // 'get' as getter propertyname + * + * Finally, a trailing comma is allowed. + * + * Key name is coerced to string at compile time (and ends up as a + * a string constant) even for numeric keys (e.g. "{1:'foo'}"). + * These could be emitted using e.g. LDINT, but that seems hardly + * worth the effort and would increase code size. + */ + + DUK_DDD(DUK_DDDPRINT("object literal loop, curr_token->t = %ld", (long) comp_ctx->curr_token.t)); + + if (comp_ctx->curr_token.t == DUK_TOK_RCURLY) { + break; + } + + if (first) { + first = 0; + } else { + if (comp_ctx->curr_token.t != DUK_TOK_COMMA) { + goto syntax_error; + } + duk__advance(comp_ctx); + if (comp_ctx->curr_token.t == DUK_TOK_RCURLY) { + /* trailing comma followed by rcurly */ + break; + } + } + + /* Advance to get one step of lookup. */ + duk__advance(comp_ctx); + + /* Flush current MPUTOBJ if enough many pairs gathered. */ + if (st.num_pairs >= max_init_pairs) { + duk__objlit_flush_keys(comp_ctx, &st); + DUK_ASSERT(st.num_pairs == 0); + } + + /* Reset temp register state and reserve reg_temp and + * reg_temp + 1 for handling the current property. + */ + DUK__SETTEMP(comp_ctx, st.temp_start + 2 * (duk_regconst_t) st.num_pairs); + reg_temp = DUK__ALLOCTEMPS(comp_ctx, 2); + + /* NOTE: "get" and "set" are not officially ReservedWords and the lexer + * currently treats them always like ordinary identifiers (DUK_TOK_GET + * and DUK_TOK_SET are unused). They need to be detected based on the + * identifier string content. + */ + + is_get = (comp_ctx->prev_token.t == DUK_TOK_IDENTIFIER && comp_ctx->prev_token.str1 == DUK_HTHREAD_STRING_GET(thr)); + is_set = (comp_ctx->prev_token.t == DUK_TOK_IDENTIFIER && comp_ctx->prev_token.str1 == DUK_HTHREAD_STRING_SET(thr)); + if ((is_get || is_set) && comp_ctx->curr_token.t != DUK_TOK_COLON) { + /* getter/setter */ + duk_int_t fnum; + + duk__objlit_flush_keys(comp_ctx, &st); + DUK_ASSERT(DUK__GETTEMP(comp_ctx) == + st.temp_start); /* 2 regs are guaranteed to be allocated w.r.t. temp_max */ + reg_temp = DUK__ALLOCTEMPS(comp_ctx, 2); + + if (duk__objlit_load_key(comp_ctx, res, &comp_ctx->curr_token, reg_temp) != 0) { + goto syntax_error; + } + + /* curr_token = get/set name */ + fnum = duk__parse_func_like_fnum(comp_ctx, DUK__FUNC_FLAG_GETSET); + + duk__emit_a_bc(comp_ctx, DUK_OP_CLOSURE, st.temp_start + 1, (duk_regconst_t) fnum); + + /* Slot C is used in a non-standard fashion (range of regs), + * emitter code has special handling for it (must not set the + * "no shuffle" flag). + */ + duk__emit_a_bc(comp_ctx, + (is_get ? DUK_OP_INITGET : DUK_OP_INITSET) | DUK__EMIT_FLAG_A_IS_SOURCE, + st.reg_obj, + st.temp_start); /* temp_start+0 = key, temp_start+1 = closure */ + + DUK_ASSERT(st.num_pairs == 0); /* temp state is reset on next loop */ +#if defined(DUK_USE_ES6) + } else if (comp_ctx->prev_token.t == DUK_TOK_IDENTIFIER && + (comp_ctx->curr_token.t == DUK_TOK_COMMA || comp_ctx->curr_token.t == DUK_TOK_RCURLY)) { + duk_bool_t load_rc; + + load_rc = duk__objlit_load_key(comp_ctx, res, &comp_ctx->prev_token, reg_temp); + DUK_UNREF(load_rc); + DUK_ASSERT(load_rc == 0); /* always succeeds because token is identifier */ + + duk__ivalue_var_hstring(comp_ctx, res, comp_ctx->prev_token.str1); + DUK_ASSERT(DUK__GETTEMP(comp_ctx) == reg_temp + 1); + duk__ivalue_toforcedreg(comp_ctx, res, reg_temp + 1); + + st.num_pairs++; + } else if ((comp_ctx->prev_token.t == DUK_TOK_IDENTIFIER || comp_ctx->prev_token.t == DUK_TOK_STRING || + comp_ctx->prev_token.t == DUK_TOK_NUMBER) && + comp_ctx->curr_token.t == DUK_TOK_LPAREN) { + duk_int_t fnum; + + /* Parsing-wise there's a small hickup here: the token parsing + * state is one step too advanced for the function parse helper + * compared to other cases. The current solution is an extra + * flag to indicate whether function parsing should use the + * current or the previous token to starting parsing from. + */ + + if (duk__objlit_load_key(comp_ctx, res, &comp_ctx->prev_token, reg_temp) != 0) { + goto syntax_error; + } + + fnum = duk__parse_func_like_fnum(comp_ctx, DUK__FUNC_FLAG_USE_PREVTOKEN | DUK__FUNC_FLAG_METDEF); + + duk__emit_a_bc(comp_ctx, DUK_OP_CLOSURE, reg_temp + 1, (duk_regconst_t) fnum); + + st.num_pairs++; +#endif /* DUK_USE_ES6 */ + } else { +#if defined(DUK_USE_ES6) + if (comp_ctx->prev_token.t == DUK_TOK_LBRACKET) { + /* ES2015 computed property name. Executor ToPropertyKey() + * coerces the key at runtime. + */ + DUK__SETTEMP(comp_ctx, reg_temp); + duk__expr_toforcedreg(comp_ctx, res, DUK__BP_FOR_EXPR, reg_temp); + duk__advance_expect(comp_ctx, DUK_TOK_RBRACKET); + + /* XXX: If next token is '(' we're dealing with + * the method shorthand with a computed name, + * e.g. { [Symbol.for('foo')](a,b) {} }. This + * form is not yet supported and causes a + * SyntaxError on the DUK_TOK_COLON check below. + */ + } else +#endif /* DUK_USE_ES6 */ + { + if (duk__objlit_load_key(comp_ctx, res, &comp_ctx->prev_token, reg_temp) != 0) { + goto syntax_error; + } + } + + duk__advance_expect(comp_ctx, DUK_TOK_COLON); + + DUK__SETTEMP(comp_ctx, reg_temp + 1); + duk__expr_toforcedreg(comp_ctx, res, DUK__BP_COMMA /*rbp_flags*/, reg_temp + 1 /*forced_reg*/); + + st.num_pairs++; + } + } /* property loop */ + + /* Flush remaining properties. */ + duk__objlit_flush_keys(comp_ctx, &st); + DUK_ASSERT(st.num_pairs == 0); + DUK_ASSERT(DUK__GETTEMP(comp_ctx) == st.temp_start); + + /* Update initial size for NEWOBJ. The init size doesn't need to be + * exact as the purpose is just to avoid object resizes in common + * cases. The size is capped to field A limit, and will be too high + * if the object literal contains duplicate keys (this is harmless but + * increases memory traffic if the object is compacted later on). + */ +#if !defined(DUK_USE_PREFER_SIZE) + instr = duk__get_instr_ptr(comp_ctx, pc_newobj); + instr->ins |= DUK_ENC_OP_A(0, st.num_total_pairs > DUK_BC_A_MAX ? DUK_BC_A_MAX : st.num_total_pairs); +#endif + + DUK_ASSERT(comp_ctx->curr_token.t == DUK_TOK_RCURLY); + duk__advance(comp_ctx); /* No RegExp after object literal. */ + + duk__ivalue_regconst(res, st.reg_obj); + return; + +syntax_error: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_OBJECT_LITERAL); + DUK_WO_NORETURN(return;); +} + +/* Parse argument list. Arguments are written to temps starting from + * "next temp". Returns number of arguments parsed. Expects left paren + * to be already eaten, and eats the right paren before returning. + */ +DUK_LOCAL duk_int_t duk__parse_arguments(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_int_t nargs = 0; + duk_regconst_t reg_temp; + + /* Note: expect that caller has already eaten the left paren */ + + DUK_DDD(DUK_DDDPRINT("start parsing arguments, prev_token.t=%ld, curr_token.t=%ld", + (long) comp_ctx->prev_token.t, + (long) comp_ctx->curr_token.t)); + + for (;;) { + if (comp_ctx->curr_token.t == DUK_TOK_RPAREN) { + break; + } + if (nargs > 0) { + duk__advance_expect(comp_ctx, DUK_TOK_COMMA); + } + + /* We want the argument expression value to go to "next temp" + * without additional moves. That should almost always be the + * case, but we double check after expression parsing. + * + * This is not the cleanest possible approach. + */ + + reg_temp = DUK__ALLOCTEMP(comp_ctx); /* bump up "allocated" reg count, just in case */ + DUK__SETTEMP(comp_ctx, reg_temp); + + /* binding power must be high enough to NOT allow comma expressions directly */ + duk__expr_toforcedreg(comp_ctx, + res, + DUK__BP_COMMA /*rbp_flags*/, + reg_temp); /* always allow 'in', coerce to 'tr' just in case */ + + DUK__SETTEMP(comp_ctx, reg_temp + 1); + nargs++; + + DUK_DDD(DUK_DDDPRINT("argument #%ld written into reg %ld", (long) nargs, (long) reg_temp)); + } + + /* eat the right paren */ + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); /* RegExp mode does not matter. */ + + DUK_DDD(DUK_DDDPRINT("end parsing arguments")); + + return nargs; +} + +DUK_LOCAL duk_bool_t duk__expr_is_empty(duk_compiler_ctx *comp_ctx) { + /* empty expressions can be detected conveniently with nud/led counts */ + return (comp_ctx->curr_func.nud_count == 0) && (comp_ctx->curr_func.led_count == 0); +} + +DUK_LOCAL void duk__expr_nud(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_hthread *thr = comp_ctx->thr; + duk_token *tk; + duk_regconst_t temp_at_entry; + duk_small_uint_t tok; + duk_uint32_t args; /* temp variable to pass constants and flags to shared code */ + + /* + * ctx->prev_token token to process with duk__expr_nud() + * ctx->curr_token updated by caller + * + * Note: the token in the switch below has already been eaten. + */ + + temp_at_entry = DUK__GETTEMP(comp_ctx); + + comp_ctx->curr_func.nud_count++; + + tk = &comp_ctx->prev_token; + tok = tk->t; + res->t = DUK_IVAL_NONE; + + DUK_DDD(DUK_DDDPRINT("duk__expr_nud(), prev_token.t=%ld, allow_in=%ld, paren_level=%ld", + (long) tk->t, + (long) comp_ctx->curr_func.allow_in, + (long) comp_ctx->curr_func.paren_level)); + + switch (tok) { + /* PRIMARY EXPRESSIONS */ + + case DUK_TOK_THIS: { + duk_regconst_t reg_temp; + reg_temp = DUK__ALLOCTEMP(comp_ctx); + duk__emit_bc(comp_ctx, DUK_OP_LDTHIS, reg_temp); + duk__ivalue_regconst(res, reg_temp); + return; + } + case DUK_TOK_IDENTIFIER: { + duk__ivalue_var_hstring(comp_ctx, res, tk->str1); + return; + } + case DUK_TOK_NULL: { + duk_push_null(thr); + goto plain_value; + } + case DUK_TOK_TRUE: { + duk_push_true(thr); + goto plain_value; + } + case DUK_TOK_FALSE: { + duk_push_false(thr); + goto plain_value; + } + case DUK_TOK_NUMBER: { + duk_push_number(thr, tk->num); + goto plain_value; + } + case DUK_TOK_STRING: { + DUK_ASSERT(tk->str1 != NULL); + duk_push_hstring(thr, tk->str1); + goto plain_value; + } + case DUK_TOK_REGEXP: { +#if defined(DUK_USE_REGEXP_SUPPORT) + duk_regconst_t reg_temp; + duk_regconst_t rc_re_bytecode; /* const */ + duk_regconst_t rc_re_source; /* const */ + + DUK_ASSERT(tk->str1 != NULL); + DUK_ASSERT(tk->str2 != NULL); + + DUK_DDD(DUK_DDDPRINT("emitting regexp op, str1=%!O, str2=%!O", (duk_heaphdr *) tk->str1, (duk_heaphdr *) tk->str2)); + + reg_temp = DUK__ALLOCTEMP(comp_ctx); + duk_push_hstring(thr, tk->str1); + duk_push_hstring(thr, tk->str2); + + /* [ ... pattern flags ] */ + + duk_regexp_compile(thr); + + /* [ ... escaped_source bytecode ] */ + + rc_re_bytecode = duk__getconst(comp_ctx); + rc_re_source = duk__getconst(comp_ctx); + + duk__emit_a_b_c(comp_ctx, + DUK_OP_REGEXP | DUK__EMIT_FLAG_BC_REGCONST, + reg_temp /*a*/, + rc_re_bytecode /*b*/, + rc_re_source /*c*/); + + duk__ivalue_regconst(res, reg_temp); + return; +#else /* DUK_USE_REGEXP_SUPPORT */ + goto syntax_error; +#endif /* DUK_USE_REGEXP_SUPPORT */ + } + case DUK_TOK_LBRACKET: { + DUK_DDD(DUK_DDDPRINT("parsing array literal")); + duk__nud_array_literal(comp_ctx, res); + return; + } + case DUK_TOK_LCURLY: { + DUK_DDD(DUK_DDDPRINT("parsing object literal")); + duk__nud_object_literal(comp_ctx, res); + return; + } + case DUK_TOK_LPAREN: { + duk_bool_t prev_allow_in; + + comp_ctx->curr_func.paren_level++; + prev_allow_in = comp_ctx->curr_func.allow_in; + comp_ctx->curr_func.allow_in = 1; /* reset 'allow_in' for parenthesized expression */ + + duk__expr(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); /* Expression, terminates at a ')' */ + + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); /* No RegExp after parenthesized expression. */ + comp_ctx->curr_func.allow_in = prev_allow_in; + comp_ctx->curr_func.paren_level--; + return; + } + + /* MEMBER/NEW/CALL EXPRESSIONS */ + + case DUK_TOK_NEW: { + /* + * Parsing an expression starting with 'new' is tricky because + * there are multiple possible productions deriving from + * LeftHandSideExpression which begin with 'new'. + * + * We currently resort to one-token lookahead to distinguish the + * cases. Hopefully this is correct. The binding power must be + * such that parsing ends at an LPAREN (CallExpression) but not at + * a PERIOD or LBRACKET (MemberExpression). + * + * See doc/compiler.rst for discussion on the parsing approach, + * and testcases/test-dev-new.js for a bunch of documented tests. + */ + + duk_regconst_t reg_target; + duk_int_t nargs; + + DUK_DDD(DUK_DDDPRINT("begin parsing new expression")); + + reg_target = DUK__ALLOCTEMPS(comp_ctx, 2); + +#if defined(DUK_USE_ES6) + if (comp_ctx->curr_token.t == DUK_TOK_PERIOD) { + /* new.target */ + DUK_DDD(DUK_DDDPRINT("new.target")); + duk__advance(comp_ctx); + if (comp_ctx->curr_token.t_nores != DUK_TOK_IDENTIFIER || + !duk_hstring_equals_ascii_cstring(comp_ctx->curr_token.str1, "target")) { + goto syntax_error_newtarget; + } + if (comp_ctx->curr_func.is_global) { + goto syntax_error_newtarget; + } + duk__advance(comp_ctx); + duk__emit_bc(comp_ctx, DUK_OP_NEWTARGET, reg_target); + duk__ivalue_regconst(res, reg_target); + return; + } +#endif /* DUK_USE_ES6 */ + + duk__expr_toforcedreg(comp_ctx, res, DUK__BP_CALL /*rbp_flags*/, reg_target /*forced_reg*/); + duk__emit_bc(comp_ctx, DUK_OP_NEWOBJ, reg_target + 1); /* default instance */ + DUK__SETTEMP(comp_ctx, reg_target + 2); + + /* XXX: 'new obj.noSuch()' doesn't use GETPROPC now which + * makes the error message worse than for obj.noSuch(). + */ + + if (comp_ctx->curr_token.t == DUK_TOK_LPAREN) { + /* 'new' MemberExpression Arguments */ + DUK_DDD(DUK_DDDPRINT("new expression has argument list")); + duk__advance(comp_ctx); + nargs = duk__parse_arguments(comp_ctx, res); /* parse args starting from "next temp", reg_target + 1 */ + /* right paren eaten */ + } else { + /* 'new' MemberExpression */ + DUK_DDD(DUK_DDDPRINT("new expression has no argument list")); + nargs = 0; + } + + duk__emit_a_bc(comp_ctx, DUK_OP_CALL0 | DUK_BC_CALL_FLAG_CONSTRUCT, nargs /*num_args*/, reg_target /*target*/); + + DUK_DDD(DUK_DDDPRINT("end parsing new expression")); + + duk__ivalue_regconst(res, reg_target); + return; + } + + /* FUNCTION EXPRESSIONS */ + + case DUK_TOK_FUNCTION: { + /* Function expression. Note that any statement beginning with 'function' + * is handled by the statement parser as a function declaration, or a + * non-standard function expression/statement (or a SyntaxError). We only + * handle actual function expressions (occurring inside an expression) here. + * + * O(depth^2) parse count for inner functions is handled by recording a + * lexer offset on the first compilation pass, so that the function can + * be efficiently skipped on the second pass. This is encapsulated into + * duk__parse_func_like_fnum(). + */ + + duk_regconst_t reg_temp; + duk_int_t fnum; + + reg_temp = DUK__ALLOCTEMP(comp_ctx); + + /* curr_token follows 'function' */ + fnum = duk__parse_func_like_fnum(comp_ctx, 0 /*flags*/); + DUK_DDD(DUK_DDDPRINT("parsed inner function -> fnum %ld", (long) fnum)); + + duk__emit_a_bc(comp_ctx, DUK_OP_CLOSURE, reg_temp /*a*/, (duk_regconst_t) fnum /*bc*/); + + duk__ivalue_regconst(res, reg_temp); + return; + } + + /* UNARY EXPRESSIONS */ + + case DUK_TOK_DELETE: { + /* Delete semantics are a bit tricky. The description in E5 specification + * is kind of confusing, because it distinguishes between resolvability of + * a reference (which is only known at runtime) seemingly at compile time + * (= SyntaxError throwing). + */ + duk__expr(comp_ctx, res, DUK__BP_MULTIPLICATIVE /*rbp_flags*/); /* UnaryExpression */ + if (res->t == DUK_IVAL_VAR) { + /* not allowed in strict mode, regardless of whether resolves; + * in non-strict mode DELVAR handles both non-resolving and + * resolving cases (the specification description is a bit confusing). + */ + + duk_regconst_t reg_temp; + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + if (comp_ctx->curr_func.is_strict) { + DUK_ERROR_SYNTAX(thr, DUK_STR_CANNOT_DELETE_IDENTIFIER); + DUK_WO_NORETURN(return;); + } + + DUK__SETTEMP(comp_ctx, temp_at_entry); + reg_temp = DUK__ALLOCTEMP(comp_ctx); + + duk_dup(thr, res->x1.valstack_idx); + if (duk__lookup_lhs(comp_ctx, ®_varbind, &rc_varname)) { + /* register bound variables are non-configurable -> always false */ + duk__emit_bc(comp_ctx, DUK_OP_LDFALSE, reg_temp); + } else { + duk_dup(thr, res->x1.valstack_idx); + rc_varname = duk__getconst(comp_ctx); + duk__emit_a_bc(comp_ctx, DUK_OP_DELVAR, reg_temp, rc_varname); + } + duk__ivalue_regconst(res, reg_temp); + } else if (res->t == DUK_IVAL_PROP) { + duk_regconst_t reg_temp; + duk_regconst_t reg_obj; + duk_regconst_t rc_key; + + DUK__SETTEMP(comp_ctx, temp_at_entry); + reg_temp = DUK__ALLOCTEMP(comp_ctx); + reg_obj = + duk__ispec_toregconst_raw(comp_ctx, &res->x1, -1 /*forced_reg*/, 0 /*flags*/); /* don't allow const */ + rc_key = + duk__ispec_toregconst_raw(comp_ctx, &res->x2, -1 /*forced_reg*/, DUK__IVAL_FLAG_ALLOW_CONST /*flags*/); + duk__emit_a_b_c(comp_ctx, DUK_OP_DELPROP | DUK__EMIT_FLAG_BC_REGCONST, reg_temp, reg_obj, rc_key); + + duk__ivalue_regconst(res, reg_temp); + } else { + /* non-Reference deletion is always 'true', even in strict mode */ + duk_push_true(thr); + goto plain_value; + } + return; + } + case DUK_TOK_VOID: { + duk__expr_toplain_ignore(comp_ctx, res, DUK__BP_MULTIPLICATIVE /*rbp_flags*/); /* UnaryExpression */ + duk_push_undefined(thr); + goto plain_value; + } + case DUK_TOK_TYPEOF: { + /* 'typeof' must handle unresolvable references without throwing + * a ReferenceError (E5 Section 11.4.3). Register mapped values + * will never be unresolvable so special handling is only required + * when an identifier is a "slow path" one. + */ + duk__expr(comp_ctx, res, DUK__BP_MULTIPLICATIVE /*rbp_flags*/); /* UnaryExpression */ + + if (res->t == DUK_IVAL_VAR) { + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + duk_regconst_t reg_temp; + + duk_dup(thr, res->x1.valstack_idx); + if (!duk__lookup_lhs(comp_ctx, ®_varbind, &rc_varname)) { + DUK_DDD(DUK_DDDPRINT("typeof for an identifier name which could not be resolved " + "at compile time, need to use special run-time handling")); + reg_temp = DUK__ALLOCTEMP(comp_ctx); + duk__emit_a_bc(comp_ctx, DUK_OP_TYPEOFID, reg_temp, rc_varname); + duk__ivalue_regconst(res, reg_temp); + return; + } + } + + args = DUK_OP_TYPEOF; + goto unary; + } + case DUK_TOK_INCREMENT: { + args = (DUK_OP_PREINCP << 8) + DUK_OP_PREINCR; + goto preincdec; + } + case DUK_TOK_DECREMENT: { + args = (DUK_OP_PREDECP << 8) + DUK_OP_PREDECR; + goto preincdec; + } + case DUK_TOK_ADD: { + /* unary plus */ + duk__expr(comp_ctx, res, DUK__BP_MULTIPLICATIVE /*rbp_flags*/); /* UnaryExpression */ + if (res->t == DUK_IVAL_PLAIN && res->x1.t == DUK_ISPEC_VALUE && duk_is_number(thr, res->x1.valstack_idx)) { + /* unary plus of a number is identity */ + return; + } + args = DUK_OP_UNP; + goto unary; + } + case DUK_TOK_SUB: { + /* unary minus */ + duk__expr(comp_ctx, res, DUK__BP_MULTIPLICATIVE /*rbp_flags*/); /* UnaryExpression */ + if (res->t == DUK_IVAL_PLAIN && res->x1.t == DUK_ISPEC_VALUE && duk_is_number(thr, res->x1.valstack_idx)) { + /* this optimization is important to handle negative literals + * (which are not directly provided by the lexical grammar) + */ + duk_tval *tv_num; + duk_double_union du; + + tv_num = DUK_GET_TVAL_POSIDX(thr, res->x1.valstack_idx); + DUK_ASSERT(tv_num != NULL); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_num)); + du.d = DUK_TVAL_GET_NUMBER(tv_num); + du.d = -du.d; + DUK_DBLUNION_NORMALIZE_NAN_CHECK(&du); + DUK_TVAL_SET_NUMBER(tv_num, du.d); + return; + } + args = DUK_OP_UNM; + goto unary; + } + case DUK_TOK_BNOT: { + duk__expr(comp_ctx, res, DUK__BP_MULTIPLICATIVE /*rbp_flags*/); /* UnaryExpression */ + args = DUK_OP_BNOT; + goto unary; + } + case DUK_TOK_LNOT: { + duk__expr(comp_ctx, res, DUK__BP_MULTIPLICATIVE /*rbp_flags*/); /* UnaryExpression */ + if (res->t == DUK_IVAL_PLAIN && res->x1.t == DUK_ISPEC_VALUE) { + /* Very minimal inlining to handle common idioms '!0' and '!1', + * and also boolean arguments like '!false' and '!true'. + */ + duk_tval *tv_val; + + tv_val = DUK_GET_TVAL_POSIDX(thr, res->x1.valstack_idx); + DUK_ASSERT(tv_val != NULL); + if (DUK_TVAL_IS_NUMBER(tv_val)) { + duk_double_t d; + d = DUK_TVAL_GET_NUMBER(tv_val); + if (duk_double_equals(d, 0.0)) { + /* Matches both +0 and -0 on purpose. */ + DUK_DDD(DUK_DDDPRINT("inlined lnot: !0 -> true")); + DUK_TVAL_SET_BOOLEAN_TRUE(tv_val); + return; + } else if (duk_double_equals(d, 1.0)) { + DUK_DDD(DUK_DDDPRINT("inlined lnot: !1 -> false")); + DUK_TVAL_SET_BOOLEAN_FALSE(tv_val); + return; + } + } else if (DUK_TVAL_IS_BOOLEAN(tv_val)) { + duk_small_uint_t v; + v = DUK_TVAL_GET_BOOLEAN(tv_val); + DUK_DDD(DUK_DDDPRINT("inlined lnot boolean: %ld", (long) v)); + DUK_ASSERT(v == 0 || v == 1); + DUK_TVAL_SET_BOOLEAN(tv_val, v ^ 0x01); + return; + } + } + args = DUK_OP_LNOT; + goto unary; + } + + } /* end switch */ + + DUK_ERROR_SYNTAX(thr, DUK_STR_PARSE_ERROR); + DUK_WO_NORETURN(return;); + +unary : { + /* Unary opcodes use just the 'BC' register source because it + * matches current shuffle limits, and maps cleanly to 16 high + * bits of the opcode. + */ + + duk_regconst_t reg_src, reg_res; + + reg_src = duk__ivalue_toregconst_raw(comp_ctx, res, -1 /*forced_reg*/, 0 /*flags*/); + if (DUK__ISREG_TEMP(comp_ctx, reg_src)) { + reg_res = reg_src; + } else { + reg_res = DUK__ALLOCTEMP(comp_ctx); + } + duk__emit_a_bc(comp_ctx, args, reg_res, reg_src); + duk__ivalue_regconst(res, reg_res); + return; +} + +preincdec : { + /* preincrement and predecrement */ + duk_regconst_t reg_res; + duk_small_uint_t args_op1 = args & 0xff; /* DUK_OP_PREINCR/DUK_OP_PREDECR */ + duk_small_uint_t args_op2 = args >> 8; /* DUK_OP_PREINCP_RR/DUK_OP_PREDECP_RR */ + + /* Specific assumptions for opcode numbering. */ + DUK_ASSERT(DUK_OP_PREINCR + 4 == DUK_OP_PREINCV); + DUK_ASSERT(DUK_OP_PREDECR + 4 == DUK_OP_PREDECV); + + reg_res = DUK__ALLOCTEMP(comp_ctx); + + duk__expr(comp_ctx, res, DUK__BP_MULTIPLICATIVE /*rbp_flags*/); /* UnaryExpression */ + if (res->t == DUK_IVAL_VAR) { + duk_hstring *h_varname; + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + h_varname = duk_known_hstring(thr, res->x1.valstack_idx); + + if (duk__hstring_is_eval_or_arguments_in_strict_mode(comp_ctx, h_varname)) { + goto syntax_error; + } + + duk_dup(thr, res->x1.valstack_idx); + if (duk__lookup_lhs(comp_ctx, ®_varbind, &rc_varname)) { + duk__emit_a_bc(comp_ctx, + args_op1, /* e.g. DUK_OP_PREINCR */ + reg_res, + reg_varbind); + } else { + duk__emit_a_bc(comp_ctx, + args_op1 + 4, /* e.g. DUK_OP_PREINCV */ + reg_res, + rc_varname); + } + + DUK_DDD(DUK_DDDPRINT("preincdec to '%!O' -> reg_varbind=%ld, rc_varname=%ld", + (duk_heaphdr *) h_varname, + (long) reg_varbind, + (long) rc_varname)); + } else if (res->t == DUK_IVAL_PROP) { + duk_regconst_t reg_obj; /* allocate to reg only (not const) */ + duk_regconst_t rc_key; + reg_obj = duk__ispec_toregconst_raw(comp_ctx, &res->x1, -1 /*forced_reg*/, 0 /*flags*/); /* don't allow const */ + rc_key = duk__ispec_toregconst_raw(comp_ctx, &res->x2, -1 /*forced_reg*/, DUK__IVAL_FLAG_ALLOW_CONST /*flags*/); + duk__emit_a_b_c(comp_ctx, + args_op2 | DUK__EMIT_FLAG_BC_REGCONST, /* e.g. DUK_OP_PREINCP */ + reg_res, + reg_obj, + rc_key); + } else { + /* Technically return value is not needed because INVLHS will + * unconditially throw a ReferenceError. Coercion is necessary + * for proper semantics (consider ToNumber() called for an object). + * Use DUK_OP_UNP with a dummy register to get ToNumber(). + */ + + duk__ivalue_toforcedreg(comp_ctx, res, reg_res); + duk__emit_bc(comp_ctx, DUK_OP_UNP, reg_res); /* for side effects, result ignored */ + duk__emit_op_only(comp_ctx, DUK_OP_INVLHS); + } + DUK__SETTEMP(comp_ctx, reg_res + 1); + duk__ivalue_regconst(res, reg_res); + return; +} + +plain_value : { + /* Stack top contains plain value */ + duk__ivalue_plain_fromstack(comp_ctx, res); + return; +} + +#if defined(DUK_USE_ES6) +syntax_error_newtarget: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_NEWTARGET); + DUK_WO_NORETURN(return;); +#endif + +syntax_error: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_EXPRESSION); + DUK_WO_NORETURN(return;); +} + +/* XXX: add flag to indicate whether caller cares about return value; this + * affects e.g. handling of assignment expressions. This change needs API + * changes elsewhere too. + */ +DUK_LOCAL void duk__expr_led(duk_compiler_ctx *comp_ctx, duk_ivalue *left, duk_ivalue *res) { + duk_hthread *thr = comp_ctx->thr; + duk_token *tk; + duk_small_uint_t tok; + duk_uint32_t args; /* temp variable to pass constants and flags to shared code */ + + /* + * ctx->prev_token token to process with duk__expr_led() + * ctx->curr_token updated by caller + */ + + comp_ctx->curr_func.led_count++; + + /* The token in the switch has already been eaten here */ + tk = &comp_ctx->prev_token; + tok = tk->t; + + DUK_DDD(DUK_DDDPRINT("duk__expr_led(), prev_token.t=%ld, allow_in=%ld, paren_level=%ld", + (long) tk->t, + (long) comp_ctx->curr_func.allow_in, + (long) comp_ctx->curr_func.paren_level)); + + /* XXX: default priority for infix operators is duk__expr_lbp(tok) -> get it here? */ + + switch (tok) { + /* PRIMARY EXPRESSIONS */ + + case DUK_TOK_PERIOD: { + /* Property access expressions are critical for correct LHS ordering, + * see comments in duk__expr()! + * + * A conservative approach would be to use duk__ivalue_totempconst() + * for 'left'. However, allowing a reg-bound variable seems safe here + * and is nice because "foo.bar" is a common expression. If the ivalue + * is used in an expression a GETPROP will occur before any changes to + * the base value can occur. If the ivalue is used as an assignment + * LHS, the assignment code will ensure the base value is safe from + * RHS mutation. + */ + + /* XXX: This now coerces an identifier into a GETVAR to a temp, which + * causes an extra LDREG in call setup. It's sufficient to coerce to a + * unary ivalue? + */ + duk__ivalue_toplain(comp_ctx, left); + + /* NB: must accept reserved words as property name */ + if (comp_ctx->curr_token.t_nores != DUK_TOK_IDENTIFIER) { + DUK_ERROR_SYNTAX(thr, DUK_STR_EXPECTED_IDENTIFIER); + DUK_WO_NORETURN(return;); + } + + res->t = DUK_IVAL_PROP; + duk__copy_ispec(comp_ctx, &left->x1, &res->x1); /* left.x1 -> res.x1 */ + DUK_ASSERT(comp_ctx->curr_token.str1 != NULL); + duk_push_hstring(thr, comp_ctx->curr_token.str1); + duk_replace(thr, res->x2.valstack_idx); + res->x2.t = DUK_ISPEC_VALUE; + + /* special RegExp literal handling after IdentifierName */ + comp_ctx->curr_func.reject_regexp_in_adv = 1; + + duk__advance(comp_ctx); + return; + } + case DUK_TOK_LBRACKET: { + /* Property access expressions are critical for correct LHS ordering, + * see comments in duk__expr()! + */ + + /* XXX: optimize temp reg use */ + /* XXX: similar coercion issue as in DUK_TOK_PERIOD */ + /* XXX: coerce to regs? it might be better for enumeration use, where the + * same PROP ivalue is used multiple times. Or perhaps coerce PROP further + * there? + */ + /* XXX: for simple cases like x['y'] an unnecessary LDREG is + * emitted for the base value; could avoid it if we knew that + * the key expression is safe (e.g. just a single literal). + */ + + /* The 'left' value must not be a register bound variable + * because it may be mutated during the rest of the expression + * and E5.1 Section 11.2.1 specifies the order of evaluation + * so that the base value is evaluated first. + * See: test-bug-nested-prop-mutate.js. + */ + duk__ivalue_totempconst(comp_ctx, left); + duk__expr_toplain(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); /* Expression, ']' terminates */ + duk__advance_expect(comp_ctx, DUK_TOK_RBRACKET); + + res->t = DUK_IVAL_PROP; + duk__copy_ispec(comp_ctx, &res->x1, &res->x2); /* res.x1 -> res.x2 */ + duk__copy_ispec(comp_ctx, &left->x1, &res->x1); /* left.x1 -> res.x1 */ + return; + } + case DUK_TOK_LPAREN: { + /* function call */ + duk_regconst_t reg_cs = DUK__ALLOCTEMPS(comp_ctx, 2); + duk_int_t nargs; + duk_small_uint_t call_op = DUK_OP_CALL0; + + /* XXX: attempt to get the call result to "next temp" whenever + * possible to avoid unnecessary register shuffles. + */ + + /* + * Setup call: target and 'this' binding. Three cases: + * + * 1. Identifier base (e.g. "foo()") + * 2. Property base (e.g. "foo.bar()") + * 3. Register base (e.g. "foo()()"; i.e. when a return value is a function) + */ + + if (left->t == DUK_IVAL_VAR) { + duk_hstring *h_varname; + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + DUK_DDD(DUK_DDDPRINT("function call with identifier base")); + + h_varname = duk_known_hstring(thr, left->x1.valstack_idx); + if (h_varname == DUK_HTHREAD_STRING_EVAL(thr)) { + /* Potential direct eval call detected, flag the CALL + * so that a run-time "direct eval" check is made and + * special behavior may be triggered. Note that this + * does not prevent 'eval' from being register bound. + */ + DUK_DDD(DUK_DDDPRINT("function call with identifier 'eval' " + "-> using EVALCALL, marking function " + "as may_direct_eval")); + call_op |= DUK_BC_CALL_FLAG_CALLED_AS_EVAL; + comp_ctx->curr_func.may_direct_eval = 1; + } + + duk_dup(thr, left->x1.valstack_idx); + if (duk__lookup_lhs(comp_ctx, ®_varbind, &rc_varname)) { + duk__emit_a_bc(comp_ctx, DUK_OP_CSREG | DUK__EMIT_FLAG_A_IS_SOURCE, reg_varbind, reg_cs + 0); + } else { + /* XXX: expand target register or constant field to + * reduce shuffling. + */ + DUK_ASSERT(DUK__ISCONST(rc_varname)); + duk__emit_a_b(comp_ctx, DUK_OP_CSVAR | DUK__EMIT_FLAG_BC_REGCONST, reg_cs + 0, rc_varname); + } + } else if (left->t == DUK_IVAL_PROP) { + /* Call through a property lookup, E5 Section 11.2.3, step 6.a.i, + * E5 Section 10.4.3. There used to be a separate CSPROP opcode + * but a typical call setup took 3 opcodes (e.g. LDREG, LDCONST, + * CSPROP) and the same can be achieved with ordinary loads. + */ +#if defined(DUK_USE_VERBOSE_ERRORS) + duk_regconst_t reg_key; +#endif + + DUK_DDD(DUK_DDDPRINT("function call with property base")); + + /* XXX: For Math.sin() this generates: LDCONST + LDREG + + * GETPROPC + call. The LDREG is unnecessary because LDCONST + * could be loaded directly into reg_cs + 1. This doesn't + * happen now because a variable cannot be in left->x1 of a + * DUK_IVAL_PROP. We could notice that left->x1 is a temp + * and reuse, but it would still be in the wrong position + * (reg_cs + 0 rather than reg_cs + 1). + */ + duk__ispec_toforcedreg(comp_ctx, &left->x1, reg_cs + 1); /* base */ +#if defined(DUK_USE_VERBOSE_ERRORS) + reg_key = duk__ispec_toregconst_raw(comp_ctx, &left->x2, -1, DUK__IVAL_FLAG_ALLOW_CONST /*flags*/); + duk__emit_a_b_c(comp_ctx, DUK_OP_GETPROPC | DUK__EMIT_FLAG_BC_REGCONST, reg_cs + 0, reg_cs + 1, reg_key); +#else + duk__ivalue_toforcedreg(comp_ctx, left, reg_cs + 0); /* base[key] */ +#endif + } else { + DUK_DDD(DUK_DDDPRINT("function call with register base")); + + duk__ivalue_toforcedreg(comp_ctx, left, reg_cs + 0); +#if 0 + duk__emit_a_bc(comp_ctx, + DUK_OP_CSREG | DUK__EMIT_FLAG_A_IS_SOURCE, + reg_cs + 0, + reg_cs + 0); /* in-place setup */ +#endif + /* Because of in-place setup, REGCS is equivalent to + * just this LDUNDEF. + */ + duk__emit_bc(comp_ctx, DUK_OP_LDUNDEF, reg_cs + 1); + } + + DUK__SETTEMP(comp_ctx, reg_cs + 2); + nargs = duk__parse_arguments(comp_ctx, res); /* parse args starting from "next temp" */ + + /* Tailcalls are handled by back-patching the already emitted opcode + * later in return statement parser. + */ + + duk__emit_a_bc(comp_ctx, call_op, (duk_regconst_t) nargs /*numargs*/, reg_cs /*basereg*/); + DUK__SETTEMP(comp_ctx, reg_cs + 1); /* result in csreg */ + + duk__ivalue_regconst(res, reg_cs); + return; + } + + /* POSTFIX EXPRESSION */ + + case DUK_TOK_INCREMENT: { + args = (DUK_OP_POSTINCP_RR << 16) + (DUK_OP_POSTINCR << 8) + 0; + goto postincdec; + } + case DUK_TOK_DECREMENT: { + args = (DUK_OP_POSTDECP_RR << 16) + (DUK_OP_POSTDECR << 8) + 0; + goto postincdec; + } + + /* EXPONENTIATION EXPRESSION */ + +#if defined(DUK_USE_ES7_EXP_OPERATOR) + case DUK_TOK_EXP: { + args = (DUK_OP_EXP << 8) + DUK__BP_EXPONENTIATION - 1; /* UnaryExpression */ + goto binary; + } +#endif + + /* MULTIPLICATIVE EXPRESSION */ + + case DUK_TOK_MUL: { + args = (DUK_OP_MUL << 8) + DUK__BP_MULTIPLICATIVE; /* ExponentiationExpression */ + goto binary; + } + case DUK_TOK_DIV: { + args = (DUK_OP_DIV << 8) + DUK__BP_MULTIPLICATIVE; /* ExponentiationExpression */ + goto binary; + } + case DUK_TOK_MOD: { + args = (DUK_OP_MOD << 8) + DUK__BP_MULTIPLICATIVE; /* ExponentiationExpression */ + goto binary; + } + + /* ADDITIVE EXPRESSION */ + + case DUK_TOK_ADD: { + args = (DUK_OP_ADD << 8) + DUK__BP_ADDITIVE; /* MultiplicativeExpression */ + goto binary; + } + case DUK_TOK_SUB: { + args = (DUK_OP_SUB << 8) + DUK__BP_ADDITIVE; /* MultiplicativeExpression */ + goto binary; + } + + /* SHIFT EXPRESSION */ + + case DUK_TOK_ALSHIFT: { + /* << */ + args = (DUK_OP_BASL << 8) + DUK__BP_SHIFT; + goto binary; + } + case DUK_TOK_ARSHIFT: { + /* >> */ + args = (DUK_OP_BASR << 8) + DUK__BP_SHIFT; + goto binary; + } + case DUK_TOK_RSHIFT: { + /* >>> */ + args = (DUK_OP_BLSR << 8) + DUK__BP_SHIFT; + goto binary; + } + + /* RELATIONAL EXPRESSION */ + + case DUK_TOK_LT: { + /* < */ + args = (DUK_OP_LT << 8) + DUK__BP_RELATIONAL; + goto binary; + } + case DUK_TOK_GT: { + args = (DUK_OP_GT << 8) + DUK__BP_RELATIONAL; + goto binary; + } + case DUK_TOK_LE: { + args = (DUK_OP_LE << 8) + DUK__BP_RELATIONAL; + goto binary; + } + case DUK_TOK_GE: { + args = (DUK_OP_GE << 8) + DUK__BP_RELATIONAL; + goto binary; + } + case DUK_TOK_INSTANCEOF: { + args = (DUK_OP_INSTOF << 8) + DUK__BP_RELATIONAL; + goto binary; + } + case DUK_TOK_IN: { + args = (DUK_OP_IN << 8) + DUK__BP_RELATIONAL; + goto binary; + } + + /* EQUALITY EXPRESSION */ + + case DUK_TOK_EQ: { + args = (DUK_OP_EQ << 8) + DUK__BP_EQUALITY; + goto binary; + } + case DUK_TOK_NEQ: { + args = (DUK_OP_NEQ << 8) + DUK__BP_EQUALITY; + goto binary; + } + case DUK_TOK_SEQ: { + args = (DUK_OP_SEQ << 8) + DUK__BP_EQUALITY; + goto binary; + } + case DUK_TOK_SNEQ: { + args = (DUK_OP_SNEQ << 8) + DUK__BP_EQUALITY; + goto binary; + } + + /* BITWISE EXPRESSIONS */ + + case DUK_TOK_BAND: { + args = (DUK_OP_BAND << 8) + DUK__BP_BAND; + goto binary; + } + case DUK_TOK_BXOR: { + args = (DUK_OP_BXOR << 8) + DUK__BP_BXOR; + goto binary; + } + case DUK_TOK_BOR: { + args = (DUK_OP_BOR << 8) + DUK__BP_BOR; + goto binary; + } + + /* LOGICAL EXPRESSIONS */ + + case DUK_TOK_LAND: { + /* syntactically left-associative but parsed as right-associative */ + args = (1 << 8) + DUK__BP_LAND - 1; + goto binary_logical; + } + case DUK_TOK_LOR: { + /* syntactically left-associative but parsed as right-associative */ + args = (0 << 8) + DUK__BP_LOR - 1; + goto binary_logical; + } + + /* CONDITIONAL EXPRESSION */ + + case DUK_TOK_QUESTION: { + /* XXX: common reg allocation need is to reuse a sub-expression's temp reg, + * but only if it really is a temp. Nothing fancy here now. + */ + duk_regconst_t reg_temp; + duk_int_t pc_jump1; + duk_int_t pc_jump2; + + reg_temp = DUK__ALLOCTEMP(comp_ctx); + duk__ivalue_toforcedreg(comp_ctx, left, reg_temp); + duk__emit_if_true_skip(comp_ctx, reg_temp); + pc_jump1 = duk__emit_jump_empty(comp_ctx); /* jump to false */ + duk__expr_toforcedreg(comp_ctx, + res, + DUK__BP_COMMA /*rbp_flags*/, + reg_temp /*forced_reg*/); /* AssignmentExpression */ + duk__advance_expect(comp_ctx, DUK_TOK_COLON); + pc_jump2 = duk__emit_jump_empty(comp_ctx); /* jump to end */ + duk__patch_jump_here(comp_ctx, pc_jump1); + duk__expr_toforcedreg(comp_ctx, + res, + DUK__BP_COMMA /*rbp_flags*/, + reg_temp /*forced_reg*/); /* AssignmentExpression */ + duk__patch_jump_here(comp_ctx, pc_jump2); + + DUK__SETTEMP(comp_ctx, reg_temp + 1); + duk__ivalue_regconst(res, reg_temp); + return; + } + + /* ASSIGNMENT EXPRESSION */ + + case DUK_TOK_EQUALSIGN: { + /* + * Assignments are right associative, allows e.g. + * a = 5; + * a += b = 9; // same as a += (b = 9) + * -> expression value 14, a = 14, b = 9 + * + * Right associativiness is reflected in the BP for recursion, + * "-1" ensures assignment operations are allowed. + * + * XXX: just use DUK__BP_COMMA (i.e. no need for 2-step bp levels)? + */ + args = (DUK_OP_NONE << 8) + DUK__BP_ASSIGNMENT - 1; /* DUK_OP_NONE marks a 'plain' assignment */ + goto assign; + } + case DUK_TOK_ADD_EQ: { + /* right associative */ + args = (DUK_OP_ADD << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + case DUK_TOK_SUB_EQ: { + /* right associative */ + args = (DUK_OP_SUB << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + case DUK_TOK_MUL_EQ: { + /* right associative */ + args = (DUK_OP_MUL << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + case DUK_TOK_DIV_EQ: { + /* right associative */ + args = (DUK_OP_DIV << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + case DUK_TOK_MOD_EQ: { + /* right associative */ + args = (DUK_OP_MOD << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } +#if defined(DUK_USE_ES7_EXP_OPERATOR) + case DUK_TOK_EXP_EQ: { + /* right associative */ + args = (DUK_OP_EXP << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } +#endif + case DUK_TOK_ALSHIFT_EQ: { + /* right associative */ + args = (DUK_OP_BASL << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + case DUK_TOK_ARSHIFT_EQ: { + /* right associative */ + args = (DUK_OP_BASR << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + case DUK_TOK_RSHIFT_EQ: { + /* right associative */ + args = (DUK_OP_BLSR << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + case DUK_TOK_BAND_EQ: { + /* right associative */ + args = (DUK_OP_BAND << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + case DUK_TOK_BOR_EQ: { + /* right associative */ + args = (DUK_OP_BOR << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + case DUK_TOK_BXOR_EQ: { + /* right associative */ + args = (DUK_OP_BXOR << 8) + DUK__BP_ASSIGNMENT - 1; + goto assign; + } + + /* COMMA */ + + case DUK_TOK_COMMA: { + /* right associative */ + + duk__ivalue_toplain_ignore(comp_ctx, left); /* need side effects, not value */ + duk__expr_toplain(comp_ctx, res, DUK__BP_COMMA - 1 /*rbp_flags*/); + + /* return 'res' (of right part) as our result */ + return; + } + + default: { + break; + } + } + + DUK_D(DUK_DPRINT("parse error: unexpected token: %ld", (long) tok)); + DUK_ERROR_SYNTAX(thr, DUK_STR_PARSE_ERROR); + DUK_WO_NORETURN(return;); + +#if 0 + /* XXX: shared handling for 'duk__expr_lhs'? */ + if (comp_ctx->curr_func.paren_level == 0 && XXX) { + comp_ctx->curr_func.duk__expr_lhs = 0; + } +#endif + +binary: + /* + * Shared handling of binary operations + * + * args = (opcode << 8) + rbp + */ + { + duk__ivalue_toplain(comp_ctx, left); + duk__expr_toplain(comp_ctx, res, args & 0xff /*rbp_flags*/); + + /* combine left->x1 and res->x1 (right->x1, really) -> (left->x1 OP res->x1) */ + DUK_ASSERT(left->t == DUK_IVAL_PLAIN); + DUK_ASSERT(res->t == DUK_IVAL_PLAIN); + + res->t = DUK_IVAL_ARITH; + res->op = (args >> 8) & 0xff; + + res->x2.t = res->x1.t; + res->x2.regconst = res->x1.regconst; + duk_copy(thr, res->x1.valstack_idx, res->x2.valstack_idx); + + res->x1.t = left->x1.t; + res->x1.regconst = left->x1.regconst; + duk_copy(thr, left->x1.valstack_idx, res->x1.valstack_idx); + + DUK_DDD(DUK_DDDPRINT("binary op, res: t=%ld, x1.t=%ld, x1.regconst=0x%08lx, x2.t=%ld, x2.regconst=0x%08lx", + (long) res->t, + (long) res->x1.t, + (unsigned long) res->x1.regconst, + (long) res->x2.t, + (unsigned long) res->x2.regconst)); + return; + } + +binary_logical: + /* + * Shared handling for logical AND and logical OR. + * + * args = (truthval << 8) + rbp + * + * Truthval determines when to skip right-hand-side. + * For logical AND truthval=1, for logical OR truthval=0. + * + * See doc/compiler.rst for discussion on compiling logical + * AND and OR expressions. The approach here is very simplistic, + * generating extra jumps and multiple evaluations of truth values, + * but generates code on-the-fly with only local back-patching. + * + * Both logical AND and OR are syntactically left-associated. + * However, logical ANDs are compiled as right associative + * expressions, i.e. "A && B && C" as "A && (B && C)", to allow + * skip jumps to skip over the entire tail. Similarly for logical OR. + */ + + { + duk_regconst_t reg_temp; + duk_int_t pc_jump; + duk_small_uint_t args_truthval = args >> 8; + duk_small_uint_t args_rbp = args & 0xff; + + /* XXX: unoptimal use of temps, resetting */ + + reg_temp = DUK__ALLOCTEMP(comp_ctx); + + duk__ivalue_toforcedreg(comp_ctx, left, reg_temp); + DUK_ASSERT(DUK__ISREG(reg_temp)); + duk__emit_bc(comp_ctx, + (args_truthval ? DUK_OP_IFTRUE_R : DUK_OP_IFFALSE_R), + reg_temp); /* skip jump conditionally */ + pc_jump = duk__emit_jump_empty(comp_ctx); + duk__expr_toforcedreg(comp_ctx, res, args_rbp /*rbp_flags*/, reg_temp /*forced_reg*/); + duk__patch_jump_here(comp_ctx, pc_jump); + + duk__ivalue_regconst(res, reg_temp); + return; + } + +assign: + /* + * Shared assignment expression handling + * + * args = (opcode << 8) + rbp + * + * If 'opcode' is DUK_OP_NONE, plain assignment without arithmetic. + * Syntactically valid left-hand-side forms which are not accepted as + * left-hand-side values (e.g. as in "f() = 1") must NOT cause a + * SyntaxError, but rather a run-time ReferenceError. + * + * When evaluating X = Y, the LHS (X) is conceptually evaluated + * to a temporary first. The RHS is then evaluated. Finally, the + * is applied to the initial value of RHS (not the value after + * RHS evaluation), and written to X. Doing so concretely generates + * inefficient code so we'd like to avoid the temporary when possible. + * See: https://github.com/svaarala/duktape/pull/992. + * + * The expression value (final LHS value, written to RHS) is + * conceptually copied into a fresh temporary so that it won't + * change even if the LHS/RHS values change in outer expressions. + * For example, it'd be generally incorrect for the expression value + * to be the RHS register binding, unless there's a guarantee that it + * won't change during further expression evaluation. Using the + * temporary concretely produces inefficient bytecode, so we try to + * avoid the extra temporary for some known-to-be-safe cases. + * Currently the only safe case we detect is a "top level assignment", + * for example "x = y + z;", where the assignment expression value is + * ignored. + * See: test-dev-assign-expr.js and test-bug-assign-mutate-gh381.js. + */ + + { + duk_small_uint_t args_op = args >> 8; + duk_small_uint_t args_rbp = args & 0xff; + duk_bool_t toplevel_assign; + + /* XXX: here we need to know if 'left' is left-hand-side compatible. + * That information is no longer available from current expr parsing + * state; it would need to be carried into the 'left' ivalue or by + * some other means. + */ + + /* A top-level assignment is e.g. "x = y;". For these it's safe + * to use the RHS as-is as the expression value, even if the RHS + * is a reg-bound identifier. The RHS ('res') is right associative + * so it has consumed all other assignment level operations; the + * only relevant lower binding power construct is comma operator + * which will ignore the expression value provided here. Usually + * the top level assignment expression value is ignored, but it + * is relevant for e.g. eval code. + */ + toplevel_assign = (comp_ctx->curr_func.nud_count == 1 && /* one token before */ + comp_ctx->curr_func.led_count == 1); /* one operator (= assign) */ + DUK_DDD(DUK_DDDPRINT("assignment: nud_count=%ld, led_count=%ld, toplevel_assign=%ld", + (long) comp_ctx->curr_func.nud_count, + (long) comp_ctx->curr_func.led_count, + (long) toplevel_assign)); + + if (left->t == DUK_IVAL_VAR) { + duk_hstring *h_varname; + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + DUK_ASSERT(left->x1.t == DUK_ISPEC_VALUE); /* LHS is already side effect free */ + + h_varname = duk_known_hstring(thr, left->x1.valstack_idx); + if (duk__hstring_is_eval_or_arguments_in_strict_mode(comp_ctx, h_varname)) { + /* E5 Section 11.13.1 (and others for other assignments), step 4. */ + goto syntax_error_lvalue; + } + duk_dup(thr, left->x1.valstack_idx); + (void) duk__lookup_lhs(comp_ctx, ®_varbind, &rc_varname); + + if (args_op == DUK_OP_NONE) { + duk__expr(comp_ctx, res, args_rbp /*rbp_flags*/); + if (toplevel_assign) { + /* Any 'res' will do. */ + DUK_DDD(DUK_DDDPRINT("plain assignment, toplevel assign, use as is")); + } else { + /* 'res' must be a plain ivalue, and not register-bound variable. */ + DUK_DDD(DUK_DDDPRINT( + "plain assignment, not toplevel assign, ensure not a reg-bound identifier")); + if (res->t != DUK_IVAL_PLAIN || + (res->x1.t == DUK_ISPEC_REGCONST && DUK__ISREG_NOTTEMP(comp_ctx, res->x1.regconst))) { + duk__ivalue_totempconst(comp_ctx, res); + } + } + } else { + /* For X = Y we need to evaluate the pre-op + * value of X before evaluating the RHS: the RHS + * can change X, but when we do we must use + * the pre-op value. + */ + duk_regconst_t reg_temp; + + reg_temp = DUK__ALLOCTEMP(comp_ctx); + + if (reg_varbind >= 0) { + duk_regconst_t reg_res; + duk_regconst_t reg_src; + duk_int_t pc_temp_load; + duk_int_t pc_before_rhs; + duk_int_t pc_after_rhs; + + if (toplevel_assign) { + /* 'reg_varbind' is the operation result and can also + * become the expression value for top level assignments + * such as: "var x; x += y;". + */ + DUK_DD(DUK_DDPRINT("= expression is top level, write directly to reg_varbind")); + reg_res = reg_varbind; + } else { + /* Not safe to use 'reg_varbind' as assignment expression + * value, so go through a temp. + */ + DUK_DD(DUK_DDPRINT("= expression is not top level, write to reg_temp")); + reg_res = reg_temp; /* reg_res should be smallest possible */ + reg_temp = DUK__ALLOCTEMP(comp_ctx); + } + + /* Try to optimize X = Y for reg-bound + * variables. Detect side-effect free RHS + * narrowly by seeing whether it emits code. + * If not, rewind the code emitter and overwrite + * the unnecessary temp reg load. + */ + + pc_temp_load = duk__get_current_pc(comp_ctx); + duk__emit_a_bc(comp_ctx, DUK_OP_LDREG, reg_temp, reg_varbind); + + pc_before_rhs = duk__get_current_pc(comp_ctx); + duk__expr_toregconst(comp_ctx, res, args_rbp /*rbp_flags*/); + DUK_ASSERT(res->t == DUK_IVAL_PLAIN && res->x1.t == DUK_ISPEC_REGCONST); + pc_after_rhs = duk__get_current_pc(comp_ctx); + + DUK_DD(DUK_DDPRINT("pc_temp_load=%ld, pc_before_rhs=%ld, pc_after_rhs=%ld", + (long) pc_temp_load, + (long) pc_before_rhs, + (long) pc_after_rhs)); + + if (pc_after_rhs == pc_before_rhs) { + /* Note: if the reg_temp load generated shuffling + * instructions, we may need to rewind more than + * one instruction, so use explicit PC computation. + */ + DUK_DD(DUK_DDPRINT("rhs is side effect free, rewind and avoid unnecessary temp for " + "reg-based =")); + DUK_BW_ADD_PTR(comp_ctx->thr, + &comp_ctx->curr_func.bw_code, + (pc_temp_load - pc_before_rhs) * + (duk_int_t) sizeof(duk_compiler_instr)); + reg_src = reg_varbind; + } else { + DUK_DD(DUK_DDPRINT("rhs evaluation emitted code, not sure if rhs is side effect " + "free; use temp reg for LHS")); + reg_src = reg_temp; + } + + duk__emit_a_b_c(comp_ctx, + args_op | DUK__EMIT_FLAG_BC_REGCONST, + reg_res, + reg_src, + res->x1.regconst); + + res->x1.regconst = reg_res; + + /* Ensure compact use of temps. */ + if (DUK__ISREG_TEMP(comp_ctx, reg_res)) { + DUK__SETTEMP(comp_ctx, reg_res + 1); + } + } else { + /* When LHS is not register bound, always go through a + * temporary. No optimization for top level assignment. + */ + + duk__emit_a_bc(comp_ctx, DUK_OP_GETVAR, reg_temp, rc_varname); + + duk__expr_toregconst(comp_ctx, res, args_rbp /*rbp_flags*/); + DUK_ASSERT(res->t == DUK_IVAL_PLAIN && res->x1.t == DUK_ISPEC_REGCONST); + + duk__emit_a_b_c(comp_ctx, + args_op | DUK__EMIT_FLAG_BC_REGCONST, + reg_temp, + reg_temp, + res->x1.regconst); + res->x1.regconst = reg_temp; + } + + DUK_ASSERT(res->t == DUK_IVAL_PLAIN && res->x1.t == DUK_ISPEC_REGCONST); + } + + /* At this point 'res' holds the potential expression value. + * It can be basically any ivalue here, including a reg-bound + * identifier (if code above deems it safe) or a unary/binary + * operation. Operations must be resolved to a side effect free + * plain value, and the side effects must happen exactly once. + */ + + if (reg_varbind >= 0) { + if (res->t != DUK_IVAL_PLAIN) { + /* Resolve 'res' directly into the LHS binding, and use + * that as the expression value if safe. If not safe, + * resolve to a temp/const and copy to LHS. + */ + if (toplevel_assign) { + duk__ivalue_toforcedreg(comp_ctx, res, (duk_int_t) reg_varbind); + } else { + duk__ivalue_totempconst(comp_ctx, res); + duk__copy_ivalue(comp_ctx, res, left); /* use 'left' as a temp */ + duk__ivalue_toforcedreg(comp_ctx, left, (duk_int_t) reg_varbind); + } + } else { + /* Use 'res' as the expression value (it's side effect + * free and may be a plain value, a register, or a + * constant) and write it to the LHS binding too. + */ + duk__copy_ivalue(comp_ctx, res, left); /* use 'left' as a temp */ + duk__ivalue_toforcedreg(comp_ctx, left, (duk_int_t) reg_varbind); + } + } else { + /* Only a reg fits into 'A' so coerce 'res' into a register + * for PUTVAR. + * + * XXX: here the current A/B/C split is suboptimal: we could + * just use 9 bits for reg_res (and support constants) and 17 + * instead of 18 bits for the varname const index. + */ + + duk__ivalue_toreg(comp_ctx, res); + duk__emit_a_bc(comp_ctx, DUK_OP_PUTVAR | DUK__EMIT_FLAG_A_IS_SOURCE, res->x1.regconst, rc_varname); + } + + /* 'res' contains expression value */ + } else if (left->t == DUK_IVAL_PROP) { + /* E5 Section 11.13.1 (and others) step 4 never matches for prop writes -> no check */ + duk_regconst_t reg_obj; + duk_regconst_t rc_key; + duk_regconst_t rc_res; + duk_regconst_t reg_temp; + + /* Property access expressions ('a[b]') are critical to correct + * LHS evaluation ordering, see test-dev-assign-eval-order*.js. + * We must make sure that the LHS target slot (base object and + * key) don't change during RHS evaluation. The only concrete + * problem is a register reference to a variable-bound register + * (i.e., non-temp). Require temp regs for both key and base. + * + * Don't allow a constant for the object (even for a number + * etc), as it goes into the 'A' field of the opcode. + */ + + reg_obj = duk__ispec_toregconst_raw(comp_ctx, + &left->x1, + -1 /*forced_reg*/, + DUK__IVAL_FLAG_REQUIRE_TEMP /*flags*/); + + rc_key = duk__ispec_toregconst_raw(comp_ctx, + &left->x2, + -1 /*forced_reg*/, + DUK__IVAL_FLAG_REQUIRE_TEMP | DUK__IVAL_FLAG_ALLOW_CONST /*flags*/); + + /* Evaluate RHS only when LHS is safe. */ + + if (args_op == DUK_OP_NONE) { + duk__expr_toregconst(comp_ctx, res, args_rbp /*rbp_flags*/); + DUK_ASSERT(res->t == DUK_IVAL_PLAIN && res->x1.t == DUK_ISPEC_REGCONST); + rc_res = res->x1.regconst; + } else { + reg_temp = DUK__ALLOCTEMP(comp_ctx); + duk__emit_a_b_c(comp_ctx, DUK_OP_GETPROP | DUK__EMIT_FLAG_BC_REGCONST, reg_temp, reg_obj, rc_key); + + duk__expr_toregconst(comp_ctx, res, args_rbp /*rbp_flags*/); + DUK_ASSERT(res->t == DUK_IVAL_PLAIN && res->x1.t == DUK_ISPEC_REGCONST); + + duk__emit_a_b_c(comp_ctx, + args_op | DUK__EMIT_FLAG_BC_REGCONST, + reg_temp, + reg_temp, + res->x1.regconst); + rc_res = reg_temp; + } + + duk__emit_a_b_c(comp_ctx, + DUK_OP_PUTPROP | DUK__EMIT_FLAG_A_IS_SOURCE | DUK__EMIT_FLAG_BC_REGCONST, + reg_obj, + rc_key, + rc_res); + + duk__ivalue_regconst(res, rc_res); + } else { + /* No support for lvalues returned from new or function call expressions. + * However, these must NOT cause compile-time SyntaxErrors, but run-time + * ReferenceErrors. Both left and right sides of the assignment must be + * evaluated before throwing a ReferenceError. For instance: + * + * f() = g(); + * + * must result in f() being evaluated, then g() being evaluated, and + * finally, a ReferenceError being thrown. See E5 Section 11.13.1. + */ + + duk_regconst_t rc_res; + + /* First evaluate LHS fully to ensure all side effects are out. */ + duk__ivalue_toplain_ignore(comp_ctx, left); + + /* Then evaluate RHS fully (its value becomes the expression value too). + * Technically we'd need the side effect safety check here too, but because + * we always throw using INVLHS the result doesn't matter. + */ + rc_res = duk__expr_toregconst(comp_ctx, res, args_rbp /*rbp_flags*/); + + duk__emit_op_only(comp_ctx, DUK_OP_INVLHS); + + duk__ivalue_regconst(res, rc_res); + } + + return; + } + +postincdec : { + /* + * Post-increment/decrement will return the original value as its + * result value. However, even that value will be coerced using + * ToNumber() which is quite awkward. Specific bytecode opcodes + * are used to handle these semantics. + * + * Note that post increment/decrement has a "no LineTerminator here" + * restriction. This is handled by duk__expr_lbp(), which forcibly terminates + * the previous expression if a LineTerminator occurs before '++'/'--'. + */ + + duk_regconst_t reg_res; + duk_small_uint_t args_op1 = (args >> 8) & 0xff; /* DUK_OP_POSTINCR/DUK_OP_POSTDECR */ + duk_small_uint_t args_op2 = args >> 16; /* DUK_OP_POSTINCP_RR/DUK_OP_POSTDECP_RR */ + + /* Specific assumptions for opcode numbering. */ + DUK_ASSERT(DUK_OP_POSTINCR + 4 == DUK_OP_POSTINCV); + DUK_ASSERT(DUK_OP_POSTDECR + 4 == DUK_OP_POSTDECV); + + reg_res = DUK__ALLOCTEMP(comp_ctx); + + if (left->t == DUK_IVAL_VAR) { + duk_hstring *h_varname; + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + h_varname = duk_known_hstring(thr, left->x1.valstack_idx); + + if (duk__hstring_is_eval_or_arguments_in_strict_mode(comp_ctx, h_varname)) { + goto syntax_error; + } + + duk_dup(thr, left->x1.valstack_idx); + if (duk__lookup_lhs(comp_ctx, ®_varbind, &rc_varname)) { + duk__emit_a_bc(comp_ctx, + args_op1, /* e.g. DUK_OP_POSTINCR */ + reg_res, + reg_varbind); + } else { + duk__emit_a_bc(comp_ctx, + args_op1 + 4, /* e.g. DUK_OP_POSTINCV */ + reg_res, + rc_varname); + } + + DUK_DDD(DUK_DDDPRINT("postincdec to '%!O' -> reg_varbind=%ld, rc_varname=%ld", + (duk_heaphdr *) h_varname, + (long) reg_varbind, + (long) rc_varname)); + } else if (left->t == DUK_IVAL_PROP) { + duk_regconst_t reg_obj; /* allocate to reg only (not const) */ + duk_regconst_t rc_key; + + reg_obj = duk__ispec_toregconst_raw(comp_ctx, &left->x1, -1 /*forced_reg*/, 0 /*flags*/); /* don't allow const */ + rc_key = duk__ispec_toregconst_raw(comp_ctx, &left->x2, -1 /*forced_reg*/, DUK__IVAL_FLAG_ALLOW_CONST /*flags*/); + duk__emit_a_b_c(comp_ctx, + args_op2 | DUK__EMIT_FLAG_BC_REGCONST, /* e.g. DUK_OP_POSTINCP */ + reg_res, + reg_obj, + rc_key); + } else { + /* Technically return value is not needed because INVLHS will + * unconditially throw a ReferenceError. Coercion is necessary + * for proper semantics (consider ToNumber() called for an object). + * Use DUK_OP_UNP with a dummy register to get ToNumber(). + */ + duk__ivalue_toforcedreg(comp_ctx, left, reg_res); + duk__emit_bc(comp_ctx, DUK_OP_UNP, reg_res); /* for side effects, result ignored */ + duk__emit_op_only(comp_ctx, DUK_OP_INVLHS); + } + + DUK__SETTEMP(comp_ctx, reg_res + 1); + duk__ivalue_regconst(res, reg_res); + return; +} + +syntax_error: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_EXPRESSION); + DUK_WO_NORETURN(return;); + +syntax_error_lvalue: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_LVALUE); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL duk_small_uint_t duk__expr_lbp(duk_compiler_ctx *comp_ctx) { + duk_small_uint_t tok = comp_ctx->curr_token.t; + + DUK_ASSERT_DISABLE(tok >= DUK_TOK_MINVAL); /* unsigned */ + DUK_ASSERT(tok <= DUK_TOK_MAXVAL); + DUK_ASSERT(sizeof(duk__token_lbp) == DUK_TOK_MAXVAL + 1); + + /* XXX: integrate support for this into led() instead? + * Similar issue as post-increment/post-decrement. + */ + + /* prevent duk__expr_led() by using a binding power less than anything valid */ + if (tok == DUK_TOK_IN && !comp_ctx->curr_func.allow_in) { + return 0; + } + + if ((tok == DUK_TOK_DECREMENT || tok == DUK_TOK_INCREMENT) && (comp_ctx->curr_token.lineterm)) { + /* '++' or '--' in a post-increment/decrement position, + * and a LineTerminator occurs between the operator and + * the preceding expression. Force the previous expr + * to terminate, in effect treating e.g. "a,b\n++" as + * "a,b;++" (= SyntaxError). + */ + return 0; + } + + return DUK__TOKEN_LBP_GET_BP(duk__token_lbp[tok]); /* format is bit packed */ +} + +/* + * Expression parsing. + * + * Upon entry to 'expr' and its variants, 'curr_tok' is assumed to be the + * first token of the expression. Upon exit, 'curr_tok' will be the first + * token not part of the expression (e.g. semicolon terminating an expression + * statement). + */ + +#define DUK__EXPR_RBP_MASK 0xff +#define DUK__EXPR_FLAG_REJECT_IN (1 << 8) /* reject 'in' token (used for for-in) */ +#define DUK__EXPR_FLAG_ALLOW_EMPTY (1 << 9) /* allow empty expression */ +#define DUK__EXPR_FLAG_REQUIRE_INIT (1 << 10) /* require initializer for var/const */ + +/* main expression parser function */ +DUK_LOCAL void duk__expr(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk_hthread *thr = comp_ctx->thr; + duk_ivalue tmp_alloc; /* 'res' is used for "left", and 'tmp' for "right" */ + duk_ivalue *tmp = &tmp_alloc; + duk_small_uint_t rbp; + + DUK__RECURSION_INCREASE(comp_ctx, thr); + + duk_require_stack(thr, DUK__PARSE_EXPR_SLOTS); + + /* filter out flags from exprtop rbp_flags here to save space */ + rbp = rbp_flags & DUK__EXPR_RBP_MASK; + + DUK_DDD(DUK_DDDPRINT("duk__expr(), rbp_flags=%ld, rbp=%ld, allow_in=%ld, paren_level=%ld", + (long) rbp_flags, + (long) rbp, + (long) comp_ctx->curr_func.allow_in, + (long) comp_ctx->curr_func.paren_level)); + + duk_memzero(&tmp_alloc, sizeof(tmp_alloc)); + tmp->x1.valstack_idx = duk_get_top(thr); + tmp->x2.valstack_idx = tmp->x1.valstack_idx + 1; + duk_push_undefined(thr); + duk_push_undefined(thr); + + /* XXX: where to release temp regs in intermediate expressions? + * e.g. 1+2+3 -> don't inflate temp register count when parsing this. + * that particular expression temp regs can be forced here. + */ + + /* XXX: increase ctx->expr_tokens here for every consumed token + * (this would be a nice statistic)? + */ + + if (comp_ctx->curr_token.t == DUK_TOK_SEMICOLON || comp_ctx->curr_token.t == DUK_TOK_RPAREN) { + /* XXX: possibly incorrect handling of empty expression */ + DUK_DDD(DUK_DDDPRINT("empty expression")); + if (!(rbp_flags & DUK__EXPR_FLAG_ALLOW_EMPTY)) { + DUK_ERROR_SYNTAX(thr, DUK_STR_EMPTY_EXPR_NOT_ALLOWED); + DUK_WO_NORETURN(return;); + } + duk_push_undefined(thr); + duk__ivalue_plain_fromstack(comp_ctx, res); + goto cleanup; + } + + duk__advance(comp_ctx); + duk__expr_nud(comp_ctx, res); /* reuse 'res' as 'left' */ + while (rbp < duk__expr_lbp(comp_ctx)) { + duk__advance(comp_ctx); + duk__expr_led(comp_ctx, res, tmp); + duk__copy_ivalue(comp_ctx, tmp, res); /* tmp -> res */ + } + +cleanup: + /* final result is already in 'res' */ + + duk_pop_2(thr); + + DUK__RECURSION_DECREASE(comp_ctx, thr); +} + +DUK_LOCAL void duk__exprtop(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk_hthread *thr = comp_ctx->thr; + + /* Note: these variables must reside in 'curr_func' instead of the global + * context: when parsing function expressions, expression parsing is nested. + */ + comp_ctx->curr_func.nud_count = 0; + comp_ctx->curr_func.led_count = 0; + comp_ctx->curr_func.paren_level = 0; + comp_ctx->curr_func.expr_lhs = 1; + comp_ctx->curr_func.allow_in = (rbp_flags & DUK__EXPR_FLAG_REJECT_IN ? 0 : 1); + + duk__expr(comp_ctx, res, rbp_flags); + + if (!(rbp_flags & DUK__EXPR_FLAG_ALLOW_EMPTY) && duk__expr_is_empty(comp_ctx)) { + DUK_ERROR_SYNTAX(thr, DUK_STR_EMPTY_EXPR_NOT_ALLOWED); + DUK_WO_NORETURN(return;); + } +} + +/* A bunch of helpers (for size optimization) that combine duk__expr()/duk__exprtop() + * and result conversions. + * + * Each helper needs at least 2-3 calls to make it worth while to wrap. + */ + +#if 0 /* unused */ +DUK_LOCAL duk_regconst_t duk__expr_toreg(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk__expr(comp_ctx, res, rbp_flags); + return duk__ivalue_toreg(comp_ctx, res); +} +#endif + +#if 0 /* unused */ +DUK_LOCAL duk_regconst_t duk__expr_totemp(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk__expr(comp_ctx, res, rbp_flags); + return duk__ivalue_totemp(comp_ctx, res); +} +#endif + +DUK_LOCAL void duk__expr_toforcedreg(duk_compiler_ctx *comp_ctx, + duk_ivalue *res, + duk_small_uint_t rbp_flags, + duk_regconst_t forced_reg) { + DUK_ASSERT(forced_reg >= 0); + duk__expr(comp_ctx, res, rbp_flags); + duk__ivalue_toforcedreg(comp_ctx, res, forced_reg); +} + +DUK_LOCAL duk_regconst_t duk__expr_toregconst(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk__expr(comp_ctx, res, rbp_flags); + return duk__ivalue_toregconst(comp_ctx, res); +} + +#if 0 /* unused */ +DUK_LOCAL duk_regconst_t duk__expr_totempconst(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk__expr(comp_ctx, res, rbp_flags); + return duk__ivalue_totempconst(comp_ctx, res); +} +#endif + +DUK_LOCAL void duk__expr_toplain(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk__expr(comp_ctx, res, rbp_flags); + duk__ivalue_toplain(comp_ctx, res); +} + +DUK_LOCAL void duk__expr_toplain_ignore(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk__expr(comp_ctx, res, rbp_flags); + duk__ivalue_toplain_ignore(comp_ctx, res); +} + +DUK_LOCAL duk_regconst_t duk__exprtop_toreg(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk__exprtop(comp_ctx, res, rbp_flags); + return duk__ivalue_toreg(comp_ctx, res); +} + +#if 0 /* unused */ +DUK_LOCAL duk_regconst_t duk__exprtop_totemp(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk__exprtop(comp_ctx, res, rbp_flags); + return duk__ivalue_totemp(comp_ctx, res); +} +#endif + +DUK_LOCAL void duk__exprtop_toforcedreg(duk_compiler_ctx *comp_ctx, + duk_ivalue *res, + duk_small_uint_t rbp_flags, + duk_regconst_t forced_reg) { + DUK_ASSERT(forced_reg >= 0); + duk__exprtop(comp_ctx, res, rbp_flags); + duk__ivalue_toforcedreg(comp_ctx, res, forced_reg); +} + +DUK_LOCAL duk_regconst_t duk__exprtop_toregconst(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t rbp_flags) { + duk__exprtop(comp_ctx, res, rbp_flags); + return duk__ivalue_toregconst(comp_ctx, res); +} + +#if 0 /* unused */ +DUK_LOCAL void duk__exprtop_toplain_ignore(duk_compiler_ctx *comp_ctx, duk_ivalue *res, int rbp_flags) { + duk__exprtop(comp_ctx, res, rbp_flags); + duk__ivalue_toplain_ignore(comp_ctx, res); +} +#endif + +/* + * Parse an individual source element (top level statement) or a statement. + * + * Handles labeled statements automatically (peeling away labels before + * parsing an expression that follows the label(s)). + * + * Upon entry, 'curr_tok' contains the first token of the statement (parsed + * in "allow regexp literal" mode). Upon exit, 'curr_tok' contains the first + * token following the statement (if the statement has a terminator, this is + * the token after the terminator). + */ + +#define DUK__HAS_VAL (1 << 0) /* stmt has non-empty value */ +#define DUK__HAS_TERM (1 << 1) /* stmt has explicit/implicit semicolon terminator */ +#define DUK__ALLOW_AUTO_SEMI_ALWAYS (1 << 2) /* allow automatic semicolon even without lineterm (compatibility) */ +#define DUK__STILL_PROLOGUE (1 << 3) /* statement does not terminate directive prologue */ +#define DUK__IS_TERMINAL (1 << 4) /* statement is guaranteed to be terminal (control doesn't flow to next statement) */ + +/* Parse a single variable declaration (e.g. "i" or "i=10"). A leading 'var' + * has already been eaten. These is no return value in 'res', it is used only + * as a temporary. + * + * When called from 'for-in' statement parser, the initializer expression must + * not allow the 'in' token. The caller supply additional expression parsing + * flags (like DUK__EXPR_FLAG_REJECT_IN) in 'expr_flags'. + * + * Finally, out_rc_varname and out_reg_varbind are updated to reflect where + * the identifier is bound: + * + * If register bound: out_reg_varbind >= 0, out_rc_varname == 0 (ignore) + * If not register bound: out_reg_varbind < 0, out_rc_varname >= 0 + * + * These allow the caller to use the variable for further assignment, e.g. + * as is done in 'for-in' parsing. + */ + +DUK_LOCAL void duk__parse_var_decl(duk_compiler_ctx *comp_ctx, + duk_ivalue *res, + duk_small_uint_t expr_flags, + duk_regconst_t *out_reg_varbind, + duk_regconst_t *out_rc_varname) { + duk_hthread *thr = comp_ctx->thr; + duk_hstring *h_varname; + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + /* assume 'var' has been eaten */ + + /* Note: Identifier rejects reserved words */ + if (comp_ctx->curr_token.t != DUK_TOK_IDENTIFIER) { + goto syntax_error; + } + h_varname = comp_ctx->curr_token.str1; + + DUK_ASSERT(h_varname != NULL); + + /* strict mode restrictions (E5 Section 12.2.1) */ + if (duk__hstring_is_eval_or_arguments_in_strict_mode(comp_ctx, h_varname)) { + goto syntax_error; + } + + /* register declarations in first pass */ + if (comp_ctx->curr_func.in_scanning) { + duk_uarridx_t n; + DUK_DDD(DUK_DDDPRINT("register variable declaration %!O in pass 1", (duk_heaphdr *) h_varname)); + n = (duk_uarridx_t) duk_get_length(thr, comp_ctx->curr_func.decls_idx); + duk_push_hstring(thr, h_varname); + duk_put_prop_index(thr, comp_ctx->curr_func.decls_idx, n); + duk_push_int(thr, DUK_DECL_TYPE_VAR + (0 << 8)); + duk_put_prop_index(thr, comp_ctx->curr_func.decls_idx, n + 1); + } + + duk_push_hstring(thr, h_varname); /* push before advancing to keep reachable */ + + /* register binding lookup is based on varmap (even in first pass) */ + duk_dup_top(thr); + (void) duk__lookup_lhs(comp_ctx, ®_varbind, &rc_varname); + + duk__advance(comp_ctx); /* eat identifier */ + + if (comp_ctx->curr_token.t == DUK_TOK_EQUALSIGN) { + duk__advance(comp_ctx); + + DUK_DDD(DUK_DDDPRINT("vardecl, assign to '%!O' -> reg_varbind=%ld, rc_varname=%ld", + (duk_heaphdr *) h_varname, + (long) reg_varbind, + (long) rc_varname)); + + duk__exprtop(comp_ctx, res, DUK__BP_COMMA | expr_flags /*rbp_flags*/); /* AssignmentExpression */ + + if (reg_varbind >= 0) { + duk__ivalue_toforcedreg(comp_ctx, res, reg_varbind); + } else { + duk_regconst_t reg_val; + reg_val = duk__ivalue_toreg(comp_ctx, res); + duk__emit_a_bc(comp_ctx, DUK_OP_PUTVAR | DUK__EMIT_FLAG_A_IS_SOURCE, reg_val, rc_varname); + } + } else { + if (expr_flags & DUK__EXPR_FLAG_REQUIRE_INIT) { + /* Used for minimal 'const': initializer required. */ + goto syntax_error; + } + } + + duk_pop(thr); /* pop varname */ + + *out_rc_varname = rc_varname; + *out_reg_varbind = reg_varbind; + + return; + +syntax_error: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_VAR_DECLARATION); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__parse_var_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_small_uint_t expr_flags) { + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + duk__advance(comp_ctx); /* eat 'var' */ + + for (;;) { + /* rc_varname and reg_varbind are ignored here */ + duk__parse_var_decl(comp_ctx, res, 0 | expr_flags, ®_varbind, &rc_varname); + + if (comp_ctx->curr_token.t != DUK_TOK_COMMA) { + break; + } + duk__advance(comp_ctx); + } +} + +DUK_LOCAL void duk__parse_for_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_int_t pc_label_site) { + duk_hthread *thr = comp_ctx->thr; + duk_int_t pc_v34_lhs; /* start variant 3/4 left-hand-side code (L1 in doc/compiler.rst example) */ + duk_regconst_t temp_reset; /* knock back "next temp" to this whenever possible */ + duk_regconst_t reg_temps; /* preallocated temporaries (2) for variants 3 and 4 */ + + DUK_DDD(DUK_DDDPRINT("start parsing a for/for-in statement")); + + /* Two temporaries are preallocated here for variants 3 and 4 which need + * registers which are never clobbered by expressions in the loop + * (concretely: for the enumerator object and the next enumerated value). + * Variants 1 and 2 "release" these temps. + */ + + reg_temps = DUK__ALLOCTEMPS(comp_ctx, 2); + + temp_reset = DUK__GETTEMP(comp_ctx); + + /* + * For/for-in main variants are: + * + * 1. for (ExpressionNoIn_opt; Expression_opt; Expression_opt) Statement + * 2. for (var VariableDeclarationNoIn; Expression_opt; Expression_opt) Statement + * 3. for (LeftHandSideExpression in Expression) Statement + * 4. for (var VariableDeclarationNoIn in Expression) Statement + * + * Parsing these without arbitrary lookahead or backtracking is relatively + * tricky but we manage to do so for now. + * + * See doc/compiler.rst for a detailed discussion of control flow + * issues, evaluation order issues, etc. + */ + + duk__advance(comp_ctx); /* eat 'for' */ + duk__advance_expect(comp_ctx, DUK_TOK_LPAREN); + + DUK_DDD(DUK_DDDPRINT("detecting for/for-in loop variant, pc=%ld", (long) duk__get_current_pc(comp_ctx))); + + /* a label site has been emitted by duk__parse_stmt() automatically + * (it will also emit the ENDLABEL). + */ + + if (comp_ctx->curr_token.t == DUK_TOK_VAR) { + /* + * Variant 2 or 4 + */ + + duk_regconst_t reg_varbind; /* variable binding register if register-bound (otherwise < 0) */ + duk_regconst_t rc_varname; /* variable name reg/const, if variable not register-bound */ + + duk__advance(comp_ctx); /* eat 'var' */ + duk__parse_var_decl(comp_ctx, res, DUK__EXPR_FLAG_REJECT_IN, ®_varbind, &rc_varname); + DUK__SETTEMP(comp_ctx, temp_reset); + + if (comp_ctx->curr_token.t == DUK_TOK_IN) { + /* + * Variant 4 + */ + + DUK_DDD(DUK_DDDPRINT("detected for variant 4: for (var VariableDeclarationNoIn in Expression) Statement")); + pc_v34_lhs = duk__get_current_pc(comp_ctx); /* jump is inserted here */ + if (reg_varbind >= 0) { + duk__emit_a_bc(comp_ctx, DUK_OP_LDREG, reg_varbind, reg_temps + 0); + } else { + duk__emit_a_bc(comp_ctx, DUK_OP_PUTVAR | DUK__EMIT_FLAG_A_IS_SOURCE, reg_temps + 0, rc_varname); + } + goto parse_3_or_4; + } else { + /* + * Variant 2 + */ + + DUK_DDD(DUK_DDDPRINT( + "detected for variant 2: for (var VariableDeclarationNoIn; Expression_opt; Expression_opt) Statement")); + for (;;) { + /* more initializers */ + if (comp_ctx->curr_token.t != DUK_TOK_COMMA) { + break; + } + DUK_DDD(DUK_DDDPRINT("variant 2 has another variable initializer")); + + duk__advance(comp_ctx); /* eat comma */ + duk__parse_var_decl(comp_ctx, res, DUK__EXPR_FLAG_REJECT_IN, ®_varbind, &rc_varname); + } + goto parse_1_or_2; + } + } else { + /* + * Variant 1 or 3 + */ + + pc_v34_lhs = duk__get_current_pc(comp_ctx); /* jump is inserted here (variant 3) */ + + /* Note that duk__exprtop() here can clobber any reg above current temp_next, + * so any loop variables (e.g. enumerator) must be "preallocated". + */ + + /* don't coerce yet to a plain value (variant 3 needs special handling) */ + duk__exprtop(comp_ctx, + res, + DUK__BP_FOR_EXPR | DUK__EXPR_FLAG_REJECT_IN | + DUK__EXPR_FLAG_ALLOW_EMPTY /*rbp_flags*/); /* Expression */ + if (comp_ctx->curr_token.t == DUK_TOK_IN) { + /* + * Variant 3 + */ + + /* XXX: need to determine LHS type, and check that it is LHS compatible */ + DUK_DDD(DUK_DDDPRINT("detected for variant 3: for (LeftHandSideExpression in Expression) Statement")); + if (duk__expr_is_empty(comp_ctx)) { + goto syntax_error; /* LeftHandSideExpression does not allow empty expression */ + } + + if (res->t == DUK_IVAL_VAR) { + duk_regconst_t reg_varbind; + duk_regconst_t rc_varname; + + duk_dup(thr, res->x1.valstack_idx); + if (duk__lookup_lhs(comp_ctx, ®_varbind, &rc_varname)) { + duk__emit_a_bc(comp_ctx, DUK_OP_LDREG, reg_varbind, reg_temps + 0); + } else { + duk__emit_a_bc(comp_ctx, + DUK_OP_PUTVAR | DUK__EMIT_FLAG_A_IS_SOURCE, + reg_temps + 0, + rc_varname); + } + } else if (res->t == DUK_IVAL_PROP) { + /* Don't allow a constant for the object (even for a number etc), as + * it goes into the 'A' field of the opcode. + */ + duk_regconst_t reg_obj; + duk_regconst_t rc_key; + reg_obj = duk__ispec_toregconst_raw(comp_ctx, + &res->x1, + -1 /*forced_reg*/, + 0 /*flags*/); /* don't allow const */ + rc_key = duk__ispec_toregconst_raw(comp_ctx, + &res->x2, + -1 /*forced_reg*/, + DUK__IVAL_FLAG_ALLOW_CONST /*flags*/); + duk__emit_a_b_c(comp_ctx, + DUK_OP_PUTPROP | DUK__EMIT_FLAG_A_IS_SOURCE | DUK__EMIT_FLAG_BC_REGCONST, + reg_obj, + rc_key, + reg_temps + 0); + } else { + duk__ivalue_toplain_ignore(comp_ctx, res); /* just in case */ + duk__emit_op_only(comp_ctx, DUK_OP_INVLHS); + } + goto parse_3_or_4; + } else { + /* + * Variant 1 + */ + + DUK_DDD(DUK_DDDPRINT( + "detected for variant 1: for (ExpressionNoIn_opt; Expression_opt; Expression_opt) Statement")); + duk__ivalue_toplain_ignore(comp_ctx, res); + goto parse_1_or_2; + } + } + +parse_1_or_2: + /* + * Parse variant 1 or 2. The first part expression (which differs + * in the variants) has already been parsed and its code emitted. + * + * reg_temps + 0: unused + * reg_temps + 1: unused + */ + { + duk_regconst_t rc_cond; + duk_int_t pc_l1, pc_l2, pc_l3, pc_l4; + duk_int_t pc_jumpto_l3, pc_jumpto_l4; + duk_bool_t expr_c_empty; + + DUK_DDD(DUK_DDDPRINT("shared code for parsing variants 1 and 2")); + + /* "release" preallocated temps since we won't need them */ + temp_reset = reg_temps + 0; + DUK__SETTEMP(comp_ctx, temp_reset); + + duk__advance_expect(comp_ctx, DUK_TOK_SEMICOLON); + + pc_l1 = duk__get_current_pc(comp_ctx); + duk__exprtop(comp_ctx, res, DUK__BP_FOR_EXPR | DUK__EXPR_FLAG_ALLOW_EMPTY /*rbp_flags*/); /* Expression_opt */ + if (duk__expr_is_empty(comp_ctx)) { + /* no need to coerce */ + pc_jumpto_l3 = duk__emit_jump_empty(comp_ctx); /* to body */ + pc_jumpto_l4 = -1; /* omitted */ + } else { + rc_cond = duk__ivalue_toregconst(comp_ctx, res); + duk__emit_if_false_skip(comp_ctx, rc_cond); + pc_jumpto_l3 = duk__emit_jump_empty(comp_ctx); /* to body */ + pc_jumpto_l4 = duk__emit_jump_empty(comp_ctx); /* to exit */ + } + DUK__SETTEMP(comp_ctx, temp_reset); + + duk__advance_expect(comp_ctx, DUK_TOK_SEMICOLON); + + pc_l2 = duk__get_current_pc(comp_ctx); + duk__exprtop(comp_ctx, res, DUK__BP_FOR_EXPR | DUK__EXPR_FLAG_ALLOW_EMPTY /*rbp_flags*/); /* Expression_opt */ + if (duk__expr_is_empty(comp_ctx)) { + /* no need to coerce */ + expr_c_empty = 1; + /* JUMP L1 omitted */ + } else { + duk__ivalue_toplain_ignore(comp_ctx, res); + expr_c_empty = 0; + duk__emit_jump(comp_ctx, pc_l1); + } + DUK__SETTEMP(comp_ctx, temp_reset); + + comp_ctx->curr_func.allow_regexp_in_adv = 1; + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); /* Allow RegExp as part of next stmt. */ + + pc_l3 = duk__get_current_pc(comp_ctx); + duk__parse_stmt(comp_ctx, res, 0 /*allow_source_elem*/); + if (expr_c_empty) { + duk__emit_jump(comp_ctx, pc_l1); + } else { + duk__emit_jump(comp_ctx, pc_l2); + } + /* temp reset is not necessary after duk__parse_stmt(), which already does it */ + + pc_l4 = duk__get_current_pc(comp_ctx); + + DUK_DDD(DUK_DDDPRINT("patching jumps: jumpto_l3: %ld->%ld, jumpto_l4: %ld->%ld, " + "break: %ld->%ld, continue: %ld->%ld", + (long) pc_jumpto_l3, + (long) pc_l3, + (long) pc_jumpto_l4, + (long) pc_l4, + (long) (pc_label_site + 1), + (long) pc_l4, + (long) (pc_label_site + 2), + (long) pc_l2)); + + duk__patch_jump(comp_ctx, pc_jumpto_l3, pc_l3); + duk__patch_jump(comp_ctx, pc_jumpto_l4, pc_l4); + duk__patch_jump(comp_ctx, pc_label_site + 1, pc_l4); /* break jump */ + duk__patch_jump(comp_ctx, pc_label_site + 2, expr_c_empty ? pc_l1 : pc_l2); /* continue jump */ + } + goto finished; + +parse_3_or_4: + /* + * Parse variant 3 or 4. + * + * For variant 3 (e.g. "for (A in C) D;") the code for A (except the + * final property/variable write) has already been emitted. The first + * instruction of that code is at pc_v34_lhs; a JUMP needs to be inserted + * there to satisfy control flow needs. + * + * For variant 4, if the variable declaration had an initializer + * (e.g. "for (var A = B in C) D;") the code for the assignment + * (B) has already been emitted. + * + * Variables set before entering here: + * + * pc_v34_lhs: insert a "JUMP L2" here (see doc/compiler.rst example). + * reg_temps + 0: iteration target value (written to LHS) + * reg_temps + 1: enumerator object + */ + { + duk_int_t pc_l1, pc_l2, pc_l3, pc_l4, pc_l5; + duk_int_t pc_jumpto_l2, pc_jumpto_l3, pc_jumpto_l4, pc_jumpto_l5; + duk_regconst_t reg_target; + + DUK_DDD(DUK_DDDPRINT("shared code for parsing variants 3 and 4, pc_v34_lhs=%ld", (long) pc_v34_lhs)); + + DUK__SETTEMP(comp_ctx, temp_reset); + + /* First we need to insert a jump in the middle of previously + * emitted code to get the control flow right. No jumps can + * cross the position where the jump is inserted. See doc/compiler.rst + * for discussion on the intricacies of control flow and side effects + * for variants 3 and 4. + */ + + duk__insert_jump_entry(comp_ctx, pc_v34_lhs); + pc_jumpto_l2 = pc_v34_lhs; /* inserted jump */ + pc_l1 = pc_v34_lhs + 1; /* +1, right after inserted jump */ + + /* The code for writing reg_temps + 0 to the left hand side has already + * been emitted. + */ + + pc_jumpto_l3 = duk__emit_jump_empty(comp_ctx); /* -> loop body */ + + duk__advance(comp_ctx); /* eat 'in' */ + + /* Parse enumeration target and initialize enumerator. For 'null' and 'undefined', + * INITENUM will creates a 'null' enumerator which works like an empty enumerator + * (E5 Section 12.6.4, step 3). Note that INITENUM requires the value to be in a + * register (constant not allowed). + */ + + pc_l2 = duk__get_current_pc(comp_ctx); + reg_target = duk__exprtop_toreg(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); /* Expression */ + duk__emit_b_c(comp_ctx, DUK_OP_INITENUM | DUK__EMIT_FLAG_B_IS_TARGET, reg_temps + 1, reg_target); + pc_jumpto_l4 = duk__emit_jump_empty(comp_ctx); + DUK__SETTEMP(comp_ctx, temp_reset); + + comp_ctx->curr_func.allow_regexp_in_adv = 1; + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); /* Allow RegExp as part of next stmt. */ + + pc_l3 = duk__get_current_pc(comp_ctx); + duk__parse_stmt(comp_ctx, res, 0 /*allow_source_elem*/); + /* temp reset is not necessary after duk__parse_stmt(), which already does it */ + + /* NEXTENUM needs a jump slot right after the main opcode. + * We need the code emitter to reserve the slot: if there's + * target shuffling, the target shuffle opcodes must happen + * after the jump slot (for NEXTENUM the shuffle opcodes are + * not needed if the enum is finished). + */ + pc_l4 = duk__get_current_pc(comp_ctx); + duk__emit_b_c(comp_ctx, + DUK_OP_NEXTENUM | DUK__EMIT_FLAG_B_IS_TARGET | DUK__EMIT_FLAG_RESERVE_JUMPSLOT, + reg_temps + 0, + reg_temps + 1); + pc_jumpto_l5 = comp_ctx->emit_jumpslot_pc; /* NEXTENUM jump slot: executed when enum finished */ + duk__emit_jump(comp_ctx, pc_l1); /* jump to next loop, using reg_v34_iter as iterated value */ + + pc_l5 = duk__get_current_pc(comp_ctx); + + /* XXX: since the enumerator may be a memory expensive object, + * perhaps clear it explicitly here? If so, break jump must + * go through this clearing operation. + */ + + DUK_DDD(DUK_DDDPRINT("patching jumps: jumpto_l2: %ld->%ld, jumpto_l3: %ld->%ld, " + "jumpto_l4: %ld->%ld, jumpto_l5: %ld->%ld, " + "break: %ld->%ld, continue: %ld->%ld", + (long) pc_jumpto_l2, + (long) pc_l2, + (long) pc_jumpto_l3, + (long) pc_l3, + (long) pc_jumpto_l4, + (long) pc_l4, + (long) pc_jumpto_l5, + (long) pc_l5, + (long) (pc_label_site + 1), + (long) pc_l5, + (long) (pc_label_site + 2), + (long) pc_l4)); + + duk__patch_jump(comp_ctx, pc_jumpto_l2, pc_l2); + duk__patch_jump(comp_ctx, pc_jumpto_l3, pc_l3); + duk__patch_jump(comp_ctx, pc_jumpto_l4, pc_l4); + duk__patch_jump(comp_ctx, pc_jumpto_l5, pc_l5); + duk__patch_jump(comp_ctx, pc_label_site + 1, pc_l5); /* break jump */ + duk__patch_jump(comp_ctx, pc_label_site + 2, pc_l4); /* continue jump */ + } + goto finished; + +finished: + DUK_DDD(DUK_DDDPRINT("end parsing a for/for-in statement")); + return; + +syntax_error: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_FOR); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__parse_switch_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_int_t pc_label_site) { + duk_hthread *thr = comp_ctx->thr; + duk_regconst_t temp_at_loop; + duk_regconst_t rc_switch; /* reg/const for switch value */ + duk_regconst_t rc_case; /* reg/const for case value */ + duk_regconst_t reg_temp; /* general temp register */ + duk_int_t pc_prevcase = -1; + duk_int_t pc_prevstmt = -1; + duk_int_t pc_default = -1; /* -1 == not set, -2 == pending (next statement list) */ + + /* Note: negative pc values are ignored when patching jumps, so no explicit checks needed */ + + /* + * Switch is pretty complicated because of several conflicting concerns: + * + * - Want to generate code without an intermediate representation, + * i.e., in one go + * + * - Case selectors are expressions, not values, and may thus e.g. throw + * exceptions (which causes evaluation order concerns) + * + * - Evaluation semantics of case selectors and default clause need to be + * carefully implemented to provide correct behavior even with case value + * side effects + * + * - Fall through case and default clauses; avoiding dead JUMPs if case + * ends with an unconditional jump (a break or a continue) + * + * - The same case value may occur multiple times, but evaluation rules + * only process the first match before switching to a "propagation" mode + * where case values are no longer evaluated + * + * See E5 Section 12.11. Also see doc/compiler.rst for compilation + * discussion. + */ + + duk__advance(comp_ctx); + duk__advance_expect(comp_ctx, DUK_TOK_LPAREN); + rc_switch = duk__exprtop_toregconst(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); /* RegExp mode does not matter. */ + duk__advance_expect(comp_ctx, DUK_TOK_LCURLY); + + DUK_DDD(DUK_DDDPRINT("switch value in register %ld", (long) rc_switch)); + + temp_at_loop = DUK__GETTEMP(comp_ctx); + + for (;;) { + duk_int_t num_stmts; + duk_small_uint_t tok; + + /* sufficient for keeping temp reg numbers in check */ + DUK__SETTEMP(comp_ctx, temp_at_loop); + + if (comp_ctx->curr_token.t == DUK_TOK_RCURLY) { + break; + } + + /* + * Parse a case or default clause. + */ + + if (comp_ctx->curr_token.t == DUK_TOK_CASE) { + /* + * Case clause. + * + * Note: cannot use reg_case as a temp register (for SEQ target) + * because it may be a constant. + */ + + duk__patch_jump_here(comp_ctx, pc_prevcase); /* chain jumps for case + * evaluation and checking + */ + + duk__advance(comp_ctx); + rc_case = duk__exprtop_toregconst(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); + duk__advance_expect(comp_ctx, DUK_TOK_COLON); + + reg_temp = DUK__ALLOCTEMP(comp_ctx); + duk__emit_a_b_c(comp_ctx, DUK_OP_SEQ | DUK__EMIT_FLAG_BC_REGCONST, reg_temp, rc_switch, rc_case); + duk__emit_if_true_skip(comp_ctx, reg_temp); + + /* jump to next case clause */ + pc_prevcase = duk__emit_jump_empty(comp_ctx); /* no match, next case */ + + /* statements go here (if any) on next loop */ + } else if (comp_ctx->curr_token.t == DUK_TOK_DEFAULT) { + /* + * Default clause. + */ + + if (pc_default >= 0) { + goto syntax_error; + } + duk__advance(comp_ctx); + duk__advance_expect(comp_ctx, DUK_TOK_COLON); + + /* Fix for https://github.com/svaarala/duktape/issues/155: + * If 'default' is first clause (detected by pc_prevcase < 0) + * we need to ensure we stay in the matching chain. + */ + if (pc_prevcase < 0) { + DUK_DD(DUK_DDPRINT("default clause is first, emit prevcase jump")); + pc_prevcase = duk__emit_jump_empty(comp_ctx); + } + + /* default clause matches next statement list (if any) */ + pc_default = -2; + } else { + /* Code is not accepted before the first case/default clause */ + goto syntax_error; + } + + /* + * Parse code after the clause. Possible terminators are + * 'case', 'default', and '}'. + * + * Note that there may be no code at all, not even an empty statement, + * between case clauses. This must be handled just like an empty statement + * (omitting seemingly pointless JUMPs), to avoid situations like + * test-bug-case-fallthrough.js. + */ + + num_stmts = 0; + if (pc_default == -2) { + pc_default = duk__get_current_pc(comp_ctx); + } + + /* Note: this is correct even for default clause statements: + * they participate in 'fall-through' behavior even if the + * default clause is in the middle. + */ + duk__patch_jump_here(comp_ctx, pc_prevstmt); /* chain jumps for 'fall-through' + * after a case matches. + */ + + for (;;) { + tok = comp_ctx->curr_token.t; + if (tok == DUK_TOK_CASE || tok == DUK_TOK_DEFAULT || tok == DUK_TOK_RCURLY) { + break; + } + num_stmts++; + duk__parse_stmt(comp_ctx, res, 0 /*allow_source_elem*/); + } + + /* fall-through jump to next code of next case (backpatched) */ + pc_prevstmt = duk__emit_jump_empty(comp_ctx); + + /* XXX: would be nice to omit this jump when the jump is not + * reachable, at least in the obvious cases (such as the case + * ending with a 'break'. + * + * Perhaps duk__parse_stmt() could provide some info on whether + * the statement is a "dead end"? + * + * If implemented, just set pc_prevstmt to -1 when not needed. + */ + } + + DUK_ASSERT(comp_ctx->curr_token.t == DUK_TOK_RCURLY); + comp_ctx->curr_func.allow_regexp_in_adv = 1; + duk__advance(comp_ctx); /* Allow RegExp as part of next stmt. */ + + /* default case control flow patchup; note that if pc_prevcase < 0 + * (i.e. no case clauses), control enters default case automatically. + */ + if (pc_default >= 0) { + /* default case exists: go there if no case matches */ + duk__patch_jump(comp_ctx, pc_prevcase, pc_default); + } else { + /* default case does not exist, or no statements present + * after default case: finish case evaluation + */ + duk__patch_jump_here(comp_ctx, pc_prevcase); + } + + /* fall-through control flow patchup; note that pc_prevstmt may be + * < 0 (i.e. no case clauses), in which case this is a no-op. + */ + duk__patch_jump_here(comp_ctx, pc_prevstmt); + + /* continue jump not patched, an INVALID opcode remains there */ + duk__patch_jump_here(comp_ctx, pc_label_site + 1); /* break jump */ + + /* Note: 'fast' breaks will jump to pc_label_site + 1, which will + * then jump here. The double jump will be eliminated by a + * peephole pass, resulting in an optimal jump here. The label + * site jumps will remain in bytecode and will waste code size. + */ + + return; + +syntax_error: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_SWITCH); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__parse_if_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_regconst_t temp_reset; + duk_regconst_t rc_cond; + duk_int_t pc_jump_false; + + DUK_DDD(DUK_DDDPRINT("begin parsing if statement")); + + temp_reset = DUK__GETTEMP(comp_ctx); + + duk__advance(comp_ctx); /* eat 'if' */ + duk__advance_expect(comp_ctx, DUK_TOK_LPAREN); + + rc_cond = duk__exprtop_toregconst(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); + duk__emit_if_true_skip(comp_ctx, rc_cond); + pc_jump_false = duk__emit_jump_empty(comp_ctx); /* jump to end or else part */ + DUK__SETTEMP(comp_ctx, temp_reset); + + comp_ctx->curr_func.allow_regexp_in_adv = 1; + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); /* Allow RegExp as part of next stmt. */ + + duk__parse_stmt(comp_ctx, res, 0 /*allow_source_elem*/); + + /* The 'else' ambiguity is resolved by 'else' binding to the innermost + * construct, so greedy matching is correct here. + */ + + if (comp_ctx->curr_token.t == DUK_TOK_ELSE) { + duk_int_t pc_jump_end; + + DUK_DDD(DUK_DDDPRINT("if has else part")); + + duk__advance(comp_ctx); + + pc_jump_end = duk__emit_jump_empty(comp_ctx); /* jump from true part to end */ + duk__patch_jump_here(comp_ctx, pc_jump_false); + + duk__parse_stmt(comp_ctx, res, 0 /*allow_source_elem*/); + + duk__patch_jump_here(comp_ctx, pc_jump_end); + } else { + DUK_DDD(DUK_DDDPRINT("if does not have else part")); + + duk__patch_jump_here(comp_ctx, pc_jump_false); + } + + DUK_DDD(DUK_DDDPRINT("end parsing if statement")); +} + +DUK_LOCAL void duk__parse_do_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_int_t pc_label_site) { + duk_regconst_t rc_cond; + duk_int_t pc_start; + + DUK_DDD(DUK_DDDPRINT("begin parsing do statement")); + + duk__advance(comp_ctx); /* Eat 'do'; allow RegExp as part of next stmt. */ + + pc_start = duk__get_current_pc(comp_ctx); + duk__parse_stmt(comp_ctx, res, 0 /*allow_source_elem*/); + duk__patch_jump_here(comp_ctx, pc_label_site + 2); /* continue jump */ + + duk__advance_expect(comp_ctx, DUK_TOK_WHILE); + duk__advance_expect(comp_ctx, DUK_TOK_LPAREN); + + rc_cond = duk__exprtop_toregconst(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); + duk__emit_if_false_skip(comp_ctx, rc_cond); + duk__emit_jump(comp_ctx, pc_start); + /* no need to reset temps, as we're finished emitting code */ + + comp_ctx->curr_func.allow_regexp_in_adv = 1; /* Allow RegExp as part of next stmt. */ + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); + + duk__patch_jump_here(comp_ctx, pc_label_site + 1); /* break jump */ + + DUK_DDD(DUK_DDDPRINT("end parsing do statement")); +} + +DUK_LOCAL void duk__parse_while_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_int_t pc_label_site) { + duk_regconst_t temp_reset; + duk_regconst_t rc_cond; + duk_int_t pc_start; + duk_int_t pc_jump_false; + + DUK_DDD(DUK_DDDPRINT("begin parsing while statement")); + + temp_reset = DUK__GETTEMP(comp_ctx); + + duk__advance(comp_ctx); /* eat 'while' */ + + duk__advance_expect(comp_ctx, DUK_TOK_LPAREN); + + pc_start = duk__get_current_pc(comp_ctx); + duk__patch_jump_here(comp_ctx, pc_label_site + 2); /* continue jump */ + + rc_cond = duk__exprtop_toregconst(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); + duk__emit_if_true_skip(comp_ctx, rc_cond); + pc_jump_false = duk__emit_jump_empty(comp_ctx); + DUK__SETTEMP(comp_ctx, temp_reset); + + comp_ctx->curr_func.allow_regexp_in_adv = 1; + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); /* Allow RegExp as part of next stmt. */ + + duk__parse_stmt(comp_ctx, res, 0 /*allow_source_elem*/); + duk__emit_jump(comp_ctx, pc_start); + + duk__patch_jump_here(comp_ctx, pc_jump_false); + duk__patch_jump_here(comp_ctx, pc_label_site + 1); /* break jump */ + + DUK_DDD(DUK_DDDPRINT("end parsing while statement")); +} + +DUK_LOCAL void duk__parse_break_or_continue_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_hthread *thr = comp_ctx->thr; + duk_bool_t is_break = (comp_ctx->curr_token.t == DUK_TOK_BREAK); + duk_int_t label_id; + duk_int_t label_catch_depth; + duk_int_t label_pc; /* points to LABEL; pc+1 = jump site for break; pc+2 = jump site for continue */ + duk_bool_t label_is_closest; + + DUK_UNREF(res); + + duk__advance(comp_ctx); /* eat 'break' or 'continue' */ + + if (comp_ctx->curr_token.t == DUK_TOK_SEMICOLON || /* explicit semi follows */ + comp_ctx->curr_token.lineterm || /* automatic semi will be inserted */ + comp_ctx->curr_token.allow_auto_semi) { /* automatic semi will be inserted */ + /* break/continue without label */ + + duk__lookup_active_label(comp_ctx, + DUK_HTHREAD_STRING_EMPTY_STRING(thr), + is_break, + &label_id, + &label_catch_depth, + &label_pc, + &label_is_closest); + } else if (comp_ctx->curr_token.t == DUK_TOK_IDENTIFIER) { + /* break/continue with label (label cannot be a reserved word, production is 'Identifier' */ + DUK_ASSERT(comp_ctx->curr_token.str1 != NULL); + duk__lookup_active_label(comp_ctx, + comp_ctx->curr_token.str1, + is_break, + &label_id, + &label_catch_depth, + &label_pc, + &label_is_closest); + duk__advance(comp_ctx); + } else { + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_BREAK_CONT_LABEL); + DUK_WO_NORETURN(return;); + } + + /* Use a fast break/continue when possible. A fast break/continue is + * just a jump to the LABEL break/continue jump slot, which then jumps + * to an appropriate place (for break, going through ENDLABEL correctly). + * The peephole optimizer will optimize the jump to a direct one. + */ + + if (label_catch_depth == comp_ctx->curr_func.catch_depth && label_is_closest) { + DUK_DDD(DUK_DDDPRINT("break/continue: is_break=%ld, label_id=%ld, label_is_closest=%ld, " + "label_catch_depth=%ld, catch_depth=%ld " + "-> use fast variant (direct jump)", + (long) is_break, + (long) label_id, + (long) label_is_closest, + (long) label_catch_depth, + (long) comp_ctx->curr_func.catch_depth)); + + duk__emit_jump(comp_ctx, label_pc + (is_break ? 1 : 2)); + } else { + DUK_DDD(DUK_DDDPRINT("break/continue: is_break=%ld, label_id=%ld, label_is_closest=%ld, " + "label_catch_depth=%ld, catch_depth=%ld " + "-> use slow variant (longjmp)", + (long) is_break, + (long) label_id, + (long) label_is_closest, + (long) label_catch_depth, + (long) comp_ctx->curr_func.catch_depth)); + + duk__emit_bc(comp_ctx, is_break ? DUK_OP_BREAK : DUK_OP_CONTINUE, (duk_regconst_t) label_id); + } +} + +DUK_LOCAL void duk__parse_return_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_hthread *thr = comp_ctx->thr; + duk_regconst_t rc_val; + + duk__advance(comp_ctx); /* eat 'return' */ + + /* A 'return' statement is only allowed inside an actual function body, + * not as part of eval or global code. + */ + if (!comp_ctx->curr_func.is_function) { + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_RETURN); + DUK_WO_NORETURN(return;); + } + + if (comp_ctx->curr_token.t == DUK_TOK_SEMICOLON || /* explicit semi follows */ + comp_ctx->curr_token.lineterm || /* automatic semi will be inserted */ + comp_ctx->curr_token.allow_auto_semi) { /* automatic semi will be inserted */ + DUK_DDD(DUK_DDDPRINT("empty return value -> undefined")); + duk__emit_op_only(comp_ctx, DUK_OP_RETUNDEF); + } else { + duk_int_t pc_before_expr; + duk_int_t pc_after_expr; + + DUK_DDD(DUK_DDDPRINT("return with a value")); + + DUK_UNREF(pc_before_expr); + DUK_UNREF(pc_after_expr); + + pc_before_expr = duk__get_current_pc(comp_ctx); + rc_val = duk__exprtop_toregconst(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); + pc_after_expr = duk__get_current_pc(comp_ctx); + + /* Tail call check: if last opcode emitted was CALL, and + * the context allows it, add a tailcall flag to the CALL. + * This doesn't guarantee that a tail call will be allowed at + * runtime, so the RETURN must still be emitted. (Duktape + * 0.10.0 avoided this and simulated a RETURN if a tail call + * couldn't be used at runtime; but this didn't work + * correctly with a thread yield/resume, see + * test-bug-tailcall-thread-yield-resume.js for discussion.) + * + * In addition to the last opcode being CALL, we also need to + * be sure that 'rc_val' is the result register of the CALL. + * For instance, for the expression 'return 0, (function () + * { return 1; }), 2' the last opcode emitted is CALL (no + * bytecode is emitted for '2') but 'rc_val' indicates + * constant '2'. Similarly if '2' is replaced by a register + * bound variable, no opcodes are emitted but tail call would + * be incorrect. + * + * This is tricky and easy to get wrong. It would be best to + * track enough expression metadata to check that 'rc_val' came + * from that last CALL instruction. We don't have that metadata + * now, so we check that 'rc_val' is a temporary register result + * (not a constant or a register bound variable). There should + * be no way currently for 'rc_val' to be a temporary for an + * expression following the CALL instruction without emitting + * some opcodes following the CALL. This proxy check is used + * below. + * + * See: test-bug-comma-expr-gh131.js. + * + * The non-standard 'caller' property disables tail calls + * because they pose some special cases which haven't been + * fixed yet. + */ + +#if defined(DUK_USE_TAILCALL) + if (comp_ctx->curr_func.catch_depth == 0 && /* no catchers */ + pc_after_expr > pc_before_expr) { /* at least one opcode emitted */ + duk_compiler_instr *instr; + duk_instr_t ins; + duk_small_uint_t op; + + instr = duk__get_instr_ptr(comp_ctx, pc_after_expr - 1); + DUK_ASSERT(instr != NULL); + + ins = instr->ins; + op = (duk_small_uint_t) DUK_DEC_OP(ins); + if ((op & ~0x0fU) == DUK_OP_CALL0 && DUK__ISREG_TEMP(comp_ctx, rc_val) /* see above */) { + DUK_DDD(DUK_DDDPRINT("return statement detected a tail call opportunity: " + "catch depth is 0, duk__exprtop() emitted >= 1 instructions, " + "and last instruction is a CALL " + "-> change to TAILCALL")); + ins |= DUK_ENC_OP(DUK_BC_CALL_FLAG_TAILCALL); + instr->ins = ins; + } + } +#endif /* DUK_USE_TAILCALL */ + + if (DUK__ISREG(rc_val)) { + duk__emit_bc(comp_ctx, DUK_OP_RETREG, rc_val); + } else { + rc_val = DUK__REMOVECONST(rc_val); + if (duk__const_needs_refcount(comp_ctx, rc_val)) { + duk__emit_bc(comp_ctx, DUK_OP_RETCONST, rc_val); + } else { + duk__emit_bc(comp_ctx, DUK_OP_RETCONSTN, rc_val); + } + } + } +} + +DUK_LOCAL void duk__parse_throw_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_regconst_t reg_val; + + duk__advance(comp_ctx); /* eat 'throw' */ + + /* Unlike break/continue, throw statement does not allow an empty value. */ + + if (comp_ctx->curr_token.lineterm) { + DUK_ERROR_SYNTAX(comp_ctx->thr, DUK_STR_INVALID_THROW); + DUK_WO_NORETURN(return;); + } + + reg_val = duk__exprtop_toreg(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); + duk__emit_bc(comp_ctx, DUK_OP_THROW, reg_val); +} + +DUK_LOCAL void duk__parse_try_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_hthread *thr = comp_ctx->thr; + duk_regconst_t reg_catch; /* reg_catch+0 and reg_catch+1 are reserved for TRYCATCH */ + duk_regconst_t rc_varname = 0; + duk_small_uint_t trycatch_flags = 0; + duk_int_t pc_ldconst = -1; + duk_int_t pc_trycatch = -1; + duk_int_t pc_catch = -1; + duk_int_t pc_finally = -1; + + DUK_UNREF(res); + + /* + * See the following documentation for discussion: + * + * doc/execution.rst: control flow details + * + * Try, catch, and finally "parts" are Blocks, not Statements, so + * they must always be delimited by curly braces. This is unlike e.g. + * the if statement, which accepts any Statement. This eliminates any + * questions of matching parts of nested try statements. The Block + * parsing is implemented inline here (instead of calling out). + * + * Finally part has a 'let scoped' variable, which requires a few kinks + * here. + */ + + comp_ctx->curr_func.catch_depth++; + + duk__advance(comp_ctx); /* eat 'try' */ + + reg_catch = DUK__ALLOCTEMPS(comp_ctx, 2); + + /* The target for this LDCONST may need output shuffling, but we assume + * that 'pc_ldconst' will be the LDCONST that we can patch later. This + * should be the case because there's no input shuffling. (If there's + * no catch clause, this LDCONST will be replaced with a NOP.) + */ + pc_ldconst = duk__get_current_pc(comp_ctx); + duk__emit_a_bc(comp_ctx, DUK_OP_LDCONST, reg_catch, 0 /*patched later*/); + + pc_trycatch = duk__get_current_pc(comp_ctx); + duk__emit_invalid(comp_ctx); /* TRYCATCH, cannot emit now (not enough info) */ + duk__emit_invalid(comp_ctx); /* jump for 'catch' case */ + duk__emit_invalid(comp_ctx); /* jump for 'finally' case or end (if no finally) */ + + /* try part */ + duk__advance_expect(comp_ctx, DUK_TOK_LCURLY); + duk__parse_stmts(comp_ctx, 0 /*allow_source_elem*/, 0 /*expect_eof*/, 1 /*regexp_after*/); + /* the DUK_TOK_RCURLY is eaten by duk__parse_stmts() */ + duk__emit_op_only(comp_ctx, DUK_OP_ENDTRY); + + if (comp_ctx->curr_token.t == DUK_TOK_CATCH) { + /* + * The catch variable must be updated to reflect the new allocated + * register for the duration of the catch clause. We need to store + * and restore the original value for the varmap entry (if any). + */ + + /* + * Note: currently register bindings must be fixed for the entire + * function. So, even though the catch variable is in a register + * we know, we must use an explicit environment record and slow path + * accesses to read/write the catch binding to make closures created + * within the catch clause work correctly. This restriction should + * be fixable (at least in common cases) later. + * + * See: test-bug-catch-binding-2.js. + * + * XXX: improve to get fast path access to most catch clauses. + */ + + duk_hstring *h_var; + duk_int_t varmap_value; /* for storing/restoring the varmap binding for catch variable */ + + DUK_DDD(DUK_DDDPRINT("stack top at start of catch clause: %ld", (long) duk_get_top(thr))); + + trycatch_flags |= DUK_BC_TRYCATCH_FLAG_HAVE_CATCH; + + pc_catch = duk__get_current_pc(comp_ctx); + + duk__advance(comp_ctx); + duk__advance_expect(comp_ctx, DUK_TOK_LPAREN); + + if (comp_ctx->curr_token.t != DUK_TOK_IDENTIFIER) { + /* Identifier, i.e. don't allow reserved words */ + goto syntax_error; + } + h_var = comp_ctx->curr_token.str1; + DUK_ASSERT(h_var != NULL); + + duk_push_hstring(thr, h_var); /* keep in on valstack, use borrowed ref below */ + + if (comp_ctx->curr_func.is_strict && + ((h_var == DUK_HTHREAD_STRING_EVAL(thr)) || (h_var == DUK_HTHREAD_STRING_LC_ARGUMENTS(thr)))) { + DUK_DDD(DUK_DDDPRINT("catch identifier 'eval' or 'arguments' in strict mode -> SyntaxError")); + goto syntax_error; + } + + duk_dup_top(thr); + rc_varname = duk__getconst(comp_ctx); + DUK_DDD(DUK_DDDPRINT("catch clause, rc_varname=0x%08lx (%ld)", (unsigned long) rc_varname, (long) rc_varname)); + + duk__advance(comp_ctx); + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); + + duk__advance_expect(comp_ctx, DUK_TOK_LCURLY); + + DUK_DDD(DUK_DDDPRINT("varmap before modifying for catch clause: %!iT", + (duk_tval *) duk_get_tval(thr, comp_ctx->curr_func.varmap_idx))); + + duk_dup_top(thr); + duk_get_prop(thr, comp_ctx->curr_func.varmap_idx); + if (duk_is_undefined(thr, -1)) { + varmap_value = -2; + } else if (duk_is_null(thr, -1)) { + varmap_value = -1; + } else { + DUK_ASSERT(duk_is_number(thr, -1)); + varmap_value = duk_get_int(thr, -1); + DUK_ASSERT(varmap_value >= 0); + } + duk_pop(thr); + +#if 0 + /* It'd be nice to do something like this - but it doesn't + * work for closures created inside the catch clause. + */ + duk_dup_top(thr); + duk_push_int(thr, (duk_int_t) (reg_catch + 0)); + duk_put_prop(thr, comp_ctx->curr_func.varmap_idx); +#endif + duk_dup_top(thr); + duk_push_null(thr); + duk_put_prop(thr, comp_ctx->curr_func.varmap_idx); + + duk__emit_a_bc(comp_ctx, + DUK_OP_PUTVAR | DUK__EMIT_FLAG_A_IS_SOURCE, + reg_catch + 0 /*value*/, + rc_varname /*varname*/); + + DUK_DDD(DUK_DDDPRINT("varmap before parsing catch clause: %!iT", + (duk_tval *) duk_get_tval(thr, comp_ctx->curr_func.varmap_idx))); + + duk__parse_stmts(comp_ctx, 0 /*allow_source_elem*/, 0 /*expect_eof*/, 1 /*regexp_after*/); + /* the DUK_TOK_RCURLY is eaten by duk__parse_stmts() */ + + if (varmap_value == -2) { + /* not present */ + duk_del_prop(thr, comp_ctx->curr_func.varmap_idx); + } else { + if (varmap_value == -1) { + duk_push_null(thr); + } else { + DUK_ASSERT(varmap_value >= 0); + duk_push_int(thr, varmap_value); + } + duk_put_prop(thr, comp_ctx->curr_func.varmap_idx); + } + /* varname is popped by above code */ + + DUK_DDD(DUK_DDDPRINT("varmap after restore catch clause: %!iT", + (duk_tval *) duk_get_tval(thr, comp_ctx->curr_func.varmap_idx))); + + duk__emit_op_only(comp_ctx, DUK_OP_ENDCATCH); + + /* + * XXX: for now, indicate that an expensive catch binding + * declarative environment is always needed. If we don't + * need it, we don't need the const_varname either. + */ + + trycatch_flags |= DUK_BC_TRYCATCH_FLAG_CATCH_BINDING; + + DUK_DDD(DUK_DDDPRINT("stack top at end of catch clause: %ld", (long) duk_get_top(thr))); + } + + if (comp_ctx->curr_token.t == DUK_TOK_FINALLY) { + trycatch_flags |= DUK_BC_TRYCATCH_FLAG_HAVE_FINALLY; + + pc_finally = duk__get_current_pc(comp_ctx); + + duk__advance(comp_ctx); + + duk__advance_expect(comp_ctx, DUK_TOK_LCURLY); + duk__parse_stmts(comp_ctx, 0 /*allow_source_elem*/, 0 /*expect_eof*/, 1 /*regexp_after*/); + /* the DUK_TOK_RCURLY is eaten by duk__parse_stmts() */ + duk__emit_abc(comp_ctx, DUK_OP_ENDFIN, reg_catch); /* rethrow */ + } + + if (!(trycatch_flags & DUK_BC_TRYCATCH_FLAG_HAVE_CATCH) && !(trycatch_flags & DUK_BC_TRYCATCH_FLAG_HAVE_FINALLY)) { + /* must have catch and/or finally */ + goto syntax_error; + } + + /* If there's no catch block, rc_varname will be 0 and duk__patch_trycatch() + * will replace the LDCONST with a NOP. For any actual constant (including + * constant 0) the DUK__CONST_MARKER flag will be set in rc_varname. + */ + + duk__patch_trycatch(comp_ctx, pc_ldconst, pc_trycatch, reg_catch, rc_varname, trycatch_flags); + + if (trycatch_flags & DUK_BC_TRYCATCH_FLAG_HAVE_CATCH) { + DUK_ASSERT(pc_catch >= 0); + duk__patch_jump(comp_ctx, pc_trycatch + 1, pc_catch); + } + + if (trycatch_flags & DUK_BC_TRYCATCH_FLAG_HAVE_FINALLY) { + DUK_ASSERT(pc_finally >= 0); + duk__patch_jump(comp_ctx, pc_trycatch + 2, pc_finally); + } else { + /* without finally, the second jump slot is used to jump to end of stmt */ + duk__patch_jump_here(comp_ctx, pc_trycatch + 2); + } + + comp_ctx->curr_func.catch_depth--; + return; + +syntax_error: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_TRY); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__parse_with_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res) { + duk_int_t pc_trycatch; + duk_int_t pc_finished; + duk_regconst_t reg_catch; + duk_small_uint_t trycatch_flags; + + if (comp_ctx->curr_func.is_strict) { + DUK_ERROR_SYNTAX(comp_ctx->thr, DUK_STR_WITH_IN_STRICT_MODE); + DUK_WO_NORETURN(return;); + } + + comp_ctx->curr_func.catch_depth++; + + duk__advance(comp_ctx); /* eat 'with' */ + + reg_catch = DUK__ALLOCTEMPS(comp_ctx, 2); + + duk__advance_expect(comp_ctx, DUK_TOK_LPAREN); + duk__exprtop_toforcedreg(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/, reg_catch); + comp_ctx->curr_func.allow_regexp_in_adv = 1; + duk__advance_expect(comp_ctx, DUK_TOK_RPAREN); /* Allow RegExp as part of next stmt. */ + + pc_trycatch = duk__get_current_pc(comp_ctx); + trycatch_flags = DUK_BC_TRYCATCH_FLAG_WITH_BINDING; + duk__emit_a_bc(comp_ctx, + DUK_OP_TRYCATCH | DUK__EMIT_FLAG_NO_SHUFFLE_A, + (duk_regconst_t) trycatch_flags /*a*/, + reg_catch /*bc*/); + duk__emit_invalid(comp_ctx); /* catch jump */ + duk__emit_invalid(comp_ctx); /* finished jump */ + + duk__parse_stmt(comp_ctx, res, 0 /*allow_source_elem*/); + duk__emit_op_only(comp_ctx, DUK_OP_ENDTRY); + + pc_finished = duk__get_current_pc(comp_ctx); + + duk__patch_jump(comp_ctx, pc_trycatch + 2, pc_finished); + + comp_ctx->curr_func.catch_depth--; +} + +DUK_LOCAL duk_int_t duk__stmt_label_site(duk_compiler_ctx *comp_ctx, duk_int_t label_id) { + /* if a site already exists, nop: max one label site per statement */ + if (label_id >= 0) { + return label_id; + } + + label_id = comp_ctx->curr_func.label_next++; + DUK_DDD(DUK_DDDPRINT("allocated new label id for label site: %ld", (long) label_id)); + + duk__emit_bc(comp_ctx, DUK_OP_LABEL, (duk_regconst_t) label_id); + duk__emit_invalid(comp_ctx); + duk__emit_invalid(comp_ctx); + + return label_id; +} + +/* Parse a single statement. + * + * Creates a label site (with an empty label) automatically for iteration + * statements. Also "peels off" any label statements for explicit labels. + */ +DUK_LOCAL void duk__parse_stmt(duk_compiler_ctx *comp_ctx, duk_ivalue *res, duk_bool_t allow_source_elem) { + duk_hthread *thr = comp_ctx->thr; + duk_bool_t dir_prol_at_entry; /* directive prologue status at entry */ + duk_regconst_t temp_at_entry; + duk_size_t labels_len_at_entry; + duk_int_t pc_at_entry; /* assumed to also be PC of "LABEL" */ + duk_int_t stmt_id; + duk_small_uint_t stmt_flags = 0; + duk_int_t label_id = -1; + duk_small_uint_t tok; + duk_bool_t test_func_decl; + + DUK__RECURSION_INCREASE(comp_ctx, thr); + + temp_at_entry = DUK__GETTEMP(comp_ctx); + pc_at_entry = duk__get_current_pc(comp_ctx); + labels_len_at_entry = duk_get_length(thr, comp_ctx->curr_func.labelnames_idx); + stmt_id = comp_ctx->curr_func.stmt_next++; + dir_prol_at_entry = comp_ctx->curr_func.in_directive_prologue; + + DUK_UNREF(stmt_id); + + DUK_DDD(DUK_DDDPRINT("parsing a statement, stmt_id=%ld, temp_at_entry=%ld, labels_len_at_entry=%ld, " + "is_strict=%ld, in_directive_prologue=%ld, catch_depth=%ld", + (long) stmt_id, + (long) temp_at_entry, + (long) labels_len_at_entry, + (long) comp_ctx->curr_func.is_strict, + (long) comp_ctx->curr_func.in_directive_prologue, + (long) comp_ctx->curr_func.catch_depth)); + + /* The directive prologue flag is cleared by default so that it is + * unset for any recursive statement parsing. It is only "revived" + * if a directive is detected. (We could also make directives only + * allowed if 'allow_source_elem' was true.) + */ + comp_ctx->curr_func.in_directive_prologue = 0; + +retry_parse: + + DUK_DDD(DUK_DDDPRINT("try stmt parse, stmt_id=%ld, label_id=%ld, allow_source_elem=%ld, catch_depth=%ld", + (long) stmt_id, + (long) label_id, + (long) allow_source_elem, + (long) comp_ctx->curr_func.catch_depth)); + + /* + * Detect iteration statements; if encountered, establish an + * empty label. + */ + + tok = comp_ctx->curr_token.t; + if (tok == DUK_TOK_FOR || tok == DUK_TOK_DO || tok == DUK_TOK_WHILE || tok == DUK_TOK_SWITCH) { + DUK_DDD(DUK_DDDPRINT("iteration/switch statement -> add empty label")); + + label_id = duk__stmt_label_site(comp_ctx, label_id); + duk__add_label(comp_ctx, DUK_HTHREAD_STRING_EMPTY_STRING(thr), pc_at_entry /*pc_label*/, label_id); + } + + /* + * Main switch for statement / source element type. + */ + + switch (comp_ctx->curr_token.t) { + case DUK_TOK_FUNCTION: { + /* + * Function declaration, function expression, or (non-standard) + * function statement. + * + * The E5 specification only allows function declarations at + * the top level (in "source elements"). An ExpressionStatement + * is explicitly not allowed to begin with a "function" keyword + * (E5 Section 12.4). Hence any non-error semantics for such + * non-top-level statements are non-standard. Duktape semantics + * for function statements are modelled after V8, see + * test-dev-func-decl-outside-top.js. + */ + test_func_decl = allow_source_elem; +#if defined(DUK_USE_NONSTD_FUNC_STMT) + /* Lenient: allow function declarations outside top level in both + * strict and non-strict modes. However, don't allow labelled + * function declarations in strict mode. + */ + test_func_decl = test_func_decl || !comp_ctx->curr_func.is_strict || label_id < 0; +#endif /* DUK_USE_NONSTD_FUNC_STMT */ + /* Strict: never allow function declarations outside top level. */ + if (test_func_decl) { + /* FunctionDeclaration: not strictly a statement but handled as such. + * + * O(depth^2) parse count for inner functions is handled by recording a + * lexer offset on the first compilation pass, so that the function can + * be efficiently skipped on the second pass. This is encapsulated into + * duk__parse_func_like_fnum(). + */ + + duk_int_t fnum; +#if defined(DUK_USE_ASSERTIONS) + duk_idx_t top_before; +#endif + + DUK_DDD(DUK_DDDPRINT("function declaration statement")); + +#if defined(DUK_USE_ASSERTIONS) + top_before = duk_get_top(thr); +#endif + + duk__advance(comp_ctx); /* eat 'function' */ + fnum = duk__parse_func_like_fnum(comp_ctx, DUK__FUNC_FLAG_DECL | DUK__FUNC_FLAG_PUSHNAME_PASS1); + + /* The value stack convention here is a bit odd: the function + * name is only pushed on pass 1 (in_scanning), and is needed + * to process function declarations. + */ + if (comp_ctx->curr_func.in_scanning) { + duk_uarridx_t n; + +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(duk_get_top(thr) == top_before + 1); +#endif + DUK_DDD(DUK_DDDPRINT("register function declaration %!T in pass 1, fnum %ld", + duk_get_tval(thr, -1), + (long) fnum)); + n = (duk_uarridx_t) duk_get_length(thr, comp_ctx->curr_func.decls_idx); + /* funcname is at index -1 */ + duk_put_prop_index(thr, comp_ctx->curr_func.decls_idx, n); + duk_push_int(thr, (duk_int_t) (DUK_DECL_TYPE_FUNC + (fnum << 8))); + duk_put_prop_index(thr, comp_ctx->curr_func.decls_idx, n + 1); + } else { +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(duk_get_top(thr) == top_before); +#endif + } + + /* no statement value (unlike function expression) */ + stmt_flags = 0; + break; + } else { + DUK_ERROR_SYNTAX(thr, DUK_STR_FUNC_STMT_NOT_ALLOWED); + DUK_WO_NORETURN(return;); + } + break; + } + case DUK_TOK_LCURLY: { + DUK_DDD(DUK_DDDPRINT("block statement")); + duk__advance(comp_ctx); + duk__parse_stmts(comp_ctx, 0 /*allow_source_elem*/, 0 /*expect_eof*/, 1 /*regexp_after*/); + /* the DUK_TOK_RCURLY is eaten by duk__parse_stmts() */ + if (label_id >= 0) { + duk__patch_jump_here(comp_ctx, pc_at_entry + 1); /* break jump */ + } + stmt_flags = 0; + break; + } + case DUK_TOK_CONST: { + DUK_DDD(DUK_DDDPRINT("constant declaration statement")); + duk__parse_var_stmt(comp_ctx, res, DUK__EXPR_FLAG_REQUIRE_INIT /*expr_flags*/); + stmt_flags = DUK__HAS_TERM; + break; + } + case DUK_TOK_VAR: { + DUK_DDD(DUK_DDDPRINT("variable declaration statement")); + duk__parse_var_stmt(comp_ctx, res, 0 /*expr_flags*/); + stmt_flags = DUK__HAS_TERM; + break; + } + case DUK_TOK_SEMICOLON: { + /* empty statement with an explicit semicolon */ + DUK_DDD(DUK_DDDPRINT("empty statement")); + stmt_flags = DUK__HAS_TERM; + break; + } + case DUK_TOK_IF: { + DUK_DDD(DUK_DDDPRINT("if statement")); + duk__parse_if_stmt(comp_ctx, res); + if (label_id >= 0) { + duk__patch_jump_here(comp_ctx, pc_at_entry + 1); /* break jump */ + } + stmt_flags = 0; + break; + } + case DUK_TOK_DO: { + /* + * Do-while statement is mostly trivial, but there is special + * handling for automatic semicolon handling (triggered by the + * DUK__ALLOW_AUTO_SEMI_ALWAYS) flag related to a bug filed at: + * + * https://bugs.ecmascript.org/show_bug.cgi?id=8 + * + * See doc/compiler.rst for details. + */ + DUK_DDD(DUK_DDDPRINT("do statement")); + DUK_ASSERT(label_id >= 0); + duk__update_label_flags(comp_ctx, label_id, DUK_LABEL_FLAG_ALLOW_BREAK | DUK_LABEL_FLAG_ALLOW_CONTINUE); + duk__parse_do_stmt(comp_ctx, res, pc_at_entry); + stmt_flags = DUK__HAS_TERM | DUK__ALLOW_AUTO_SEMI_ALWAYS; /* DUK__ALLOW_AUTO_SEMI_ALWAYS workaround */ + break; + } + case DUK_TOK_WHILE: { + DUK_DDD(DUK_DDDPRINT("while statement")); + DUK_ASSERT(label_id >= 0); + duk__update_label_flags(comp_ctx, label_id, DUK_LABEL_FLAG_ALLOW_BREAK | DUK_LABEL_FLAG_ALLOW_CONTINUE); + duk__parse_while_stmt(comp_ctx, res, pc_at_entry); + stmt_flags = 0; + break; + } + case DUK_TOK_FOR: { + /* + * For/for-in statement is complicated to parse because + * determining the statement type (three-part for vs. a + * for-in) requires potential backtracking. + * + * See the helper for the messy stuff. + */ + DUK_DDD(DUK_DDDPRINT("for/for-in statement")); + DUK_ASSERT(label_id >= 0); + duk__update_label_flags(comp_ctx, label_id, DUK_LABEL_FLAG_ALLOW_BREAK | DUK_LABEL_FLAG_ALLOW_CONTINUE); + duk__parse_for_stmt(comp_ctx, res, pc_at_entry); + stmt_flags = 0; + break; + } + case DUK_TOK_CONTINUE: + case DUK_TOK_BREAK: { + DUK_DDD(DUK_DDDPRINT("break/continue statement")); + duk__parse_break_or_continue_stmt(comp_ctx, res); + stmt_flags = DUK__HAS_TERM | DUK__IS_TERMINAL; + break; + } + case DUK_TOK_RETURN: { + DUK_DDD(DUK_DDDPRINT("return statement")); + duk__parse_return_stmt(comp_ctx, res); + stmt_flags = DUK__HAS_TERM | DUK__IS_TERMINAL; + break; + } + case DUK_TOK_WITH: { + DUK_DDD(DUK_DDDPRINT("with statement")); + comp_ctx->curr_func.with_depth++; + duk__parse_with_stmt(comp_ctx, res); + if (label_id >= 0) { + duk__patch_jump_here(comp_ctx, pc_at_entry + 1); /* break jump */ + } + comp_ctx->curr_func.with_depth--; + stmt_flags = 0; + break; + } + case DUK_TOK_SWITCH: { + /* + * The switch statement is pretty messy to compile. + * See the helper for details. + */ + DUK_DDD(DUK_DDDPRINT("switch statement")); + DUK_ASSERT(label_id >= 0); + duk__update_label_flags(comp_ctx, label_id, DUK_LABEL_FLAG_ALLOW_BREAK); /* don't allow continue */ + duk__parse_switch_stmt(comp_ctx, res, pc_at_entry); + stmt_flags = 0; + break; + } + case DUK_TOK_THROW: { + DUK_DDD(DUK_DDDPRINT("throw statement")); + duk__parse_throw_stmt(comp_ctx, res); + stmt_flags = DUK__HAS_TERM | DUK__IS_TERMINAL; + break; + } + case DUK_TOK_TRY: { + DUK_DDD(DUK_DDDPRINT("try statement")); + duk__parse_try_stmt(comp_ctx, res); + stmt_flags = 0; + break; + } + case DUK_TOK_DEBUGGER: { + duk__advance(comp_ctx); +#if defined(DUK_USE_DEBUGGER_SUPPORT) + DUK_DDD(DUK_DDDPRINT("debugger statement: debugging enabled, emit debugger opcode")); + duk__emit_op_only(comp_ctx, DUK_OP_DEBUGGER); +#else + DUK_DDD(DUK_DDDPRINT("debugger statement: ignored")); +#endif + stmt_flags = DUK__HAS_TERM; + break; + } + default: { + /* + * Else, must be one of: + * - ExpressionStatement, possibly a directive (String) + * - LabelledStatement (Identifier followed by ':') + * + * Expressions beginning with 'function' keyword are covered by a case + * above (such expressions are not allowed in standard E5 anyway). + * Also expressions starting with '{' are interpreted as block + * statements. See E5 Section 12.4. + * + * Directive detection is tricky; see E5 Section 14.1 on directive + * prologue. A directive is an expression statement with a single + * string literal and an explicit or automatic semicolon. Escape + * characters are significant and no parens etc are allowed: + * + * 'use strict'; // valid 'use strict' directive + * 'use\u0020strict'; // valid directive, not a 'use strict' directive + * ('use strict'); // not a valid directive + * + * The expression is determined to consist of a single string literal + * based on duk__expr_nud() and duk__expr_led() call counts. The string literal + * of a 'use strict' directive is determined to lack any escapes based + * num_escapes count from the lexer. Note that other directives may be + * allowed to contain escapes, so a directive with escapes does not + * terminate a directive prologue. + * + * We rely on the fact that the expression parser will not emit any + * code for a single token expression. However, it will generate an + * intermediate value which we will then successfully ignore. + * + * A similar approach is used for labels. + */ + + duk_bool_t single_token; + + DUK_DDD(DUK_DDDPRINT("expression statement")); + duk__exprtop(comp_ctx, res, DUK__BP_FOR_EXPR /*rbp_flags*/); + + single_token = (comp_ctx->curr_func.nud_count == 1 && /* one token */ + comp_ctx->curr_func.led_count == 0); /* no operators */ + + if (single_token && comp_ctx->prev_token.t == DUK_TOK_IDENTIFIER && comp_ctx->curr_token.t == DUK_TOK_COLON) { + /* + * Detected label + */ + + duk_hstring *h_lab; + + /* expected ival */ + DUK_ASSERT(res->t == DUK_IVAL_VAR); + DUK_ASSERT(res->x1.t == DUK_ISPEC_VALUE); + DUK_ASSERT(DUK_TVAL_IS_STRING(duk_get_tval(thr, res->x1.valstack_idx))); + h_lab = comp_ctx->prev_token.str1; + DUK_ASSERT(h_lab != NULL); + + DUK_DDD(DUK_DDDPRINT("explicit label site for label '%!O'", (duk_heaphdr *) h_lab)); + + duk__advance(comp_ctx); /* eat colon */ + + label_id = duk__stmt_label_site(comp_ctx, label_id); + + duk__add_label(comp_ctx, h_lab, pc_at_entry /*pc_label*/, label_id); + + /* a statement following a label cannot be a source element + * (a function declaration). + */ + allow_source_elem = 0; + + DUK_DDD(DUK_DDDPRINT("label handled, retry statement parsing")); + goto retry_parse; + } + + stmt_flags = 0; + + if (dir_prol_at_entry && /* still in prologue */ + single_token && /* single string token */ + comp_ctx->prev_token.t == DUK_TOK_STRING) { + /* + * Detected a directive + */ + duk_hstring *h_dir; + + /* expected ival */ + DUK_ASSERT(res->t == DUK_IVAL_PLAIN); + DUK_ASSERT(res->x1.t == DUK_ISPEC_VALUE); + DUK_ASSERT(DUK_TVAL_IS_STRING(duk_get_tval(thr, res->x1.valstack_idx))); + h_dir = comp_ctx->prev_token.str1; + DUK_ASSERT(h_dir != NULL); + + DUK_DDD(DUK_DDDPRINT("potential directive: %!O", h_dir)); + + stmt_flags |= DUK__STILL_PROLOGUE; + + /* Note: escaped characters differentiate directives */ + + if (comp_ctx->prev_token.num_escapes > 0) { + DUK_DDD(DUK_DDDPRINT("directive contains escapes: valid directive " + "but we ignore such directives")); + } else { + /* + * The length comparisons are present to handle + * strings like "use strict\u0000foo" as required. + */ + + if (DUK_HSTRING_GET_BYTELEN(h_dir) == 10 && + DUK_STRCMP((const char *) DUK_HSTRING_GET_DATA(h_dir), "use strict") == 0) { +#if defined(DUK_USE_STRICT_DECL) + DUK_DDD(DUK_DDDPRINT("use strict directive detected: strict flag %ld -> %ld", + (long) comp_ctx->curr_func.is_strict, + (long) 1)); + comp_ctx->curr_func.is_strict = 1; +#else + DUK_DDD(DUK_DDDPRINT("use strict detected but strict declarations disabled, ignoring")); +#endif + } else if (DUK_HSTRING_GET_BYTELEN(h_dir) == 14 && + DUK_STRCMP((const char *) DUK_HSTRING_GET_DATA(h_dir), "use duk notail") == 0) { + DUK_DDD(DUK_DDDPRINT("use duk notail directive detected: notail flag %ld -> %ld", + (long) comp_ctx->curr_func.is_notail, + (long) 1)); + comp_ctx->curr_func.is_notail = 1; + } else { + DUK_DD(DUK_DDPRINT("unknown directive: '%!O', ignoring but not terminating " + "directive prologue", + (duk_hobject *) h_dir)); + } + } + } else { + DUK_DDD(DUK_DDDPRINT("non-directive expression statement or no longer in prologue; " + "prologue terminated if still active")); + } + + stmt_flags |= DUK__HAS_VAL | DUK__HAS_TERM; + } + } /* end switch (tok) */ + + /* + * Statement value handling. + * + * Global code and eval code has an implicit return value + * which comes from the last statement with a value + * (technically a non-"empty" continuation, which is + * different from an empty statement). + * + * Since we don't know whether a later statement will + * override the value of the current statement, we need + * to coerce the statement value to a register allocated + * for implicit return values. In other cases we need + * to coerce the statement value to a plain value to get + * any side effects out (consider e.g. "foo.bar;"). + */ + + /* XXX: what about statements which leave a half-cooked value in 'res' + * but have no stmt value? Any such statements? + */ + + if (stmt_flags & DUK__HAS_VAL) { + duk_regconst_t reg_stmt_value = comp_ctx->curr_func.reg_stmt_value; + if (reg_stmt_value >= 0) { + duk__ivalue_toforcedreg(comp_ctx, res, reg_stmt_value); + } else { + duk__ivalue_toplain_ignore(comp_ctx, res); + } + } else { + ; + } + + /* + * Statement terminator check, including automatic semicolon + * handling. After this step, 'curr_tok' should be the first + * token after a possible statement terminator. + */ + + if (stmt_flags & DUK__HAS_TERM) { + if (comp_ctx->curr_token.t == DUK_TOK_SEMICOLON) { + DUK_DDD(DUK_DDDPRINT("explicit semicolon terminates statement")); + duk__advance(comp_ctx); + } else { + if (comp_ctx->curr_token.allow_auto_semi) { + DUK_DDD(DUK_DDDPRINT("automatic semicolon terminates statement")); + } else if (stmt_flags & DUK__ALLOW_AUTO_SEMI_ALWAYS) { + /* XXX: make this lenience dependent on flags or strictness? */ + DUK_DDD(DUK_DDDPRINT("automatic semicolon terminates statement (allowed for compatibility " + "even though no lineterm present before next token)")); + } else { + DUK_ERROR_SYNTAX(thr, DUK_STR_UNTERMINATED_STMT); + DUK_WO_NORETURN(return;); + } + } + } else { + DUK_DDD(DUK_DDDPRINT("statement has no terminator")); + } + + /* + * Directive prologue tracking. + */ + + if (stmt_flags & DUK__STILL_PROLOGUE) { + DUK_DDD(DUK_DDDPRINT("setting in_directive_prologue")); + comp_ctx->curr_func.in_directive_prologue = 1; + } + + /* + * Cleanups (all statement parsing flows through here). + * + * Pop label site and reset labels. Reset 'next temp' to value at + * entry to reuse temps. + */ + + if (label_id >= 0) { + duk__emit_bc(comp_ctx, DUK_OP_ENDLABEL, (duk_regconst_t) label_id); + } + + DUK__SETTEMP(comp_ctx, temp_at_entry); + + duk__reset_labels_to_length(comp_ctx, labels_len_at_entry); + + /* XXX: return indication of "terminalness" (e.g. a 'throw' is terminal) */ + + DUK__RECURSION_DECREASE(comp_ctx, thr); +} + +/* + * Parse a statement list. + * + * Handles automatic semicolon insertion and implicit return value. + * + * Upon entry, 'curr_tok' should contain the first token of the first + * statement (parsed in the "allow regexp literal" mode). Upon exit, + * 'curr_tok' contains the token following the statement list terminator + * (EOF or closing brace). + */ + +DUK_LOCAL void duk__parse_stmts(duk_compiler_ctx *comp_ctx, + duk_bool_t allow_source_elem, + duk_bool_t expect_eof, + duk_bool_t regexp_after) { + duk_hthread *thr = comp_ctx->thr; + duk_ivalue res_alloc; + duk_ivalue *res = &res_alloc; + + /* Setup state. Initial ivalue is 'undefined'. */ + + duk_require_stack(thr, DUK__PARSE_STATEMENTS_SLOTS); + + /* XXX: 'res' setup can be moved to function body level; in fact, two 'res' + * intermediate values suffice for parsing of each function. Nesting is needed + * for nested functions (which may occur inside expressions). + */ + + duk_memzero(&res_alloc, sizeof(res_alloc)); + res->t = DUK_IVAL_PLAIN; + res->x1.t = DUK_ISPEC_VALUE; + res->x1.valstack_idx = duk_get_top(thr); + res->x2.valstack_idx = res->x1.valstack_idx + 1; + duk_push_undefined(thr); + duk_push_undefined(thr); + + /* Parse statements until a closing token (EOF or '}') is found. */ + + for (;;) { + /* Check whether statement list ends. */ + + if (expect_eof) { + if (comp_ctx->curr_token.t == DUK_TOK_EOF) { + break; + } + } else { + if (comp_ctx->curr_token.t == DUK_TOK_RCURLY) { + break; + } + } + + /* Check statement type based on the first token type. + * + * Note: expression parsing helpers expect 'curr_tok' to + * contain the first token of the expression upon entry. + */ + + DUK_DDD(DUK_DDDPRINT("TOKEN %ld (non-whitespace, non-comment)", (long) comp_ctx->curr_token.t)); + + duk__parse_stmt(comp_ctx, res, allow_source_elem); + } + + /* RegExp is allowed / not allowed depending on context. For function + * declarations RegExp is allowed because it follows a function + * declaration statement and may appear as part of the next statement. + * For function expressions RegExp is not allowed, and it's possible + * to do something like '(function () {} / 123)'. + */ + if (regexp_after) { + comp_ctx->curr_func.allow_regexp_in_adv = 1; + } + duk__advance(comp_ctx); + + /* Tear down state. */ + + duk_pop_2(thr); +} + +/* + * Declaration binding instantiation conceptually happens when calling a + * function; for us it essentially means that function prologue. The + * conceptual process is described in E5 Section 10.5. + * + * We need to keep track of all encountered identifiers to (1) create an + * identifier-to-register map ("varmap"); and (2) detect duplicate + * declarations. Identifiers which are not bound to registers still need + * to be tracked for detecting duplicates. Currently such identifiers + * are put into the varmap with a 'null' value, which is later cleaned up. + * + * To support functions with a large number of variable and function + * declarations, registers are not allocated beyond a certain limit; + * after that limit, variables and functions need slow path access. + * Arguments are currently always register bound, which imposes a hard + * (and relatively small) argument count limit. + * + * Some bindings in E5 are not configurable (= deletable) and almost all + * are mutable (writable). Exceptions are: + * + * - The 'arguments' binding, established only if no shadowing argument + * or function declaration exists. We handle 'arguments' creation + * and binding through an explicit slow path environment record. + * + * - The "name" binding for a named function expression. This is also + * handled through an explicit slow path environment record. + */ + +/* XXX: add support for variables to not be register bound always, to + * handle cases with a very large number of variables? + */ + +DUK_LOCAL void duk__init_varmap_and_prologue_for_pass2(duk_compiler_ctx *comp_ctx, duk_regconst_t *out_stmt_value_reg) { + duk_hthread *thr = comp_ctx->thr; + duk_hstring *h_name; + duk_bool_t configurable_bindings; + duk_uarridx_t num_args; + duk_uarridx_t num_decls; + duk_regconst_t rc_name; + duk_small_uint_t declvar_flags; + duk_uarridx_t i; +#if defined(DUK_USE_ASSERTIONS) + duk_idx_t entry_top; +#endif + +#if defined(DUK_USE_ASSERTIONS) + entry_top = duk_get_top(thr); +#endif + + /* + * Preliminaries + */ + + configurable_bindings = comp_ctx->curr_func.is_eval; + DUK_DDD(DUK_DDDPRINT("configurable_bindings=%ld", (long) configurable_bindings)); + + /* varmap is already in comp_ctx->curr_func.varmap_idx */ + + /* + * Function formal arguments, always bound to registers + * (there's no support for shuffling them now). + */ + + num_args = (duk_uarridx_t) duk_get_length(thr, comp_ctx->curr_func.argnames_idx); + DUK_DDD(DUK_DDDPRINT("num_args=%ld", (long) num_args)); + /* XXX: check num_args */ + + for (i = 0; i < num_args; i++) { + duk_get_prop_index(thr, comp_ctx->curr_func.argnames_idx, i); + h_name = duk_known_hstring(thr, -1); + + if (comp_ctx->curr_func.is_strict) { + if (duk__hstring_is_eval_or_arguments(comp_ctx, h_name)) { + DUK_DDD(DUK_DDDPRINT("arg named 'eval' or 'arguments' in strict mode -> SyntaxError")); + goto error_argname; + } + duk_dup_top(thr); + if (duk_has_prop(thr, comp_ctx->curr_func.varmap_idx)) { + DUK_DDD(DUK_DDDPRINT("duplicate arg name in strict mode -> SyntaxError")); + goto error_argname; + } + + /* Ensure argument name is not a reserved word in current + * (final) strictness. Formal argument parsing may not + * catch reserved names if strictness changes during + * parsing. + * + * We only need to do this in strict mode because non-strict + * keyword are always detected in formal argument parsing. + */ + + if (DUK_HSTRING_HAS_STRICT_RESERVED_WORD(h_name)) { + goto error_argname; + } + } + + /* overwrite any previous binding of the same name; the effect is + * that last argument of a certain name wins. + */ + + /* only functions can have arguments */ + DUK_ASSERT(comp_ctx->curr_func.is_function); + duk_push_uarridx(thr, i); /* -> [ ... name index ] */ + duk_put_prop(thr, comp_ctx->curr_func.varmap_idx); /* -> [ ... ] */ + + /* no code needs to be emitted, the regs already have values */ + } + + /* use temp_next for tracking register allocations */ + DUK__SETTEMP_CHECKMAX(comp_ctx, (duk_regconst_t) num_args); + + /* + * After arguments, allocate special registers (like shuffling temps) + */ + + if (out_stmt_value_reg) { + *out_stmt_value_reg = DUK__ALLOCTEMP(comp_ctx); + } + if (comp_ctx->curr_func.needs_shuffle) { + duk_regconst_t shuffle_base = DUK__ALLOCTEMPS(comp_ctx, 3); + comp_ctx->curr_func.shuffle1 = shuffle_base; + comp_ctx->curr_func.shuffle2 = shuffle_base + 1; + comp_ctx->curr_func.shuffle3 = shuffle_base + 2; + DUK_D(DUK_DPRINT("shuffle registers needed by function, allocated: %ld %ld %ld", + (long) comp_ctx->curr_func.shuffle1, + (long) comp_ctx->curr_func.shuffle2, + (long) comp_ctx->curr_func.shuffle3)); + } + if (comp_ctx->curr_func.temp_next > 0x100) { + DUK_D(DUK_DPRINT("not enough 8-bit regs: temp_next=%ld", (long) comp_ctx->curr_func.temp_next)); + goto error_outofregs; + } + + /* + * Function declarations + */ + + num_decls = (duk_uarridx_t) duk_get_length(thr, comp_ctx->curr_func.decls_idx); + DUK_DDD( + DUK_DDDPRINT("num_decls=%ld -> %!T", (long) num_decls, (duk_tval *) duk_get_tval(thr, comp_ctx->curr_func.decls_idx))); + for (i = 0; i < num_decls; i += 2) { + duk_int_t decl_type; + duk_int_t fnum; + + duk_get_prop_index(thr, comp_ctx->curr_func.decls_idx, i + 1); /* decl type */ + decl_type = duk_to_int(thr, -1); + fnum = decl_type >> 8; /* XXX: macros */ + decl_type = decl_type & 0xff; + duk_pop(thr); + + if (decl_type != DUK_DECL_TYPE_FUNC) { + continue; + } + + duk_get_prop_index(thr, comp_ctx->curr_func.decls_idx, i); /* decl name */ + + /* XXX: spilling */ + if (comp_ctx->curr_func.is_function) { + duk_regconst_t reg_bind; + duk_dup_top(thr); + if (duk_has_prop(thr, comp_ctx->curr_func.varmap_idx)) { + /* shadowed; update value */ + duk_dup_top(thr); + duk_get_prop(thr, comp_ctx->curr_func.varmap_idx); + reg_bind = duk_to_int(thr, -1); /* [ ... name reg_bind ] */ + duk__emit_a_bc(comp_ctx, DUK_OP_CLOSURE, reg_bind, (duk_regconst_t) fnum); + } else { + /* function: always register bound */ + reg_bind = DUK__ALLOCTEMP(comp_ctx); + duk__emit_a_bc(comp_ctx, DUK_OP_CLOSURE, reg_bind, (duk_regconst_t) fnum); + duk_push_int(thr, (duk_int_t) reg_bind); + } + } else { + /* Function declaration for global/eval code is emitted even + * for duplicates, because of E5 Section 10.5, step 5.e of + * E5.1 (special behavior for variable bound to global object). + * + * DECLVAR will not re-declare a variable as such, but will + * update the binding value. + */ + + duk_regconst_t reg_temp = DUK__ALLOCTEMP(comp_ctx); + duk_dup_top(thr); + rc_name = duk__getconst(comp_ctx); + duk_push_null(thr); + + duk__emit_a_bc(comp_ctx, DUK_OP_CLOSURE, reg_temp, (duk_regconst_t) fnum); + + declvar_flags = DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_ENUMERABLE | DUK_BC_DECLVAR_FLAG_FUNC_DECL; + + if (configurable_bindings) { + declvar_flags |= DUK_PROPDESC_FLAG_CONFIGURABLE; + } + + duk__emit_a_b_c(comp_ctx, + DUK_OP_DECLVAR | DUK__EMIT_FLAG_NO_SHUFFLE_A | DUK__EMIT_FLAG_BC_REGCONST, + (duk_regconst_t) declvar_flags /*flags*/, + rc_name /*name*/, + reg_temp /*value*/); + + DUK__SETTEMP(comp_ctx, reg_temp); /* forget temp */ + } + + DUK_DDD(DUK_DDDPRINT("function declaration to varmap: %!T -> %!T", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + +#if defined(DUK_USE_FASTINT) + DUK_ASSERT(DUK_TVAL_IS_NULL(duk_get_tval(thr, -1)) || DUK_TVAL_IS_FASTINT(duk_get_tval(thr, -1))); +#endif + duk_put_prop(thr, comp_ctx->curr_func.varmap_idx); /* [ ... name reg/null ] -> [ ... ] */ + } + + /* + * 'arguments' binding is special; if a shadowing argument or + * function declaration exists, an arguments object will + * definitely not be needed, regardless of whether the identifier + * 'arguments' is referenced inside the function body. + */ + + if (duk_has_prop_stridx(thr, comp_ctx->curr_func.varmap_idx, DUK_STRIDX_LC_ARGUMENTS)) { + DUK_DDD(DUK_DDDPRINT("'arguments' is shadowed by argument or function declaration " + "-> arguments object creation can be skipped")); + comp_ctx->curr_func.is_arguments_shadowed = 1; + } + + /* + * Variable declarations. + * + * Unlike function declarations, variable declaration values don't get + * assigned on entry. If a binding of the same name already exists, just + * ignore it silently. + */ + + for (i = 0; i < num_decls; i += 2) { + duk_int_t decl_type; + + duk_get_prop_index(thr, comp_ctx->curr_func.decls_idx, i + 1); /* decl type */ + decl_type = duk_to_int(thr, -1); + decl_type = decl_type & 0xff; + duk_pop(thr); + + if (decl_type != DUK_DECL_TYPE_VAR) { + continue; + } + + duk_get_prop_index(thr, comp_ctx->curr_func.decls_idx, i); /* decl name */ + + if (duk_has_prop(thr, comp_ctx->curr_func.varmap_idx)) { + /* shadowed, ignore */ + } else { + duk_get_prop_index(thr, comp_ctx->curr_func.decls_idx, i); /* decl name */ + h_name = duk_known_hstring(thr, -1); + + if (h_name == DUK_HTHREAD_STRING_LC_ARGUMENTS(thr) && !comp_ctx->curr_func.is_arguments_shadowed) { + /* E5 Section steps 7-8 */ + DUK_DDD(DUK_DDDPRINT("'arguments' not shadowed by a function declaration, " + "but appears as a variable declaration -> treat as " + "a no-op for variable declaration purposes")); + duk_pop(thr); + continue; + } + + /* XXX: spilling */ + if (comp_ctx->curr_func.is_function) { + duk_regconst_t reg_bind = DUK__ALLOCTEMP(comp_ctx); + /* no need to init reg, it will be undefined on entry */ + duk_push_int(thr, (duk_int_t) reg_bind); + } else { + duk_dup_top(thr); + rc_name = duk__getconst(comp_ctx); + duk_push_null(thr); + + declvar_flags = DUK_PROPDESC_FLAG_WRITABLE | DUK_PROPDESC_FLAG_ENUMERABLE; + if (configurable_bindings) { + declvar_flags |= DUK_PROPDESC_FLAG_CONFIGURABLE; + } + + duk__emit_a_b_c(comp_ctx, + DUK_OP_DECLVAR | DUK__EMIT_FLAG_NO_SHUFFLE_A | DUK__EMIT_FLAG_BC_REGCONST, + (duk_regconst_t) declvar_flags /*flags*/, + rc_name /*name*/, + 0 /*value*/); + } + + duk_put_prop(thr, comp_ctx->curr_func.varmap_idx); /* [ ... name reg/null ] -> [ ... ] */ + } + } + + /* + * Wrap up + */ + + DUK_DDD(DUK_DDDPRINT("varmap: %!T, is_arguments_shadowed=%ld", + (duk_tval *) duk_get_tval(thr, comp_ctx->curr_func.varmap_idx), + (long) comp_ctx->curr_func.is_arguments_shadowed)); + + DUK_ASSERT_TOP(thr, entry_top); + return; + +error_outofregs: + DUK_ERROR_RANGE(thr, DUK_STR_REG_LIMIT); + DUK_WO_NORETURN(return;); + +error_argname: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_ARG_NAME); + DUK_WO_NORETURN(return;); +} + +/* + * Parse a function-body-like expression (FunctionBody or Program + * in E5 grammar) using a two-pass parse. The productions appear + * in the following contexts: + * + * - function expression + * - function statement + * - function declaration + * - getter in object literal + * - setter in object literal + * - global code + * - eval code + * - Function constructor body + * + * This function only parses the statement list of the body; the argument + * list and possible function name must be initialized by the caller. + * For instance, for Function constructor, the argument names are originally + * on the value stack. The parsing of statements ends either at an EOF or + * a closing brace; this is controlled by an input flag. + * + * Note that there are many differences affecting parsing and even code + * generation: + * + * - Global and eval code have an implicit return value generated + * by the last statement; function code does not + * + * - Global code, eval code, and Function constructor body end in + * an EOF, other bodies in a closing brace ('}') + * + * Upon entry, 'curr_tok' is ignored and the function will pull in the + * first token on its own. Upon exit, 'curr_tok' is the terminating + * token (EOF or closing brace). + */ + +DUK_LOCAL void duk__parse_func_body(duk_compiler_ctx *comp_ctx, + duk_bool_t expect_eof, + duk_bool_t implicit_return_value, + duk_bool_t regexp_after, + duk_small_int_t expect_token) { + duk_compiler_func *func; + duk_hthread *thr; + duk_regconst_t reg_stmt_value = -1; + duk_lexer_point lex_pt; + duk_regconst_t temp_first; + duk_small_int_t compile_round = 1; + + DUK_ASSERT(comp_ctx != NULL); + + thr = comp_ctx->thr; + DUK_ASSERT(thr != NULL); + + func = &comp_ctx->curr_func; + DUK_ASSERT(func != NULL); + + DUK__RECURSION_INCREASE(comp_ctx, thr); + + duk_require_stack(thr, DUK__FUNCTION_BODY_REQUIRE_SLOTS); + + /* + * Store lexer position for a later rewind + */ + + DUK_LEXER_GETPOINT(&comp_ctx->lex, &lex_pt); + + /* + * Program code (global and eval code) has an implicit return value + * from the last statement value (e.g. eval("1; 2+3;") returns 3). + * This is not the case with functions. If implicit statement return + * value is requested, all statements are coerced to a register + * allocated here, and used in the implicit return statement below. + */ + + /* XXX: this is pointless here because pass 1 is throw-away */ + if (implicit_return_value) { + reg_stmt_value = DUK__ALLOCTEMP(comp_ctx); + + /* If an implicit return value is needed by caller, it must be + * initialized to 'undefined' because we don't know whether any + * non-empty (where "empty" is a continuation type, and different + * from an empty statement) statements will be executed. + * + * However, since 1st pass is a throwaway one, no need to emit + * it here. + */ +#if 0 + duk__emit_bc(comp_ctx, + DUK_OP_LDUNDEF, + 0); +#endif + } + + /* + * First pass. + * + * Gather variable/function declarations needed for second pass. + * Code generated is dummy and discarded. + */ + + func->in_directive_prologue = 1; + func->in_scanning = 1; + func->may_direct_eval = 0; + func->id_access_arguments = 0; + func->id_access_slow = 0; + func->id_access_slow_own = 0; + func->reg_stmt_value = reg_stmt_value; +#if defined(DUK_USE_DEBUGGER_SUPPORT) + func->min_line = DUK_INT_MAX; + func->max_line = 0; +#endif + + /* duk__parse_stmts() expects curr_tok to be set; parse in "allow + * regexp literal" mode with current strictness. + */ + if (expect_token >= 0) { + /* Eating a left curly; regexp mode is allowed by left curly + * based on duk__token_lbp[] automatically. + */ + DUK_ASSERT(expect_token == DUK_TOK_LCURLY); + duk__update_lineinfo_currtoken(comp_ctx); + duk__advance_expect(comp_ctx, expect_token); + } else { + /* Need to set curr_token.t because lexing regexp mode depends on current + * token type. Zero value causes "allow regexp" mode. + */ + comp_ctx->curr_token.t = 0; + duk__advance(comp_ctx); + } + + DUK_DDD(DUK_DDDPRINT("begin 1st pass")); + duk__parse_stmts(comp_ctx, + 1, /* allow source elements */ + expect_eof, /* expect EOF instead of } */ + regexp_after); /* regexp after */ + DUK_DDD(DUK_DDDPRINT("end 1st pass")); + + /* + * Second (and possibly third) pass. + * + * Generate actual code. In most cases the need for shuffle + * registers is detected during pass 1, but in some corner cases + * we'll only detect it during pass 2 and a third pass is then + * needed (see GH-115). + */ + + for (;;) { + duk_bool_t needs_shuffle_before = comp_ctx->curr_func.needs_shuffle; + compile_round++; + + /* + * Rewind lexer. + * + * duk__parse_stmts() expects curr_tok to be set; parse in "allow regexp + * literal" mode with current strictness. + * + * curr_token line number info should be initialized for pass 2 before + * generating prologue, to ensure prologue bytecode gets nice line numbers. + */ + + DUK_DDD(DUK_DDDPRINT("rewind lexer")); + DUK_LEXER_SETPOINT(&comp_ctx->lex, &lex_pt); + comp_ctx->curr_token.t = 0; /* this is needed for regexp mode */ + comp_ctx->curr_token.start_line = 0; /* needed for line number tracking (becomes prev_token.start_line) */ + duk__advance(comp_ctx); + + /* + * Reset function state and perform register allocation, which creates + * 'varmap' for second pass. Function prologue for variable declarations, + * binding value initializations etc is emitted as a by-product. + * + * Strict mode restrictions for duplicate and invalid argument + * names are checked here now that we know whether the function + * is actually strict. See: test-dev-strict-mode-boundary.js. + * + * Inner functions are compiled during pass 1 and are not reset. + */ + + duk__reset_func_for_pass2(comp_ctx); + func->in_directive_prologue = 1; + func->in_scanning = 0; + + /* must be able to emit code, alloc consts, etc. */ + + duk__init_varmap_and_prologue_for_pass2(comp_ctx, (implicit_return_value ? ®_stmt_value : NULL)); + func->reg_stmt_value = reg_stmt_value; + + temp_first = DUK__GETTEMP(comp_ctx); + + func->temp_first = temp_first; + func->temp_next = temp_first; + func->stmt_next = 0; + func->label_next = 0; + + /* XXX: init or assert catch depth etc -- all values */ + func->id_access_arguments = 0; + func->id_access_slow = 0; + func->id_access_slow_own = 0; + + /* + * Check function name validity now that we know strictness. + * This only applies to function declarations and expressions, + * not setter/getter name. + * + * See: test-dev-strict-mode-boundary.js + */ + + if (func->is_function && !func->is_setget && func->h_name != NULL) { + if (func->is_strict) { + if (duk__hstring_is_eval_or_arguments(comp_ctx, func->h_name)) { + DUK_DDD(DUK_DDDPRINT("func name is 'eval' or 'arguments' in strict mode")); + goto error_funcname; + } + if (DUK_HSTRING_HAS_STRICT_RESERVED_WORD(func->h_name)) { + DUK_DDD(DUK_DDDPRINT("func name is a reserved word in strict mode")); + goto error_funcname; + } + } else { + if (DUK_HSTRING_HAS_RESERVED_WORD(func->h_name) && + !DUK_HSTRING_HAS_STRICT_RESERVED_WORD(func->h_name)) { + DUK_DDD(DUK_DDDPRINT("func name is a reserved word in non-strict mode")); + goto error_funcname; + } + } + } + + /* + * Second pass parsing. + */ + + if (implicit_return_value) { + /* Default implicit return value. */ + duk__emit_bc(comp_ctx, DUK_OP_LDUNDEF, 0); + } + + DUK_DDD(DUK_DDDPRINT("begin 2nd pass")); + duk__parse_stmts(comp_ctx, + 1, /* allow source elements */ + expect_eof, /* expect EOF instead of } */ + regexp_after); /* regexp after */ + DUK_DDD(DUK_DDDPRINT("end 2nd pass")); + + duk__update_lineinfo_currtoken(comp_ctx); + + if (needs_shuffle_before == comp_ctx->curr_func.needs_shuffle) { + /* Shuffle decision not changed. */ + break; + } + if (compile_round >= 3) { + /* Should never happen but avoid infinite loop just in case. */ + DUK_D(DUK_DPRINT("more than 3 compile passes needed, should never happen")); + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return;); + } + DUK_D(DUK_DPRINT("need additional round to compile function, round now %d", (int) compile_round)); + } + + /* + * Emit a final RETURN. + * + * It would be nice to avoid emitting an unnecessary "return" opcode + * if the current PC is not reachable. However, this cannot be reliably + * detected; even if the previous instruction is an unconditional jump, + * there may be a previous jump which jumps to current PC (which is the + * case for iteration and conditional statements, for instance). + */ + + /* XXX: request a "last statement is terminal" from duk__parse_stmt() and duk__parse_stmts(); + * we could avoid the last RETURN if we could ensure there is no way to get here + * (directly or via a jump) + */ + + DUK_ASSERT(comp_ctx->curr_func.catch_depth == 0); + if (reg_stmt_value >= 0) { + DUK_ASSERT(DUK__ISREG(reg_stmt_value)); + duk__emit_bc(comp_ctx, DUK_OP_RETREG, reg_stmt_value /*reg*/); + } else { + duk__emit_op_only(comp_ctx, DUK_OP_RETUNDEF); + } + + /* + * Peephole optimize JUMP chains. + */ + + duk__peephole_optimize_bytecode(comp_ctx); + + /* + * comp_ctx->curr_func is now ready to be converted into an actual + * function template. + */ + + DUK__RECURSION_DECREASE(comp_ctx, thr); + return; + +error_funcname: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_FUNC_NAME); + DUK_WO_NORETURN(return;); +} + +/* + * Parse a function-like expression: + * + * - function expression + * - function declaration + * - function statement (non-standard) + * - setter/getter + * + * Adds the function to comp_ctx->curr_func function table and returns the + * function number. + * + * On entry, curr_token points to: + * + * - the token after 'function' for function expression/declaration/statement + * - the token after 'set' or 'get' for setter/getter + */ + +/* Parse formals. */ +DUK_LOCAL void duk__parse_func_formals(duk_compiler_ctx *comp_ctx) { + duk_hthread *thr = comp_ctx->thr; + duk_bool_t first = 1; + duk_uarridx_t n; + + for (;;) { + if (comp_ctx->curr_token.t == DUK_TOK_RPAREN) { + break; + } + + if (first) { + /* no comma */ + first = 0; + } else { + duk__advance_expect(comp_ctx, DUK_TOK_COMMA); + } + + /* Note: when parsing a formal list in non-strict context, e.g. + * "implements" is parsed as an identifier. When the function is + * later detected to be strict, the argument list must be rechecked + * against a larger set of reserved words (that of strict mode). + * This is handled by duk__parse_func_body(). Here we recognize + * whatever tokens are considered reserved in current strictness + * (which is not always enough). + */ + + if (comp_ctx->curr_token.t != DUK_TOK_IDENTIFIER) { + DUK_ERROR_SYNTAX(thr, DUK_STR_EXPECTED_IDENTIFIER); + DUK_WO_NORETURN(return;); + } + DUK_ASSERT(comp_ctx->curr_token.t == DUK_TOK_IDENTIFIER); + DUK_ASSERT(comp_ctx->curr_token.str1 != NULL); + DUK_DDD(DUK_DDDPRINT("formal argument: %!O", (duk_heaphdr *) comp_ctx->curr_token.str1)); + + /* XXX: append primitive */ + duk_push_hstring(thr, comp_ctx->curr_token.str1); + n = (duk_uarridx_t) duk_get_length(thr, comp_ctx->curr_func.argnames_idx); + duk_put_prop_index(thr, comp_ctx->curr_func.argnames_idx, n); + + duk__advance(comp_ctx); /* eat identifier */ + } +} + +/* Parse a function-like expression, assuming that 'comp_ctx->curr_func' is + * correctly set up. Assumes that curr_token is just after 'function' (or + * 'set'/'get' etc). + */ +DUK_LOCAL void duk__parse_func_like_raw(duk_compiler_ctx *comp_ctx, duk_small_uint_t flags) { + duk_hthread *thr = comp_ctx->thr; + duk_token *tok; + duk_bool_t no_advance; + + DUK_ASSERT(comp_ctx->curr_func.num_formals == 0); + DUK_ASSERT(comp_ctx->curr_func.is_function == 1); + DUK_ASSERT(comp_ctx->curr_func.is_eval == 0); + DUK_ASSERT(comp_ctx->curr_func.is_global == 0); + DUK_ASSERT(comp_ctx->curr_func.is_setget == ((flags & DUK__FUNC_FLAG_GETSET) != 0)); + + duk__update_lineinfo_currtoken(comp_ctx); + + /* + * Function name (if any) + * + * We don't check for prohibited names here, because we don't + * yet know whether the function will be strict. Function body + * parsing handles this retroactively. + * + * For function expressions and declarations function name must + * be an Identifer (excludes reserved words). For setter/getter + * it is a PropertyName which allows reserved words and also + * strings and numbers (e.g. "{ get 1() { ... } }"). + * + * Function parsing may start either from prev_token or curr_token + * (object literal method definition uses prev_token for example). + * This is dealt with for the initial token. + */ + + no_advance = (flags & DUK__FUNC_FLAG_USE_PREVTOKEN); + if (no_advance) { + tok = &comp_ctx->prev_token; + } else { + tok = &comp_ctx->curr_token; + } + + if (flags & DUK__FUNC_FLAG_GETSET) { + /* PropertyName -> IdentifierName | StringLiteral | NumericLiteral */ + if (tok->t_nores == DUK_TOK_IDENTIFIER || tok->t == DUK_TOK_STRING) { + duk_push_hstring(thr, tok->str1); /* keep in valstack */ + } else if (tok->t == DUK_TOK_NUMBER) { + duk_push_number(thr, tok->num); + duk_to_string(thr, -1); + } else { + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_GETSET_NAME); + DUK_WO_NORETURN(return;); + } + comp_ctx->curr_func.h_name = duk_known_hstring(thr, -1); /* borrowed reference */ + } else { + /* Function name is an Identifier (not IdentifierName), but we get + * the raw name (not recognizing keywords) here and perform the name + * checks only after pass 1. + */ + if (tok->t_nores == DUK_TOK_IDENTIFIER) { + duk_push_hstring(thr, tok->str1); /* keep in valstack */ + comp_ctx->curr_func.h_name = duk_known_hstring(thr, -1); /* borrowed reference */ + } else { + /* valstack will be unbalanced, which is OK */ + DUK_ASSERT((flags & DUK__FUNC_FLAG_GETSET) == 0); + DUK_ASSERT(comp_ctx->curr_func.h_name == NULL); + no_advance = 1; + if (flags & DUK__FUNC_FLAG_DECL) { + DUK_ERROR_SYNTAX(thr, DUK_STR_FUNC_NAME_REQUIRED); + DUK_WO_NORETURN(return;); + } + } + } + + DUK_DD(DUK_DDPRINT("function name: %!O", (duk_heaphdr *) comp_ctx->curr_func.h_name)); + + if (!no_advance) { + duk__advance(comp_ctx); + } + + /* + * Formal argument list + * + * We don't check for prohibited names or for duplicate argument + * names here, becase we don't yet know whether the function will + * be strict. Function body parsing handles this retroactively. + */ + + duk__advance_expect(comp_ctx, DUK_TOK_LPAREN); + + duk__parse_func_formals(comp_ctx); + + DUK_ASSERT(comp_ctx->curr_token.t == DUK_TOK_RPAREN); + duk__advance(comp_ctx); + + /* + * Parse function body + */ + + duk__parse_func_body(comp_ctx, + 0, /* expect_eof */ + 0, /* implicit_return_value */ + flags & DUK__FUNC_FLAG_DECL, /* regexp_after */ + DUK_TOK_LCURLY); /* expect_token */ + + /* + * Convert duk_compiler_func to a function template and add it + * to the parent function table. + */ + + duk__convert_to_func_template(comp_ctx); /* -> [ ... func ] */ +} + +/* Parse an inner function, adding the function template to the current function's + * function table. Return a function number to be used by the outer function. + * + * Avoiding O(depth^2) inner function parsing is handled here. On the first pass, + * compile and register the function normally into the 'funcs' array, also recording + * a lexer point (offset/line) to the closing brace of the function. On the second + * pass, skip the function and return the same 'fnum' as on the first pass by using + * a running counter. + * + * An unfortunate side effect of this is that when parsing the inner function, almost + * nothing is known of the outer function, i.e. the inner function's scope. We don't + * need that information at the moment, but it would allow some optimizations if it + * were used. + */ +DUK_LOCAL duk_int_t duk__parse_func_like_fnum(duk_compiler_ctx *comp_ctx, duk_small_uint_t flags) { + duk_hthread *thr = comp_ctx->thr; + duk_compiler_func old_func; + duk_idx_t entry_top; + duk_int_t fnum; + + /* + * On second pass, skip the function. + */ + + if (!comp_ctx->curr_func.in_scanning) { + duk_lexer_point lex_pt; + + fnum = comp_ctx->curr_func.fnum_next++; + duk_get_prop_index(thr, comp_ctx->curr_func.funcs_idx, (duk_uarridx_t) (fnum * 3 + 1)); + lex_pt.offset = (duk_size_t) duk_to_uint(thr, -1); + duk_pop(thr); + duk_get_prop_index(thr, comp_ctx->curr_func.funcs_idx, (duk_uarridx_t) (fnum * 3 + 2)); + lex_pt.line = duk_to_int(thr, -1); + duk_pop(thr); + + DUK_DDD( + DUK_DDDPRINT("second pass of an inner func, skip the function, reparse closing brace; lex offset=%ld, line=%ld", + (long) lex_pt.offset, + (long) lex_pt.line)); + + DUK_LEXER_SETPOINT(&comp_ctx->lex, &lex_pt); + comp_ctx->curr_token.t = 0; /* this is needed for regexp mode */ + comp_ctx->curr_token.start_line = 0; /* needed for line number tracking (becomes prev_token.start_line) */ + duk__advance(comp_ctx); + + /* RegExp is not allowed after a function expression, e.g. in + * (function () {} / 123). A RegExp *is* allowed after a + * function declaration! + */ + if (flags & DUK__FUNC_FLAG_DECL) { + comp_ctx->curr_func.allow_regexp_in_adv = 1; + } + duk__advance_expect(comp_ctx, DUK_TOK_RCURLY); + + return fnum; + } + + /* + * On first pass, perform actual parsing. Remember valstack top on entry + * to restore it later, and switch to using a new function in comp_ctx. + */ + + entry_top = duk_get_top(thr); + DUK_DDD(DUK_DDDPRINT("before func: entry_top=%ld, curr_tok.start_offset=%ld", + (long) entry_top, + (long) comp_ctx->curr_token.start_offset)); + + duk_memcpy(&old_func, &comp_ctx->curr_func, sizeof(duk_compiler_func)); + + duk_memzero(&comp_ctx->curr_func, sizeof(duk_compiler_func)); + duk__init_func_valstack_slots(comp_ctx); + DUK_ASSERT(comp_ctx->curr_func.num_formals == 0); + + /* inherit initial strictness from parent */ + comp_ctx->curr_func.is_strict = old_func.is_strict; + + /* XXX: It might be better to just store the flags into the curr_func + * struct and use them as is without this flag interpretation step + * here. + */ + DUK_ASSERT(comp_ctx->curr_func.is_notail == 0); + comp_ctx->curr_func.is_function = 1; + DUK_ASSERT(comp_ctx->curr_func.is_eval == 0); + DUK_ASSERT(comp_ctx->curr_func.is_global == 0); + comp_ctx->curr_func.is_setget = ((flags & DUK__FUNC_FLAG_GETSET) != 0); + comp_ctx->curr_func.is_namebinding = + !(flags & (DUK__FUNC_FLAG_GETSET | DUK__FUNC_FLAG_METDEF | + DUK__FUNC_FLAG_DECL)); /* no name binding for: declarations, objlit getset, objlit method def */ + comp_ctx->curr_func.is_constructable = + !(flags & (DUK__FUNC_FLAG_GETSET | DUK__FUNC_FLAG_METDEF)); /* not constructable: objlit getset, objlit method def */ + + /* + * Parse inner function + */ + + duk__parse_func_like_raw(comp_ctx, flags); /* pushes function template */ + + /* prev_token.start_offset points to the closing brace here; when skipping + * we're going to reparse the closing brace to ensure semicolon insertion + * etc work as expected. + */ + DUK_DDD(DUK_DDDPRINT("after func: prev_tok.start_offset=%ld, curr_tok.start_offset=%ld", + (long) comp_ctx->prev_token.start_offset, + (long) comp_ctx->curr_token.start_offset)); + DUK_ASSERT(comp_ctx->lex.input[comp_ctx->prev_token.start_offset] == (duk_uint8_t) DUK_ASC_RCURLY); + + /* XXX: append primitive */ + DUK_ASSERT(duk_get_length(thr, old_func.funcs_idx) == (duk_size_t) (old_func.fnum_next * 3)); + fnum = old_func.fnum_next++; + + if (fnum > DUK__MAX_FUNCS) { + DUK_ERROR_RANGE(comp_ctx->thr, DUK_STR_FUNC_LIMIT); + DUK_WO_NORETURN(return 0;); + } + + /* array writes autoincrement length */ + (void) duk_put_prop_index(thr, old_func.funcs_idx, (duk_uarridx_t) (fnum * 3)); + duk_push_size_t(thr, comp_ctx->prev_token.start_offset); + (void) duk_put_prop_index(thr, old_func.funcs_idx, (duk_uarridx_t) (fnum * 3 + 1)); + duk_push_int(thr, comp_ctx->prev_token.start_line); + (void) duk_put_prop_index(thr, old_func.funcs_idx, (duk_uarridx_t) (fnum * 3 + 2)); + + /* + * Cleanup: restore original function, restore valstack state. + * + * Function declaration handling needs the function name to be pushed + * on the value stack. + */ + + if (flags & DUK__FUNC_FLAG_PUSHNAME_PASS1) { + DUK_ASSERT(comp_ctx->curr_func.h_name != NULL); + duk_push_hstring(thr, comp_ctx->curr_func.h_name); + duk_replace(thr, entry_top); + duk_set_top(thr, entry_top + 1); + } else { + duk_set_top(thr, entry_top); + } + duk_memcpy((void *) &comp_ctx->curr_func, (void *) &old_func, sizeof(duk_compiler_func)); + + return fnum; +} + +/* + * Compile input string into an executable function template without + * arguments. + * + * The string is parsed as the "Program" production of ECMAScript E5. + * Compilation context can be either global code or eval code (see E5 + * Sections 14 and 15.1.2.1). + * + * Input stack: [ ... filename ] + * Output stack: [ ... func_template ] + */ + +/* XXX: source code property */ + +DUK_LOCAL duk_ret_t duk__js_compile_raw(duk_hthread *thr, void *udata) { + duk_hstring *h_filename; + duk__compiler_stkstate *comp_stk; + duk_compiler_ctx *comp_ctx; + duk_lexer_point *lex_pt; + duk_compiler_func *func; + duk_idx_t entry_top; + duk_bool_t is_strict; + duk_bool_t is_eval; + duk_bool_t is_funcexpr; + duk_small_uint_t flags; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(udata != NULL); + + /* + * Arguments check + */ + + entry_top = duk_get_top(thr); + DUK_ASSERT(entry_top >= 1); + + comp_stk = (duk__compiler_stkstate *) udata; + comp_ctx = &comp_stk->comp_ctx_alloc; + lex_pt = &comp_stk->lex_pt_alloc; + DUK_ASSERT(comp_ctx != NULL); + DUK_ASSERT(lex_pt != NULL); + + flags = comp_stk->flags; + is_eval = (flags & DUK_COMPILE_EVAL ? 1 : 0); + is_strict = (flags & DUK_COMPILE_STRICT ? 1 : 0); + is_funcexpr = (flags & DUK_COMPILE_FUNCEXPR ? 1 : 0); + + h_filename = duk_get_hstring(thr, -1); /* may be undefined */ + + /* + * Init compiler and lexer contexts + */ + + func = &comp_ctx->curr_func; +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + comp_ctx->thr = NULL; + comp_ctx->h_filename = NULL; + comp_ctx->prev_token.str1 = NULL; + comp_ctx->prev_token.str2 = NULL; + comp_ctx->curr_token.str1 = NULL; + comp_ctx->curr_token.str2 = NULL; +#endif + + duk_require_stack(thr, DUK__COMPILE_ENTRY_SLOTS); + + duk_push_dynamic_buffer(thr, 0); /* entry_top + 0 */ + duk_push_undefined(thr); /* entry_top + 1 */ + duk_push_undefined(thr); /* entry_top + 2 */ + duk_push_undefined(thr); /* entry_top + 3 */ + duk_push_undefined(thr); /* entry_top + 4 */ + + comp_ctx->thr = thr; + comp_ctx->h_filename = h_filename; + comp_ctx->tok11_idx = entry_top + 1; + comp_ctx->tok12_idx = entry_top + 2; + comp_ctx->tok21_idx = entry_top + 3; + comp_ctx->tok22_idx = entry_top + 4; + comp_ctx->recursion_limit = DUK_USE_COMPILER_RECLIMIT; + + /* comp_ctx->lex has been pre-initialized by caller: it has been + * zeroed and input/input_length has been set. + */ + comp_ctx->lex.thr = thr; + /* comp_ctx->lex.input and comp_ctx->lex.input_length filled by caller */ + comp_ctx->lex.slot1_idx = comp_ctx->tok11_idx; + comp_ctx->lex.slot2_idx = comp_ctx->tok12_idx; + comp_ctx->lex.buf_idx = entry_top + 0; + comp_ctx->lex.buf = (duk_hbuffer_dynamic *) duk_known_hbuffer(thr, entry_top + 0); + DUK_ASSERT(DUK_HBUFFER_HAS_DYNAMIC(comp_ctx->lex.buf) && !DUK_HBUFFER_HAS_EXTERNAL(comp_ctx->lex.buf)); + comp_ctx->lex.token_limit = DUK_COMPILER_TOKEN_LIMIT; + + lex_pt->offset = 0; + lex_pt->line = 1; + DUK_LEXER_SETPOINT(&comp_ctx->lex, lex_pt); /* fills window */ + comp_ctx->curr_token.start_line = 0; /* needed for line number tracking (becomes prev_token.start_line) */ + + /* + * Initialize function state for a zero-argument function + */ + + duk__init_func_valstack_slots(comp_ctx); + DUK_ASSERT(func->num_formals == 0); + + if (is_funcexpr) { + /* Name will be filled from function expression, not by caller. + * This case is used by Function constructor and duk_compile() + * API with the DUK_COMPILE_FUNCTION option. + */ + DUK_ASSERT(func->h_name == NULL); + } else { + duk_push_hstring_stridx(thr, (is_eval ? DUK_STRIDX_EVAL : DUK_STRIDX_GLOBAL)); + func->h_name = duk_get_hstring(thr, -1); + } + + /* + * Parse a function body or a function-like expression, depending + * on flags. + */ + + DUK_ASSERT(func->is_setget == 0); + func->is_strict = (duk_uint8_t) is_strict; + DUK_ASSERT(func->is_notail == 0); + + if (is_funcexpr) { + func->is_function = 1; + DUK_ASSERT(func->is_eval == 0); + DUK_ASSERT(func->is_global == 0); + func->is_namebinding = 1; + func->is_constructable = 1; + + duk__advance(comp_ctx); /* init 'curr_token' */ + duk__advance_expect(comp_ctx, DUK_TOK_FUNCTION); + (void) duk__parse_func_like_raw(comp_ctx, 0 /*flags*/); + } else { + DUK_ASSERT(func->is_function == 0); + DUK_ASSERT(is_eval == 0 || is_eval == 1); + func->is_eval = (duk_uint8_t) is_eval; + func->is_global = (duk_uint8_t) !is_eval; + DUK_ASSERT(func->is_namebinding == 0); + DUK_ASSERT(func->is_constructable == 0); + + duk__parse_func_body(comp_ctx, + 1, /* expect_eof */ + 1, /* implicit_return_value */ + 1, /* regexp_after (does not matter) */ + -1); /* expect_token */ + } + + /* + * Convert duk_compiler_func to a function template + */ + + duk__convert_to_func_template(comp_ctx); + + /* + * Wrapping duk_safe_call() will mangle the stack, just return stack top + */ + + /* [ ... filename (temps) func ] */ + + return 1; +} + +DUK_INTERNAL void duk_js_compile(duk_hthread *thr, const duk_uint8_t *src_buffer, duk_size_t src_length, duk_small_uint_t flags) { + duk__compiler_stkstate comp_stk; + duk_compiler_ctx *prev_ctx; + duk_ret_t safe_rc; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(src_buffer != NULL); + + /* preinitialize lexer state partially */ + duk_memzero(&comp_stk, sizeof(comp_stk)); + comp_stk.flags = flags; + DUK_LEXER_INITCTX(&comp_stk.comp_ctx_alloc.lex); + comp_stk.comp_ctx_alloc.lex.input = src_buffer; + comp_stk.comp_ctx_alloc.lex.input_length = src_length; + comp_stk.comp_ctx_alloc.lex.flags = flags; /* Forward flags directly for now. */ + + /* [ ... filename ] */ + + prev_ctx = thr->compile_ctx; + thr->compile_ctx = &comp_stk.comp_ctx_alloc; /* for duk_error_augment.c */ + safe_rc = duk_safe_call(thr, duk__js_compile_raw, (void *) &comp_stk /*udata*/, 1 /*nargs*/, 1 /*nrets*/); + thr->compile_ctx = prev_ctx; /* must restore reliably before returning */ + + if (safe_rc != DUK_EXEC_SUCCESS) { + DUK_D(DUK_DPRINT("compilation failed: %!T", duk_get_tval(thr, -1))); + (void) duk_throw(thr); + DUK_WO_NORETURN(return;); + } + + /* [ ... template ] */ +} + +/* automatic undefs */ +#undef DUK__ALLOCTEMP +#undef DUK__ALLOCTEMPS +#undef DUK__ALLOW_AUTO_SEMI_ALWAYS +#undef DUK__BC_INITIAL_INSTS +#undef DUK__BP_ADDITIVE +#undef DUK__BP_ASSIGNMENT +#undef DUK__BP_BAND +#undef DUK__BP_BOR +#undef DUK__BP_BXOR +#undef DUK__BP_CALL +#undef DUK__BP_CLOSING +#undef DUK__BP_COMMA +#undef DUK__BP_CONDITIONAL +#undef DUK__BP_EOF +#undef DUK__BP_EQUALITY +#undef DUK__BP_EXPONENTIATION +#undef DUK__BP_FOR_EXPR +#undef DUK__BP_INVALID +#undef DUK__BP_LAND +#undef DUK__BP_LOR +#undef DUK__BP_MEMBER +#undef DUK__BP_MULTIPLICATIVE +#undef DUK__BP_POSTFIX +#undef DUK__BP_RELATIONAL +#undef DUK__BP_SHIFT +#undef DUK__COMPILE_ENTRY_SLOTS +#undef DUK__CONST_MARKER +#undef DUK__DUMP_ISPEC +#undef DUK__DUMP_IVALUE +#undef DUK__EMIT_FLAG_A_IS_SOURCE +#undef DUK__EMIT_FLAG_BC_REGCONST +#undef DUK__EMIT_FLAG_B_IS_TARGET +#undef DUK__EMIT_FLAG_C_IS_TARGET +#undef DUK__EMIT_FLAG_NO_SHUFFLE_A +#undef DUK__EMIT_FLAG_NO_SHUFFLE_B +#undef DUK__EMIT_FLAG_NO_SHUFFLE_C +#undef DUK__EMIT_FLAG_RESERVE_JUMPSLOT +#undef DUK__EXPR_FLAG_ALLOW_EMPTY +#undef DUK__EXPR_FLAG_REJECT_IN +#undef DUK__EXPR_FLAG_REQUIRE_INIT +#undef DUK__EXPR_RBP_MASK +#undef DUK__FUNCTION_BODY_REQUIRE_SLOTS +#undef DUK__FUNCTION_INIT_REQUIRE_SLOTS +#undef DUK__FUNC_FLAG_DECL +#undef DUK__FUNC_FLAG_GETSET +#undef DUK__FUNC_FLAG_METDEF +#undef DUK__FUNC_FLAG_PUSHNAME_PASS1 +#undef DUK__FUNC_FLAG_USE_PREVTOKEN +#undef DUK__GETCONST_MAX_CONSTS_CHECK +#undef DUK__GETTEMP +#undef DUK__HAS_TERM +#undef DUK__HAS_VAL +#undef DUK__ISCONST +#undef DUK__ISREG +#undef DUK__ISREG_NOTTEMP +#undef DUK__ISREG_TEMP +#undef DUK__IS_TERMINAL +#undef DUK__IVAL_FLAG_ALLOW_CONST +#undef DUK__IVAL_FLAG_REQUIRE_SHORT +#undef DUK__IVAL_FLAG_REQUIRE_TEMP +#undef DUK__MAX_ARRAY_INIT_VALUES +#undef DUK__MAX_CONSTS +#undef DUK__MAX_FUNCS +#undef DUK__MAX_OBJECT_INIT_PAIRS +#undef DUK__MAX_TEMPS +#undef DUK__MK_LBP +#undef DUK__MK_LBP_FLAGS +#undef DUK__OBJ_LIT_KEY_GET +#undef DUK__OBJ_LIT_KEY_PLAIN +#undef DUK__OBJ_LIT_KEY_SET +#undef DUK__PARSE_EXPR_SLOTS +#undef DUK__PARSE_STATEMENTS_SLOTS +#undef DUK__RECURSION_DECREASE +#undef DUK__RECURSION_INCREASE +#undef DUK__REMOVECONST +#undef DUK__SETTEMP +#undef DUK__SETTEMP_CHECKMAX +#undef DUK__STILL_PROLOGUE +#undef DUK__TOKEN_LBP_BP_MASK +#undef DUK__TOKEN_LBP_FLAG_NO_REGEXP +#undef DUK__TOKEN_LBP_FLAG_TERMINATES +#undef DUK__TOKEN_LBP_FLAG_UNUSED +#undef DUK__TOKEN_LBP_GET_BP +#line 1 "duk_js_executor.c" +/* + * ECMAScript bytecode executor. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Local declarations. + */ + +DUK_LOCAL_DECL void duk__js_execute_bytecode_inner(duk_hthread *entry_thread, duk_activation *entry_act); + +/* + * Misc helpers. + */ + +/* Replace value stack top to value at 'tv_ptr'. Optimize for + * performance by only applying the net refcount change. + */ +#define DUK__REPLACE_TO_TVPTR(thr, tv_ptr) \ + do { \ + duk_hthread *duk__thr; \ + duk_tval *duk__tvsrc; \ + duk_tval *duk__tvdst; \ + duk_tval duk__tvtmp; \ + duk__thr = (thr); \ + duk__tvsrc = DUK_GET_TVAL_NEGIDX(duk__thr, -1); \ + duk__tvdst = (tv_ptr); \ + DUK_TVAL_SET_TVAL(&duk__tvtmp, duk__tvdst); \ + DUK_TVAL_SET_TVAL(duk__tvdst, duk__tvsrc); \ + DUK_TVAL_SET_UNDEFINED(duk__tvsrc); /* value stack init policy */ \ + duk__thr->valstack_top = duk__tvsrc; \ + DUK_TVAL_DECREF(duk__thr, &duk__tvtmp); \ + } while (0) + +/* XXX: candidate of being an internal shared API call */ +#if 0 /* unused */ +DUK_LOCAL void duk__push_tvals_incref_only(duk_hthread *thr, duk_tval *tv_src, duk_small_uint_fast_t count) { + duk_tval *tv_dst; + duk_size_t copy_size; + duk_size_t i; + + tv_dst = thr->valstack_top; + copy_size = sizeof(duk_tval) * count; + duk_memcpy((void *) tv_dst, (const void *) tv_src, copy_size); + for (i = 0; i < count; i++) { + DUK_TVAL_INCREF(thr, tv_dst); + tv_dst++; + } + thr->valstack_top = tv_dst; +} +#endif + +/* + * Arithmetic, binary, and logical helpers. + * + * Note: there is no opcode for logical AND or logical OR; this is on + * purpose, because the evalution order semantics for them make such + * opcodes pretty pointless: short circuiting means they are most + * comfortably implemented as jumps. However, a logical NOT opcode + * is useful. + * + * Note: careful with duk_tval pointers here: they are potentially + * invalidated by any DECREF and almost any API call. It's still + * preferable to work without making a copy but that's not always + * possible. + */ + +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF duk_double_t duk__compute_mod(duk_double_t d1, duk_double_t d2) { + return (duk_double_t) duk_js_arith_mod((double) d1, (double) d2); +} + +#if defined(DUK_USE_ES7_EXP_OPERATOR) +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF duk_double_t duk__compute_exp(duk_double_t d1, duk_double_t d2) { + return (duk_double_t) duk_js_arith_pow((double) d1, (double) d2); +} +#endif + +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF void duk__vm_arith_add(duk_hthread *thr, + duk_tval *tv_x, + duk_tval *tv_y, + duk_small_uint_fast_t idx_z) { + /* + * Addition operator is different from other arithmetic + * operations in that it also provides string concatenation. + * Hence it is implemented separately. + * + * There is a fast path for number addition. Other cases go + * through potentially multiple coercions as described in the + * E5 specification. It may be possible to reduce the number + * of coercions, but this must be done carefully to preserve + * the exact semantics. + * + * E5 Section 11.6.1. + * + * Custom types also have special behavior implemented here. + */ + + duk_double_union du; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv_x != NULL); /* may be reg or const */ + DUK_ASSERT(tv_y != NULL); /* may be reg or const */ + DUK_ASSERT_DISABLE(idx_z >= 0); /* unsigned */ + DUK_ASSERT((duk_uint_t) idx_z < (duk_uint_t) duk_get_top(thr)); + + /* + * Fast paths + */ + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_x) && DUK_TVAL_IS_FASTINT(tv_y)) { + duk_int64_t v1, v2, v3; + duk_int32_t v3_hi; + duk_tval *tv_z; + + /* Input values are signed 48-bit so we can detect overflow + * reliably from high bits or just a comparison. + */ + + v1 = DUK_TVAL_GET_FASTINT(tv_x); + v2 = DUK_TVAL_GET_FASTINT(tv_y); + v3 = v1 + v2; + v3_hi = (duk_int32_t) (v3 >> 32); + if (DUK_LIKELY(v3_hi >= DUK_I64_CONSTANT(-0x8000) && v3_hi <= DUK_I64_CONSTANT(0x7fff))) { + tv_z = thr->valstack_bottom + idx_z; + DUK_TVAL_SET_FASTINT_UPDREF(thr, tv_z, v3); /* side effects */ + return; + } else { + /* overflow, fall through */ + ; + } + } +#endif /* DUK_USE_FASTINT */ + + if (DUK_TVAL_IS_NUMBER(tv_x) && DUK_TVAL_IS_NUMBER(tv_y)) { +#if !defined(DUK_USE_EXEC_PREFER_SIZE) + duk_tval *tv_z; +#endif + + du.d = DUK_TVAL_GET_NUMBER(tv_x) + DUK_TVAL_GET_NUMBER(tv_y); +#if defined(DUK_USE_EXEC_PREFER_SIZE) + duk_push_number(thr, du.d); /* will NaN normalize result */ + duk_replace(thr, (duk_idx_t) idx_z); +#else /* DUK_USE_EXEC_PREFER_SIZE */ + DUK_DBLUNION_NORMALIZE_NAN_CHECK(&du); + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&du)); + tv_z = thr->valstack_bottom + idx_z; + DUK_TVAL_SET_NUMBER_UPDREF(thr, tv_z, du.d); /* side effects */ +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + return; + } + + /* + * Slow path: potentially requires function calls for coercion + */ + + duk_push_tval(thr, tv_x); + duk_push_tval(thr, tv_y); + duk_to_primitive(thr, -2, DUK_HINT_NONE); /* side effects -> don't use tv_x, tv_y after */ + duk_to_primitive(thr, -1, DUK_HINT_NONE); + + /* Since Duktape 2.x plain buffers are treated like ArrayBuffer. */ + if (duk_is_string(thr, -2) || duk_is_string(thr, -1)) { + /* Symbols shouldn't technically be handled here, but should + * go into the default ToNumber() coercion path instead and + * fail there with a TypeError. However, there's a ToString() + * in duk_concat_2() which also fails with TypeError so no + * explicit check is needed. + */ + duk_concat_2(thr); /* [... s1 s2] -> [... s1+s2] */ + } else { + duk_double_t d1, d2; + + d1 = duk_to_number_m2(thr); + d2 = duk_to_number_m1(thr); + DUK_ASSERT(duk_is_number(thr, -2)); + DUK_ASSERT(duk_is_number(thr, -1)); + DUK_ASSERT_DOUBLE_IS_NORMALIZED(d1); + DUK_ASSERT_DOUBLE_IS_NORMALIZED(d2); + + du.d = d1 + d2; + duk_pop_2_unsafe(thr); + duk_push_number(thr, du.d); /* will NaN normalize result */ + } + duk_replace(thr, (duk_idx_t) idx_z); /* side effects */ +} + +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF void duk__vm_arith_binary_op(duk_hthread *thr, + duk_tval *tv_x, + duk_tval *tv_y, + duk_uint_fast_t idx_z, + duk_small_uint_fast_t opcode) { + /* + * Arithmetic operations other than '+' have number-only semantics + * and are implemented here. The separate switch-case here means a + * "double dispatch" of the arithmetic opcode, but saves code space. + * + * E5 Sections 11.5, 11.5.1, 11.5.2, 11.5.3, 11.6, 11.6.1, 11.6.2, 11.6.3. + */ + + duk_double_t d1, d2; + duk_double_union du; + duk_small_uint_fast_t opcode_shifted; +#if defined(DUK_USE_FASTINT) || !defined(DUK_USE_EXEC_PREFER_SIZE) + duk_tval *tv_z; +#endif + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv_x != NULL); /* may be reg or const */ + DUK_ASSERT(tv_y != NULL); /* may be reg or const */ + DUK_ASSERT_DISABLE(idx_z >= 0); /* unsigned */ + DUK_ASSERT((duk_uint_t) idx_z < (duk_uint_t) duk_get_top(thr)); + + opcode_shifted = opcode >> 2; /* Get base opcode without reg/const modifiers. */ + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_x) && DUK_TVAL_IS_FASTINT(tv_y)) { + duk_int64_t v1, v2, v3; + duk_int32_t v3_hi; + + v1 = DUK_TVAL_GET_FASTINT(tv_x); + v2 = DUK_TVAL_GET_FASTINT(tv_y); + + switch (opcode_shifted) { + case DUK_OP_SUB >> 2: { + v3 = v1 - v2; + break; + } + case DUK_OP_MUL >> 2: { + /* Must ensure result is 64-bit (no overflow); a + * simple and sufficient fast path is to allow only + * 32-bit inputs. Avoid zero inputs to avoid + * negative zero issues (-1 * 0 = -0, for instance). + */ + if (v1 >= DUK_I64_CONSTANT(-0x80000000) && v1 <= DUK_I64_CONSTANT(0x7fffffff) && v1 != 0 && + v2 >= DUK_I64_CONSTANT(-0x80000000) && v2 <= DUK_I64_CONSTANT(0x7fffffff) && v2 != 0) { + v3 = v1 * v2; + } else { + goto skip_fastint; + } + break; + } + case DUK_OP_DIV >> 2: { + /* Don't allow a zero divisor. Fast path check by + * "verifying" with multiplication. Also avoid zero + * dividend to avoid negative zero issues (0 / -1 = -0 + * for instance). + */ + if (v1 == 0 || v2 == 0) { + goto skip_fastint; + } + v3 = v1 / v2; + if (v3 * v2 != v1) { + goto skip_fastint; + } + break; + } + case DUK_OP_MOD >> 2: { + /* Don't allow a zero divisor. Restrict both v1 and + * v2 to positive values to avoid compiler specific + * behavior. + */ + if (v1 < 1 || v2 < 1) { + goto skip_fastint; + } + v3 = v1 % v2; + DUK_ASSERT(v3 >= 0); + DUK_ASSERT(v3 < v2); + DUK_ASSERT(v1 - (v1 / v2) * v2 == v3); + break; + } + default: { + /* Possible with DUK_OP_EXP. */ + goto skip_fastint; + } + } + + v3_hi = (duk_int32_t) (v3 >> 32); + if (DUK_LIKELY(v3_hi >= DUK_I64_CONSTANT(-0x8000) && v3_hi <= DUK_I64_CONSTANT(0x7fff))) { + tv_z = thr->valstack_bottom + idx_z; + DUK_TVAL_SET_FASTINT_UPDREF(thr, tv_z, v3); /* side effects */ + return; + } + /* fall through if overflow etc */ + } +skip_fastint: +#endif /* DUK_USE_FASTINT */ + + if (DUK_TVAL_IS_NUMBER(tv_x) && DUK_TVAL_IS_NUMBER(tv_y)) { + /* fast path */ + d1 = DUK_TVAL_GET_NUMBER(tv_x); + d2 = DUK_TVAL_GET_NUMBER(tv_y); + } else { + duk_push_tval(thr, tv_x); + duk_push_tval(thr, tv_y); + d1 = duk_to_number_m2(thr); /* side effects */ + d2 = duk_to_number_m1(thr); + DUK_ASSERT(duk_is_number(thr, -2)); + DUK_ASSERT(duk_is_number(thr, -1)); + DUK_ASSERT_DOUBLE_IS_NORMALIZED(d1); + DUK_ASSERT_DOUBLE_IS_NORMALIZED(d2); + duk_pop_2_unsafe(thr); + } + + switch (opcode_shifted) { + case DUK_OP_SUB >> 2: { + du.d = d1 - d2; + break; + } + case DUK_OP_MUL >> 2: { + du.d = d1 * d2; + break; + } + case DUK_OP_DIV >> 2: { + /* Division-by-zero is undefined behavior, so + * rely on a helper. + */ + du.d = duk_double_div(d1, d2); + break; + } + case DUK_OP_MOD >> 2: { + du.d = duk__compute_mod(d1, d2); + break; + } +#if defined(DUK_USE_ES7_EXP_OPERATOR) + case DUK_OP_EXP >> 2: { + du.d = duk__compute_exp(d1, d2); + break; + } +#endif + default: { + DUK_UNREACHABLE(); + du.d = DUK_DOUBLE_NAN; /* should not happen */ + break; + } + } + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + duk_push_number(thr, du.d); /* will NaN normalize result */ + duk_replace(thr, (duk_idx_t) idx_z); +#else /* DUK_USE_EXEC_PREFER_SIZE */ + /* important to use normalized NaN with 8-byte tagged types */ + DUK_DBLUNION_NORMALIZE_NAN_CHECK(&du); + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&du)); + tv_z = thr->valstack_bottom + idx_z; + DUK_TVAL_SET_NUMBER_UPDREF(thr, tv_z, du.d); /* side effects */ +#endif /* DUK_USE_EXEC_PREFER_SIZE */ +} + +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF void duk__vm_bitwise_binary_op(duk_hthread *thr, + duk_tval *tv_x, + duk_tval *tv_y, + duk_small_uint_fast_t idx_z, + duk_small_uint_fast_t opcode) { + /* + * Binary bitwise operations use different coercions (ToInt32, ToUint32) + * depending on the operation. We coerce the arguments first using + * ToInt32(), and then cast to an 32-bit value if necessary. Note that + * such casts must be correct even if there is no native 32-bit type + * (e.g., duk_int32_t and duk_uint32_t are 64-bit). + * + * E5 Sections 11.10, 11.7.1, 11.7.2, 11.7.3 + */ + + duk_int32_t i1, i2, i3; + duk_uint32_t u1, u2, u3; +#if defined(DUK_USE_FASTINT) + duk_int64_t fi3; +#else + duk_double_t d3; +#endif + duk_small_uint_fast_t opcode_shifted; +#if defined(DUK_USE_FASTINT) || !defined(DUK_USE_EXEC_PREFER_SIZE) + duk_tval *tv_z; +#endif + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv_x != NULL); /* may be reg or const */ + DUK_ASSERT(tv_y != NULL); /* may be reg or const */ + DUK_ASSERT_DISABLE(idx_z >= 0); /* unsigned */ + DUK_ASSERT((duk_uint_t) idx_z < (duk_uint_t) duk_get_top(thr)); + + opcode_shifted = opcode >> 2; /* Get base opcode without reg/const modifiers. */ + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_x) && DUK_TVAL_IS_FASTINT(tv_y)) { + i1 = (duk_int32_t) DUK_TVAL_GET_FASTINT_I32(tv_x); + i2 = (duk_int32_t) DUK_TVAL_GET_FASTINT_I32(tv_y); + } else +#endif /* DUK_USE_FASTINT */ + { + duk_push_tval(thr, tv_x); + duk_push_tval(thr, tv_y); + i1 = duk_to_int32(thr, -2); + i2 = duk_to_int32(thr, -1); + duk_pop_2_unsafe(thr); + } + + switch (opcode_shifted) { + case DUK_OP_BAND >> 2: { + i3 = i1 & i2; + break; + } + case DUK_OP_BOR >> 2: { + i3 = i1 | i2; + break; + } + case DUK_OP_BXOR >> 2: { + i3 = i1 ^ i2; + break; + } + case DUK_OP_BASL >> 2: { + /* Signed shift, named "arithmetic" (asl) because the result + * is signed, e.g. 4294967295 << 1 -> -2. Note that result + * must be masked. + */ + + u2 = ((duk_uint32_t) i2) & 0xffffffffUL; + i3 = (duk_int32_t) (((duk_uint32_t) i1) << (u2 & 0x1fUL)); /* E5 Section 11.7.1, steps 7 and 8 */ + i3 = i3 & ((duk_int32_t) 0xffffffffUL); /* Note: left shift, should mask */ + break; + } + case DUK_OP_BASR >> 2: { + /* signed shift */ + + u2 = ((duk_uint32_t) i2) & 0xffffffffUL; + i3 = i1 >> (u2 & 0x1fUL); /* E5 Section 11.7.2, steps 7 and 8 */ + break; + } + case DUK_OP_BLSR >> 2: { + /* unsigned shift */ + + u1 = ((duk_uint32_t) i1) & 0xffffffffUL; + u2 = ((duk_uint32_t) i2) & 0xffffffffUL; + + /* special result value handling */ + u3 = u1 >> (u2 & 0x1fUL); /* E5 Section 11.7.2, steps 7 and 8 */ +#if defined(DUK_USE_FASTINT) + fi3 = (duk_int64_t) u3; + goto fastint_result_set; +#else + d3 = (duk_double_t) u3; + goto result_set; +#endif + } + default: { + DUK_UNREACHABLE(); + i3 = 0; /* should not happen */ + break; + } + } + +#if defined(DUK_USE_FASTINT) + /* Result is always fastint compatible. */ + /* XXX: Set 32-bit result (but must then handle signed and + * unsigned results separately). + */ + fi3 = (duk_int64_t) i3; + +fastint_result_set: + tv_z = thr->valstack_bottom + idx_z; + DUK_TVAL_SET_FASTINT_UPDREF(thr, tv_z, fi3); /* side effects */ +#else /* DUK_USE_FASTINT */ + d3 = (duk_double_t) i3; + +result_set: + DUK_ASSERT(!DUK_ISNAN(d3)); /* 'd3' is never NaN, so no need to normalize */ + DUK_ASSERT_DOUBLE_IS_NORMALIZED(d3); /* always normalized */ + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + duk_push_number(thr, d3); /* would NaN normalize result, but unnecessary */ + duk_replace(thr, (duk_idx_t) idx_z); +#else /* DUK_USE_EXEC_PREFER_SIZE */ + tv_z = thr->valstack_bottom + idx_z; + DUK_TVAL_SET_NUMBER_UPDREF(thr, tv_z, d3); /* side effects */ +#endif /* DUK_USE_EXEC_PREFER_SIZE */ +#endif /* DUK_USE_FASTINT */ +} + +/* In-place unary operation. */ +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF void duk__vm_arith_unary_op(duk_hthread *thr, + duk_uint_fast_t idx_src, + duk_uint_fast_t idx_dst, + duk_small_uint_fast_t opcode) { + /* + * Arithmetic operations other than '+' have number-only semantics + * and are implemented here. The separate switch-case here means a + * "double dispatch" of the arithmetic opcode, but saves code space. + * + * E5 Sections 11.5, 11.5.1, 11.5.2, 11.5.3, 11.6, 11.6.1, 11.6.2, 11.6.3. + */ + + duk_tval *tv; + duk_double_t d1; + duk_double_union du; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(opcode == DUK_OP_UNM || opcode == DUK_OP_UNP); + DUK_ASSERT_DISABLE(idx_src >= 0); + DUK_ASSERT_DISABLE(idx_dst >= 0); + + tv = DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_src); + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv)) { + duk_int64_t v1, v2; + + v1 = DUK_TVAL_GET_FASTINT(tv); + if (opcode == DUK_OP_UNM) { + /* The smallest fastint is no longer 48-bit when + * negated. Positive zero becames negative zero + * (cannot be represented) when negated. + */ + if (DUK_LIKELY(v1 != DUK_FASTINT_MIN && v1 != 0)) { + v2 = -v1; + tv = DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_dst); + DUK_TVAL_SET_FASTINT_UPDREF(thr, tv, v2); + return; + } + } else { + /* ToNumber() for a fastint is a no-op. */ + DUK_ASSERT(opcode == DUK_OP_UNP); + v2 = v1; + tv = DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_dst); + DUK_TVAL_SET_FASTINT_UPDREF(thr, tv, v2); + return; + } + /* fall through if overflow etc */ + } +#endif /* DUK_USE_FASTINT */ + + if (DUK_TVAL_IS_NUMBER(tv)) { + d1 = DUK_TVAL_GET_NUMBER(tv); + } else { + d1 = duk_to_number_tval(thr, tv); /* side effects */ + } + + if (opcode == DUK_OP_UNP) { + /* ToNumber() for a double is a no-op, but unary plus is + * used to force a fastint check so do that here. + */ + du.d = d1; + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&du)); +#if defined(DUK_USE_FASTINT) + tv = DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_dst); + DUK_TVAL_SET_NUMBER_CHKFAST_UPDREF(thr, tv, du.d); /* always 'fast', i.e. inlined */ + return; +#endif + } else { + DUK_ASSERT(opcode == DUK_OP_UNM); + du.d = -d1; + DUK_DBLUNION_NORMALIZE_NAN_CHECK(&du); /* mandatory if du.d is a NaN */ + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&du)); + } + + /* XXX: size optimize: push+replace? */ + tv = DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_dst); + DUK_TVAL_SET_NUMBER_UPDREF(thr, tv, du.d); +} + +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF void duk__vm_bitwise_not(duk_hthread *thr, duk_uint_fast_t idx_src, duk_uint_fast_t idx_dst) { + /* + * E5 Section 11.4.8 + */ + + duk_tval *tv; + duk_int32_t i1, i2; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT_DISABLE(idx_src >= 0); + DUK_ASSERT_DISABLE(idx_dst >= 0); + DUK_ASSERT((duk_uint_t) idx_src < (duk_uint_t) duk_get_top(thr)); + DUK_ASSERT((duk_uint_t) idx_dst < (duk_uint_t) duk_get_top(thr)); + + tv = DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_src); + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv)) { + i1 = (duk_int32_t) DUK_TVAL_GET_FASTINT_I32(tv); + } else +#endif /* DUK_USE_FASTINT */ + { + duk_push_tval(thr, tv); + i1 = duk_to_int32(thr, -1); /* side effects */ + duk_pop_unsafe(thr); + } + + /* Result is always fastint compatible. */ + i2 = ~i1; + tv = DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_dst); + DUK_TVAL_SET_I32_UPDREF(thr, tv, i2); /* side effects */ +} + +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF void duk__vm_logical_not(duk_hthread *thr, duk_uint_fast_t idx_src, duk_uint_fast_t idx_dst) { + /* + * E5 Section 11.4.9 + */ + + duk_tval *tv; + duk_bool_t res; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT_DISABLE(idx_src >= 0); + DUK_ASSERT_DISABLE(idx_dst >= 0); + DUK_ASSERT((duk_uint_t) idx_src < (duk_uint_t) duk_get_top(thr)); + DUK_ASSERT((duk_uint_t) idx_dst < (duk_uint_t) duk_get_top(thr)); + + /* ToBoolean() does not require any operations with side effects so + * we can do it efficiently. For footprint it would be better to use + * duk_js_toboolean() and then push+replace to the result slot. + */ + tv = DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_src); + res = duk_js_toboolean(tv); /* does not modify 'tv' */ + DUK_ASSERT(res == 0 || res == 1); + res ^= 1; + tv = DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_dst); + /* XXX: size optimize: push+replace? */ + DUK_TVAL_SET_BOOLEAN_UPDREF(thr, tv, res); /* side effects */ +} + +/* XXX: size optimized variant */ +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF void duk__prepost_incdec_reg_helper(duk_hthread *thr, + duk_tval *tv_dst, + duk_tval *tv_src, + duk_small_uint_t op) { + duk_double_t x, y, z; + + /* Two lowest bits of opcode are used to distinguish + * variants. Bit 0 = inc(0)/dec(1), bit 1 = pre(0)/post(1). + */ + DUK_ASSERT((DUK_OP_PREINCR & 0x03) == 0x00); + DUK_ASSERT((DUK_OP_PREDECR & 0x03) == 0x01); + DUK_ASSERT((DUK_OP_POSTINCR & 0x03) == 0x02); + DUK_ASSERT((DUK_OP_POSTDECR & 0x03) == 0x03); + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_src)) { + duk_int64_t x_fi, y_fi, z_fi; + x_fi = DUK_TVAL_GET_FASTINT(tv_src); + if (op & 0x01) { + if (DUK_UNLIKELY(x_fi == DUK_FASTINT_MIN)) { + goto skip_fastint; + } + y_fi = x_fi - 1; + } else { + if (DUK_UNLIKELY(x_fi == DUK_FASTINT_MAX)) { + goto skip_fastint; + } + y_fi = x_fi + 1; + } + + DUK_TVAL_SET_FASTINT(tv_src, y_fi); /* no need for refcount update */ + + z_fi = (op & 0x02) ? x_fi : y_fi; + DUK_TVAL_SET_FASTINT_UPDREF(thr, tv_dst, z_fi); /* side effects */ + return; + } +skip_fastint: +#endif + if (DUK_TVAL_IS_NUMBER(tv_src)) { + /* Fast path for the case where the register + * is a number (e.g. loop counter). + */ + + x = DUK_TVAL_GET_NUMBER(tv_src); + if (op & 0x01) { + y = x - 1.0; + } else { + y = x + 1.0; + } + + DUK_TVAL_SET_NUMBER(tv_src, y); /* no need for refcount update */ + } else { + /* Preserve duk_tval pointer(s) across a potential valstack + * resize by converting them into offsets temporarily. + */ + duk_idx_t bc; + duk_size_t off_dst; + + off_dst = (duk_size_t) ((duk_uint8_t *) tv_dst - (duk_uint8_t *) thr->valstack_bottom); + bc = (duk_idx_t) (tv_src - thr->valstack_bottom); /* XXX: pass index explicitly? */ + tv_src = NULL; /* no longer referenced */ + + x = duk_to_number(thr, bc); + if (op & 0x01) { + y = x - 1.0; + } else { + y = x + 1.0; + } + + duk_push_number(thr, y); + duk_replace(thr, bc); + + tv_dst = (duk_tval *) (void *) (((duk_uint8_t *) thr->valstack_bottom) + off_dst); + } + + z = (op & 0x02) ? x : y; + DUK_TVAL_SET_NUMBER_UPDREF(thr, tv_dst, z); /* side effects */ +} + +DUK_LOCAL DUK_EXEC_ALWAYS_INLINE_PERF void duk__prepost_incdec_var_helper(duk_hthread *thr, + duk_small_uint_t idx_dst, + duk_tval *tv_id, + duk_small_uint_t op, + duk_small_uint_t is_strict) { + duk_activation *act; + duk_double_t x, y; + duk_hstring *name; + + /* XXX: The pre/post inc/dec for an identifier lookup is + * missing the important fast path where the identifier + * has a storage location e.g. in a scope object so that + * it can be updated in-place. In particular, the case + * where the identifier has a storage location AND the + * previous value is a number should be optimized because + * it's side effect free. + */ + + /* Two lowest bits of opcode are used to distinguish + * variants. Bit 0 = inc(0)/dec(1), bit 1 = pre(0)/post(1). + */ + DUK_ASSERT((DUK_OP_PREINCV & 0x03) == 0x00); + DUK_ASSERT((DUK_OP_PREDECV & 0x03) == 0x01); + DUK_ASSERT((DUK_OP_POSTINCV & 0x03) == 0x02); + DUK_ASSERT((DUK_OP_POSTDECV & 0x03) == 0x03); + + DUK_ASSERT(DUK_TVAL_IS_STRING(tv_id)); + name = DUK_TVAL_GET_STRING(tv_id); + DUK_ASSERT(name != NULL); + act = thr->callstack_curr; + (void) duk_js_getvar_activation(thr, act, name, 1 /*throw*/); /* -> [ ... val this ] */ + + /* XXX: Fastint fast path would be useful here. Also fastints + * now lose their fastint status in current handling which is + * not intuitive. + */ + + x = duk_to_number_m2(thr); + if (op & 0x01) { + y = x - 1.0; + } else { + y = x + 1.0; + } + + /* [... x this] */ + + if (op & 0x02) { + duk_push_number(thr, y); /* -> [ ... x this y ] */ + DUK_ASSERT(act == thr->callstack_curr); + duk_js_putvar_activation(thr, act, name, DUK_GET_TVAL_NEGIDX(thr, -1), is_strict); + duk_pop_2_unsafe(thr); /* -> [ ... x ] */ + } else { + duk_pop_2_unsafe(thr); /* -> [ ... ] */ + duk_push_number(thr, y); /* -> [ ... y ] */ + DUK_ASSERT(act == thr->callstack_curr); + duk_js_putvar_activation(thr, act, name, DUK_GET_TVAL_NEGIDX(thr, -1), is_strict); + } + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + duk_replace(thr, (duk_idx_t) idx_dst); +#else /* DUK_USE_EXEC_PREFER_SIZE */ + DUK__REPLACE_TO_TVPTR(thr, DUK_GET_TVAL_POSIDX(thr, (duk_idx_t) idx_dst)); +#endif /* DUK_USE_EXEC_PREFER_SIZE */ +} + +/* + * Longjmp and other control flow transfer for the bytecode executor. + * + * The longjmp handler can handle all longjmp types: error, yield, and + * resume (pseudotypes are never actually thrown). + * + * Error policy for longjmp: should not ordinarily throw errors; if errors + * occur (e.g. due to out-of-memory) they bubble outwards rather than being + * handled recursively. + */ + +#define DUK__LONGJMP_RESTART 0 /* state updated, restart bytecode execution */ +#define DUK__LONGJMP_RETHROW 1 /* exit bytecode executor by rethrowing an error to caller */ + +#define DUK__RETHAND_RESTART 0 /* state updated, restart bytecode execution */ +#define DUK__RETHAND_FINISHED 1 /* exit bytecode execution with return value */ + +/* XXX: optimize reconfig valstack operations so that resize, clamp, and setting + * top are combined into one pass. + */ + +/* Reconfigure value stack for return to an ECMAScript function at + * callstack top (caller unwinds). + */ +DUK_LOCAL void duk__reconfig_valstack_ecma_return(duk_hthread *thr) { + duk_activation *act; + duk_hcompfunc *h_func; + duk_idx_t clamp_top; + + DUK_ASSERT(thr != NULL); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(act) != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(act))); + + /* Clamp so that values at 'clamp_top' and above are wiped and won't + * retain reachable garbage. Then extend to 'nregs' because we're + * returning to an ECMAScript function. + */ + + h_func = (duk_hcompfunc *) DUK_ACT_GET_FUNC(act); + + thr->valstack_bottom = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + act->bottom_byteoff); + DUK_ASSERT(act->retval_byteoff >= act->bottom_byteoff); + clamp_top = + (duk_idx_t) ((act->retval_byteoff - act->bottom_byteoff + sizeof(duk_tval)) / sizeof(duk_tval)); /* +1 = one retval */ + duk_set_top_and_wipe(thr, h_func->nregs, clamp_top); + + DUK_ASSERT((duk_uint8_t *) thr->valstack_end >= (duk_uint8_t *) thr->valstack + act->reserve_byteoff); + thr->valstack_end = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + act->reserve_byteoff); + + /* XXX: a best effort shrink check would be OK here */ +} + +/* Reconfigure value stack for an ECMAScript catcher. Use topmost catcher + * in 'act'. + */ +DUK_LOCAL void duk__reconfig_valstack_ecma_catcher(duk_hthread *thr, duk_activation *act) { + duk_catcher *cat; + duk_hcompfunc *h_func; + duk_size_t idx_bottom; + duk_idx_t clamp_top; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(act != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(act) != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(act))); + cat = act->cat; + DUK_ASSERT(cat != NULL); + + h_func = (duk_hcompfunc *) DUK_ACT_GET_FUNC(act); + + thr->valstack_bottom = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + act->bottom_byteoff); + idx_bottom = (duk_size_t) (thr->valstack_bottom - thr->valstack); + DUK_ASSERT(cat->idx_base >= idx_bottom); + clamp_top = (duk_idx_t) (cat->idx_base - idx_bottom + 2); /* +2 = catcher value, catcher lj_type */ + duk_set_top_and_wipe(thr, h_func->nregs, clamp_top); + + DUK_ASSERT((duk_uint8_t *) thr->valstack_end >= (duk_uint8_t *) thr->valstack + act->reserve_byteoff); + thr->valstack_end = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + act->reserve_byteoff); + + /* XXX: a best effort shrink check would be OK here */ +} + +/* Set catcher regs: idx_base+0 = value, idx_base+1 = lj_type. + * No side effects. + */ +DUK_LOCAL void duk__set_catcher_regs_norz(duk_hthread *thr, duk_catcher *cat, duk_tval *tv_val_unstable, duk_small_uint_t lj_type) { + duk_tval *tv1; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv_val_unstable != NULL); + + tv1 = thr->valstack + cat->idx_base; + DUK_ASSERT(tv1 < thr->valstack_top); + DUK_TVAL_SET_TVAL_UPDREF_NORZ(thr, tv1, tv_val_unstable); + + tv1++; + DUK_ASSERT(tv1 == thr->valstack + cat->idx_base + 1); + DUK_ASSERT(tv1 < thr->valstack_top); + DUK_TVAL_SET_U32_UPDREF_NORZ(thr, tv1, (duk_uint32_t) lj_type); +} + +DUK_LOCAL void duk__handle_catch_part1(duk_hthread *thr, + duk_tval *tv_val_unstable, + duk_small_uint_t lj_type, + volatile duk_bool_t *out_delayed_catch_setup) { + duk_activation *act; + duk_catcher *cat; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv_val_unstable != NULL); + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + DUK_DD(DUK_DDPRINT("handle catch, part 1; act=%!A, cat=%!C", act, act->cat)); + + DUK_ASSERT(act->cat != NULL); + DUK_ASSERT(DUK_CAT_GET_TYPE(act->cat) == DUK_CAT_TYPE_TCF); + + /* The part1/part2 split could also be made here at the very top + * of catch handling. Value stack would be reconfigured inside + * part2's protection. Value stack reconfiguration should be free + * of allocs, however. + */ + + duk__set_catcher_regs_norz(thr, act->cat, tv_val_unstable, lj_type); + + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr) != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr))); + + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + duk__reconfig_valstack_ecma_catcher(thr, act); + + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + cat = act->cat; + DUK_ASSERT(cat != NULL); + + act->curr_pc = cat->pc_base + 0; /* +0 = catch */ + + /* + * If the catch block has an automatic catch variable binding, + * we need to create a lexical environment for it which requires + * allocations. Move out of "error handling state" before the + * allocations to avoid e.g. out-of-memory errors (leading to + * GH-2022 or similar). + */ + + if (DUK_CAT_HAS_CATCH_BINDING_ENABLED(cat)) { + DUK_DDD(DUK_DDDPRINT("catcher has an automatic catch binding, handle in part 2")); + *out_delayed_catch_setup = 1; + } else { + DUK_DDD(DUK_DDDPRINT("catcher has no catch binding")); + } + + DUK_CAT_CLEAR_CATCH_ENABLED(cat); +} + +DUK_LOCAL void duk__handle_catch_part2(duk_hthread *thr) { + duk_activation *act; + duk_catcher *cat; + duk_hdecenv *new_env; + + DUK_ASSERT(thr != NULL); + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + DUK_DD(DUK_DDPRINT("handle catch, part 2; act=%!A, cat=%!C", act, act->cat)); + + DUK_ASSERT(act->cat != NULL); + cat = act->cat; + DUK_ASSERT(cat != NULL); + DUK_ASSERT(DUK_CAT_GET_TYPE(cat) == DUK_CAT_TYPE_TCF); + DUK_ASSERT(DUK_CAT_HAS_CATCH_BINDING_ENABLED(cat)); + DUK_ASSERT(thr->valstack + cat->idx_base < thr->valstack_top); + + /* + * Create lexical environment for the catch clause, containing + * a binding for the caught value. + * + * The binding is mutable (= writable) but not deletable. + * Step 4 for the catch production in E5 Section 12.14; + * no value is given for CreateMutableBinding 'D' argument, + * which implies the binding is not deletable. + */ + + if (act->lex_env == NULL) { + DUK_ASSERT(act->var_env == NULL); + DUK_DDD(DUK_DDDPRINT("delayed environment initialization")); + + duk_js_init_activation_environment_records_delayed(thr, act); + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + } + DUK_ASSERT(act->lex_env != NULL); + DUK_ASSERT(act->var_env != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(act) != NULL); + + new_env = duk_hdecenv_alloc(thr, DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_DECENV)); + DUK_ASSERT(new_env != NULL); + duk_push_hobject(thr, (duk_hobject *) new_env); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) new_env) == NULL); + DUK_DDD(DUK_DDDPRINT("new_env allocated: %!iO", (duk_heaphdr *) new_env)); + + /* Note: currently the catch binding is handled without a register + * binding because we don't support dynamic register bindings (they + * must be fixed for an entire function). So, there is no need to + * record regbases etc. + */ + + /* [ ...env ] */ + + DUK_ASSERT(cat->h_varname != NULL); + duk_push_hstring(thr, cat->h_varname); + DUK_ASSERT(thr->valstack + cat->idx_base < thr->valstack_top); + duk_push_tval(thr, thr->valstack + cat->idx_base); + duk_xdef_prop(thr, -3, DUK_PROPDESC_FLAGS_W); /* writable, not configurable */ + + /* [ ... env ] */ + + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + DUK_HOBJECT_SET_PROTOTYPE(thr->heap, (duk_hobject *) new_env, act->lex_env); + act->lex_env = (duk_hobject *) new_env; + DUK_HOBJECT_INCREF(thr, (duk_hobject *) new_env); /* reachable through activation */ + /* Net refcount change to act->lex_env is 0: incref for new_env's + * prototype, decref for act->lex_env overwrite. + */ + + DUK_CAT_SET_LEXENV_ACTIVE(cat); + + duk_pop_unsafe(thr); + + DUK_DDD(DUK_DDDPRINT("new_env finished: %!iO", (duk_heaphdr *) new_env)); +} + +DUK_LOCAL void duk__handle_finally(duk_hthread *thr, duk_tval *tv_val_unstable, duk_small_uint_t lj_type) { + duk_activation *act; + duk_catcher *cat; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv_val_unstable != NULL); + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + DUK_ASSERT(act->cat != NULL); + DUK_ASSERT(DUK_CAT_GET_TYPE(act->cat) == DUK_CAT_TYPE_TCF); + + duk__set_catcher_regs_norz(thr, act->cat, tv_val_unstable, lj_type); + + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr) != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr))); + + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + duk__reconfig_valstack_ecma_catcher(thr, act); + + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + cat = act->cat; + DUK_ASSERT(cat != NULL); + + act->curr_pc = cat->pc_base + 1; /* +1 = finally */ + + DUK_CAT_CLEAR_FINALLY_ENABLED(cat); +} + +DUK_LOCAL void duk__handle_label(duk_hthread *thr, duk_small_uint_t lj_type) { + duk_activation *act; + duk_catcher *cat; + + DUK_ASSERT(thr != NULL); + + DUK_ASSERT(thr->callstack_top >= 1); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(act) != NULL); + DUK_ASSERT(DUK_HOBJECT_HAS_COMPFUNC(DUK_ACT_GET_FUNC(act))); + + /* +0 = break, +1 = continue */ + cat = act->cat; + DUK_ASSERT(cat != NULL); + DUK_ASSERT(DUK_CAT_GET_TYPE(cat) == DUK_CAT_TYPE_LABEL); + + act->curr_pc = cat->pc_base + (lj_type == DUK_LJ_TYPE_CONTINUE ? 1 : 0); + + /* valstack should not need changes */ +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack_bottom) == + (duk_size_t) ((duk_hcompfunc *) DUK_ACT_GET_FUNC(act))->nregs); +#endif +} + +/* Called for handling both a longjmp() with type DUK_LJ_TYPE_YIELD and + * when a RETURN opcode terminates a thread and yields to the resumer. + * Caller unwinds so that top of callstack is the activation we return to. + */ +#if defined(DUK_USE_COROUTINE_SUPPORT) +DUK_LOCAL void duk__handle_yield(duk_hthread *thr, duk_hthread *resumer, duk_tval *tv_val_unstable) { + duk_activation *act_resumer; + duk_tval *tv1; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(resumer != NULL); + DUK_ASSERT(tv_val_unstable != NULL); + act_resumer = resumer->callstack_curr; + DUK_ASSERT(act_resumer != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(act_resumer) != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(act_resumer))); /* resume caller must be an ECMAScript func */ + + tv1 = (duk_tval *) (void *) ((duk_uint8_t *) resumer->valstack + + act_resumer->retval_byteoff); /* return value from Duktape.Thread.resume() */ + DUK_TVAL_SET_TVAL_UPDREF(thr, tv1, tv_val_unstable); /* side effects */ /* XXX: avoid side effects */ + + duk__reconfig_valstack_ecma_return(resumer); + + /* caller must change active thread, and set thr->resumer to NULL */ +} +#endif /* DUK_USE_COROUTINE_SUPPORT */ + +DUK_LOCAL duk_small_uint_t duk__handle_longjmp(duk_hthread *thr, + duk_activation *entry_act, + volatile duk_bool_t *out_delayed_catch_setup) { + duk_small_uint_t retval = DUK__LONGJMP_RESTART; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(entry_act != NULL); + + /* 'thr' is the current thread, as no-one resumes except us and we + * switch 'thr' in that case. + */ + DUK_ASSERT(thr == thr->heap->curr_thread); + + /* + * (Re)try handling the longjmp. + * + * A longjmp handler may convert the longjmp to a different type and + * "virtually" rethrow by goto'ing to 'check_longjmp'. Before the goto, + * the following must be updated: + * - the heap 'lj' state + * - 'thr' must reflect the "throwing" thread + */ + +check_longjmp: + + DUK_DD(DUK_DDPRINT("handling longjmp: type=%ld, value1=%!T, value2=%!T, iserror=%ld, top=%ld", + (long) thr->heap->lj.type, + (duk_tval *) &thr->heap->lj.value1, + (duk_tval *) &thr->heap->lj.value2, + (long) thr->heap->lj.iserror, + (long) duk_get_top(thr))); + + switch (thr->heap->lj.type) { +#if defined(DUK_USE_COROUTINE_SUPPORT) + case DUK_LJ_TYPE_RESUME: { + /* + * Note: lj.value1 is 'value', lj.value2 is 'resumee'. + * This differs from YIELD. + */ + + duk_tval *tv; + duk_tval *tv2; + duk_hthread *resumee; + + /* duk_bi_duk_object_yield() and duk_bi_duk_object_resume() ensure all of these are met */ + + DUK_ASSERT(thr->state == DUK_HTHREAD_STATE_RUNNING); /* unchanged by Duktape.Thread.resume() */ + DUK_ASSERT(thr->callstack_top >= 2); /* ECMAScript activation + Duktape.Thread.resume() activation */ + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(thr->callstack_curr->parent != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr) != NULL && + DUK_HOBJECT_IS_NATFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr)) && + ((duk_hnatfunc *) DUK_ACT_GET_FUNC(thr->callstack_curr))->func == duk_bi_thread_resume); + + tv = &thr->heap->lj.value2; /* resumee */ + DUK_ASSERT(DUK_TVAL_IS_OBJECT(tv)); + DUK_ASSERT(DUK_TVAL_GET_OBJECT(tv) != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_THREAD(DUK_TVAL_GET_OBJECT(tv))); + resumee = (duk_hthread *) DUK_TVAL_GET_OBJECT(tv); + + DUK_ASSERT(resumee != NULL); + DUK_ASSERT(resumee->resumer == NULL); + DUK_ASSERT(resumee->state == DUK_HTHREAD_STATE_INACTIVE || + resumee->state == DUK_HTHREAD_STATE_YIELDED); /* checked by Duktape.Thread.resume() */ + DUK_ASSERT(resumee->state != DUK_HTHREAD_STATE_YIELDED || + resumee->callstack_top >= 2); /* YIELDED: ECMAScript activation + Duktape.Thread.yield() activation */ + DUK_ASSERT(resumee->state != DUK_HTHREAD_STATE_YIELDED || + (DUK_ACT_GET_FUNC(resumee->callstack_curr) != NULL && + DUK_HOBJECT_IS_NATFUNC(DUK_ACT_GET_FUNC(resumee->callstack_curr)) && + ((duk_hnatfunc *) DUK_ACT_GET_FUNC(resumee->callstack_curr))->func == duk_bi_thread_yield)); + DUK_ASSERT(resumee->state != DUK_HTHREAD_STATE_INACTIVE || + resumee->callstack_top == 0); /* INACTIVE: no activation, single function value on valstack */ + + if (thr->heap->lj.iserror) { + /* + * Throw the error in the resumed thread's context; the + * error value is pushed onto the resumee valstack. + * + * Note: the callstack of the target may empty in this case + * too (i.e. the target thread has never been resumed). The + * value stack will contain the initial function in that case, + * which we simply ignore. + */ + + DUK_ASSERT(resumee->resumer == NULL); + resumee->resumer = thr; + DUK_HTHREAD_INCREF(thr, thr); + resumee->state = DUK_HTHREAD_STATE_RUNNING; + thr->state = DUK_HTHREAD_STATE_RESUMED; + DUK_HEAP_SWITCH_THREAD(thr->heap, resumee); + thr = resumee; + + thr->heap->lj.type = DUK_LJ_TYPE_THROW; + + /* thr->heap->lj.value1 is already the value to throw */ + /* thr->heap->lj.value2 is 'thread', will be wiped out at the end */ + + DUK_ASSERT(thr->heap->lj.iserror); /* already set */ + + DUK_DD(DUK_DDPRINT("-> resume with an error, converted to a throw in the resumee, propagate")); + goto check_longjmp; + } else if (resumee->state == DUK_HTHREAD_STATE_YIELDED) { + /* Unwind previous Duktape.Thread.yield() call. The + * activation remaining must always be an ECMAScript + * call now (yield() accepts calls from ECMAScript + * only). + */ + duk_activation *act_resumee; + + DUK_ASSERT(resumee->callstack_top >= 2); + act_resumee = resumee->callstack_curr; /* Duktape.Thread.yield() */ + DUK_ASSERT(act_resumee != NULL); + act_resumee = act_resumee->parent; /* ECMAScript call site for yield() */ + DUK_ASSERT(act_resumee != NULL); + + tv = (duk_tval *) (void *) ((duk_uint8_t *) resumee->valstack + + act_resumee->retval_byteoff); /* return value from Duktape.Thread.yield() */ + DUK_ASSERT(tv >= resumee->valstack && tv < resumee->valstack_top); + tv2 = &thr->heap->lj.value1; + DUK_TVAL_SET_TVAL_UPDREF(thr, tv, tv2); /* side effects */ /* XXX: avoid side effects */ + + duk_hthread_activation_unwind_norz(resumee); /* unwind to 'yield' caller */ + /* no need to unwind catch stack */ + + duk__reconfig_valstack_ecma_return(resumee); + + DUK_ASSERT(resumee->resumer == NULL); + resumee->resumer = thr; + DUK_HTHREAD_INCREF(thr, thr); + resumee->state = DUK_HTHREAD_STATE_RUNNING; + thr->state = DUK_HTHREAD_STATE_RESUMED; + DUK_HEAP_SWITCH_THREAD(thr->heap, resumee); +#if 0 + thr = resumee; /* not needed, as we exit right away */ +#endif + DUK_DD(DUK_DDPRINT("-> resume with a value, restart execution in resumee")); + retval = DUK__LONGJMP_RESTART; + goto wipe_and_return; + } else { + /* Initial resume call. */ + duk_small_uint_t call_flags; + duk_int_t setup_rc; + + /* resumee: [... initial_func] (currently actually: [initial_func]) */ + + duk_push_undefined(resumee); + tv = &thr->heap->lj.value1; + duk_push_tval(resumee, tv); + + /* resumee: [... initial_func undefined(= this) resume_value ] */ + + call_flags = DUK_CALL_FLAG_ALLOW_ECMATOECMA; /* not tailcall, ecma-to-ecma (assumed to succeed) */ + + setup_rc = duk_handle_call_unprotected_nargs(resumee, 1 /*nargs*/, call_flags); + if (setup_rc == 0) { + /* This shouldn't happen; Duktape.Thread.resume() + * should make sure of that. If it does happen + * this internal error will propagate out of the + * executor which can be quite misleading. + */ + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return 0;); + } + + DUK_ASSERT(resumee->resumer == NULL); + resumee->resumer = thr; + DUK_HTHREAD_INCREF(thr, thr); + resumee->state = DUK_HTHREAD_STATE_RUNNING; + thr->state = DUK_HTHREAD_STATE_RESUMED; + DUK_HEAP_SWITCH_THREAD(thr->heap, resumee); +#if 0 + thr = resumee; /* not needed, as we exit right away */ +#endif + DUK_DD(DUK_DDPRINT("-> resume with a value, restart execution in resumee")); + retval = DUK__LONGJMP_RESTART; + goto wipe_and_return; + } + DUK_UNREACHABLE(); + break; /* never here */ + } + + case DUK_LJ_TYPE_YIELD: { + /* + * Currently only allowed only if yielding thread has only + * ECMAScript activations (except for the Duktape.Thread.yield() + * call at the callstack top) and none of them constructor + * calls. + * + * This excludes the 'entry' thread which will always have + * a preventcount > 0. + */ + + duk_hthread *resumer; + + /* duk_bi_duk_object_yield() and duk_bi_duk_object_resume() ensure all of these are met */ + +#if 0 /* entry_thread not available for assert */ + DUK_ASSERT(thr != entry_thread); /* Duktape.Thread.yield() should prevent */ +#endif + DUK_ASSERT(thr->state == DUK_HTHREAD_STATE_RUNNING); /* unchanged from Duktape.Thread.yield() */ + DUK_ASSERT(thr->callstack_top >= 2); /* ECMAScript activation + Duktape.Thread.yield() activation */ + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(thr->callstack_curr->parent != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr) != NULL && + DUK_HOBJECT_IS_NATFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr)) && + ((duk_hnatfunc *) DUK_ACT_GET_FUNC(thr->callstack_curr))->func == duk_bi_thread_yield); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr->parent) != NULL && + DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr->parent))); /* an ECMAScript function */ + + resumer = thr->resumer; + + DUK_ASSERT(resumer != NULL); + DUK_ASSERT(resumer->state == DUK_HTHREAD_STATE_RESUMED); /* written by a previous RESUME handling */ + DUK_ASSERT(resumer->callstack_top >= 2); /* ECMAScript activation + Duktape.Thread.resume() activation */ + DUK_ASSERT(resumer->callstack_curr != NULL); + DUK_ASSERT(resumer->callstack_curr->parent != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(resumer->callstack_curr) != NULL && + DUK_HOBJECT_IS_NATFUNC(DUK_ACT_GET_FUNC(resumer->callstack_curr)) && + ((duk_hnatfunc *) DUK_ACT_GET_FUNC(resumer->callstack_curr))->func == duk_bi_thread_resume); + DUK_ASSERT(DUK_ACT_GET_FUNC(resumer->callstack_curr->parent) != NULL && + DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(resumer->callstack_curr->parent))); /* an ECMAScript function */ + + if (thr->heap->lj.iserror) { + thr->state = DUK_HTHREAD_STATE_YIELDED; + thr->resumer = NULL; + DUK_HTHREAD_DECREF_NORZ(thr, resumer); + resumer->state = DUK_HTHREAD_STATE_RUNNING; + DUK_HEAP_SWITCH_THREAD(thr->heap, resumer); + thr = resumer; + + thr->heap->lj.type = DUK_LJ_TYPE_THROW; + /* lj.value1 is already set */ + DUK_ASSERT(thr->heap->lj.iserror); /* already set */ + + DUK_DD(DUK_DDPRINT("-> yield an error, converted to a throw in the resumer, propagate")); + goto check_longjmp; + } else { + /* When handling the yield, the last reference to + * 'thr' may disappear. + */ + + DUK_GC_TORTURE(resumer->heap); + duk_hthread_activation_unwind_norz(resumer); + DUK_GC_TORTURE(resumer->heap); + thr->state = DUK_HTHREAD_STATE_YIELDED; + thr->resumer = NULL; + DUK_HTHREAD_DECREF_NORZ(thr, resumer); + resumer->state = DUK_HTHREAD_STATE_RUNNING; + DUK_HEAP_SWITCH_THREAD(thr->heap, resumer); + duk__handle_yield(thr, resumer, &thr->heap->lj.value1); + thr = resumer; + DUK_GC_TORTURE(resumer->heap); + + DUK_DD(DUK_DDPRINT("-> yield a value, restart execution in resumer")); + retval = DUK__LONGJMP_RESTART; + goto wipe_and_return; + } + DUK_UNREACHABLE(); + break; /* never here */ + } +#endif /* DUK_USE_COROUTINE_SUPPORT */ + + case DUK_LJ_TYPE_THROW: { + /* + * Three possible outcomes: + * * A try or finally catcher is found => resume there. + * (or) + * * The error propagates to the bytecode executor entry + * level (and we're in the entry thread) => rethrow + * with a new longjmp(), after restoring the previous + * catchpoint. + * * The error is not caught in the current thread, so + * the thread finishes with an error. This works like + * a yielded error, except that the thread is finished + * and can no longer be resumed. (There is always a + * resumer in this case.) + * + * Note: until we hit the entry level, there can only be + * ECMAScript activations. + */ + + duk_activation *act; + duk_catcher *cat; + duk_hthread *resumer; + + for (;;) { + act = thr->callstack_curr; + if (act == NULL) { + break; + } + + for (;;) { + cat = act->cat; + if (cat == NULL) { + break; + } + + if (DUK_CAT_HAS_CATCH_ENABLED(cat)) { + DUK_ASSERT(DUK_CAT_GET_TYPE(cat) == DUK_CAT_TYPE_TCF); + + DUK_DDD(DUK_DDDPRINT("before catch part 1: thr=%p, act=%p, cat=%p", + (void *) thr, + (void *) act, + (void *) act->cat)); + duk__handle_catch_part1(thr, + &thr->heap->lj.value1, + DUK_LJ_TYPE_THROW, + out_delayed_catch_setup); + + DUK_DD(DUK_DDPRINT("-> throw caught by a 'catch' clause, restart execution")); + retval = DUK__LONGJMP_RESTART; + goto wipe_and_return; + } + + if (DUK_CAT_HAS_FINALLY_ENABLED(cat)) { + DUK_ASSERT(DUK_CAT_GET_TYPE(cat) == DUK_CAT_TYPE_TCF); + DUK_ASSERT(!DUK_CAT_HAS_CATCH_ENABLED(cat)); + + duk__handle_finally(thr, &thr->heap->lj.value1, DUK_LJ_TYPE_THROW); + + DUK_DD(DUK_DDPRINT("-> throw caught by a 'finally' clause, restart execution")); + retval = DUK__LONGJMP_RESTART; + goto wipe_and_return; + } + + duk_hthread_catcher_unwind_norz(thr, act); + } + + if (act == entry_act) { + /* Not caught by anything before entry level; rethrow and let the + * final catcher finish unwinding (esp. value stack). + */ + DUK_D(DUK_DPRINT("-> throw propagated up to entry level, rethrow and exit bytecode executor")); + retval = DUK__LONGJMP_RETHROW; + goto just_return; + } + + duk_hthread_activation_unwind_norz(thr); + } + + DUK_DD(DUK_DDPRINT("-> throw not caught by current thread, yield error to resumer and recheck longjmp")); + + /* Not caught by current thread, thread terminates (yield error to resumer); + * note that this may cause a cascade if the resumer terminates with an uncaught + * exception etc (this is OK, but needs careful testing). + */ + + DUK_ASSERT(thr->resumer != NULL); + DUK_ASSERT(thr->resumer->callstack_top >= 2); /* ECMAScript activation + Duktape.Thread.resume() activation */ + DUK_ASSERT(thr->resumer->callstack_curr != NULL); + DUK_ASSERT(thr->resumer->callstack_curr->parent != NULL); + DUK_ASSERT( + DUK_ACT_GET_FUNC(thr->resumer->callstack_curr->parent) != NULL && + DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(thr->resumer->callstack_curr->parent))); /* an ECMAScript function */ + + resumer = thr->resumer; + + /* reset longjmp */ + + DUK_ASSERT(thr->heap->lj.type == DUK_LJ_TYPE_THROW); /* already set */ + /* lj.value1 already set */ + + duk_hthread_terminate(thr); /* updates thread state, minimizes its allocations */ + DUK_ASSERT(thr->state == DUK_HTHREAD_STATE_TERMINATED); + + thr->resumer = NULL; + DUK_HTHREAD_DECREF_NORZ(thr, resumer); + resumer->state = DUK_HTHREAD_STATE_RUNNING; + DUK_HEAP_SWITCH_THREAD(thr->heap, resumer); + thr = resumer; + goto check_longjmp; + } + + case DUK_LJ_TYPE_BREAK: /* pseudotypes, not used in actual longjmps */ + case DUK_LJ_TYPE_CONTINUE: + case DUK_LJ_TYPE_RETURN: + case DUK_LJ_TYPE_NORMAL: + default: { + /* should never happen, but be robust */ + DUK_D(DUK_DPRINT("caught unknown longjmp type %ld, treat as internal error", (long) thr->heap->lj.type)); + goto convert_to_internal_error; + } + + } /* end switch */ + + DUK_UNREACHABLE(); + +wipe_and_return: + DUK_DD(DUK_DDPRINT("handling longjmp done, wipe-and-return, top=%ld", (long) duk_get_top(thr))); + thr->heap->lj.type = DUK_LJ_TYPE_UNKNOWN; + thr->heap->lj.iserror = 0; + + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, &thr->heap->lj.value1); /* side effects */ + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, &thr->heap->lj.value2); /* side effects */ + + DUK_GC_TORTURE(thr->heap); + +just_return: + return retval; + +convert_to_internal_error: + /* This could also be thrown internally (set the error, goto check_longjmp), + * but it's better for internal errors to bubble outwards so that we won't + * infinite loop in this catchpoint. + */ + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return 0;); +} + +/* Handle a BREAK/CONTINUE opcode. Avoid using longjmp() for BREAK/CONTINUE + * handling because it has a measurable performance impact in ordinary + * environments and an extreme impact in Emscripten (GH-342). + */ +DUK_LOCAL DUK_EXEC_NOINLINE_PERF void duk__handle_break_or_continue(duk_hthread *thr, + duk_uint_t label_id, + duk_small_uint_t lj_type) { + duk_activation *act; + duk_catcher *cat; + + DUK_ASSERT(thr != NULL); + + /* Find a matching label catcher or 'finally' catcher in + * the same function, unwinding catchers as we go. + * + * A label catcher must always exist and will match unless + * a 'finally' captures the break/continue first. It is the + * compiler's responsibility to ensure that labels are used + * correctly. + */ + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + + for (;;) { + cat = act->cat; + if (cat == NULL) { + break; + } + + DUK_DDD(DUK_DDDPRINT("considering catcher %p: type=%ld label=%ld", + (void *) cat, + (long) DUK_CAT_GET_TYPE(cat), + (long) DUK_CAT_GET_LABEL(cat))); + + /* XXX: bit mask test; FINALLY <-> TCF, single bit mask would suffice? */ + + if (DUK_CAT_GET_TYPE(cat) == DUK_CAT_TYPE_TCF && DUK_CAT_HAS_FINALLY_ENABLED(cat)) { + duk_tval tv_tmp; + + DUK_TVAL_SET_U32(&tv_tmp, (duk_uint32_t) label_id); + duk__handle_finally(thr, &tv_tmp, lj_type); + + DUK_DD(DUK_DDPRINT("-> break/continue caught by 'finally', restart execution")); + return; + } + if (DUK_CAT_GET_TYPE(cat) == DUK_CAT_TYPE_LABEL && (duk_uint_t) DUK_CAT_GET_LABEL(cat) == label_id) { + duk__handle_label(thr, lj_type); + + DUK_DD( + DUK_DDPRINT("-> break/continue caught by a label catcher (in the same function), restart execution")); + return; + } + + duk_hthread_catcher_unwind_norz(thr, act); + } + + /* Should never happen, but be robust. */ + DUK_D(DUK_DPRINT( + "-> break/continue not caught by anything in the current function (should never happen), throw internal error")); + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return;); +} + +/* Handle a RETURN opcode. Avoid using longjmp() for return handling because + * it has a measurable performance impact in ordinary environments and an extreme + * impact in Emscripten (GH-342). Return value is on value stack top. + */ +DUK_LOCAL duk_small_uint_t duk__handle_return(duk_hthread *thr, duk_activation *entry_act) { + duk_tval *tv1; + duk_tval *tv2; +#if defined(DUK_USE_COROUTINE_SUPPORT) + duk_hthread *resumer; +#endif + duk_activation *act; + duk_catcher *cat; + + /* We can directly access value stack here. */ + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(entry_act != NULL); + DUK_ASSERT(thr->valstack_top - 1 >= thr->valstack_bottom); + tv1 = thr->valstack_top - 1; + DUK_TVAL_CHKFAST_INPLACE_FAST(tv1); /* fastint downgrade check for return values */ + + /* + * Four possible outcomes: + * + * 1. A 'finally' in the same function catches the 'return'. + * It may continue to propagate when 'finally' is finished, + * or it may be neutralized by 'finally' (both handled by + * ENDFIN). + * + * 2. The return happens at the entry level of the bytecode + * executor, so return from the executor (in C stack). + * + * 3. There is a calling (ECMAScript) activation in the call + * stack => return to it, in the same executor instance. + * + * 4. There is no calling activation, and the thread is + * terminated. There is always a resumer in this case, + * which gets the return value similarly to a 'yield' + * (except that the current thread can no longer be + * resumed). + */ + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->callstack_top >= 1); + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + + for (;;) { + cat = act->cat; + if (cat == NULL) { + break; + } + + if (DUK_CAT_GET_TYPE(cat) == DUK_CAT_TYPE_TCF && DUK_CAT_HAS_FINALLY_ENABLED(cat)) { + DUK_ASSERT(thr->valstack_top - 1 >= thr->valstack_bottom); + duk__handle_finally(thr, thr->valstack_top - 1, DUK_LJ_TYPE_RETURN); + + DUK_DD(DUK_DDPRINT("-> return caught by 'finally', restart execution")); + return DUK__RETHAND_RESTART; + } + + duk_hthread_catcher_unwind_norz(thr, act); + } + + if (act == entry_act) { + /* Return to the bytecode executor caller who will unwind stacks + * and handle constructor post-processing. + * Return value is already on the stack top: [ ... retval ]. + */ + + DUK_DDD(DUK_DDDPRINT("-> return propagated up to entry level, exit bytecode executor")); + return DUK__RETHAND_FINISHED; + } + + if (thr->callstack_top >= 2) { + /* There is a caller; it MUST be an ECMAScript caller (otherwise it would + * match entry_act check). + */ + DUK_DDD(DUK_DDDPRINT("return to ECMAScript caller, retval_byteoff=%ld, lj_value1=%!T", + (long) (thr->callstack_curr->parent->retval_byteoff), + (duk_tval *) &thr->heap->lj.value1)); + + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(thr->callstack_curr->parent != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr->parent))); /* must be ECMAScript */ + +#if defined(DUK_USE_ES6_PROXY) + if (thr->callstack_curr->flags & (DUK_ACT_FLAG_CONSTRUCT | DUK_ACT_FLAG_CONSTRUCT_PROXY)) { + duk_call_construct_postprocess(thr, + thr->callstack_curr->flags & + DUK_ACT_FLAG_CONSTRUCT_PROXY); /* side effects */ + } +#else + if (thr->callstack_curr->flags & DUK_ACT_FLAG_CONSTRUCT) { + duk_call_construct_postprocess(thr, 0); /* side effects */ + } +#endif + + tv1 = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + thr->callstack_curr->parent->retval_byteoff); + DUK_ASSERT(thr->valstack_top - 1 >= thr->valstack_bottom); + tv2 = thr->valstack_top - 1; + DUK_TVAL_SET_TVAL_UPDREF(thr, tv1, tv2); /* side effects */ + + /* Catch stack unwind happens inline in callstack unwind. */ + duk_hthread_activation_unwind_norz(thr); + + duk__reconfig_valstack_ecma_return(thr); + + DUK_DD(DUK_DDPRINT("-> return not intercepted, restart execution in caller")); + return DUK__RETHAND_RESTART; + } + +#if defined(DUK_USE_COROUTINE_SUPPORT) + DUK_DD(DUK_DDPRINT("no calling activation, thread finishes (similar to yield)")); + + DUK_ASSERT(thr->resumer != NULL); + DUK_ASSERT(thr->resumer->callstack_top >= 2); /* ECMAScript activation + Duktape.Thread.resume() activation */ + DUK_ASSERT(thr->resumer->callstack_curr != NULL); + DUK_ASSERT(thr->resumer->callstack_curr->parent != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->resumer->callstack_curr) != NULL && + DUK_HOBJECT_IS_NATFUNC(DUK_ACT_GET_FUNC(thr->resumer->callstack_curr)) && + ((duk_hnatfunc *) DUK_ACT_GET_FUNC(thr->resumer->callstack_curr))->func == + duk_bi_thread_resume); /* Duktape.Thread.resume() */ + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->resumer->callstack_curr->parent) != NULL && + DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(thr->resumer->callstack_curr->parent))); /* an ECMAScript function */ + DUK_ASSERT(thr->state == DUK_HTHREAD_STATE_RUNNING); + DUK_ASSERT(thr->resumer->state == DUK_HTHREAD_STATE_RESUMED); + + resumer = thr->resumer; + + /* Share yield longjmp handler. + * + * This sequence of steps is a bit fragile (see GH-1845): + * - We need the return value from 'thr' (resumed thread) value stack. + * The termination unwinds its value stack, losing the value. + * - We need a refcounted reference for 'thr', which may only exist + * in the caller value stack. We can't unwind or reconfigure the + * caller's value stack without potentially freeing 'thr'. + * + * Current approach is to capture the 'thr' return value and store + * a reference to 'thr' in the caller value stack temporarily. This + * keeps 'thr' reachable until final yield/return handling which + * removes the references atomatically. + */ + + DUK_ASSERT(thr->valstack_top - 1 >= thr->valstack_bottom); + duk_hthread_activation_unwind_norz(resumer); /* May remove last reference to 'thr', but is NORZ. */ + duk_push_tval(resumer, thr->valstack_top - 1); /* Capture return value, side effect free. */ + duk_push_hthread(resumer, thr); /* Make 'thr' reachable again, before side effects. */ + + duk_hthread_terminate(thr); /* Updates thread state, minimizes its allocations. */ + thr->resumer = NULL; + DUK_HTHREAD_DECREF(thr, resumer); + DUK_ASSERT(thr->state == DUK_HTHREAD_STATE_TERMINATED); + + resumer->state = DUK_HTHREAD_STATE_RUNNING; + DUK_HEAP_SWITCH_THREAD(thr->heap, resumer); + + DUK_ASSERT(resumer->valstack_top - 2 >= resumer->valstack_bottom); + duk__handle_yield(thr, resumer, resumer->valstack_top - 2); + thr = NULL; /* 'thr' invalidated by call */ + +#if 0 + thr = resumer; /* not needed */ +#endif + + DUK_DD(DUK_DDPRINT("-> return not caught, thread terminated; handle like yield, restart execution in resumer")); + return DUK__RETHAND_RESTART; +#else + /* Without coroutine support this case should never happen. */ + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return 0;); +#endif +} + +/* + * Executor interrupt handling + * + * The handler is called whenever the interrupt countdown reaches zero + * (or below). The handler must perform whatever checks are activated, + * e.g. check for cumulative step count to impose an execution step + * limit or check for breakpoints or other debugger interaction. + * + * When the actions are done, the handler must reinit the interrupt + * init and counter values. The 'init' value must indicate how many + * bytecode instructions are executed before the next interrupt. The + * counter must interface with the bytecode executor loop. Concretely, + * the new init value is normally one higher than the new counter value. + * For instance, to execute exactly one bytecode instruction the init + * value is set to 1 and the counter to 0. If an error is thrown by the + * interrupt handler, the counters are set to the same value (e.g. both + * to 0 to cause an interrupt when the next bytecode instruction is about + * to be executed after error handling). + * + * Maintaining the init/counter value properly is important for accurate + * behavior. For instance, executor step limit needs a cumulative step + * count which is simply computed as a sum of 'init' values. This must + * work accurately even when single stepping. + */ + +#if defined(DUK_USE_INTERRUPT_COUNTER) + +#define DUK__INT_NOACTION 0 /* no specific action, resume normal execution */ +#define DUK__INT_RESTART 1 /* must "goto restart_execution", e.g. breakpoints changed */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) +DUK_LOCAL void duk__interrupt_handle_debugger(duk_hthread *thr, duk_bool_t *out_immediate, duk_small_uint_t *out_interrupt_retval) { + duk_activation *act; + duk_breakpoint *bp; + duk_breakpoint **bp_active; + duk_uint_fast32_t line = 0; + duk_bool_t process_messages; + duk_bool_t processed_messages = 0; + + DUK_ASSERT(thr->heap->dbg_processing == 0); /* don't re-enter e.g. during Eval */ + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + + /* It might seem that replacing 'thr->heap' with just 'heap' below + * might be a good idea, but it increases code size slightly + * (probably due to unnecessary spilling) at least on x64. + */ + + /* + * Single opcode step check + */ + + if (thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_ONE_OPCODE_ACTIVE) { + DUK_D(DUK_DPRINT("PAUSE TRIGGERED by one opcode step")); + duk_debug_set_paused(thr->heap); + } + + /* + * Breakpoint and step state checks + */ + + if (act->flags & DUK_ACT_FLAG_BREAKPOINT_ACTIVE || (thr->heap->dbg_pause_act == thr->callstack_curr)) { + line = duk_debug_curr_line(thr); + + if (act->prev_line != line) { + /* Stepped? Step out is handled by callstack unwind. */ + if ((thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_LINE_CHANGE) && + (thr->heap->dbg_pause_act == thr->callstack_curr) && (line != thr->heap->dbg_pause_startline)) { + DUK_D(DUK_DPRINT("PAUSE TRIGGERED by line change, at line %ld", (long) line)); + duk_debug_set_paused(thr->heap); + } + + /* Check for breakpoints only on line transition. + * Breakpoint is triggered when we enter the target + * line from a different line, and the previous line + * was within the same function. + * + * This condition is tricky: the condition used to be + * that transition to -or across- the breakpoint line + * triggered the breakpoint. This seems intuitively + * better because it handles breakpoints on lines with + * no emitted opcodes; but this leads to the issue + * described in: https://github.com/svaarala/duktape/issues/263. + */ + bp_active = thr->heap->dbg_breakpoints_active; + for (;;) { + bp = *bp_active++; + if (bp == NULL) { + break; + } + + DUK_ASSERT(bp->filename != NULL); + if (act->prev_line != bp->line && line == bp->line) { + DUK_D(DUK_DPRINT("PAUSE TRIGGERED by breakpoint at %!O:%ld", + (duk_heaphdr *) bp->filename, + (long) bp->line)); + duk_debug_set_paused(thr->heap); + } + } + } else { + ; + } + + act->prev_line = (duk_uint32_t) line; + } + + /* + * Rate limit check for sending status update or peeking into + * the debug transport. Both can be expensive operations that + * we don't want to do on every opcode. + * + * Making sure the interval remains reasonable on a wide variety + * of targets and bytecode is difficult without a timestamp, so + * we use a Date-provided timestamp for the rate limit check. + * But since it's also expensive to get a timestamp, a bytecode + * counter is used to rate limit getting timestamps. + */ + + process_messages = 0; + if (thr->heap->dbg_state_dirty || DUK_HEAP_HAS_DEBUGGER_PAUSED(thr->heap) || thr->heap->dbg_detaching) { + /* Enter message processing loop for sending Status notifys and + * to finish a pending detach. + */ + process_messages = 1; + } + + /* XXX: remove heap->dbg_exec_counter, use heap->inst_count_interrupt instead? */ + DUK_ASSERT(thr->interrupt_init >= 0); + thr->heap->dbg_exec_counter += (duk_uint_t) thr->interrupt_init; + if (thr->heap->dbg_exec_counter - thr->heap->dbg_last_counter >= DUK_HEAP_DBG_RATELIMIT_OPCODES) { + /* Overflow of the execution counter is fine and doesn't break + * anything here. + */ + + duk_double_t now, diff_last; + + thr->heap->dbg_last_counter = thr->heap->dbg_exec_counter; + now = duk_time_get_monotonic_time(thr); + + diff_last = now - thr->heap->dbg_last_time; + if (diff_last < 0.0 || diff_last >= (duk_double_t) DUK_HEAP_DBG_RATELIMIT_MILLISECS) { + /* Monotonic time should not experience time jumps, + * but the provider may be missing and we're actually + * using ECMAScript time. So, tolerate negative values + * so that a time jump works reasonably. + * + * Same interval is now used for status sending and + * peeking. + */ + + thr->heap->dbg_last_time = now; + thr->heap->dbg_state_dirty = 1; + process_messages = 1; + } + } + + /* + * Process messages and send status if necessary. + * + * If we're paused, we'll block for new messages. If we're not + * paused, we'll process anything we can peek but won't block + * for more. Detach (and re-attach) handling is all localized + * to duk_debug_process_messages() too. + * + * Debugger writes outside the message loop may cause debugger + * detach1 phase to run, after which dbg_read_cb == NULL and + * dbg_detaching != 0. The message loop will finish the detach + * by running detach2 phase, so enter the message loop also when + * detaching. + */ + + if (process_messages) { + DUK_ASSERT(thr->heap->dbg_processing == 0); + processed_messages = duk_debug_process_messages(thr, 0 /*no_block*/); + DUK_ASSERT(thr->heap->dbg_processing == 0); + } + + /* Continue checked execution if there are breakpoints or we're stepping. + * Also use checked execution if paused flag is active - it shouldn't be + * because the debug message loop shouldn't terminate if it was. Step out + * is handled by callstack unwind and doesn't need checked execution. + * Note that debugger may have detached due to error or explicit request + * above, so we must recheck attach status. + */ + + if (duk_debug_is_attached(thr->heap)) { + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + if (act->flags & DUK_ACT_FLAG_BREAKPOINT_ACTIVE || (thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_ONE_OPCODE) || + ((thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_LINE_CHANGE) && + thr->heap->dbg_pause_act == thr->callstack_curr) || + DUK_HEAP_HAS_DEBUGGER_PAUSED(thr->heap)) { + *out_immediate = 1; + } + + /* If we processed any debug messages breakpoints may have + * changed; restart execution to re-check active breakpoints. + */ + if (processed_messages) { + DUK_D(DUK_DPRINT("processed debug messages, restart execution to recheck possibly changed breakpoints")); + *out_interrupt_retval = DUK__INT_RESTART; + } else { + if (thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_ONE_OPCODE) { + /* Set 'pause after one opcode' active only when we're + * actually just about to execute code. + */ + thr->heap->dbg_pause_flags |= DUK_PAUSE_FLAG_ONE_OPCODE_ACTIVE; + } + } + } else { + DUK_D(DUK_DPRINT("debugger became detached, resume normal execution")); + } +} +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + +DUK_LOCAL DUK_EXEC_NOINLINE_PERF DUK_COLD duk_small_uint_t duk__executor_interrupt(duk_hthread *thr) { + duk_int_t ctr; + duk_activation *act; + duk_hcompfunc *fun; + duk_bool_t immediate = 0; + duk_small_uint_t retval; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->heap != NULL); + DUK_ASSERT(thr->callstack_top > 0); + +#if defined(DUK_USE_DEBUG) + thr->heap->inst_count_interrupt += thr->interrupt_init; + DUK_DD(DUK_DDPRINT("execution interrupt, counter=%ld, init=%ld, " + "instruction counts: executor=%ld, interrupt=%ld", + (long) thr->interrupt_counter, + (long) thr->interrupt_init, + (long) thr->heap->inst_count_exec, + (long) thr->heap->inst_count_interrupt)); +#endif + + retval = DUK__INT_NOACTION; + ctr = DUK_HTHREAD_INTCTR_DEFAULT; + + /* + * Avoid nested calls. Concretely this happens during debugging, e.g. + * when we eval() an expression. + * + * Also don't interrupt if we're currently doing debug processing + * (which can be initiated outside the bytecode executor) as this + * may cause the debugger to be called recursively. Check required + * for correct operation of throw intercept and other "exotic" halting + * scenarios. + */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + if (DUK_HEAP_HAS_INTERRUPT_RUNNING(thr->heap) || thr->heap->dbg_processing) { +#else + if (DUK_HEAP_HAS_INTERRUPT_RUNNING(thr->heap)) { +#endif + DUK_DD(DUK_DDPRINT("nested executor interrupt, ignoring")); + + /* Set a high interrupt counter; the original executor + * interrupt invocation will rewrite before exiting. + */ + thr->interrupt_init = ctr; + thr->interrupt_counter = ctr - 1; + return DUK__INT_NOACTION; + } + DUK_HEAP_SET_INTERRUPT_RUNNING(thr->heap); + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + + fun = (duk_hcompfunc *) DUK_ACT_GET_FUNC(act); + DUK_ASSERT(DUK_HOBJECT_HAS_COMPFUNC((duk_hobject *) fun)); + + DUK_UNREF(fun); + +#if defined(DUK_USE_EXEC_TIMEOUT_CHECK) + /* + * Execution timeout check + */ + + if (DUK_USE_EXEC_TIMEOUT_CHECK(thr->heap->heap_udata)) { + /* Keep throwing an error whenever we get here. The unusual values + * are set this way because no instruction is ever executed, we just + * throw an error until all try/catch/finally and other catchpoints + * have been exhausted. Duktape/C code gets control at each protected + * call but whenever it enters back into Duktape the RangeError gets + * raised. User exec timeout check must consistently indicate a timeout + * until we've fully bubbled out of Duktape. + */ + DUK_D(DUK_DPRINT("execution timeout, throwing a RangeError")); + thr->interrupt_init = 0; + thr->interrupt_counter = 0; + DUK_HEAP_CLEAR_INTERRUPT_RUNNING(thr->heap); + DUK_ERROR_RANGE(thr, "execution timeout"); + DUK_WO_NORETURN(return 0;); + } +#endif /* DUK_USE_EXEC_TIMEOUT_CHECK */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + if (!thr->heap->dbg_processing && (thr->heap->dbg_read_cb != NULL || thr->heap->dbg_detaching)) { + /* Avoid recursive re-entry; enter when we're attached or + * detaching (to finish off the pending detach). + */ + duk__interrupt_handle_debugger(thr, &immediate, &retval); + DUK_ASSERT(act == thr->callstack_curr); + } +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + + /* + * Update the interrupt counter + */ + + if (immediate) { + /* Cause an interrupt after executing one instruction. */ + ctr = 1; + } + + /* The counter value is one less than the init value: init value should + * indicate how many instructions are executed before interrupt. To + * execute 1 instruction (after interrupt handler return), counter must + * be 0. + */ + DUK_ASSERT(ctr >= 1); + thr->interrupt_init = ctr; + thr->interrupt_counter = ctr - 1; + DUK_HEAP_CLEAR_INTERRUPT_RUNNING(thr->heap); + + return retval; +} +#endif /* DUK_USE_INTERRUPT_COUNTER */ + +/* + * Debugger handling for executor restart + * + * Check for breakpoints, stepping, etc, and figure out if we should execute + * in checked or normal mode. Note that we can't do this when an activation + * is created, because breakpoint status (and stepping status) may change + * later, so we must recheck every time we're executing an activation. + * This primitive should be side effect free to avoid changes during check. + */ + +#if defined(DUK_USE_DEBUGGER_SUPPORT) +DUK_LOCAL void duk__executor_recheck_debugger(duk_hthread *thr, duk_activation *act, duk_hcompfunc *fun) { + duk_heap *heap; + duk_tval *tv_tmp; + duk_hstring *filename; + duk_small_uint_t bp_idx; + duk_breakpoint **bp_active; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(act != NULL); + DUK_ASSERT(fun != NULL); + + heap = thr->heap; + bp_active = heap->dbg_breakpoints_active; + act->flags &= ~DUK_ACT_FLAG_BREAKPOINT_ACTIVE; + + tv_tmp = duk_hobject_find_entry_tval_ptr_stridx(thr->heap, (duk_hobject *) fun, DUK_STRIDX_FILE_NAME); + if (tv_tmp && DUK_TVAL_IS_STRING(tv_tmp)) { + filename = DUK_TVAL_GET_STRING(tv_tmp); + + /* Figure out all active breakpoints. A breakpoint is + * considered active if the current function's fileName + * matches the breakpoint's fileName, AND there is no + * inner function that has matching line numbers + * (otherwise a breakpoint would be triggered both + * inside and outside of the inner function which would + * be confusing). Example: + * + * function foo() { + * print('foo'); + * function bar() { <-. breakpoints in these + * print('bar'); | lines should not affect + * } <-' foo() execution + * bar(); + * } + * + * We need a few things that are only available when + * debugger support is enabled: (1) a line range for + * each function, and (2) access to the function + * template to access the inner functions (and their + * line ranges). + * + * It's important to have a narrow match for active + * breakpoints so that we don't enter checked execution + * when that's not necessary. For instance, if we're + * running inside a certain function and there's + * breakpoint outside in (after the call site), we + * don't want to slow down execution of the function. + */ + + for (bp_idx = 0; bp_idx < heap->dbg_breakpoint_count; bp_idx++) { + duk_breakpoint *bp = heap->dbg_breakpoints + bp_idx; + duk_hobject **funcs, **funcs_end; + duk_hcompfunc *inner_fun; + duk_bool_t bp_match; + + if (bp->filename == filename && bp->line >= fun->start_line && bp->line <= fun->end_line) { + bp_match = 1; + DUK_DD(DUK_DDPRINT("breakpoint filename and line match: " + "%s:%ld vs. %s (line %ld vs. %ld-%ld)", + DUK_HSTRING_GET_DATA(bp->filename), + (long) bp->line, + DUK_HSTRING_GET_DATA(filename), + (long) bp->line, + (long) fun->start_line, + (long) fun->end_line)); + + funcs = DUK_HCOMPFUNC_GET_FUNCS_BASE(thr->heap, fun); + funcs_end = DUK_HCOMPFUNC_GET_FUNCS_END(thr->heap, fun); + while (funcs != funcs_end) { + inner_fun = (duk_hcompfunc *) *funcs; + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC((duk_hobject *) inner_fun)); + if (bp->line >= inner_fun->start_line && bp->line <= inner_fun->end_line) { + DUK_DD(DUK_DDPRINT("inner function masks ('captures') breakpoint")); + bp_match = 0; + break; + } + funcs++; + } + + if (bp_match) { + /* No need to check for size of bp_active list, + * it's always larger than maximum number of + * breakpoints. + */ + act->flags |= DUK_ACT_FLAG_BREAKPOINT_ACTIVE; + *bp_active = heap->dbg_breakpoints + bp_idx; + bp_active++; + } + } + } + } + + *bp_active = NULL; /* terminate */ + + DUK_DD(DUK_DDPRINT("ACTIVE BREAKPOINTS: %ld", (long) (bp_active - thr->heap->dbg_breakpoints_active))); + + /* Force pause if we were doing "step into" in another activation. */ + if ((thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_FUNC_ENTRY) && thr->heap->dbg_pause_act != thr->callstack_curr) { + DUK_D(DUK_DPRINT("PAUSE TRIGGERED by function entry")); + duk_debug_set_paused(thr->heap); + } + + /* Force interrupt right away if we're paused or in "checked mode". + * Step out is handled by callstack unwind. + */ + if ((act->flags & DUK_ACT_FLAG_BREAKPOINT_ACTIVE) || DUK_HEAP_HAS_DEBUGGER_PAUSED(thr->heap) || + ((thr->heap->dbg_pause_flags & DUK_PAUSE_FLAG_LINE_CHANGE) && thr->heap->dbg_pause_act == thr->callstack_curr)) { + /* We'll need to interrupt early so recompute the init + * counter to reflect the number of bytecode instructions + * executed so that step counts for e.g. debugger rate + * limiting are accurate. + */ + DUK_ASSERT(thr->interrupt_counter <= thr->interrupt_init); + thr->interrupt_init = thr->interrupt_init - thr->interrupt_counter; + thr->interrupt_counter = 0; + } +} +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + +/* + * Opcode handlers for opcodes with a lot of code and which are relatively + * rare; NOINLINE to reduce amount of code in main bytecode dispatcher. + */ + +DUK_LOCAL DUK_EXEC_NOINLINE_PERF void duk__handle_op_initset_initget(duk_hthread *thr, duk_uint_fast32_t ins) { + duk_bool_t is_set = (DUK_DEC_OP(ins) == DUK_OP_INITSET); + duk_uint_fast_t idx; + duk_uint_t defprop_flags; + + /* A -> object register (acts as a source) + * BC -> BC+0 contains key, BC+1 closure (value) + */ + + /* INITSET/INITGET are only used to initialize object literal keys. + * There may be a previous propery in ES2015 because duplicate property + * names are allowed. + */ + + /* This could be made more optimal by accessing internals directly. */ + + idx = (duk_uint_fast_t) DUK_DEC_BC(ins); + duk_dup(thr, (duk_idx_t) (idx + 0)); /* key */ + duk_dup(thr, (duk_idx_t) (idx + 1)); /* getter/setter */ + if (is_set) { + defprop_flags = + DUK_DEFPROP_HAVE_SETTER | DUK_DEFPROP_FORCE | DUK_DEFPROP_SET_ENUMERABLE | DUK_DEFPROP_SET_CONFIGURABLE; + } else { + defprop_flags = + DUK_DEFPROP_HAVE_GETTER | DUK_DEFPROP_FORCE | DUK_DEFPROP_SET_ENUMERABLE | DUK_DEFPROP_SET_CONFIGURABLE; + } + duk_def_prop(thr, (duk_idx_t) DUK_DEC_A(ins), defprop_flags); +} + +DUK_LOCAL DUK_EXEC_NOINLINE_PERF void duk__handle_op_trycatch(duk_hthread *thr, duk_uint_fast32_t ins, duk_instr_t *curr_pc) { + duk_activation *act; + duk_catcher *cat; + duk_tval *tv1; + duk_small_uint_fast_t a; + duk_small_uint_fast_t bc; + + /* A -> flags + * BC -> reg_catch; base register for two registers used both during + * trycatch setup and when catch is triggered + * + * If DUK_BC_TRYCATCH_FLAG_CATCH_BINDING set: + * reg_catch + 0: catch binding variable name (string). + * Automatic declarative environment is established for + * the duration of the 'catch' clause. + * + * If DUK_BC_TRYCATCH_FLAG_WITH_BINDING set: + * reg_catch + 0: with 'target value', which is coerced to + * an object and then used as a bindind object for an + * environment record. The binding is initialized here, for + * the 'try' clause. + * + * Note that a TRYCATCH generated for a 'with' statement has no + * catch or finally parts. + */ + + /* XXX: TRYCATCH handling should be reworked to avoid creating + * an explicit scope unless it is actually needed (e.g. function + * instances or eval is executed inside the catch block). This + * rework is not trivial because the compiler doesn't have an + * intermediate representation. When the rework is done, the + * opcode format can also be made more straightforward. + */ + + /* XXX: side effect handling is quite awkward here */ + + DUK_DDD(DUK_DDDPRINT("TRYCATCH: reg_catch=%ld, have_catch=%ld, " + "have_finally=%ld, catch_binding=%ld, with_binding=%ld (flags=0x%02lx)", + (long) DUK_DEC_BC(ins), + (long) (DUK_DEC_A(ins) & DUK_BC_TRYCATCH_FLAG_HAVE_CATCH ? 1 : 0), + (long) (DUK_DEC_A(ins) & DUK_BC_TRYCATCH_FLAG_HAVE_FINALLY ? 1 : 0), + (long) (DUK_DEC_A(ins) & DUK_BC_TRYCATCH_FLAG_CATCH_BINDING ? 1 : 0), + (long) (DUK_DEC_A(ins) & DUK_BC_TRYCATCH_FLAG_WITH_BINDING ? 1 : 0), + (unsigned long) DUK_DEC_A(ins))); + + a = DUK_DEC_A(ins); + bc = DUK_DEC_BC(ins); + + /* Registers 'bc' and 'bc + 1' are written in longjmp handling + * and if their previous values (which are temporaries) become + * unreachable -and- have a finalizer, there'll be a function + * call during error handling which is not supported now (GH-287). + * Ensure that both 'bc' and 'bc + 1' have primitive values to + * guarantee no finalizer calls in error handling. Scrubbing also + * ensures finalizers for the previous values run here rather than + * later. Error handling related values are also written to 'bc' + * and 'bc + 1' but those values never become unreachable during + * error handling, so there's no side effect problem even if the + * error value has a finalizer. + */ + duk_dup(thr, (duk_idx_t) bc); /* Stabilize value. */ + duk_to_undefined(thr, (duk_idx_t) bc); + duk_to_undefined(thr, (duk_idx_t) (bc + 1)); + + /* Allocate catcher and populate it. Doesn't have to + * be fully atomic, but the catcher must be in a + * consistent state if side effects (such as finalizer + * calls) occur. + */ + + cat = duk_hthread_catcher_alloc(thr); + DUK_ASSERT(cat != NULL); + + cat->flags = DUK_CAT_TYPE_TCF; + cat->h_varname = NULL; + cat->pc_base = (duk_instr_t *) curr_pc; /* pre-incremented, points to first jump slot */ + cat->idx_base = (duk_size_t) (thr->valstack_bottom - thr->valstack) + bc; + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + cat->parent = act->cat; + act->cat = cat; + + if (a & DUK_BC_TRYCATCH_FLAG_HAVE_CATCH) { + cat->flags |= DUK_CAT_FLAG_CATCH_ENABLED; + } + if (a & DUK_BC_TRYCATCH_FLAG_HAVE_FINALLY) { + cat->flags |= DUK_CAT_FLAG_FINALLY_ENABLED; + } + if (a & DUK_BC_TRYCATCH_FLAG_CATCH_BINDING) { + DUK_DDD(DUK_DDDPRINT("catch binding flag set to catcher")); + cat->flags |= DUK_CAT_FLAG_CATCH_BINDING_ENABLED; + tv1 = DUK_GET_TVAL_NEGIDX(thr, -1); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv1)); + + /* borrowed reference; although 'tv1' comes from a register, + * its value was loaded using LDCONST so the constant will + * also exist and be reachable. + */ + cat->h_varname = DUK_TVAL_GET_STRING(tv1); + } else if (a & DUK_BC_TRYCATCH_FLAG_WITH_BINDING) { + duk_hobjenv *env; + duk_hobject *target; + + /* Delayed env initialization for activation (if needed). */ + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + if (act->lex_env == NULL) { + DUK_DDD(DUK_DDDPRINT("delayed environment initialization")); + DUK_ASSERT(act->var_env == NULL); + + duk_js_init_activation_environment_records_delayed(thr, act); + DUK_ASSERT(act == thr->callstack_curr); + DUK_UNREF(act); /* 'act' is no longer accessed, scanbuild fix */ + } + DUK_ASSERT(act->lex_env != NULL); + DUK_ASSERT(act->var_env != NULL); + + /* Coerce 'with' target. */ + target = duk_to_hobject(thr, -1); + DUK_ASSERT(target != NULL); + + /* Create an object environment; it is not pushed + * so avoid side effects very carefully until it is + * referenced. + */ + env = duk_hobjenv_alloc(thr, DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_OBJENV)); + DUK_ASSERT(env != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) env) == NULL); + env->target = target; /* always provideThis=true */ + DUK_HOBJECT_INCREF(thr, target); + env->has_this = 1; + DUK_HOBJENV_ASSERT_VALID(env); + DUK_DDD(DUK_DDDPRINT("environment for with binding: %!iO", env)); + + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) env) == NULL); + DUK_ASSERT(act->lex_env != NULL); + DUK_HOBJECT_SET_PROTOTYPE(thr->heap, (duk_hobject *) env, act->lex_env); + act->lex_env = (duk_hobject *) env; /* Now reachable. */ + DUK_HOBJECT_INCREF(thr, (duk_hobject *) env); + /* Net refcount change to act->lex_env is 0: incref for env's + * prototype, decref for act->lex_env overwrite. + */ + + /* Set catcher lex_env active (affects unwind) + * only when the whole setup is complete. + */ + cat = act->cat; /* XXX: better to relookup? not mandatory because 'cat' is stable */ + cat->flags |= DUK_CAT_FLAG_LEXENV_ACTIVE; + } else { + ; + } + + DUK_DDD(DUK_DDDPRINT("TRYCATCH catcher: flags=0x%08lx, pc_base=%ld, " + "idx_base=%ld, h_varname=%!O", + (unsigned long) cat->flags, + (long) cat->pc_base, + (long) cat->idx_base, + (duk_heaphdr *) cat->h_varname)); + + duk_pop_unsafe(thr); +} + +DUK_LOCAL DUK_EXEC_NOINLINE_PERF duk_instr_t *duk__handle_op_endtry(duk_hthread *thr, duk_uint_fast32_t ins) { + duk_activation *act; + duk_catcher *cat; + duk_tval *tv1; + duk_instr_t *pc_base; + + DUK_UNREF(ins); + + DUK_ASSERT(thr->callstack_top >= 1); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + cat = act->cat; + DUK_ASSERT(cat != NULL); + DUK_ASSERT(DUK_CAT_GET_TYPE(act->cat) == DUK_CAT_TYPE_TCF); + + DUK_DDD(DUK_DDDPRINT("ENDTRY: clearing catch active flag (regardless of whether it was set or not)")); + DUK_CAT_CLEAR_CATCH_ENABLED(cat); + + pc_base = cat->pc_base; + + if (DUK_CAT_HAS_FINALLY_ENABLED(cat)) { + DUK_DDD(DUK_DDDPRINT("ENDTRY: finally part is active, jump through 2nd jump slot with 'normal continuation'")); + + tv1 = thr->valstack + cat->idx_base; + DUK_ASSERT(tv1 >= thr->valstack && tv1 < thr->valstack_top); + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, tv1); /* side effects */ + tv1 = NULL; + + tv1 = thr->valstack + cat->idx_base + 1; + DUK_ASSERT(tv1 >= thr->valstack && tv1 < thr->valstack_top); + DUK_TVAL_SET_U32_UPDREF(thr, tv1, (duk_uint32_t) DUK_LJ_TYPE_NORMAL); /* side effects */ + tv1 = NULL; + + DUK_CAT_CLEAR_FINALLY_ENABLED(cat); + } else { + DUK_DDD( + DUK_DDDPRINT("ENDTRY: no finally part, dismantle catcher, jump through 2nd jump slot (to end of statement)")); + + duk_hthread_catcher_unwind_norz(thr, act); /* lexenv may be set for 'with' binding */ + /* no need to unwind callstack */ + } + + return pc_base + 1; /* new curr_pc value */ +} + +DUK_LOCAL DUK_EXEC_NOINLINE_PERF duk_instr_t *duk__handle_op_endcatch(duk_hthread *thr, duk_uint_fast32_t ins) { + duk_activation *act; + duk_catcher *cat; + duk_tval *tv1; + duk_instr_t *pc_base; + + DUK_UNREF(ins); + + DUK_ASSERT(thr->callstack_top >= 1); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + cat = act->cat; + DUK_ASSERT(cat != NULL); + DUK_ASSERT(!DUK_CAT_HAS_CATCH_ENABLED(cat)); /* cleared before entering catch part */ + + if (DUK_CAT_HAS_LEXENV_ACTIVE(cat)) { + duk_hobject *prev_env; + + /* 'with' binding has no catch clause, so can't be here unless a normal try-catch */ + DUK_ASSERT(DUK_CAT_HAS_CATCH_BINDING_ENABLED(cat)); + DUK_ASSERT(act->lex_env != NULL); + + DUK_DDD(DUK_DDDPRINT("ENDCATCH: popping catcher part lexical environment")); + + prev_env = act->lex_env; + DUK_ASSERT(prev_env != NULL); + act->lex_env = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, prev_env); + DUK_CAT_CLEAR_LEXENV_ACTIVE(cat); + DUK_HOBJECT_INCREF(thr, act->lex_env); + DUK_HOBJECT_DECREF(thr, prev_env); /* side effects */ + + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + } + + pc_base = cat->pc_base; + + if (DUK_CAT_HAS_FINALLY_ENABLED(cat)) { + DUK_DDD(DUK_DDDPRINT("ENDCATCH: finally part is active, jump through 2nd jump slot with 'normal continuation'")); + + tv1 = thr->valstack + cat->idx_base; + DUK_ASSERT(tv1 >= thr->valstack && tv1 < thr->valstack_top); + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, tv1); /* side effects */ + tv1 = NULL; + + tv1 = thr->valstack + cat->idx_base + 1; + DUK_ASSERT(tv1 >= thr->valstack && tv1 < thr->valstack_top); + DUK_TVAL_SET_U32_UPDREF(thr, tv1, (duk_uint32_t) DUK_LJ_TYPE_NORMAL); /* side effects */ + tv1 = NULL; + + DUK_CAT_CLEAR_FINALLY_ENABLED(cat); + } else { + DUK_DDD( + DUK_DDDPRINT("ENDCATCH: no finally part, dismantle catcher, jump through 2nd jump slot (to end of statement)")); + + duk_hthread_catcher_unwind_norz(thr, act); + /* no need to unwind callstack */ + } + + return pc_base + 1; /* new curr_pc value */ +} + +DUK_LOCAL DUK_EXEC_NOINLINE_PERF duk_small_uint_t duk__handle_op_endfin(duk_hthread *thr, + duk_uint_fast32_t ins, + duk_activation *entry_act) { + duk_activation *act; + duk_tval *tv1; + duk_uint_t reg_catch; + duk_small_uint_t cont_type; + duk_small_uint_t ret_result; + + DUK_ASSERT(thr->ptr_curr_pc == NULL); + DUK_ASSERT(thr->callstack_top >= 1); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + reg_catch = DUK_DEC_ABC(ins); + + /* CATCH flag may be enabled or disabled here; it may be enabled if + * the statement has a catch block but the try block does not throw + * an error. + */ + + DUK_DDD(DUK_DDDPRINT("ENDFIN: completion value=%!T, type=%!T", + (duk_tval *) (thr->valstack_bottom + reg_catch + 0), + (duk_tval *) (thr->valstack_bottom + reg_catch + 1))); + + tv1 = thr->valstack_bottom + reg_catch + 1; /* type */ + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv1)); +#if defined(DUK_USE_FASTINT) + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv1)); + cont_type = (duk_small_uint_t) DUK_TVAL_GET_FASTINT_U32(tv1); +#else + cont_type = (duk_small_uint_t) DUK_TVAL_GET_NUMBER(tv1); +#endif + + tv1--; /* value */ + + switch (cont_type) { + case DUK_LJ_TYPE_NORMAL: { + DUK_DDD(DUK_DDDPRINT("ENDFIN: finally part finishing with 'normal' (non-abrupt) completion -> " + "dismantle catcher, resume execution after ENDFIN")); + + duk_hthread_catcher_unwind_norz(thr, act); + /* no need to unwind callstack */ + return 0; /* restart execution */ + } + case DUK_LJ_TYPE_RETURN: { + DUK_DDD(DUK_DDDPRINT("ENDFIN: finally part finishing with 'return' complation -> dismantle " + "catcher, handle return, lj.value1=%!T", + tv1)); + + /* Not necessary to unwind catch stack: return handling will + * do it. The finally flag of 'cat' is no longer set. The + * catch flag may be set, but it's not checked by return handling. + */ + + duk_push_tval(thr, tv1); + ret_result = duk__handle_return(thr, entry_act); + if (ret_result == DUK__RETHAND_RESTART) { + return 0; /* restart execution */ + } + DUK_ASSERT(ret_result == DUK__RETHAND_FINISHED); + + DUK_DDD(DUK_DDDPRINT("exiting executor after ENDFIN and RETURN (pseudo) longjmp type")); + return 1; /* exit executor */ + } + case DUK_LJ_TYPE_BREAK: + case DUK_LJ_TYPE_CONTINUE: { + duk_uint_t label_id; + duk_small_uint_t lj_type; + + /* Not necessary to unwind catch stack: break/continue + * handling will do it. The finally flag of 'cat' is + * no longer set. The catch flag may be set, but it's + * not checked by break/continue handling. + */ + + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv1)); +#if defined(DUK_USE_FASTINT) + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv1)); + label_id = (duk_small_uint_t) DUK_TVAL_GET_FASTINT_U32(tv1); +#else + label_id = (duk_small_uint_t) DUK_TVAL_GET_NUMBER(tv1); +#endif + lj_type = cont_type; + duk__handle_break_or_continue(thr, label_id, lj_type); + return 0; /* restart execution */ + } + default: { + DUK_DDD(DUK_DDDPRINT("ENDFIN: finally part finishing with abrupt completion, lj_type=%ld -> " + "dismantle catcher, re-throw error", + (long) cont_type)); + + duk_err_setup_ljstate1(thr, (duk_small_uint_t) cont_type, tv1); + /* No debugger Throw notify check on purpose (rethrow). */ + + DUK_ASSERT(thr->heap->lj.jmpbuf_ptr != NULL); /* always in executor */ + duk_err_longjmp(thr); + DUK_UNREACHABLE(); + } + } + + DUK_UNREACHABLE(); + return 0; +} + +DUK_LOCAL DUK_EXEC_NOINLINE_PERF void duk__handle_op_initenum(duk_hthread *thr, duk_uint_fast32_t ins) { + duk_small_uint_t b; + duk_small_uint_t c; + + /* + * Enumeration semantics come from for-in statement, E5 Section 12.6.4. + * If called with 'null' or 'undefined', this opcode returns 'null' as + * the enumerator, which is special cased in NEXTENUM. This simplifies + * the compiler part + */ + + /* B -> register for writing enumerator object + * C -> value to be enumerated (register) + */ + b = DUK_DEC_B(ins); + c = DUK_DEC_C(ins); + + if (duk_is_null_or_undefined(thr, (duk_idx_t) c)) { + duk_push_null(thr); + duk_replace(thr, (duk_idx_t) b); + } else { + duk_dup(thr, (duk_idx_t) c); + duk_to_object(thr, -1); + duk_hobject_enumerator_create(thr, 0 /*enum_flags*/); /* [ ... val ] --> [ ... enum ] */ + duk_replace(thr, (duk_idx_t) b); + } +} + +DUK_LOCAL DUK_EXEC_NOINLINE_PERF duk_small_uint_t duk__handle_op_nextenum(duk_hthread *thr, duk_uint_fast32_t ins) { + duk_small_uint_t b; + duk_small_uint_t c; + duk_small_uint_t pc_skip = 0; + + /* + * NEXTENUM checks whether the enumerator still has unenumerated + * keys. If so, the next key is loaded to the target register + * and the next instruction is skipped. Otherwise the next instruction + * will be executed, jumping out of the enumeration loop. + */ + + /* B -> target register for next key + * C -> enum register + */ + b = DUK_DEC_B(ins); + c = DUK_DEC_C(ins); + + DUK_DDD(DUK_DDDPRINT("NEXTENUM: b->%!T, c->%!T", + (duk_tval *) duk_get_tval(thr, (duk_idx_t) b), + (duk_tval *) duk_get_tval(thr, (duk_idx_t) c))); + + if (duk_is_object(thr, (duk_idx_t) c)) { + /* XXX: assert 'c' is an enumerator */ + duk_dup(thr, (duk_idx_t) c); + if (duk_hobject_enumerator_next(thr, 0 /*get_value*/)) { + /* [ ... enum ] -> [ ... next_key ] */ + DUK_DDD(DUK_DDDPRINT("enum active, next key is %!T, skip jump slot ", (duk_tval *) duk_get_tval(thr, -1))); + pc_skip = 1; + } else { + /* [ ... enum ] -> [ ... ] */ + DUK_DDD(DUK_DDDPRINT("enum finished, execute jump slot")); + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top)); /* valstack policy */ + thr->valstack_top++; + } + duk_replace(thr, (duk_idx_t) b); + } else { + /* 'null' enumerator case -> behave as with an empty enumerator */ + DUK_ASSERT(duk_is_null(thr, (duk_idx_t) c)); + DUK_DDD(DUK_DDDPRINT("enum is null, execute jump slot")); + } + + return pc_skip; +} + +/* + * Call handling helpers. + */ + +DUK_LOCAL duk_bool_t duk__executor_handle_call(duk_hthread *thr, duk_idx_t idx, duk_idx_t nargs, duk_small_uint_t call_flags) { + duk_bool_t rc; + + duk_set_top_unsafe(thr, (duk_idx_t) (idx + nargs + 2)); /* [ ... func this arg1 ... argN ] */ + + /* Attempt an Ecma-to-Ecma call setup. If the call + * target is (directly or indirectly) Reflect.construct(), + * the call may change into a constructor call on the fly. + */ + rc = (duk_bool_t) duk_handle_call_unprotected(thr, idx, call_flags); + if (rc != 0) { + /* Ecma-to-ecma call possible, may or may not + * be a tail call. Avoid C recursion by + * reusing current executor instance. + */ + DUK_DDD(DUK_DDDPRINT("ecma-to-ecma call setup possible, restart execution")); + /* curr_pc synced by duk_handle_call_unprotected() */ + DUK_ASSERT(thr->ptr_curr_pc == NULL); + return rc; + } else { + /* Call was handled inline. */ + } + DUK_ASSERT(thr->ptr_curr_pc != NULL); + return rc; +} + +/* + * ECMAScript bytecode executor. + * + * Resume execution for the current thread from its current activation. + * Returns when execution would return from the entry level activation, + * leaving a single return value on top of the stack. Function calls + * and thread resumptions are handled internally. If an error occurs, + * a longjmp() with type DUK_LJ_TYPE_THROW is called on the entry level + * setjmp() jmpbuf. + * + * ECMAScript function calls and coroutine resumptions are handled + * internally (by the outer executor function) without recursive C calls. + * Other function calls are handled using duk_handle_call(), increasing + * C recursion depth. + * + * Abrupt completions (= long control tranfers) are handled either + * directly by reconfiguring relevant stacks and restarting execution, + * or via a longjmp. Longjmp-free handling is preferable for performance + * (especially Emscripten performance), and is used for: break, continue, + * and return. + * + * For more detailed notes, see doc/execution.rst. + * + * Also see doc/code-issues.rst for discussion of setjmp(), longjmp(), + * and volatile. + */ + +/* Presence of 'fun' is config based, there's a marginal performance + * difference and the best option is architecture dependent. + */ +#if defined(DUK_USE_EXEC_FUN_LOCAL) +#define DUK__FUN() fun +#else +#define DUK__FUN() ((duk_hcompfunc *) DUK_ACT_GET_FUNC((thr)->callstack_curr)) +#endif + +/* Strict flag. */ +#define DUK__STRICT() ((duk_small_uint_t) DUK_HOBJECT_HAS_STRICT((duk_hobject *) DUK__FUN())) + +/* Reg/const access macros: these are very footprint and performance sensitive + * so modify with care. Arguments are sometimes evaluated multiple times which + * is not ideal. + */ +#define DUK__REG(x) (*(thr->valstack_bottom + (x))) +#define DUK__REGP(x) (thr->valstack_bottom + (x)) +#define DUK__CONST(x) (*(consts + (x))) +#define DUK__CONSTP(x) (consts + (x)) + +/* Reg/const access macros which take the 32-bit instruction and avoid an + * explicit field decoding step by using shifts and masks. These must be + * kept in sync with duk_js_bytecode.h. The shift/mask values are chosen + * so that 'ins' can be shifted and masked and used as a -byte- offset + * instead of a duk_tval offset which needs further shifting (which is an + * issue on some, but not all, CPUs). + */ +#define DUK__RCBIT_B DUK_BC_REGCONST_B +#define DUK__RCBIT_C DUK_BC_REGCONST_C +#if defined(DUK_USE_EXEC_REGCONST_OPTIMIZE) +#if defined(DUK_USE_PACKED_TVAL) +#define DUK__TVAL_SHIFT 3 /* sizeof(duk_tval) == 8 */ +#else +#define DUK__TVAL_SHIFT 4 /* sizeof(duk_tval) == 16; not always the case so also asserted for */ +#endif +#define DUK__SHIFT_A (DUK_BC_SHIFT_A - DUK__TVAL_SHIFT) +#define DUK__SHIFT_B (DUK_BC_SHIFT_B - DUK__TVAL_SHIFT) +#define DUK__SHIFT_C (DUK_BC_SHIFT_C - DUK__TVAL_SHIFT) +#define DUK__SHIFT_BC (DUK_BC_SHIFT_BC - DUK__TVAL_SHIFT) +#define DUK__MASK_A (DUK_BC_UNSHIFTED_MASK_A << DUK__TVAL_SHIFT) +#define DUK__MASK_B (DUK_BC_UNSHIFTED_MASK_B << DUK__TVAL_SHIFT) +#define DUK__MASK_C (DUK_BC_UNSHIFTED_MASK_C << DUK__TVAL_SHIFT) +#define DUK__MASK_BC (DUK_BC_UNSHIFTED_MASK_BC << DUK__TVAL_SHIFT) +#define DUK__BYTEOFF_A(ins) (((ins) >> DUK__SHIFT_A) & DUK__MASK_A) +#define DUK__BYTEOFF_B(ins) (((ins) >> DUK__SHIFT_B) & DUK__MASK_B) +#define DUK__BYTEOFF_C(ins) (((ins) >> DUK__SHIFT_C) & DUK__MASK_C) +#define DUK__BYTEOFF_BC(ins) (((ins) >> DUK__SHIFT_BC) & DUK__MASK_BC) + +#define DUK__REGP_A(ins) ((duk_tval *) (void *) ((duk_uint8_t *) thr->valstack_bottom + DUK__BYTEOFF_A((ins)))) +#define DUK__REGP_B(ins) ((duk_tval *) (void *) ((duk_uint8_t *) thr->valstack_bottom + DUK__BYTEOFF_B((ins)))) +#define DUK__REGP_C(ins) ((duk_tval *) (void *) ((duk_uint8_t *) thr->valstack_bottom + DUK__BYTEOFF_C((ins)))) +#define DUK__REGP_BC(ins) ((duk_tval *) (void *) ((duk_uint8_t *) thr->valstack_bottom + DUK__BYTEOFF_BC((ins)))) +#define DUK__CONSTP_A(ins) ((duk_tval *) (void *) ((duk_uint8_t *) consts + DUK__BYTEOFF_A((ins)))) +#define DUK__CONSTP_B(ins) ((duk_tval *) (void *) ((duk_uint8_t *) consts + DUK__BYTEOFF_B((ins)))) +#define DUK__CONSTP_C(ins) ((duk_tval *) (void *) ((duk_uint8_t *) consts + DUK__BYTEOFF_C((ins)))) +#define DUK__CONSTP_BC(ins) ((duk_tval *) (void *) ((duk_uint8_t *) consts + DUK__BYTEOFF_BC((ins)))) +#define DUK__REGCONSTP_B(ins) \ + ((duk_tval *) (void *) ((duk_uint8_t *) (((ins) &DUK__RCBIT_B) ? consts : thr->valstack_bottom) + DUK__BYTEOFF_B((ins)))) +#define DUK__REGCONSTP_C(ins) \ + ((duk_tval *) (void *) ((duk_uint8_t *) (((ins) &DUK__RCBIT_C) ? consts : thr->valstack_bottom) + DUK__BYTEOFF_C((ins)))) +#else /* DUK_USE_EXEC_REGCONST_OPTIMIZE */ +/* Safe alternatives, no assumption about duk_tval size. */ +#define DUK__REGP_A(ins) DUK__REGP(DUK_DEC_A((ins))) +#define DUK__REGP_B(ins) DUK__REGP(DUK_DEC_B((ins))) +#define DUK__REGP_C(ins) DUK__REGP(DUK_DEC_C((ins))) +#define DUK__REGP_BC(ins) DUK__REGP(DUK_DEC_BC((ins))) +#define DUK__CONSTP_A(ins) DUK__CONSTP(DUK_DEC_A((ins))) +#define DUK__CONSTP_B(ins) DUK__CONSTP(DUK_DEC_B((ins))) +#define DUK__CONSTP_C(ins) DUK__CONSTP(DUK_DEC_C((ins))) +#define DUK__CONSTP_BC(ins) DUK__CONSTP(DUK_DEC_BC((ins))) +#define DUK__REGCONSTP_B(ins) ((((ins) &DUK__RCBIT_B) ? consts : thr->valstack_bottom) + DUK_DEC_B((ins))) +#define DUK__REGCONSTP_C(ins) ((((ins) &DUK__RCBIT_C) ? consts : thr->valstack_bottom) + DUK_DEC_C((ins))) +#endif /* DUK_USE_EXEC_REGCONST_OPTIMIZE */ + +#if defined(DUK_USE_VERBOSE_EXECUTOR_ERRORS) +#define DUK__INTERNAL_ERROR(msg) \ + do { \ + DUK_ERROR_ERROR(thr, (msg)); \ + DUK_WO_NORETURN(return;); \ + } while (0) +#else +#define DUK__INTERNAL_ERROR(msg) \ + do { \ + goto internal_error; \ + } while (0) +#endif + +#define DUK__SYNC_CURR_PC() \ + do { \ + duk_activation *duk__act; \ + duk__act = thr->callstack_curr; \ + duk__act->curr_pc = curr_pc; \ + } while (0) +#define DUK__SYNC_AND_NULL_CURR_PC() \ + do { \ + duk_activation *duk__act; \ + duk__act = thr->callstack_curr; \ + duk__act->curr_pc = curr_pc; \ + thr->ptr_curr_pc = NULL; \ + } while (0) + +#if defined(DUK_USE_EXEC_PREFER_SIZE) +#define DUK__LOOKUP_INDIRECT(idx) \ + do { \ + (idx) = (duk_uint_fast_t) duk_get_uint(thr, (duk_idx_t) (idx)); \ + } while (0) +#elif defined(DUK_USE_FASTINT) +#define DUK__LOOKUP_INDIRECT(idx) \ + do { \ + duk_tval *tv_ind; \ + tv_ind = DUK__REGP((idx)); \ + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_ind)); \ + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv_ind)); /* compiler guarantees */ \ + (idx) = (duk_uint_fast_t) DUK_TVAL_GET_FASTINT_U32(tv_ind); \ + } while (0) +#else +#define DUK__LOOKUP_INDIRECT(idx) \ + do { \ + duk_tval *tv_ind; \ + tv_ind = DUK__REGP(idx); \ + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_ind)); \ + idx = (duk_uint_fast_t) DUK_TVAL_GET_NUMBER(tv_ind); \ + } while (0) +#endif + +DUK_LOCAL void duk__handle_executor_error(duk_heap *heap, + duk_activation *entry_act, + duk_int_t entry_call_recursion_depth, + duk_jmpbuf *entry_jmpbuf_ptr, + volatile duk_bool_t *out_delayed_catch_setup) { + duk_small_uint_t lj_ret; + + /* Longjmp callers are required to sync-and-null thr->ptr_curr_pc + * before longjmp. + */ + DUK_ASSERT(heap->curr_thread != NULL); + DUK_ASSERT(heap->curr_thread->ptr_curr_pc == NULL); + + /* XXX: signalling the need to shrink check (only if unwound) */ + + /* Must be restored here to handle e.g. yields properly. */ + heap->call_recursion_depth = entry_call_recursion_depth; + + /* Switch to caller's setjmp() catcher so that if an error occurs + * during error handling, it is always propagated outwards instead + * of causing an infinite loop in our own handler. + */ + heap->lj.jmpbuf_ptr = (duk_jmpbuf *) entry_jmpbuf_ptr; + + lj_ret = duk__handle_longjmp(heap->curr_thread, entry_act, out_delayed_catch_setup); + + /* Error handling complete, remove side effect protections. + */ +#if defined(DUK_USE_ASSERTIONS) + DUK_ASSERT(heap->error_not_allowed == 1); + heap->error_not_allowed = 0; +#endif + DUK_ASSERT(heap->pf_prevent_count > 0); + heap->pf_prevent_count--; + DUK_DD(DUK_DDPRINT("executor error handled, pf_prevent_count updated to %ld", (long) heap->pf_prevent_count)); + + if (lj_ret == DUK__LONGJMP_RESTART) { + /* Restart bytecode execution, possibly with a changed thread. */ + DUK_REFZERO_CHECK_SLOW(heap->curr_thread); + } else { + /* If an error is propagated, don't run refzero checks here. + * The next catcher will deal with that. Pf_prevent_count + * will be re-bumped by the longjmp. + */ + + DUK_ASSERT(lj_ret == DUK__LONGJMP_RETHROW); /* Rethrow error to calling state. */ + DUK_ASSERT(heap->lj.jmpbuf_ptr == entry_jmpbuf_ptr); /* Longjmp handling has restored jmpbuf_ptr. */ + + /* Thread may have changed, e.g. YIELD converted to THROW. */ + duk_err_longjmp(heap->curr_thread); + DUK_UNREACHABLE(); + } +} + +/* Outer executor with setjmp/longjmp handling. */ +DUK_INTERNAL void duk_js_execute_bytecode(duk_hthread *exec_thr) { + /* Entry level info. */ + duk_hthread *entry_thread; + duk_activation *entry_act; + duk_int_t entry_call_recursion_depth; + duk_jmpbuf *entry_jmpbuf_ptr; + duk_jmpbuf our_jmpbuf; + duk_heap *heap; + volatile duk_bool_t delayed_catch_setup = 0; + + DUK_ASSERT(exec_thr != NULL); + DUK_ASSERT(exec_thr->heap != NULL); + DUK_ASSERT(exec_thr->heap->curr_thread != NULL); + DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR((duk_heaphdr *) exec_thr); + DUK_ASSERT(exec_thr->callstack_top >= 1); /* at least one activation, ours */ + DUK_ASSERT(exec_thr->callstack_curr != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(exec_thr->callstack_curr) != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(exec_thr->callstack_curr))); + + DUK_GC_TORTURE(exec_thr->heap); + + entry_thread = exec_thr; + heap = entry_thread->heap; + entry_act = entry_thread->callstack_curr; + DUK_ASSERT(entry_act != NULL); + entry_call_recursion_depth = entry_thread->heap->call_recursion_depth; + entry_jmpbuf_ptr = entry_thread->heap->lj.jmpbuf_ptr; + + /* + * Note: we currently assume that the setjmp() catchpoint is + * not re-entrant (longjmp() cannot be called more than once + * for a single setjmp()). + * + * See doc/code-issues.rst for notes on variable assignment + * before and after setjmp(). + */ + + for (;;) { + heap->lj.jmpbuf_ptr = &our_jmpbuf; + DUK_ASSERT(heap->lj.jmpbuf_ptr != NULL); + +#if defined(DUK_USE_CPP_EXCEPTIONS) + try { +#else + DUK_ASSERT(heap->lj.jmpbuf_ptr == &our_jmpbuf); + if (DUK_SETJMP(our_jmpbuf.jb) == 0) { +#endif + DUK_DDD(DUK_DDDPRINT("after setjmp, delayed catch setup: %ld\n", (long) delayed_catch_setup)); + + if (DUK_UNLIKELY(delayed_catch_setup != 0)) { + duk_hthread *thr = entry_thread->heap->curr_thread; + + delayed_catch_setup = 0; + duk__handle_catch_part2(thr); + DUK_ASSERT(delayed_catch_setup == 0); + DUK_DDD(DUK_DDDPRINT("top after delayed catch setup: %ld", (long) duk_get_top(entry_thread))); + } + + /* Execute bytecode until returned or longjmp(). */ + duk__js_execute_bytecode_inner(entry_thread, entry_act); + + /* Successful return: restore jmpbuf and return to caller. */ + heap->lj.jmpbuf_ptr = entry_jmpbuf_ptr; + + return; +#if defined(DUK_USE_CPP_EXCEPTIONS) + } catch (duk_internal_exception &exc) { +#else + } else { +#endif +#if defined(DUK_USE_CPP_EXCEPTIONS) + DUK_UNREF(exc); +#endif + DUK_DDD(DUK_DDDPRINT("longjmp caught by bytecode executor")); + DUK_STATS_INC(exec_thr->heap, stats_exec_throw); + + duk__handle_executor_error(heap, + entry_act, + entry_call_recursion_depth, + entry_jmpbuf_ptr, + &delayed_catch_setup); + } +#if defined(DUK_USE_CPP_EXCEPTIONS) + catch (duk_fatal_exception &exc) { + DUK_D(DUK_DPRINT("rethrow duk_fatal_exception")); + DUK_UNREF(exc); + throw; + } catch (std::exception &exc) { + const char *what = exc.what(); + if (!what) { + what = "unknown"; + } + DUK_D(DUK_DPRINT("unexpected c++ std::exception (perhaps thrown by user code)")); + DUK_STATS_INC(exec_thr->heap, stats_exec_throw); + try { + DUK_ASSERT(heap->curr_thread != NULL); + DUK_ERROR_FMT1(heap->curr_thread, + DUK_ERR_TYPE_ERROR, + "caught invalid c++ std::exception '%s' (perhaps thrown by user code)", + what); + DUK_WO_NORETURN(return;); + } catch (duk_internal_exception exc) { + DUK_D(DUK_DPRINT("caught api error thrown from unexpected c++ std::exception")); + DUK_UNREF(exc); + duk__handle_executor_error(heap, + entry_act, + entry_call_recursion_depth, + entry_jmpbuf_ptr, + &delayed_catch_setup); + } + } catch (...) { + DUK_D(DUK_DPRINT("unexpected c++ exception (perhaps thrown by user code)")); + DUK_STATS_INC(exec_thr->heap, stats_exec_throw); + try { + DUK_ASSERT(heap->curr_thread != NULL); + DUK_ERROR_TYPE(heap->curr_thread, "caught invalid c++ exception (perhaps thrown by user code)"); + DUK_WO_NORETURN(return;); + } catch (duk_internal_exception exc) { + DUK_D(DUK_DPRINT("caught api error thrown from unexpected c++ exception")); + DUK_UNREF(exc); + duk__handle_executor_error(heap, + entry_act, + entry_call_recursion_depth, + entry_jmpbuf_ptr, + &delayed_catch_setup); + } + } +#endif + } + + DUK_WO_NORETURN(return;); +} + +/* Inner executor, performance critical. */ +DUK_LOCAL DUK_NOINLINE DUK_HOT void duk__js_execute_bytecode_inner(duk_hthread *entry_thread, duk_activation *entry_act) { + /* Current PC, accessed by other functions through thr->ptr_to_curr_pc. + * Critical for performance. It would be safest to make this volatile, + * but that eliminates performance benefits; aliasing guarantees + * should be enough though. + */ + duk_instr_t *curr_pc; /* bytecode has a stable pointer */ + + /* Hot variables for interpretation. Critical for performance, + * but must add sparingly to minimize register shuffling. + */ + duk_hthread *thr; /* stable */ + duk_tval *consts; /* stable */ + duk_uint_fast32_t ins; + /* 'funcs' is quite rarely used, so no local for it */ +#if defined(DUK_USE_EXEC_FUN_LOCAL) + duk_hcompfunc *fun; +#else + /* 'fun' is quite rarely used, so no local for it */ +#endif + +#if defined(DUK_USE_INTERRUPT_COUNTER) + duk_int_t int_ctr; +#endif + +#if defined(DUK_USE_ASSERTIONS) + duk_size_t valstack_top_base; /* valstack top, should match before interpreting each op (no leftovers) */ +#endif + + /* Optimized reg/const access macros assume sizeof(duk_tval) to be + * either 8 or 16. Heap allocation checks this even without asserts + * enabled now because it can't be autodetected in duk_config.h. + */ +#if 1 +#if defined(DUK_USE_PACKED_TVAL) + DUK_ASSERT(sizeof(duk_tval) == 8); +#else + DUK_ASSERT(sizeof(duk_tval) == 16); +#endif +#endif + + DUK_GC_TORTURE(entry_thread->heap); + + /* + * Restart execution by reloading thread state. + * + * Note that 'thr' and any thread configuration may have changed, + * so all local variables are suspect and we need to reinitialize. + * + * The number of local variables should be kept to a minimum: if + * the variables are spilled, they will need to be loaded from + * memory anyway. + * + * Any 'goto restart_execution;' code path in opcode dispatch must + * ensure 'curr_pc' is synced back to act->curr_pc before the goto + * takes place. + * + * The interpreter must be very careful with memory pointers, as + * many pointers are not guaranteed to be 'stable' and may be + * reallocated and relocated on-the-fly quite easily (e.g. by a + * memory allocation or a property access). + * + * The following are assumed to have stable pointers: + * - the current thread + * - the current function + * - the bytecode, constant table, inner function table of the + * current function (as they are a part of the function allocation) + * + * The following are assumed to have semi-stable pointers: + * - the current activation entry: stable as long as callstack + * is not changed (reallocated by growing or shrinking), or + * by any garbage collection invocation (through finalizers) + * - Note in particular that ANY DECREF can invalidate the + * activation pointer, so for the most part a fresh lookup + * is required + * + * The following are not assumed to have stable pointers at all: + * - the value stack (registers) of the current thread + * + * See execution.rst for discussion. + */ + +restart_execution: + + /* Lookup current thread; use the stable 'entry_thread' for this to + * avoid clobber warnings. Any valid, reachable 'thr' value would be + * fine for this, so using 'entry_thread' is just to silence warnings. + */ + thr = entry_thread->heap->curr_thread; + DUK_ASSERT(thr != NULL); + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(thr->callstack_curr != NULL); + DUK_ASSERT(DUK_ACT_GET_FUNC(thr->callstack_curr) != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(DUK_ACT_GET_FUNC(thr->callstack_curr))); + + DUK_GC_TORTURE(thr->heap); + + thr->ptr_curr_pc = &curr_pc; + + /* Relookup and initialize dispatch loop variables. Debugger check. */ + { + duk_activation *act; +#if !defined(DUK_USE_EXEC_FUN_LOCAL) + duk_hcompfunc *fun; +#endif + + /* Assume interrupt init/counter are properly initialized here. */ + /* Assume that thr->valstack_bottom has been set-up before getting here. */ + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + fun = (duk_hcompfunc *) DUK_ACT_GET_FUNC(act); + DUK_ASSERT(fun != NULL); + DUK_ASSERT(thr->valstack_top - thr->valstack_bottom == fun->nregs); + consts = DUK_HCOMPFUNC_GET_CONSTS_BASE(thr->heap, fun); + DUK_ASSERT(consts != NULL); + +#if defined(DUK_USE_DEBUGGER_SUPPORT) + if (DUK_UNLIKELY(duk_debug_is_attached(thr->heap) && !thr->heap->dbg_processing)) { + duk__executor_recheck_debugger(thr, act, fun); + DUK_ASSERT(act == thr->callstack_curr); + DUK_ASSERT(act != NULL); + } +#endif /* DUK_USE_DEBUGGER_SUPPORT */ + +#if defined(DUK_USE_ASSERTIONS) + valstack_top_base = (duk_size_t) (thr->valstack_top - thr->valstack); +#endif + + /* Set up curr_pc for opcode dispatch. */ + curr_pc = act->curr_pc; + } + + DUK_DD(DUK_DDPRINT("restarting execution, thr %p, act idx %ld, fun %p," + "consts %p, funcs %p, lev %ld, regbot %ld, regtop %ld, " + "preventcount=%ld", + (void *) thr, + (long) (thr->callstack_top - 1), + (void *) DUK__FUN(), + (void *) DUK_HCOMPFUNC_GET_CONSTS_BASE(thr->heap, DUK__FUN()), + (void *) DUK_HCOMPFUNC_GET_FUNCS_BASE(thr->heap, DUK__FUN()), + (long) (thr->callstack_top - 1), + (long) (thr->valstack_bottom - thr->valstack), + (long) (thr->valstack_top - thr->valstack), + (long) thr->callstack_preventcount)); + + /* Dispatch loop. */ + + for (;;) { + duk_uint8_t op; + + DUK_ASSERT(thr->callstack_top >= 1); + DUK_ASSERT(thr->valstack_top - thr->valstack_bottom == DUK__FUN()->nregs); + DUK_ASSERT((duk_size_t) (thr->valstack_top - thr->valstack) == valstack_top_base); + + /* Executor interrupt counter check, used to implement breakpoints, + * debugging interface, execution timeouts, etc. The counter is heap + * specific but is maintained in the current thread to make the check + * as fast as possible. The counter is copied back to the heap struct + * whenever a thread switch occurs by the DUK_HEAP_SWITCH_THREAD() macro. + */ +#if defined(DUK_USE_INTERRUPT_COUNTER) + int_ctr = thr->interrupt_counter; + if (DUK_LIKELY(int_ctr > 0)) { + thr->interrupt_counter = int_ctr - 1; + } else { + /* Trigger at zero or below */ + duk_small_uint_t exec_int_ret; + + DUK_STATS_INC(thr->heap, stats_exec_interrupt); + + /* Write curr_pc back for the debugger. */ + { + duk_activation *act; + DUK_ASSERT(thr->callstack_top > 0); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + act->curr_pc = (duk_instr_t *) curr_pc; + } + + /* Forced restart caused by a function return; must recheck + * debugger breakpoints before checking line transitions, + * see GH-303. Restart and then handle interrupt_counter + * zero again. + */ +#if defined(DUK_USE_DEBUGGER_SUPPORT) + if (thr->heap->dbg_force_restart) { + DUK_DD(DUK_DDPRINT("dbg_force_restart flag forced restart execution")); /* GH-303 */ + thr->heap->dbg_force_restart = 0; + goto restart_execution; + } +#endif + + exec_int_ret = duk__executor_interrupt(thr); + if (exec_int_ret == DUK__INT_RESTART) { + /* curr_pc synced back above */ + goto restart_execution; + } + } +#endif /* DUK_USE_INTERRUPT_COUNTER */ +#if defined(DUK_USE_INTERRUPT_COUNTER) && defined(DUK_USE_DEBUG) + /* For cross-checking during development: ensure dispatch count + * matches cumulative interrupt counter init value sums. + */ + thr->heap->inst_count_exec++; +#endif + +#if defined(DUK_USE_ASSERTIONS) || defined(DUK_USE_DEBUG) + { + duk_activation *act; + act = thr->callstack_curr; + DUK_ASSERT(curr_pc >= DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, DUK__FUN())); + DUK_ASSERT(curr_pc < DUK_HCOMPFUNC_GET_CODE_END(thr->heap, DUK__FUN())); + DUK_UNREF(act); /* if debugging disabled */ + + DUK_DDD(DUK_DDDPRINT( + "executing bytecode: pc=%ld, ins=0x%08lx, op=%ld, valstack_top=%ld/%ld, nregs=%ld --> %!I", + (long) (curr_pc - DUK_HCOMPFUNC_GET_CODE_BASE(thr->heap, DUK__FUN())), + (unsigned long) *curr_pc, + (long) DUK_DEC_OP(*curr_pc), + (long) (thr->valstack_top - thr->valstack), + (long) (thr->valstack_end - thr->valstack), + (long) (DUK__FUN() ? DUK__FUN()->nregs : -1), + (duk_instr_t) *curr_pc)); + } +#endif + +#if defined(DUK_USE_ASSERTIONS) + /* Quite heavy assert: check valstack policy. Improper + * shuffle instructions can write beyond valstack_top/end + * so this check catches them in the act. + */ + { + duk_tval *tv; + tv = thr->valstack_top; + while (tv != thr->valstack_end) { + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(tv)); + tv++; + } + } +#endif + + ins = *curr_pc++; + DUK_STATS_INC(thr->heap, stats_exec_opcodes); + + /* Typing: use duk_small_(u)int_fast_t when decoding small + * opcode fields (op, A, B, C, BC) which fit into 16 bits + * and duk_(u)int_fast_t when decoding larger fields (e.g. + * ABC). Use unsigned variant by default, signed when the + * value is used in signed arithmetic. Using variable names + * such as 'a', 'b', 'c', 'bc', etc makes it easier to spot + * typing mismatches. + */ + + /* Switch based on opcode. Cast to 8-bit unsigned value and + * use a fully populated case clauses so that the compiler + * will (at least usually) omit a bounds check. + */ + op = (duk_uint8_t) DUK_DEC_OP(ins); + switch (op) { + /* Some useful macros. These access inner executor variables + * directly so they only apply within the executor. + */ +#if defined(DUK_USE_EXEC_PREFER_SIZE) +#define DUK__REPLACE_TOP_A_BREAK() \ + { goto replace_top_a; } +#define DUK__REPLACE_TOP_BC_BREAK() \ + { goto replace_top_bc; } +#define DUK__REPLACE_BOOL_A_BREAK(bval) \ + { \ + duk_bool_t duk__bval; \ + duk__bval = (bval); \ + DUK_ASSERT(duk__bval == 0 || duk__bval == 1); \ + duk_push_boolean(thr, duk__bval); \ + DUK__REPLACE_TOP_A_BREAK(); \ + } +#else +#define DUK__REPLACE_TOP_A_BREAK() \ + { \ + DUK__REPLACE_TO_TVPTR(thr, DUK__REGP_A(ins)); \ + break; \ + } +#define DUK__REPLACE_TOP_BC_BREAK() \ + { \ + DUK__REPLACE_TO_TVPTR(thr, DUK__REGP_BC(ins)); \ + break; \ + } +#define DUK__REPLACE_BOOL_A_BREAK(bval) \ + { \ + duk_bool_t duk__bval; \ + duk_tval *duk__tvdst; \ + duk__bval = (bval); \ + DUK_ASSERT(duk__bval == 0 || duk__bval == 1); \ + duk__tvdst = DUK__REGP_A(ins); \ + DUK_TVAL_SET_BOOLEAN_UPDREF(thr, duk__tvdst, duk__bval); \ + break; \ + } +#endif + + /* XXX: 12 + 12 bit variant might make sense too, for both reg and + * const loads. + */ + + /* For LDREG, STREG, LDCONST footprint optimized variants would just + * duk_dup() + duk_replace(), but because they're used quite a lot + * they're currently intentionally not size optimized. + */ + case DUK_OP_LDREG: { + duk_tval *tv1, *tv2; + + tv1 = DUK__REGP_A(ins); + tv2 = DUK__REGP_BC(ins); + DUK_TVAL_SET_TVAL_UPDREF_FAST(thr, tv1, tv2); /* side effects */ + break; + } + + case DUK_OP_STREG: { + duk_tval *tv1, *tv2; + + tv1 = DUK__REGP_A(ins); + tv2 = DUK__REGP_BC(ins); + DUK_TVAL_SET_TVAL_UPDREF_FAST(thr, tv2, tv1); /* side effects */ + break; + } + + case DUK_OP_LDCONST: { + duk_tval *tv1, *tv2; + + tv1 = DUK__REGP_A(ins); + tv2 = DUK__CONSTP_BC(ins); + DUK_TVAL_SET_TVAL_UPDREF_FAST(thr, tv1, tv2); /* side effects */ + break; + } + + /* LDINT and LDINTX are intended to load an arbitrary signed + * 32-bit value. Only an LDINT+LDINTX sequence is supported. + * This also guarantees all values remain fastints. + */ +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_LDINT: { + duk_int32_t val; + + val = (duk_int32_t) DUK_DEC_BC(ins) - (duk_int32_t) DUK_BC_LDINT_BIAS; + duk_push_int(thr, val); + DUK__REPLACE_TOP_A_BREAK(); + } + case DUK_OP_LDINTX: { + duk_int32_t val; + + val = (duk_int32_t) duk_get_int(thr, DUK_DEC_A(ins)); + val = (val << DUK_BC_LDINTX_SHIFT) + (duk_int32_t) DUK_DEC_BC(ins); /* no bias */ + duk_push_int(thr, val); + DUK__REPLACE_TOP_A_BREAK(); + } +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_LDINT: { + duk_tval *tv1; + duk_int32_t val; + + val = (duk_int32_t) DUK_DEC_BC(ins) - (duk_int32_t) DUK_BC_LDINT_BIAS; + tv1 = DUK__REGP_A(ins); + DUK_TVAL_SET_I32_UPDREF(thr, tv1, val); /* side effects */ + break; + } + case DUK_OP_LDINTX: { + duk_tval *tv1; + duk_int32_t val; + + tv1 = DUK__REGP_A(ins); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv1)); +#if defined(DUK_USE_FASTINT) + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv1)); + val = DUK_TVAL_GET_FASTINT_I32(tv1); +#else + /* XXX: fast double-to-int conversion, we know number is integer in [-0x80000000,0xffffffff]. */ + val = (duk_int32_t) DUK_TVAL_GET_NUMBER(tv1); +#endif + val = + (duk_int32_t) ((duk_uint32_t) val << DUK_BC_LDINTX_SHIFT) + (duk_int32_t) DUK_DEC_BC(ins); /* no bias */ + DUK_TVAL_SET_I32_UPDREF(thr, tv1, val); /* side effects */ + break; + } +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_LDTHIS: { + duk_push_this(thr); + DUK__REPLACE_TOP_BC_BREAK(); + } + case DUK_OP_LDUNDEF: { + duk_to_undefined(thr, (duk_idx_t) DUK_DEC_BC(ins)); + break; + } + case DUK_OP_LDNULL: { + duk_to_null(thr, (duk_idx_t) DUK_DEC_BC(ins)); + break; + } + case DUK_OP_LDTRUE: { + duk_push_true(thr); + DUK__REPLACE_TOP_BC_BREAK(); + } + case DUK_OP_LDFALSE: { + duk_push_false(thr); + DUK__REPLACE_TOP_BC_BREAK(); + } +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_LDTHIS: { + /* Note: 'this' may be bound to any value, not just an object */ + duk_tval *tv1, *tv2; + + tv1 = DUK__REGP_BC(ins); + tv2 = thr->valstack_bottom - 1; /* 'this binding' is just under bottom */ + DUK_ASSERT(tv2 >= thr->valstack); + DUK_TVAL_SET_TVAL_UPDREF_FAST(thr, tv1, tv2); /* side effects */ + break; + } + case DUK_OP_LDUNDEF: { + duk_tval *tv1; + + tv1 = DUK__REGP_BC(ins); + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, tv1); /* side effects */ + break; + } + case DUK_OP_LDNULL: { + duk_tval *tv1; + + tv1 = DUK__REGP_BC(ins); + DUK_TVAL_SET_NULL_UPDREF(thr, tv1); /* side effects */ + break; + } + case DUK_OP_LDTRUE: { + duk_tval *tv1; + + tv1 = DUK__REGP_BC(ins); + DUK_TVAL_SET_BOOLEAN_UPDREF(thr, tv1, 1); /* side effects */ + break; + } + case DUK_OP_LDFALSE: { + duk_tval *tv1; + + tv1 = DUK__REGP_BC(ins); + DUK_TVAL_SET_BOOLEAN_UPDREF(thr, tv1, 0); /* side effects */ + break; + } +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + + case DUK_OP_BNOT: { + duk__vm_bitwise_not(thr, DUK_DEC_BC(ins), DUK_DEC_A(ins)); + break; + } + + case DUK_OP_LNOT: { + duk__vm_logical_not(thr, DUK_DEC_BC(ins), DUK_DEC_A(ins)); + break; + } + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_UNM: + case DUK_OP_UNP: { + duk__vm_arith_unary_op(thr, DUK_DEC_BC(ins), DUK_DEC_A(ins), op); + break; + } +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_UNM: { + duk__vm_arith_unary_op(thr, DUK_DEC_BC(ins), DUK_DEC_A(ins), DUK_OP_UNM); + break; + } + case DUK_OP_UNP: { + duk__vm_arith_unary_op(thr, DUK_DEC_BC(ins), DUK_DEC_A(ins), DUK_OP_UNP); + break; + } +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_TYPEOF: { + duk_small_uint_t stridx; + + stridx = duk_js_typeof_stridx(DUK__REGP_BC(ins)); + DUK_ASSERT_STRIDX_VALID(stridx); + duk_push_hstring_stridx(thr, stridx); + DUK__REPLACE_TOP_A_BREAK(); + } +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_TYPEOF: { + duk_tval *tv; + duk_small_uint_t stridx; + duk_hstring *h_str; + + tv = DUK__REGP_BC(ins); + stridx = duk_js_typeof_stridx(tv); + DUK_ASSERT_STRIDX_VALID(stridx); + h_str = DUK_HTHREAD_GET_STRING(thr, stridx); + tv = DUK__REGP_A(ins); + DUK_TVAL_SET_STRING_UPDREF(thr, tv, h_str); + break; + } +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + + case DUK_OP_TYPEOFID: { + duk_small_uint_t stridx; +#if !defined(DUK_USE_EXEC_PREFER_SIZE) + duk_hstring *h_str; +#endif + duk_activation *act; + duk_hstring *name; + duk_tval *tv; + + /* A -> target register + * BC -> constant index of identifier name + */ + + tv = DUK__CONSTP_BC(ins); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv)); + name = DUK_TVAL_GET_STRING(tv); + tv = NULL; /* lookup has side effects */ + act = thr->callstack_curr; + if (duk_js_getvar_activation(thr, act, name, 0 /*throw*/)) { + /* -> [... val this] */ + tv = DUK_GET_TVAL_NEGIDX(thr, -2); + stridx = duk_js_typeof_stridx(tv); + tv = NULL; /* no longer needed */ + duk_pop_2_unsafe(thr); + } else { + /* unresolvable, no stack changes */ + stridx = DUK_STRIDX_LC_UNDEFINED; + } + DUK_ASSERT_STRIDX_VALID(stridx); +#if defined(DUK_USE_EXEC_PREFER_SIZE) + duk_push_hstring_stridx(thr, stridx); + DUK__REPLACE_TOP_A_BREAK(); +#else /* DUK_USE_EXEC_PREFER_SIZE */ + h_str = DUK_HTHREAD_GET_STRING(thr, stridx); + tv = DUK__REGP_A(ins); + DUK_TVAL_SET_STRING_UPDREF(thr, tv, h_str); + break; +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + } + + /* Equality: E5 Sections 11.9.1, 11.9.3 */ + +#define DUK__EQ_BODY(barg, carg) \ + { \ + duk_bool_t tmp; \ + tmp = duk_js_equals(thr, (barg), (carg)); \ + DUK_ASSERT(tmp == 0 || tmp == 1); \ + DUK__REPLACE_BOOL_A_BREAK(tmp); \ + } +#define DUK__NEQ_BODY(barg, carg) \ + { \ + duk_bool_t tmp; \ + tmp = duk_js_equals(thr, (barg), (carg)); \ + DUK_ASSERT(tmp == 0 || tmp == 1); \ + tmp ^= 1; \ + DUK__REPLACE_BOOL_A_BREAK(tmp); \ + } +#define DUK__SEQ_BODY(barg, carg) \ + { \ + duk_bool_t tmp; \ + tmp = duk_js_strict_equals((barg), (carg)); \ + DUK_ASSERT(tmp == 0 || tmp == 1); \ + DUK__REPLACE_BOOL_A_BREAK(tmp); \ + } +#define DUK__SNEQ_BODY(barg, carg) \ + { \ + duk_bool_t tmp; \ + tmp = duk_js_strict_equals((barg), (carg)); \ + DUK_ASSERT(tmp == 0 || tmp == 1); \ + tmp ^= 1; \ + DUK__REPLACE_BOOL_A_BREAK(tmp); \ + } +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_EQ_RR: + case DUK_OP_EQ_CR: + case DUK_OP_EQ_RC: + case DUK_OP_EQ_CC: + DUK__EQ_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); + case DUK_OP_NEQ_RR: + case DUK_OP_NEQ_CR: + case DUK_OP_NEQ_RC: + case DUK_OP_NEQ_CC: + DUK__NEQ_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); + case DUK_OP_SEQ_RR: + case DUK_OP_SEQ_CR: + case DUK_OP_SEQ_RC: + case DUK_OP_SEQ_CC: + DUK__SEQ_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); + case DUK_OP_SNEQ_RR: + case DUK_OP_SNEQ_CR: + case DUK_OP_SNEQ_RC: + case DUK_OP_SNEQ_CC: + DUK__SNEQ_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_EQ_RR: + DUK__EQ_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_EQ_CR: + DUK__EQ_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_EQ_RC: + DUK__EQ_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_EQ_CC: + DUK__EQ_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_NEQ_RR: + DUK__NEQ_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_NEQ_CR: + DUK__NEQ_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_NEQ_RC: + DUK__NEQ_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_NEQ_CC: + DUK__NEQ_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_SEQ_RR: + DUK__SEQ_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_SEQ_CR: + DUK__SEQ_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_SEQ_RC: + DUK__SEQ_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_SEQ_CC: + DUK__SEQ_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_SNEQ_RR: + DUK__SNEQ_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_SNEQ_CR: + DUK__SNEQ_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_SNEQ_RC: + DUK__SNEQ_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_SNEQ_CC: + DUK__SNEQ_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + +#define DUK__COMPARE_BODY(arg1, arg2, flags) \ + { \ + duk_bool_t tmp; \ + tmp = duk_js_compare_helper(thr, (arg1), (arg2), (flags)); \ + DUK_ASSERT(tmp == 0 || tmp == 1); \ + DUK__REPLACE_BOOL_A_BREAK(tmp); \ + } +#define DUK__GT_BODY(barg, carg) DUK__COMPARE_BODY((carg), (barg), 0) +#define DUK__GE_BODY(barg, carg) DUK__COMPARE_BODY((barg), (carg), DUK_COMPARE_FLAG_EVAL_LEFT_FIRST | DUK_COMPARE_FLAG_NEGATE) +#define DUK__LT_BODY(barg, carg) DUK__COMPARE_BODY((barg), (carg), DUK_COMPARE_FLAG_EVAL_LEFT_FIRST) +#define DUK__LE_BODY(barg, carg) DUK__COMPARE_BODY((carg), (barg), DUK_COMPARE_FLAG_NEGATE) +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_GT_RR: + case DUK_OP_GT_CR: + case DUK_OP_GT_RC: + case DUK_OP_GT_CC: + DUK__GT_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); + case DUK_OP_GE_RR: + case DUK_OP_GE_CR: + case DUK_OP_GE_RC: + case DUK_OP_GE_CC: + DUK__GE_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); + case DUK_OP_LT_RR: + case DUK_OP_LT_CR: + case DUK_OP_LT_RC: + case DUK_OP_LT_CC: + DUK__LT_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); + case DUK_OP_LE_RR: + case DUK_OP_LE_CR: + case DUK_OP_LE_RC: + case DUK_OP_LE_CC: + DUK__LE_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_GT_RR: + DUK__GT_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_GT_CR: + DUK__GT_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_GT_RC: + DUK__GT_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_GT_CC: + DUK__GT_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_GE_RR: + DUK__GE_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_GE_CR: + DUK__GE_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_GE_RC: + DUK__GE_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_GE_CC: + DUK__GE_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_LT_RR: + DUK__LT_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_LT_CR: + DUK__LT_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_LT_RC: + DUK__LT_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_LT_CC: + DUK__LT_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_LE_RR: + DUK__LE_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_LE_CR: + DUK__LE_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_LE_RC: + DUK__LE_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_LE_CC: + DUK__LE_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + + /* No size optimized variant at present for IF. */ + case DUK_OP_IFTRUE_R: { + if (duk_js_toboolean(DUK__REGP_BC(ins)) != 0) { + curr_pc++; + } + break; + } + case DUK_OP_IFTRUE_C: { + if (duk_js_toboolean(DUK__CONSTP_BC(ins)) != 0) { + curr_pc++; + } + break; + } + case DUK_OP_IFFALSE_R: { + if (duk_js_toboolean(DUK__REGP_BC(ins)) == 0) { + curr_pc++; + } + break; + } + case DUK_OP_IFFALSE_C: { + if (duk_js_toboolean(DUK__CONSTP_BC(ins)) == 0) { + curr_pc++; + } + break; + } + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_ADD_RR: + case DUK_OP_ADD_CR: + case DUK_OP_ADD_RC: + case DUK_OP_ADD_CC: { + /* XXX: could leave value on stack top and goto replace_top_a; */ + duk__vm_arith_add(thr, DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins), DUK_DEC_A(ins)); + break; + } +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_ADD_RR: { + duk__vm_arith_add(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins)); + break; + } + case DUK_OP_ADD_CR: { + duk__vm_arith_add(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins)); + break; + } + case DUK_OP_ADD_RC: { + duk__vm_arith_add(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins)); + break; + } + case DUK_OP_ADD_CC: { + duk__vm_arith_add(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins)); + break; + } +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_SUB_RR: + case DUK_OP_SUB_CR: + case DUK_OP_SUB_RC: + case DUK_OP_SUB_CC: + case DUK_OP_MUL_RR: + case DUK_OP_MUL_CR: + case DUK_OP_MUL_RC: + case DUK_OP_MUL_CC: + case DUK_OP_DIV_RR: + case DUK_OP_DIV_CR: + case DUK_OP_DIV_RC: + case DUK_OP_DIV_CC: + case DUK_OP_MOD_RR: + case DUK_OP_MOD_CR: + case DUK_OP_MOD_RC: + case DUK_OP_MOD_CC: +#if defined(DUK_USE_ES7_EXP_OPERATOR) + case DUK_OP_EXP_RR: + case DUK_OP_EXP_CR: + case DUK_OP_EXP_RC: + case DUK_OP_EXP_CC: +#endif /* DUK_USE_ES7_EXP_OPERATOR */ + { + /* XXX: could leave value on stack top and goto replace_top_a; */ + duk__vm_arith_binary_op(thr, DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins), DUK_DEC_A(ins), op); + break; + } +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_SUB_RR: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_SUB); + break; + } + case DUK_OP_SUB_CR: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_SUB); + break; + } + case DUK_OP_SUB_RC: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_SUB); + break; + } + case DUK_OP_SUB_CC: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_SUB); + break; + } + case DUK_OP_MUL_RR: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_MUL); + break; + } + case DUK_OP_MUL_CR: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_MUL); + break; + } + case DUK_OP_MUL_RC: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_MUL); + break; + } + case DUK_OP_MUL_CC: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_MUL); + break; + } + case DUK_OP_DIV_RR: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_DIV); + break; + } + case DUK_OP_DIV_CR: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_DIV); + break; + } + case DUK_OP_DIV_RC: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_DIV); + break; + } + case DUK_OP_DIV_CC: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_DIV); + break; + } + case DUK_OP_MOD_RR: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_MOD); + break; + } + case DUK_OP_MOD_CR: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_MOD); + break; + } + case DUK_OP_MOD_RC: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_MOD); + break; + } + case DUK_OP_MOD_CC: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_MOD); + break; + } +#if defined(DUK_USE_ES7_EXP_OPERATOR) + case DUK_OP_EXP_RR: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_EXP); + break; + } + case DUK_OP_EXP_CR: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_EXP); + break; + } + case DUK_OP_EXP_RC: { + duk__vm_arith_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_EXP); + break; + } + case DUK_OP_EXP_CC: { + duk__vm_arith_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_EXP); + break; + } +#endif /* DUK_USE_ES7_EXP_OPERATOR */ +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_BAND_RR: + case DUK_OP_BAND_CR: + case DUK_OP_BAND_RC: + case DUK_OP_BAND_CC: + case DUK_OP_BOR_RR: + case DUK_OP_BOR_CR: + case DUK_OP_BOR_RC: + case DUK_OP_BOR_CC: + case DUK_OP_BXOR_RR: + case DUK_OP_BXOR_CR: + case DUK_OP_BXOR_RC: + case DUK_OP_BXOR_CC: + case DUK_OP_BASL_RR: + case DUK_OP_BASL_CR: + case DUK_OP_BASL_RC: + case DUK_OP_BASL_CC: + case DUK_OP_BLSR_RR: + case DUK_OP_BLSR_CR: + case DUK_OP_BLSR_RC: + case DUK_OP_BLSR_CC: + case DUK_OP_BASR_RR: + case DUK_OP_BASR_CR: + case DUK_OP_BASR_RC: + case DUK_OP_BASR_CC: { + /* XXX: could leave value on stack top and goto replace_top_a; */ + duk__vm_bitwise_binary_op(thr, DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins), DUK_DEC_A(ins), op); + break; + } +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_BAND_RR: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BAND); + break; + } + case DUK_OP_BAND_CR: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BAND); + break; + } + case DUK_OP_BAND_RC: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BAND); + break; + } + case DUK_OP_BAND_CC: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BAND); + break; + } + case DUK_OP_BOR_RR: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BOR); + break; + } + case DUK_OP_BOR_CR: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BOR); + break; + } + case DUK_OP_BOR_RC: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BOR); + break; + } + case DUK_OP_BOR_CC: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BOR); + break; + } + case DUK_OP_BXOR_RR: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BXOR); + break; + } + case DUK_OP_BXOR_CR: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BXOR); + break; + } + case DUK_OP_BXOR_RC: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BXOR); + break; + } + case DUK_OP_BXOR_CC: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BXOR); + break; + } + case DUK_OP_BASL_RR: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BASL); + break; + } + case DUK_OP_BASL_CR: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BASL); + break; + } + case DUK_OP_BASL_RC: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BASL); + break; + } + case DUK_OP_BASL_CC: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BASL); + break; + } + case DUK_OP_BLSR_RR: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BLSR); + break; + } + case DUK_OP_BLSR_CR: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BLSR); + break; + } + case DUK_OP_BLSR_RC: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BLSR); + break; + } + case DUK_OP_BLSR_CC: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BLSR); + break; + } + case DUK_OP_BASR_RR: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BASR); + break; + } + case DUK_OP_BASR_CR: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__REGP_C(ins), DUK_DEC_A(ins), DUK_OP_BASR); + break; + } + case DUK_OP_BASR_RC: { + duk__vm_bitwise_binary_op(thr, DUK__REGP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BASR); + break; + } + case DUK_OP_BASR_CC: { + duk__vm_bitwise_binary_op(thr, DUK__CONSTP_B(ins), DUK__CONSTP_C(ins), DUK_DEC_A(ins), DUK_OP_BASR); + break; + } +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + + /* For INSTOF and IN, B is always a register. */ +#define DUK__INSTOF_BODY(barg, carg) \ + { \ + duk_bool_t tmp; \ + tmp = duk_js_instanceof(thr, (barg), (carg)); \ + DUK_ASSERT(tmp == 0 || tmp == 1); \ + DUK__REPLACE_BOOL_A_BREAK(tmp); \ + } +#define DUK__IN_BODY(barg, carg) \ + { \ + duk_bool_t tmp; \ + tmp = duk_js_in(thr, (barg), (carg)); \ + DUK_ASSERT(tmp == 0 || tmp == 1); \ + DUK__REPLACE_BOOL_A_BREAK(tmp); \ + } +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_INSTOF_RR: + case DUK_OP_INSTOF_CR: + case DUK_OP_INSTOF_RC: + case DUK_OP_INSTOF_CC: + DUK__INSTOF_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); + case DUK_OP_IN_RR: + case DUK_OP_IN_CR: + case DUK_OP_IN_RC: + case DUK_OP_IN_CC: + DUK__IN_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_INSTOF_RR: + DUK__INSTOF_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_INSTOF_CR: + DUK__INSTOF_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_INSTOF_RC: + DUK__INSTOF_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_INSTOF_CC: + DUK__INSTOF_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_IN_RR: + DUK__IN_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_IN_CR: + DUK__IN_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_IN_RC: + DUK__IN_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_IN_CC: + DUK__IN_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + + /* Pre/post inc/dec for register variables, important for loops. */ +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_PREINCR: + case DUK_OP_PREDECR: + case DUK_OP_POSTINCR: + case DUK_OP_POSTDECR: { + duk__prepost_incdec_reg_helper(thr, DUK__REGP_A(ins), DUK__REGP_BC(ins), op); + break; + } + case DUK_OP_PREINCV: + case DUK_OP_PREDECV: + case DUK_OP_POSTINCV: + case DUK_OP_POSTDECV: { + duk__prepost_incdec_var_helper(thr, DUK_DEC_A(ins), DUK__CONSTP_BC(ins), op, DUK__STRICT()); + break; + } +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_PREINCR: { + duk__prepost_incdec_reg_helper(thr, DUK__REGP_A(ins), DUK__REGP_BC(ins), DUK_OP_PREINCR); + break; + } + case DUK_OP_PREDECR: { + duk__prepost_incdec_reg_helper(thr, DUK__REGP_A(ins), DUK__REGP_BC(ins), DUK_OP_PREDECR); + break; + } + case DUK_OP_POSTINCR: { + duk__prepost_incdec_reg_helper(thr, DUK__REGP_A(ins), DUK__REGP_BC(ins), DUK_OP_POSTINCR); + break; + } + case DUK_OP_POSTDECR: { + duk__prepost_incdec_reg_helper(thr, DUK__REGP_A(ins), DUK__REGP_BC(ins), DUK_OP_POSTDECR); + break; + } + case DUK_OP_PREINCV: { + duk__prepost_incdec_var_helper(thr, DUK_DEC_A(ins), DUK__CONSTP_BC(ins), DUK_OP_PREINCV, DUK__STRICT()); + break; + } + case DUK_OP_PREDECV: { + duk__prepost_incdec_var_helper(thr, DUK_DEC_A(ins), DUK__CONSTP_BC(ins), DUK_OP_PREDECV, DUK__STRICT()); + break; + } + case DUK_OP_POSTINCV: { + duk__prepost_incdec_var_helper(thr, DUK_DEC_A(ins), DUK__CONSTP_BC(ins), DUK_OP_POSTINCV, DUK__STRICT()); + break; + } + case DUK_OP_POSTDECV: { + duk__prepost_incdec_var_helper(thr, DUK_DEC_A(ins), DUK__CONSTP_BC(ins), DUK_OP_POSTDECV, DUK__STRICT()); + break; + } +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + + /* XXX: Move to separate helper, optimize for perf/size separately. */ + /* Preinc/predec for object properties. */ + case DUK_OP_PREINCP_RR: + case DUK_OP_PREINCP_CR: + case DUK_OP_PREINCP_RC: + case DUK_OP_PREINCP_CC: + case DUK_OP_PREDECP_RR: + case DUK_OP_PREDECP_CR: + case DUK_OP_PREDECP_RC: + case DUK_OP_PREDECP_CC: + case DUK_OP_POSTINCP_RR: + case DUK_OP_POSTINCP_CR: + case DUK_OP_POSTINCP_RC: + case DUK_OP_POSTINCP_CC: + case DUK_OP_POSTDECP_RR: + case DUK_OP_POSTDECP_CR: + case DUK_OP_POSTDECP_RC: + case DUK_OP_POSTDECP_CC: { + duk_tval *tv_obj; + duk_tval *tv_key; + duk_tval *tv_val; + duk_bool_t rc; + duk_double_t x, y, z; +#if !defined(DUK_USE_EXEC_PREFER_SIZE) + duk_tval *tv_dst; +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + + /* A -> target reg + * B -> object reg/const (may be const e.g. in "'foo'[1]") + * C -> key reg/const + */ + + /* Opcode bits 0-1 are used to distinguish reg/const variants. + * Opcode bits 2-3 are used to distinguish inc/dec variants: + * Bit 2 = inc(0)/dec(1), bit 3 = pre(0)/post(1). + */ + DUK_ASSERT((DUK_OP_PREINCP_RR & 0x0c) == 0x00); + DUK_ASSERT((DUK_OP_PREDECP_RR & 0x0c) == 0x04); + DUK_ASSERT((DUK_OP_POSTINCP_RR & 0x0c) == 0x08); + DUK_ASSERT((DUK_OP_POSTDECP_RR & 0x0c) == 0x0c); + + tv_obj = DUK__REGCONSTP_B(ins); + tv_key = DUK__REGCONSTP_C(ins); + rc = duk_hobject_getprop(thr, tv_obj, tv_key); /* -> [val] */ + DUK_UNREF(rc); /* ignore */ + tv_obj = NULL; /* invalidated */ + tv_key = NULL; /* invalidated */ + + /* XXX: Fastint fast path would be useful here. Also fastints + * now lose their fastint status in current handling which is + * not intuitive. + */ + + x = duk_to_number_m1(thr); + duk_pop_unsafe(thr); + if (ins & DUK_BC_INCDECP_FLAG_DEC) { + y = x - 1.0; + } else { + y = x + 1.0; + } + + duk_push_number(thr, y); + tv_val = DUK_GET_TVAL_NEGIDX(thr, -1); + DUK_ASSERT(tv_val != NULL); + tv_obj = DUK__REGCONSTP_B(ins); + tv_key = DUK__REGCONSTP_C(ins); + rc = duk_hobject_putprop(thr, tv_obj, tv_key, tv_val, DUK__STRICT()); + DUK_UNREF(rc); /* ignore */ + tv_obj = NULL; /* invalidated */ + tv_key = NULL; /* invalidated */ + duk_pop_unsafe(thr); + + z = (ins & DUK_BC_INCDECP_FLAG_POST) ? x : y; +#if defined(DUK_USE_EXEC_PREFER_SIZE) + duk_push_number(thr, z); + DUK__REPLACE_TOP_A_BREAK(); +#else + tv_dst = DUK__REGP_A(ins); + DUK_TVAL_SET_NUMBER_UPDREF(thr, tv_dst, z); + break; +#endif + } + + /* XXX: GETPROP where object is 'this', GETPROPT? + * Occurs relatively often in object oriented code. + */ + +#define DUK__GETPROP_BODY(barg, carg) \ + { \ + /* A -> target reg \ + * B -> object reg/const (may be const e.g. in "'foo'[1]") \ + * C -> key reg/const \ + */ \ + (void) duk_hobject_getprop(thr, (barg), (carg)); \ + DUK__REPLACE_TOP_A_BREAK(); \ + } +#define DUK__GETPROPC_BODY(barg, carg) \ + { \ + /* Same as GETPROP but callability check for property-based calls. */ \ + duk_tval *tv__targ; \ + (void) duk_hobject_getprop(thr, (barg), (carg)); \ + DUK_GC_TORTURE(thr->heap); \ + tv__targ = DUK_GET_TVAL_NEGIDX(thr, -1); \ + if (DUK_UNLIKELY(!duk_is_callable_tval(thr, tv__targ))) { \ + /* Here we intentionally re-evaluate the macro \ + * arguments to deal with potentially changed \ + * valstack base pointer! \ + */ \ + duk_call_setup_propcall_error(thr, (barg), (carg)); \ + } \ + DUK__REPLACE_TOP_A_BREAK(); \ + } +#define DUK__PUTPROP_BODY(aarg, barg, carg) \ + { \ + /* A -> object reg \ + * B -> key reg/const \ + * C -> value reg/const \ + * \ + * Note: intentional difference to register arrangement \ + * of e.g. GETPROP; 'A' must contain a register-only value. \ + */ \ + (void) duk_hobject_putprop(thr, (aarg), (barg), (carg), DUK__STRICT()); \ + break; \ + } +#define DUK__DELPROP_BODY(barg, carg) \ + { \ + /* A -> result reg \ + * B -> object reg \ + * C -> key reg/const \ + */ \ + duk_bool_t rc; \ + rc = duk_hobject_delprop(thr, (barg), (carg), DUK__STRICT()); \ + DUK_ASSERT(rc == 0 || rc == 1); \ + DUK__REPLACE_BOOL_A_BREAK(rc); \ + } +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_GETPROP_RR: + case DUK_OP_GETPROP_CR: + case DUK_OP_GETPROP_RC: + case DUK_OP_GETPROP_CC: + DUK__GETPROP_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); +#if defined(DUK_USE_VERBOSE_ERRORS) + case DUK_OP_GETPROPC_RR: + case DUK_OP_GETPROPC_CR: + case DUK_OP_GETPROPC_RC: + case DUK_OP_GETPROPC_CC: + DUK__GETPROPC_BODY(DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); +#endif + case DUK_OP_PUTPROP_RR: + case DUK_OP_PUTPROP_CR: + case DUK_OP_PUTPROP_RC: + case DUK_OP_PUTPROP_CC: + DUK__PUTPROP_BODY(DUK__REGP_A(ins), DUK__REGCONSTP_B(ins), DUK__REGCONSTP_C(ins)); + case DUK_OP_DELPROP_RR: + case DUK_OP_DELPROP_RC: /* B is always reg */ + DUK__DELPROP_BODY(DUK__REGP_B(ins), DUK__REGCONSTP_C(ins)); +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_GETPROP_RR: + DUK__GETPROP_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_GETPROP_CR: + DUK__GETPROP_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_GETPROP_RC: + DUK__GETPROP_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_GETPROP_CC: + DUK__GETPROP_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); +#if defined(DUK_USE_VERBOSE_ERRORS) + case DUK_OP_GETPROPC_RR: + DUK__GETPROPC_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_GETPROPC_CR: + DUK__GETPROPC_BODY(DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_GETPROPC_RC: + DUK__GETPROPC_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_GETPROPC_CC: + DUK__GETPROPC_BODY(DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); +#endif + case DUK_OP_PUTPROP_RR: + DUK__PUTPROP_BODY(DUK__REGP_A(ins), DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_PUTPROP_CR: + DUK__PUTPROP_BODY(DUK__REGP_A(ins), DUK__CONSTP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_PUTPROP_RC: + DUK__PUTPROP_BODY(DUK__REGP_A(ins), DUK__REGP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_PUTPROP_CC: + DUK__PUTPROP_BODY(DUK__REGP_A(ins), DUK__CONSTP_B(ins), DUK__CONSTP_C(ins)); + case DUK_OP_DELPROP_RR: /* B is always reg */ + DUK__DELPROP_BODY(DUK__REGP_B(ins), DUK__REGP_C(ins)); + case DUK_OP_DELPROP_RC: + DUK__DELPROP_BODY(DUK__REGP_B(ins), DUK__CONSTP_C(ins)); +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + + /* No fast path for DECLVAR now, it's quite a rare instruction. */ + case DUK_OP_DECLVAR_RR: + case DUK_OP_DECLVAR_CR: + case DUK_OP_DECLVAR_RC: + case DUK_OP_DECLVAR_CC: { + duk_activation *act; + duk_small_uint_fast_t a = DUK_DEC_A(ins); + duk_tval *tv1; + duk_hstring *name; + duk_small_uint_t prop_flags; + duk_bool_t is_func_decl; + + tv1 = DUK__REGCONSTP_B(ins); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv1)); + name = DUK_TVAL_GET_STRING(tv1); + DUK_ASSERT(name != NULL); + + is_func_decl = ((a & DUK_BC_DECLVAR_FLAG_FUNC_DECL) != 0); + + /* XXX: declvar takes an duk_tval pointer, which is awkward and + * should be reworked. + */ + + /* Compiler is responsible for selecting property flags (configurability, + * writability, etc). + */ + prop_flags = a & DUK_PROPDESC_FLAGS_MASK; + + if (is_func_decl) { + duk_push_tval(thr, DUK__REGCONSTP_C(ins)); + } else { + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top)); /* valstack policy */ + thr->valstack_top++; + } + tv1 = DUK_GET_TVAL_NEGIDX(thr, -1); + + act = thr->callstack_curr; + if (duk_js_declvar_activation(thr, act, name, tv1, prop_flags, is_func_decl)) { + if (is_func_decl) { + /* Already declared, update value. */ + tv1 = DUK_GET_TVAL_NEGIDX(thr, -1); + duk_js_putvar_activation(thr, act, name, tv1, DUK__STRICT()); + } else { + /* Already declared but no initializer value + * (e.g. 'var xyz;'), no-op. + */ + } + } + + duk_pop_unsafe(thr); + break; + } + +#if defined(DUK_USE_REGEXP_SUPPORT) + /* The compiler should never emit DUK_OP_REGEXP if there is no + * regexp support. + */ + case DUK_OP_REGEXP_RR: + case DUK_OP_REGEXP_CR: + case DUK_OP_REGEXP_RC: + case DUK_OP_REGEXP_CC: { + /* A -> target register + * B -> bytecode (also contains flags) + * C -> escaped source + */ + + duk_push_tval(thr, DUK__REGCONSTP_C(ins)); + duk_push_tval(thr, DUK__REGCONSTP_B(ins)); /* -> [ ... escaped_source bytecode ] */ + duk_regexp_create_instance(thr); /* -> [ ... regexp_instance ] */ + DUK__REPLACE_TOP_A_BREAK(); + } +#endif /* DUK_USE_REGEXP_SUPPORT */ + + /* XXX: 'c' is unused, use whole BC, etc. */ + case DUK_OP_CSVAR_RR: + case DUK_OP_CSVAR_CR: + case DUK_OP_CSVAR_RC: + case DUK_OP_CSVAR_CC: { + /* The speciality of calling through a variable binding is that the + * 'this' value may be provided by the variable lookup: E5 Section 6.b.i. + * + * The only (standard) case where the 'this' binding is non-null is when + * (1) the variable is found in an object environment record, and + * (2) that object environment record is a 'with' block. + */ + + duk_activation *act; + duk_uint_fast_t idx; + duk_tval *tv1; + duk_hstring *name; + + /* A -> target registers (A, A + 1) for call setup + * B -> identifier name, usually constant but can be a register due to shuffling + */ + + tv1 = DUK__REGCONSTP_B(ins); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv1)); + name = DUK_TVAL_GET_STRING(tv1); + DUK_ASSERT(name != NULL); + act = thr->callstack_curr; + (void) duk_js_getvar_activation(thr, act, name, 1 /*throw*/); /* -> [... val this] */ + + idx = (duk_uint_fast_t) DUK_DEC_A(ins); + + /* Could add direct value stack handling. */ + duk_replace(thr, (duk_idx_t) (idx + 1)); /* 'this' binding */ + duk_replace(thr, (duk_idx_t) idx); /* variable value (function, we hope, not checked here) */ + break; + } + + case DUK_OP_CLOSURE: { + duk_activation *act; + duk_hcompfunc *fun_act; + duk_small_uint_fast_t bc = DUK_DEC_BC(ins); + duk_hobject *fun_temp; + + /* A -> target reg + * BC -> inner function index + */ + + DUK_DDD(DUK_DDDPRINT("CLOSURE to target register %ld, fnum %ld (count %ld)", + (long) DUK_DEC_A(ins), + (long) DUK_DEC_BC(ins), + (long) DUK_HCOMPFUNC_GET_FUNCS_COUNT(thr->heap, DUK__FUN()))); + + DUK_ASSERT_DISABLE(bc >= 0); /* unsigned */ + DUK_ASSERT((duk_uint_t) bc < (duk_uint_t) DUK_HCOMPFUNC_GET_FUNCS_COUNT(thr->heap, DUK__FUN())); + + act = thr->callstack_curr; + fun_act = (duk_hcompfunc *) DUK_ACT_GET_FUNC(act); + fun_temp = DUK_HCOMPFUNC_GET_FUNCS_BASE(thr->heap, fun_act)[bc]; + DUK_ASSERT(fun_temp != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC(fun_temp)); + + DUK_DDD( + DUK_DDDPRINT("CLOSURE: function template is: %p -> %!O", (void *) fun_temp, (duk_heaphdr *) fun_temp)); + + if (act->lex_env == NULL) { + DUK_ASSERT(act->var_env == NULL); + duk_js_init_activation_environment_records_delayed(thr, act); + act = thr->callstack_curr; + } + DUK_ASSERT(act->lex_env != NULL); + DUK_ASSERT(act->var_env != NULL); + + /* functions always have a NEWENV flag, i.e. they get a + * new variable declaration environment, so only lex_env + * matters here. + */ + duk_js_push_closure(thr, (duk_hcompfunc *) fun_temp, act->var_env, act->lex_env, 1 /*add_auto_proto*/); + DUK__REPLACE_TOP_A_BREAK(); + } + + case DUK_OP_GETVAR: { + duk_activation *act; + duk_tval *tv1; + duk_hstring *name; + + tv1 = DUK__CONSTP_BC(ins); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv1)); + name = DUK_TVAL_GET_STRING(tv1); + DUK_ASSERT(name != NULL); + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + (void) duk_js_getvar_activation(thr, act, name, 1 /*throw*/); /* -> [... val this] */ + duk_pop_unsafe(thr); /* 'this' binding is not needed here */ + DUK__REPLACE_TOP_A_BREAK(); + } + + case DUK_OP_PUTVAR: { + duk_activation *act; + duk_tval *tv1; + duk_hstring *name; + + tv1 = DUK__CONSTP_BC(ins); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv1)); + name = DUK_TVAL_GET_STRING(tv1); + DUK_ASSERT(name != NULL); + + /* XXX: putvar takes a duk_tval pointer, which is awkward and + * should be reworked. + */ + + tv1 = DUK__REGP_A(ins); /* val */ + act = thr->callstack_curr; + duk_js_putvar_activation(thr, act, name, tv1, DUK__STRICT()); + break; + } + + case DUK_OP_DELVAR: { + duk_activation *act; + duk_tval *tv1; + duk_hstring *name; + duk_bool_t rc; + + tv1 = DUK__CONSTP_BC(ins); + DUK_ASSERT(DUK_TVAL_IS_STRING(tv1)); + name = DUK_TVAL_GET_STRING(tv1); + DUK_ASSERT(name != NULL); + act = thr->callstack_curr; + rc = duk_js_delvar_activation(thr, act, name); + DUK__REPLACE_BOOL_A_BREAK(rc); + } + + case DUK_OP_JUMP: { + /* Note: without explicit cast to signed, MSVC will + * apparently generate a large positive jump when the + * bias-corrected value would normally be negative. + */ + curr_pc += (duk_int_fast_t) DUK_DEC_ABC(ins) - (duk_int_fast_t) DUK_BC_JUMP_BIAS; + break; + } + +#define DUK__RETURN_SHARED() \ + do { \ + duk_small_uint_t ret_result; \ + /* duk__handle_return() is guaranteed never to throw, except \ + * for potential out-of-memory situations which will then \ + * propagate out of the executor longjmp handler. \ + */ \ + DUK_ASSERT(thr->ptr_curr_pc == NULL); \ + ret_result = duk__handle_return(thr, entry_act); \ + if (ret_result == DUK__RETHAND_RESTART) { \ + goto restart_execution; \ + } \ + DUK_ASSERT(ret_result == DUK__RETHAND_FINISHED); \ + return; \ + } while (0) +#if defined(DUK_USE_EXEC_PREFER_SIZE) + case DUK_OP_RETREG: + case DUK_OP_RETCONST: + case DUK_OP_RETCONSTN: + case DUK_OP_RETUNDEF: { + /* BC -> return value reg/const */ + + DUK__SYNC_AND_NULL_CURR_PC(); + + if (op == DUK_OP_RETREG) { + duk_push_tval(thr, DUK__REGP_BC(ins)); + } else if (op == DUK_OP_RETUNDEF) { + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top)); /* valstack policy */ + thr->valstack_top++; + } else { + DUK_ASSERT(op == DUK_OP_RETCONST || op == DUK_OP_RETCONSTN); + duk_push_tval(thr, DUK__CONSTP_BC(ins)); + } + + DUK__RETURN_SHARED(); + } +#else /* DUK_USE_EXEC_PREFER_SIZE */ + case DUK_OP_RETREG: { + duk_tval *tv; + + DUK__SYNC_AND_NULL_CURR_PC(); + tv = DUK__REGP_BC(ins); + DUK_TVAL_SET_TVAL(thr->valstack_top, tv); + DUK_TVAL_INCREF(thr, tv); + thr->valstack_top++; + DUK__RETURN_SHARED(); + } + /* This will be unused without refcounting. */ + case DUK_OP_RETCONST: { + duk_tval *tv; + + DUK__SYNC_AND_NULL_CURR_PC(); + tv = DUK__CONSTP_BC(ins); + DUK_TVAL_SET_TVAL(thr->valstack_top, tv); + DUK_TVAL_INCREF(thr, tv); + thr->valstack_top++; + DUK__RETURN_SHARED(); + } + case DUK_OP_RETCONSTN: { + duk_tval *tv; + + DUK__SYNC_AND_NULL_CURR_PC(); + tv = DUK__CONSTP_BC(ins); + DUK_TVAL_SET_TVAL(thr->valstack_top, tv); +#if defined(DUK_USE_REFERENCE_COUNTING) + /* Without refcounting only RETCONSTN is used. */ + DUK_ASSERT(!DUK_TVAL_IS_HEAP_ALLOCATED(tv)); /* no INCREF for this constant */ +#endif + thr->valstack_top++; + DUK__RETURN_SHARED(); + } + case DUK_OP_RETUNDEF: { + DUK__SYNC_AND_NULL_CURR_PC(); + thr->valstack_top++; /* value at valstack top is already undefined by valstack policy */ + DUK_ASSERT(DUK_TVAL_IS_UNDEFINED(thr->valstack_top)); + DUK__RETURN_SHARED(); + } +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + + case DUK_OP_LABEL: { + duk_activation *act; + duk_catcher *cat; + duk_small_uint_fast_t bc = DUK_DEC_BC(ins); + + /* Allocate catcher and populate it (must be atomic). */ + + cat = duk_hthread_catcher_alloc(thr); + DUK_ASSERT(cat != NULL); + + cat->flags = (duk_uint32_t) (DUK_CAT_TYPE_LABEL | (bc << DUK_CAT_LABEL_SHIFT)); + cat->pc_base = (duk_instr_t *) curr_pc; /* pre-incremented, points to first jump slot */ + cat->idx_base = 0; /* unused for label */ + cat->h_varname = NULL; + + act = thr->callstack_curr; + DUK_ASSERT(act != NULL); + cat->parent = act->cat; + act->cat = cat; + + DUK_DDD(DUK_DDDPRINT("LABEL catcher: flags=0x%08lx, pc_base=%ld, " + "idx_base=%ld, h_varname=%!O, label_id=%ld", + (long) cat->flags, + (long) cat->pc_base, + (long) cat->idx_base, + (duk_heaphdr *) cat->h_varname, + (long) DUK_CAT_GET_LABEL(cat))); + + curr_pc += 2; /* skip jump slots */ + break; + } + + case DUK_OP_ENDLABEL: { + duk_activation *act; +#if (defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2)) || defined(DUK_USE_ASSERTIONS) + duk_small_uint_fast_t bc = DUK_DEC_BC(ins); +#endif +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) + DUK_DDD(DUK_DDDPRINT("ENDLABEL %ld", (long) bc)); +#endif + + act = thr->callstack_curr; + DUK_ASSERT(act->cat != NULL); + DUK_ASSERT(DUK_CAT_GET_TYPE(act->cat) == DUK_CAT_TYPE_LABEL); + DUK_ASSERT((duk_uint_fast_t) DUK_CAT_GET_LABEL(act->cat) == bc); + duk_hthread_catcher_unwind_nolexenv_norz(thr, act); + + /* no need to unwind callstack */ + break; + } + + case DUK_OP_BREAK: { + duk_small_uint_fast_t bc = DUK_DEC_BC(ins); + + DUK__SYNC_AND_NULL_CURR_PC(); + duk__handle_break_or_continue(thr, (duk_uint_t) bc, DUK_LJ_TYPE_BREAK); + goto restart_execution; + } + + case DUK_OP_CONTINUE: { + duk_small_uint_fast_t bc = DUK_DEC_BC(ins); + + DUK__SYNC_AND_NULL_CURR_PC(); + duk__handle_break_or_continue(thr, (duk_uint_t) bc, DUK_LJ_TYPE_CONTINUE); + goto restart_execution; + } + + /* XXX: move to helper, too large to be inline here */ + case DUK_OP_TRYCATCH: { + duk__handle_op_trycatch(thr, ins, curr_pc); + curr_pc += 2; /* skip jump slots */ + break; + } + + case DUK_OP_ENDTRY: { + curr_pc = duk__handle_op_endtry(thr, ins); + break; + } + + case DUK_OP_ENDCATCH: { + duk__handle_op_endcatch(thr, ins); + break; + } + + case DUK_OP_ENDFIN: { + /* Sync and NULL early. */ + DUK__SYNC_AND_NULL_CURR_PC(); + + if (duk__handle_op_endfin(thr, ins, entry_act) != 0) { + return; + } + + /* Must restart because we NULLed out curr_pc. */ + goto restart_execution; + } + + case DUK_OP_THROW: { + duk_small_uint_fast_t bc = DUK_DEC_BC(ins); + + /* Note: errors are augmented when they are created, not + * when they are thrown. So, don't augment here, it would + * break re-throwing for instance. + */ + + /* Sync so that augmentation sees up-to-date activations, NULL + * thr->ptr_curr_pc so that it's not used if side effects occur + * in augmentation or longjmp handling. + */ + DUK__SYNC_AND_NULL_CURR_PC(); + + duk_dup(thr, (duk_idx_t) bc); + DUK_DDD(DUK_DDDPRINT("THROW ERROR (BYTECODE): %!dT (before throw augment)", + (duk_tval *) duk_get_tval(thr, -1))); +#if defined(DUK_USE_AUGMENT_ERROR_THROW) + duk_err_augment_error_throw(thr); + DUK_DDD( + DUK_DDDPRINT("THROW ERROR (BYTECODE): %!dT (after throw augment)", (duk_tval *) duk_get_tval(thr, -1))); +#endif + + duk_err_setup_ljstate1(thr, DUK_LJ_TYPE_THROW, DUK_GET_TVAL_NEGIDX(thr, -1)); +#if defined(DUK_USE_DEBUGGER_SUPPORT) + duk_err_check_debugger_integration(thr); +#endif + + DUK_ASSERT(thr->heap->lj.jmpbuf_ptr != NULL); /* always in executor */ + duk_err_longjmp(thr); + DUK_UNREACHABLE(); + break; + } + + case DUK_OP_CSREG: { + /* + * Assuming a register binds to a variable declared within this + * function (a declarative binding), the 'this' for the call + * setup is always 'undefined'. E5 Section 10.2.1.1.6. + */ + + duk_small_uint_fast_t a = DUK_DEC_A(ins); + duk_small_uint_fast_t bc = DUK_DEC_BC(ins); + + /* A -> register containing target function (not type checked here) + * BC -> target registers (BC, BC + 1) for call setup + */ + +#if defined(DUK_USE_PREFER_SIZE) + duk_dup(thr, (duk_idx_t) a); + duk_replace(thr, (duk_idx_t) bc); + duk_to_undefined(thr, (duk_idx_t) (bc + 1)); +#else + duk_tval *tv1; + duk_tval *tv2; + duk_tval *tv3; + duk_tval tv_tmp1; + duk_tval tv_tmp2; + + tv1 = DUK__REGP(bc); + tv2 = tv1 + 1; + DUK_TVAL_SET_TVAL(&tv_tmp1, tv1); + DUK_TVAL_SET_TVAL(&tv_tmp2, tv2); + tv3 = DUK__REGP(a); + DUK_TVAL_SET_TVAL(tv1, tv3); + DUK_TVAL_INCREF(thr, tv1); /* no side effects */ + DUK_TVAL_SET_UNDEFINED(tv2); /* no need for incref */ + DUK_TVAL_DECREF(thr, &tv_tmp1); + DUK_TVAL_DECREF(thr, &tv_tmp2); +#endif + break; + } + + /* XXX: in some cases it's faster NOT to reuse the value + * stack but rather copy the arguments on top of the stack + * (mainly when the calling value stack is large and the value + * stack resize would be large). + */ + + case DUK_OP_CALL0: + case DUK_OP_CALL1: + case DUK_OP_CALL2: + case DUK_OP_CALL3: + case DUK_OP_CALL4: + case DUK_OP_CALL5: + case DUK_OP_CALL6: + case DUK_OP_CALL7: { + /* Opcode packs 4 flag bits: 1 for indirect, 3 map + * 1:1 to three lowest call handling flags. + * + * A -> nargs or register with nargs (indirect) + * BC -> base register for call (base -> func, base+1 -> this, base+2 -> arg1 ... base+2+N-1 -> argN) + */ + + duk_idx_t nargs; + duk_idx_t idx; + duk_small_uint_t call_flags; +#if !defined(DUK_USE_EXEC_FUN_LOCAL) + duk_hcompfunc *fun; +#endif + + DUK_ASSERT((DUK_OP_CALL0 & 0x0fU) == 0); + DUK_ASSERT((ins & DUK_BC_CALL_FLAG_INDIRECT) == 0); + + nargs = (duk_idx_t) DUK_DEC_A(ins); + call_flags = (ins & 0x07U) | DUK_CALL_FLAG_ALLOW_ECMATOECMA; + idx = (duk_idx_t) DUK_DEC_BC(ins); + + if (duk__executor_handle_call(thr, idx, nargs, call_flags)) { + /* curr_pc synced by duk_handle_call_unprotected() */ + DUK_ASSERT(thr->ptr_curr_pc == NULL); + goto restart_execution; + } + DUK_ASSERT(thr->ptr_curr_pc != NULL); + + /* duk_js_call.c is required to restore the stack reserve + * so we only need to reset the top. + */ +#if !defined(DUK_USE_EXEC_FUN_LOCAL) + fun = DUK__FUN(); +#endif + duk_set_top_unsafe(thr, (duk_idx_t) fun->nregs); + + /* No need to reinit setjmp() catchpoint, as call handling + * will store and restore our state. + * + * When debugger is enabled, we need to recheck the activation + * status after returning. This is now handled by call handling + * and heap->dbg_force_restart. + */ + break; + } + + case DUK_OP_CALL8: + case DUK_OP_CALL9: + case DUK_OP_CALL10: + case DUK_OP_CALL11: + case DUK_OP_CALL12: + case DUK_OP_CALL13: + case DUK_OP_CALL14: + case DUK_OP_CALL15: { + /* Indirect variant. */ + duk_uint_fast_t nargs; + duk_idx_t idx; + duk_small_uint_t call_flags; +#if !defined(DUK_USE_EXEC_FUN_LOCAL) + duk_hcompfunc *fun; +#endif + + DUK_ASSERT((DUK_OP_CALL0 & 0x0fU) == 0); + DUK_ASSERT((ins & DUK_BC_CALL_FLAG_INDIRECT) != 0); + + nargs = (duk_uint_fast_t) DUK_DEC_A(ins); + DUK__LOOKUP_INDIRECT(nargs); + call_flags = (ins & 0x07U) | DUK_CALL_FLAG_ALLOW_ECMATOECMA; + idx = (duk_idx_t) DUK_DEC_BC(ins); + + if (duk__executor_handle_call(thr, idx, (duk_idx_t) nargs, call_flags)) { + DUK_ASSERT(thr->ptr_curr_pc == NULL); + goto restart_execution; + } + DUK_ASSERT(thr->ptr_curr_pc != NULL); + +#if !defined(DUK_USE_EXEC_FUN_LOCAL) + fun = DUK__FUN(); +#endif + duk_set_top_unsafe(thr, (duk_idx_t) fun->nregs); + break; + } + + case DUK_OP_NEWOBJ: { + duk_push_object(thr); +#if defined(DUK_USE_ASSERTIONS) + { + duk_hobject *h; + h = duk_require_hobject(thr, -1); + DUK_ASSERT(DUK_HOBJECT_GET_ESIZE(h) == 0); + DUK_ASSERT(DUK_HOBJECT_GET_ENEXT(h) == 0); + DUK_ASSERT(DUK_HOBJECT_GET_ASIZE(h) == 0); + DUK_ASSERT(DUK_HOBJECT_GET_HSIZE(h) == 0); + } +#endif +#if !defined(DUK_USE_PREFER_SIZE) + /* XXX: could do a direct props realloc, but need hash size */ + duk_hobject_resize_entrypart(thr, duk_known_hobject(thr, -1), DUK_DEC_A(ins)); +#endif + DUK__REPLACE_TOP_BC_BREAK(); + } + + case DUK_OP_NEWARR: { + duk_push_array(thr); +#if defined(DUK_USE_ASSERTIONS) + { + duk_hobject *h; + h = duk_require_hobject(thr, -1); + DUK_ASSERT(DUK_HOBJECT_GET_ESIZE(h) == 0); + DUK_ASSERT(DUK_HOBJECT_GET_ENEXT(h) == 0); + DUK_ASSERT(DUK_HOBJECT_GET_ASIZE(h) == 0); + DUK_ASSERT(DUK_HOBJECT_GET_HSIZE(h) == 0); + DUK_ASSERT(DUK_HOBJECT_HAS_ARRAY_PART(h)); + } +#endif +#if !defined(DUK_USE_PREFER_SIZE) + duk_hobject_realloc_props(thr, + duk_known_hobject(thr, -1), + 0 /*new_e_size*/, + DUK_DEC_A(ins) /*new_a_size*/, + 0 /*new_h_size*/, + 0 /*abandon_array*/); +#if 0 + duk_hobject_resize_arraypart(thr, duk_known_hobject(thr, -1), DUK_DEC_A(ins)); +#endif +#endif + DUK__REPLACE_TOP_BC_BREAK(); + } + + case DUK_OP_MPUTOBJ: + case DUK_OP_MPUTOBJI: { + duk_idx_t obj_idx; + duk_uint_fast_t idx, idx_end; + duk_small_uint_fast_t count; + + /* A -> register of target object + * B -> first register of key/value pair list + * or register containing first register number if indirect + * C -> number of key/value pairs * 2 + * (= number of value stack indices used starting from 'B') + */ + + obj_idx = DUK_DEC_A(ins); + DUK_ASSERT(duk_is_object(thr, obj_idx)); + + idx = (duk_uint_fast_t) DUK_DEC_B(ins); + if (DUK_DEC_OP(ins) == DUK_OP_MPUTOBJI) { + DUK__LOOKUP_INDIRECT(idx); + } + + count = (duk_small_uint_fast_t) DUK_DEC_C(ins); + DUK_ASSERT(count > 0); /* compiler guarantees */ + idx_end = idx + count; + +#if defined(DUK_USE_EXEC_INDIRECT_BOUND_CHECK) + if (DUK_UNLIKELY(idx_end > (duk_uint_fast_t) duk_get_top(thr))) { + /* XXX: use duk_is_valid_index() instead? */ + /* XXX: improve check; check against nregs, not against top */ + DUK__INTERNAL_ERROR("MPUTOBJ out of bounds"); + } +#endif + + /* Use 'force' flag to duk_def_prop() to ensure that any + * inherited properties don't prevent the operation. + * With ES2015 duplicate properties are allowed, so that we + * must overwrite any previous data or accessor property. + * + * With ES2015 computed property names the literal keys + * may be arbitrary values and need to be ToPropertyKey() + * coerced at runtime. + */ + do { + /* XXX: faster initialization (direct access or better primitives) */ + duk_dup(thr, (duk_idx_t) idx); + duk_dup(thr, (duk_idx_t) (idx + 1)); + duk_def_prop(thr, + obj_idx, + DUK_DEFPROP_HAVE_VALUE | DUK_DEFPROP_FORCE | DUK_DEFPROP_SET_WRITABLE | + DUK_DEFPROP_SET_ENUMERABLE | DUK_DEFPROP_SET_CONFIGURABLE); + idx += 2; + } while (idx < idx_end); + break; + } + + case DUK_OP_INITSET: + case DUK_OP_INITGET: { + duk__handle_op_initset_initget(thr, ins); + break; + } + + case DUK_OP_MPUTARR: + case DUK_OP_MPUTARRI: { + duk_idx_t obj_idx; + duk_uint_fast_t idx, idx_end; + duk_small_uint_fast_t count; + duk_tval *tv1; + duk_uint32_t arr_idx; + + /* A -> register of target object + * B -> first register of value data (start_index, value1, value2, ..., valueN) + * or register containing first register number if indirect + * C -> number of key/value pairs (N) + */ + + obj_idx = DUK_DEC_A(ins); + DUK_ASSERT(duk_is_object(thr, obj_idx)); + + idx = (duk_uint_fast_t) DUK_DEC_B(ins); + if (DUK_DEC_OP(ins) == DUK_OP_MPUTARRI) { + DUK__LOOKUP_INDIRECT(idx); + } + + count = (duk_small_uint_fast_t) DUK_DEC_C(ins); + DUK_ASSERT(count > 0 + 1); /* compiler guarantees */ + idx_end = idx + count; + +#if defined(DUK_USE_EXEC_INDIRECT_BOUND_CHECK) + if (idx_end > (duk_uint_fast_t) duk_get_top(thr)) { + /* XXX: use duk_is_valid_index() instead? */ + /* XXX: improve check; check against nregs, not against top */ + DUK__INTERNAL_ERROR("MPUTARR out of bounds"); + } +#endif + + tv1 = DUK__REGP(idx); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv1)); +#if defined(DUK_USE_FASTINT) + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv1)); + arr_idx = (duk_uint32_t) DUK_TVAL_GET_FASTINT_U32(tv1); +#else + arr_idx = (duk_uint32_t) DUK_TVAL_GET_NUMBER(tv1); +#endif + idx++; + + do { + /* duk_xdef_prop() will define an own property without any array + * special behaviors. We'll need to set the array length explicitly + * in the end. For arrays with elisions, the compiler will emit an + * explicit SETALEN which will update the length. + */ + + /* XXX: because we're dealing with 'own' properties of a fresh array, + * the array initializer should just ensure that the array has a large + * enough array part and write the values directly into array part, + * and finally set 'length' manually in the end (as already happens now). + */ + + duk_dup(thr, (duk_idx_t) idx); + duk_xdef_prop_index_wec(thr, obj_idx, arr_idx); + + idx++; + arr_idx++; + } while (idx < idx_end); + + /* XXX: E5.1 Section 11.1.4 coerces the final length through + * ToUint32() which is odd but happens now as a side effect of + * 'arr_idx' type. + */ + duk_set_length(thr, obj_idx, (duk_size_t) (duk_uarridx_t) arr_idx); + break; + } + + case DUK_OP_SETALEN: { + duk_tval *tv1; + duk_hobject *h; + duk_uint32_t len; + + tv1 = DUK__REGP_A(ins); + DUK_ASSERT(DUK_TVAL_IS_OBJECT(tv1)); + h = DUK_TVAL_GET_OBJECT(tv1); + DUK_ASSERT(DUK_HOBJECT_IS_ARRAY(h)); + + tv1 = DUK__REGP_BC(ins); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv1)); +#if defined(DUK_USE_FASTINT) + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv1)); + len = (duk_uint32_t) DUK_TVAL_GET_FASTINT_U32(tv1); +#else + len = (duk_uint32_t) DUK_TVAL_GET_NUMBER(tv1); +#endif + ((duk_harray *) h)->length = len; + break; + } + + case DUK_OP_INITENUM: { + duk__handle_op_initenum(thr, ins); + break; + } + + case DUK_OP_NEXTENUM: { + curr_pc += duk__handle_op_nextenum(thr, ins); + break; + } + + case DUK_OP_INVLHS: { + DUK_ERROR_REFERENCE(thr, DUK_STR_INVALID_LVALUE); + DUK_WO_NORETURN(return;); + break; + } + + case DUK_OP_DEBUGGER: { + /* Opcode only emitted by compiler when debugger + * support is enabled. Ignore it silently without + * debugger support, in case it has been loaded + * from precompiled bytecode. + */ +#if defined(DUK_USE_DEBUGGER_SUPPORT) + if (duk_debug_is_attached(thr->heap)) { + DUK_D(DUK_DPRINT("DEBUGGER statement encountered, halt execution")); + DUK__SYNC_AND_NULL_CURR_PC(); + duk_debug_halt_execution(thr, 1 /*use_prev_pc*/); + DUK_D(DUK_DPRINT("DEBUGGER statement finished, resume execution")); + goto restart_execution; + } else { + DUK_D(DUK_DPRINT("DEBUGGER statement ignored, debugger not attached")); + } +#else + DUK_D(DUK_DPRINT("DEBUGGER statement ignored, no debugger support")); +#endif + break; + } + + case DUK_OP_NOP: { + /* Nop, ignored, but ABC fields may carry a value e.g. + * for indirect opcode handling. + */ + break; + } + + case DUK_OP_INVALID: { + DUK_ERROR_FMT1(thr, DUK_ERR_ERROR, "INVALID opcode (%ld)", (long) DUK_DEC_ABC(ins)); + DUK_WO_NORETURN(return;); + break; + } + +#if defined(DUK_USE_ES6) + case DUK_OP_NEWTARGET: { + duk_push_new_target(thr); + DUK__REPLACE_TOP_BC_BREAK(); + } +#endif /* DUK_USE_ES6 */ + +#if !defined(DUK_USE_EXEC_PREFER_SIZE) +#if !defined(DUK_USE_ES7_EXP_OPERATOR) + case DUK_OP_EXP_RR: + case DUK_OP_EXP_CR: + case DUK_OP_EXP_RC: + case DUK_OP_EXP_CC: +#endif +#if !defined(DUK_USE_ES6) + case DUK_OP_NEWTARGET: +#endif +#if !defined(DUK_USE_VERBOSE_ERRORS) + case DUK_OP_GETPROPC_RR: + case DUK_OP_GETPROPC_CR: + case DUK_OP_GETPROPC_RC: + case DUK_OP_GETPROPC_CC: +#endif + case DUK_OP_UNUSED207: + case DUK_OP_UNUSED212: + case DUK_OP_UNUSED213: + case DUK_OP_UNUSED214: + case DUK_OP_UNUSED215: + case DUK_OP_UNUSED216: + case DUK_OP_UNUSED217: + case DUK_OP_UNUSED218: + case DUK_OP_UNUSED219: + case DUK_OP_UNUSED220: + case DUK_OP_UNUSED221: + case DUK_OP_UNUSED222: + case DUK_OP_UNUSED223: + case DUK_OP_UNUSED224: + case DUK_OP_UNUSED225: + case DUK_OP_UNUSED226: + case DUK_OP_UNUSED227: + case DUK_OP_UNUSED228: + case DUK_OP_UNUSED229: + case DUK_OP_UNUSED230: + case DUK_OP_UNUSED231: + case DUK_OP_UNUSED232: + case DUK_OP_UNUSED233: + case DUK_OP_UNUSED234: + case DUK_OP_UNUSED235: + case DUK_OP_UNUSED236: + case DUK_OP_UNUSED237: + case DUK_OP_UNUSED238: + case DUK_OP_UNUSED239: + case DUK_OP_UNUSED240: + case DUK_OP_UNUSED241: + case DUK_OP_UNUSED242: + case DUK_OP_UNUSED243: + case DUK_OP_UNUSED244: + case DUK_OP_UNUSED245: + case DUK_OP_UNUSED246: + case DUK_OP_UNUSED247: + case DUK_OP_UNUSED248: + case DUK_OP_UNUSED249: + case DUK_OP_UNUSED250: + case DUK_OP_UNUSED251: + case DUK_OP_UNUSED252: + case DUK_OP_UNUSED253: + case DUK_OP_UNUSED254: + case DUK_OP_UNUSED255: + /* Force all case clauses to map to an actual handler + * so that the compiler can emit a jump without a bounds + * check: the switch argument is a duk_uint8_t so that + * the compiler may be able to figure it out. This is + * a small detail and obviously compiler dependent. + */ + /* default: clause omitted on purpose */ +#else /* DUK_USE_EXEC_PREFER_SIZE */ + default: +#endif /* DUK_USE_EXEC_PREFER_SIZE */ + { + /* Default case catches invalid/unsupported opcodes. */ + DUK_D(DUK_DPRINT("invalid opcode: %ld - %!I", (long) op, ins)); + DUK__INTERNAL_ERROR("invalid opcode"); + break; + } + + } /* end switch */ + + continue; + + /* Some shared exit paths for opcode handling below. These + * are mostly useful to reduce code footprint when multiple + * opcodes have a similar epilogue (like replacing stack top + * with index 'a'). + */ + +#if defined(DUK_USE_EXEC_PREFER_SIZE) + replace_top_a: + DUK__REPLACE_TO_TVPTR(thr, DUK__REGP_A(ins)); + continue; + replace_top_bc: + DUK__REPLACE_TO_TVPTR(thr, DUK__REGP_BC(ins)); + continue; +#endif + } + DUK_WO_NORETURN(return;); + +#if !defined(DUK_USE_VERBOSE_EXECUTOR_ERRORS) +internal_error: + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return;); +#endif +} + +/* automatic undefs */ +#undef DUK__BYTEOFF_A +#undef DUK__BYTEOFF_B +#undef DUK__BYTEOFF_BC +#undef DUK__BYTEOFF_C +#undef DUK__COMPARE_BODY +#undef DUK__CONST +#undef DUK__CONSTP +#undef DUK__CONSTP_A +#undef DUK__CONSTP_B +#undef DUK__CONSTP_BC +#undef DUK__CONSTP_C +#undef DUK__DELPROP_BODY +#undef DUK__EQ_BODY +#undef DUK__FUN +#undef DUK__GETPROPC_BODY +#undef DUK__GETPROP_BODY +#undef DUK__GE_BODY +#undef DUK__GT_BODY +#undef DUK__INSTOF_BODY +#undef DUK__INTERNAL_ERROR +#undef DUK__INT_NOACTION +#undef DUK__INT_RESTART +#undef DUK__IN_BODY +#undef DUK__LE_BODY +#undef DUK__LONGJMP_RESTART +#undef DUK__LONGJMP_RETHROW +#undef DUK__LOOKUP_INDIRECT +#undef DUK__LT_BODY +#undef DUK__MASK_A +#undef DUK__MASK_B +#undef DUK__MASK_BC +#undef DUK__MASK_C +#undef DUK__NEQ_BODY +#undef DUK__PUTPROP_BODY +#undef DUK__RCBIT_B +#undef DUK__RCBIT_C +#undef DUK__REG +#undef DUK__REGCONSTP_B +#undef DUK__REGCONSTP_C +#undef DUK__REGP +#undef DUK__REGP_A +#undef DUK__REGP_B +#undef DUK__REGP_BC +#undef DUK__REGP_C +#undef DUK__REPLACE_BOOL_A_BREAK +#undef DUK__REPLACE_TOP_A_BREAK +#undef DUK__REPLACE_TOP_BC_BREAK +#undef DUK__REPLACE_TO_TVPTR +#undef DUK__RETHAND_FINISHED +#undef DUK__RETHAND_RESTART +#undef DUK__RETURN_SHARED +#undef DUK__SEQ_BODY +#undef DUK__SHIFT_A +#undef DUK__SHIFT_B +#undef DUK__SHIFT_BC +#undef DUK__SHIFT_C +#undef DUK__SNEQ_BODY +#undef DUK__STRICT +#undef DUK__SYNC_AND_NULL_CURR_PC +#undef DUK__SYNC_CURR_PC +#undef DUK__TVAL_SHIFT +#line 1 "duk_js_ops.c" +/* + * ECMAScript specification algorithm and conversion helpers. + * + * These helpers encapsulate the primitive ECMAScript operation semantics, + * and are used by the bytecode executor and the API (among other places). + * Some primitives are only implemented as part of the API and have no + * "internal" helper. This is the case when an internal helper would not + * really be useful; e.g. the operation is rare, uses value stack heavily, + * etc. + * + * The operation arguments depend on what is required to implement + * the operation: + * + * - If an operation is simple and stateless, and has no side + * effects, it won't take an duk_hthread argument and its + * arguments may be duk_tval pointers (which are safe as long + * as no side effects take place). + * + * - If complex coercions are required (e.g. a "ToNumber" coercion) + * or errors may be thrown, the operation takes an duk_hthread + * argument. This also implies that the operation may have + * arbitrary side effects, invalidating any duk_tval pointers. + * + * - For operations with potential side effects, arguments can be + * taken in several ways: + * + * a) as duk_tval pointers, which makes sense if the "common case" + * can be resolved without side effects (e.g. coercion); the + * arguments are pushed to the valstack for coercion if + * necessary + * + * b) as duk_tval values + * + * c) implicitly on value stack top + * + * d) as indices to the value stack + * + * Future work: + * + * - Argument styles may not be the most sensible in every case now. + * + * - In-place coercions might be useful for several operations, if + * in-place coercion is OK for the bytecode executor and the API. + */ + +/* #include duk_internal.h -> already included */ + +/* + * ToPrimitive() (E5 Section 9.1) + * + * ==> implemented in the API. + */ + +/* + * ToBoolean() (E5 Section 9.2) + */ + +DUK_INTERNAL duk_bool_t duk_js_toboolean(duk_tval *tv) { + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNDEFINED: + case DUK_TAG_NULL: + return 0; + case DUK_TAG_BOOLEAN: + DUK_ASSERT(DUK_TVAL_GET_BOOLEAN(tv) == 0 || DUK_TVAL_GET_BOOLEAN(tv) == 1); + return DUK_TVAL_GET_BOOLEAN(tv); + case DUK_TAG_STRING: { + /* Symbols ToBoolean() coerce to true, regardless of their + * description. This happens with no explicit check because + * of the symbol representation byte prefix. + */ + duk_hstring *h = DUK_TVAL_GET_STRING(tv); + DUK_ASSERT(h != NULL); + return (DUK_HSTRING_GET_BYTELEN(h) > 0 ? 1 : 0); + } + case DUK_TAG_OBJECT: { + return 1; + } + case DUK_TAG_BUFFER: { + /* Mimic Uint8Array semantics: objects coerce true, regardless + * of buffer length (zero or not) or context. + */ + return 1; + } + case DUK_TAG_POINTER: { + void *p = DUK_TVAL_GET_POINTER(tv); + return (p != NULL ? 1 : 0); + } + case DUK_TAG_LIGHTFUNC: { + return 1; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: + if (DUK_TVAL_GET_FASTINT(tv) != 0) { + return 1; + } else { + return 0; + } +#endif + default: { + /* number */ + duk_double_t d; +#if defined(DUK_USE_PREFER_SIZE) + int c; +#endif + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_DOUBLE(tv)); + d = DUK_TVAL_GET_DOUBLE(tv); +#if defined(DUK_USE_PREFER_SIZE) + c = DUK_FPCLASSIFY((double) d); + if (c == DUK_FP_ZERO || c == DUK_FP_NAN) { + return 0; + } else { + return 1; + } +#else + DUK_ASSERT(duk_double_is_nan_or_zero(d) == 0 || duk_double_is_nan_or_zero(d) == 1); + return duk_double_is_nan_or_zero(d) ^ 1; +#endif + } + } + DUK_UNREACHABLE(); + DUK_WO_UNREACHABLE(return 0;); +} + +/* + * ToNumber() (E5 Section 9.3) + * + * Value to convert must be on stack top, and is popped before exit. + * + * See: http://www.cs.indiana.edu/~burger/FP-Printing-PLDI96.pdf + * http://www.cs.indiana.edu/~burger/fp/index.html + * + * Notes on the conversion: + * + * - There are specific requirements on the accuracy of the conversion + * through a "Mathematical Value" (MV), so this conversion is not + * trivial. + * + * - Quick rejects (e.g. based on first char) are difficult because + * the grammar allows leading and trailing white space. + * + * - Quick reject based on string length is difficult even after + * accounting for white space; there may be arbitrarily many + * decimal digits. + * + * - Standard grammar allows decimal values ("123"), hex values + * ("0x123") and infinities + * + * - Unlike source code literals, ToNumber() coerces empty strings + * and strings with only whitespace to zero (not NaN). However, + * while '' coerces to 0, '+' and '-' coerce to NaN. + */ + +/* E5 Section 9.3.1 */ +DUK_LOCAL duk_double_t duk__tonumber_string_raw(duk_hthread *thr) { + duk_small_uint_t s2n_flags; + duk_double_t d; + + DUK_ASSERT(duk_is_string(thr, -1)); + + /* Quite lenient, e.g. allow empty as zero, but don't allow trailing + * garbage. + */ + s2n_flags = DUK_S2N_FLAG_TRIM_WHITE | DUK_S2N_FLAG_ALLOW_EXP | DUK_S2N_FLAG_ALLOW_PLUS | DUK_S2N_FLAG_ALLOW_MINUS | + DUK_S2N_FLAG_ALLOW_INF | DUK_S2N_FLAG_ALLOW_FRAC | DUK_S2N_FLAG_ALLOW_NAKED_FRAC | + DUK_S2N_FLAG_ALLOW_EMPTY_FRAC | DUK_S2N_FLAG_ALLOW_EMPTY_AS_ZERO | DUK_S2N_FLAG_ALLOW_LEADING_ZERO | + DUK_S2N_FLAG_ALLOW_AUTO_HEX_INT | DUK_S2N_FLAG_ALLOW_AUTO_OCT_INT | DUK_S2N_FLAG_ALLOW_AUTO_BIN_INT; + + duk_numconv_parse(thr, 10 /*radix*/, s2n_flags); + +#if defined(DUK_USE_PREFER_SIZE) + d = duk_get_number(thr, -1); + duk_pop_unsafe(thr); +#else + thr->valstack_top--; + DUK_ASSERT(DUK_TVAL_IS_NUMBER(thr->valstack_top)); + DUK_ASSERT(DUK_TVAL_IS_DOUBLE(thr->valstack_top)); /* no fastint conversion in numconv now */ + DUK_ASSERT(!DUK_TVAL_NEEDS_REFCOUNT_UPDATE(thr->valstack_top)); + d = DUK_TVAL_GET_DOUBLE(thr->valstack_top); /* assumes not a fastint */ + DUK_TVAL_SET_UNDEFINED(thr->valstack_top); +#endif + + return d; +} + +DUK_INTERNAL duk_double_t duk_js_tonumber(duk_hthread *thr, duk_tval *tv) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(tv != NULL); + + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_UNDEFINED: { + /* return a specific NaN (although not strictly necessary) */ + duk_double_union du; + DUK_DBLUNION_SET_NAN(&du); + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&du)); + return du.d; + } + case DUK_TAG_NULL: { + /* +0.0 */ + return 0.0; + } + case DUK_TAG_BOOLEAN: { + if (DUK_TVAL_IS_BOOLEAN_TRUE(tv)) { + return 1.0; + } + return 0.0; + } + case DUK_TAG_STRING: { + /* For Symbols ToNumber() is always a TypeError. */ + duk_hstring *h = DUK_TVAL_GET_STRING(tv); + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(h))) { + DUK_ERROR_TYPE(thr, DUK_STR_CANNOT_NUMBER_COERCE_SYMBOL); + DUK_WO_NORETURN(return 0.0;); + } + duk_push_hstring(thr, h); + return duk__tonumber_string_raw(thr); + } + case DUK_TAG_BUFFER: /* plain buffer treated like object */ + case DUK_TAG_OBJECT: { + duk_double_t d; + duk_push_tval(thr, tv); + duk_to_primitive(thr, -1, DUK_HINT_NUMBER); /* 'tv' becomes invalid */ + + /* recursive call for a primitive value (guaranteed not to cause second + * recursion). + */ + DUK_ASSERT(duk_get_tval(thr, -1) != NULL); + d = duk_js_tonumber(thr, duk_get_tval(thr, -1)); + + duk_pop_unsafe(thr); + return d; + } + case DUK_TAG_POINTER: { + /* Coerce like boolean */ + void *p = DUK_TVAL_GET_POINTER(tv); + return (p != NULL ? 1.0 : 0.0); + } + case DUK_TAG_LIGHTFUNC: { + /* +(function(){}) -> NaN */ + return DUK_DOUBLE_NAN; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: + return (duk_double_t) DUK_TVAL_GET_FASTINT(tv); +#endif + default: { + /* number */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv)); + DUK_ASSERT(DUK_TVAL_IS_DOUBLE(tv)); + return DUK_TVAL_GET_DOUBLE(tv); + } + } + + DUK_UNREACHABLE(); + DUK_WO_UNREACHABLE(return 0.0;); +} + +/* + * ToInteger() (E5 Section 9.4) + */ + +/* exposed, used by e.g. duk_bi_date.c */ +DUK_INTERNAL duk_double_t duk_js_tointeger_number(duk_double_t x) { +#if defined(DUK_USE_PREFER_SIZE) + duk_small_int_t c = (duk_small_int_t) DUK_FPCLASSIFY(x); + + if (DUK_UNLIKELY(c == DUK_FP_NAN)) { + return 0.0; + } else if (DUK_UNLIKELY(c == DUK_FP_INFINITE)) { + return x; + } else { + /* Finite, including neg/pos zero. Neg zero sign must be + * preserved. + */ + return duk_double_trunc_towards_zero(x); + } +#else /* DUK_USE_PREFER_SIZE */ + /* NaN and Infinity have the same exponent so it's a cheap + * initial check for the rare path. + */ + if (DUK_UNLIKELY(duk_double_is_nan_or_inf(x) != 0U)) { + if (duk_double_is_nan(x)) { + return 0.0; + } else { + return x; + } + } else { + return duk_double_trunc_towards_zero(x); + } +#endif /* DUK_USE_PREFER_SIZE */ +} + +DUK_INTERNAL duk_double_t duk_js_tointeger(duk_hthread *thr, duk_tval *tv) { + /* XXX: fastint */ + duk_double_t d = duk_js_tonumber(thr, tv); /* invalidates tv */ + return duk_js_tointeger_number(d); +} + +/* + * ToInt32(), ToUint32(), ToUint16() (E5 Sections 9.5, 9.6, 9.7) + */ + +/* combined algorithm matching E5 Sections 9.5 and 9.6 */ +DUK_LOCAL duk_double_t duk__toint32_touint32_helper(duk_double_t x, duk_bool_t is_toint32) { +#if defined(DUK_USE_PREFER_SIZE) + duk_small_int_t c; +#endif + +#if defined(DUK_USE_PREFER_SIZE) + c = (duk_small_int_t) DUK_FPCLASSIFY(x); + if (c == DUK_FP_NAN || c == DUK_FP_ZERO || c == DUK_FP_INFINITE) { + return 0.0; + } +#else + if (duk_double_is_nan_zero_inf(x)) { + return 0.0; + } +#endif + + /* x = sign(x) * floor(abs(x)), i.e. truncate towards zero, keep sign */ + x = duk_double_trunc_towards_zero(x); + + /* NOTE: fmod(x) result sign is same as sign of x, which + * differs from what Javascript wants (see Section 9.6). + */ + + x = DUK_FMOD(x, DUK_DOUBLE_2TO32); /* -> x in ]-2**32, 2**32[ */ + + if (x < 0.0) { + x += DUK_DOUBLE_2TO32; + } + DUK_ASSERT(x >= 0 && x < DUK_DOUBLE_2TO32); /* -> x in [0, 2**32[ */ + + if (is_toint32) { + if (x >= DUK_DOUBLE_2TO31) { + /* x in [2**31, 2**32[ */ + + x -= DUK_DOUBLE_2TO32; /* -> x in [-2**31,2**31[ */ + } + } + + return x; +} + +DUK_INTERNAL duk_int32_t duk_js_toint32(duk_hthread *thr, duk_tval *tv) { + duk_double_t d; + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv)) { + return DUK_TVAL_GET_FASTINT_I32(tv); + } +#endif + + d = duk_js_tonumber(thr, tv); /* invalidates tv */ + d = duk__toint32_touint32_helper(d, 1); + DUK_ASSERT(DUK_FPCLASSIFY(d) == DUK_FP_ZERO || DUK_FPCLASSIFY(d) == DUK_FP_NORMAL); + DUK_ASSERT(d >= -2147483648.0 && d <= 2147483647.0); /* [-0x80000000,0x7fffffff] */ + DUK_ASSERT(duk_double_equals(d, (duk_double_t) ((duk_int32_t) d))); /* whole, won't clip */ + return (duk_int32_t) d; +} + +DUK_INTERNAL duk_uint32_t duk_js_touint32(duk_hthread *thr, duk_tval *tv) { + duk_double_t d; + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv)) { + return DUK_TVAL_GET_FASTINT_U32(tv); + } +#endif + + d = duk_js_tonumber(thr, tv); /* invalidates tv */ + d = duk__toint32_touint32_helper(d, 0); + DUK_ASSERT(DUK_FPCLASSIFY(d) == DUK_FP_ZERO || DUK_FPCLASSIFY(d) == DUK_FP_NORMAL); + DUK_ASSERT(d >= 0.0 && d <= 4294967295.0); /* [0x00000000, 0xffffffff] */ + DUK_ASSERT(duk_double_equals(d, (duk_double_t) ((duk_uint32_t) d))); /* whole, won't clip */ + return (duk_uint32_t) d; +} + +DUK_INTERNAL duk_uint16_t duk_js_touint16(duk_hthread *thr, duk_tval *tv) { + /* should be a safe way to compute this */ + return (duk_uint16_t) (duk_js_touint32(thr, tv) & 0x0000ffffU); +} + +/* + * ToString() (E5 Section 9.8) + * ToObject() (E5 Section 9.9) + * CheckObjectCoercible() (E5 Section 9.10) + * IsCallable() (E5 Section 9.11) + * + * ==> implemented in the API. + */ + +/* + * Loose equality, strict equality, and SameValue (E5 Sections 11.9.1, 11.9.4, + * 9.12). These have much in common so they can share some helpers. + * + * Future work notes: + * + * - Current implementation (and spec definition) has recursion; this should + * be fixed if possible. + * + * - String-to-number coercion should be possible without going through the + * value stack (and be more compact) if a shared helper is invoked. + */ + +/* Note that this is the same operation for strict and loose equality: + * - E5 Section 11.9.3, step 1.c (loose) + * - E5 Section 11.9.6, step 4 (strict) + */ + +DUK_LOCAL duk_bool_t duk__js_equals_number(duk_double_t x, duk_double_t y) { +#if defined(DUK_USE_PARANOID_MATH) + /* Straightforward algorithm, makes fewer compiler assumptions. */ + duk_small_int_t cx = (duk_small_int_t) DUK_FPCLASSIFY(x); + duk_small_int_t cy = (duk_small_int_t) DUK_FPCLASSIFY(y); + if (cx == DUK_FP_NAN || cy == DUK_FP_NAN) { + return 0; + } + if (cx == DUK_FP_ZERO && cy == DUK_FP_ZERO) { + return 1; + } + if (x == y) { + return 1; + } + return 0; +#else /* DUK_USE_PARANOID_MATH */ + /* Better equivalent algorithm. If the compiler is compliant, C and + * ECMAScript semantics are identical for this particular comparison. + * In particular, NaNs must never compare equal and zeroes must compare + * equal regardless of sign. Could also use a macro, but this inlines + * already nicely (no difference on gcc, for instance). + */ + if (duk_double_equals(x, y)) { + /* IEEE requires that NaNs compare false */ + DUK_ASSERT(DUK_FPCLASSIFY(x) != DUK_FP_NAN); + DUK_ASSERT(DUK_FPCLASSIFY(y) != DUK_FP_NAN); + return 1; + } else { + /* IEEE requires that zeros compare the same regardless + * of their signed, so if both x and y are zeroes, they + * are caught above. + */ + DUK_ASSERT(!(DUK_FPCLASSIFY(x) == DUK_FP_ZERO && DUK_FPCLASSIFY(y) == DUK_FP_ZERO)); + return 0; + } +#endif /* DUK_USE_PARANOID_MATH */ +} + +DUK_LOCAL duk_bool_t duk__js_samevalue_number(duk_double_t x, duk_double_t y) { +#if defined(DUK_USE_PARANOID_MATH) + duk_small_int_t cx = (duk_small_int_t) DUK_FPCLASSIFY(x); + duk_small_int_t cy = (duk_small_int_t) DUK_FPCLASSIFY(y); + + if (cx == DUK_FP_NAN && cy == DUK_FP_NAN) { + /* SameValue(NaN, NaN) = true, regardless of NaN sign or extra bits */ + return 1; + } + if (cx == DUK_FP_ZERO && cy == DUK_FP_ZERO) { + /* Note: cannot assume that a non-zero return value of signbit() would + * always be the same -- hence cannot (portably) use something like: + * + * signbit(x) == signbit(y) + */ + duk_small_int_t sx = DUK_SIGNBIT(x) ? 1 : 0; + duk_small_int_t sy = DUK_SIGNBIT(y) ? 1 : 0; + return (sx == sy); + } + + /* normal comparison; known: + * - both x and y are not NaNs (but one of them can be) + * - both x and y are not zero (but one of them can be) + * - x and y may be denormal or infinite + */ + + return (x == y); +#else /* DUK_USE_PARANOID_MATH */ + duk_small_int_t cx = (duk_small_int_t) DUK_FPCLASSIFY(x); + duk_small_int_t cy = (duk_small_int_t) DUK_FPCLASSIFY(y); + + if (duk_double_equals(x, y)) { + /* IEEE requires that NaNs compare false */ + DUK_ASSERT(DUK_FPCLASSIFY(x) != DUK_FP_NAN); + DUK_ASSERT(DUK_FPCLASSIFY(y) != DUK_FP_NAN); + + /* Using classification has smaller footprint than direct comparison. */ + if (DUK_UNLIKELY(cx == DUK_FP_ZERO && cy == DUK_FP_ZERO)) { + /* Note: cannot assume that a non-zero return value of signbit() would + * always be the same -- hence cannot (portably) use something like: + * + * signbit(x) == signbit(y) + */ + return duk_double_same_sign(x, y); + } + return 1; + } else { + /* IEEE requires that zeros compare the same regardless + * of their sign, so if both x and y are zeroes, they + * are caught above. + */ + DUK_ASSERT(!(DUK_FPCLASSIFY(x) == DUK_FP_ZERO && DUK_FPCLASSIFY(y) == DUK_FP_ZERO)); + + /* Difference to non-strict/strict comparison is that NaNs compare + * equal and signed zero signs matter. + */ + if (DUK_UNLIKELY(cx == DUK_FP_NAN && cy == DUK_FP_NAN)) { + /* SameValue(NaN, NaN) = true, regardless of NaN sign or extra bits */ + return 1; + } + return 0; + } +#endif /* DUK_USE_PARANOID_MATH */ +} + +DUK_INTERNAL duk_bool_t duk_js_equals_helper(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y, duk_small_uint_t flags) { + duk_uint_t type_mask_x; + duk_uint_t type_mask_y; + + /* If flags != 0 (strict or SameValue), thr can be NULL. For loose + * equals comparison it must be != NULL. + */ + DUK_ASSERT(flags != 0 || thr != NULL); + + /* + * Same type? + * + * Note: since number values have no explicit tag in the 8-byte + * representation, need the awkward if + switch. + */ + +#if defined(DUK_USE_FASTINT) + if (DUK_TVAL_IS_FASTINT(tv_x) && DUK_TVAL_IS_FASTINT(tv_y)) { + if (DUK_TVAL_GET_FASTINT(tv_x) == DUK_TVAL_GET_FASTINT(tv_y)) { + return 1; + } else { + return 0; + } + } else +#endif + if (DUK_TVAL_IS_NUMBER(tv_x) && DUK_TVAL_IS_NUMBER(tv_y)) { + duk_double_t d1, d2; + + /* Catches both doubles and cases where only one argument is + * a fastint so can't assume a double. + */ + d1 = DUK_TVAL_GET_NUMBER(tv_x); + d2 = DUK_TVAL_GET_NUMBER(tv_y); + if (DUK_UNLIKELY((flags & DUK_EQUALS_FLAG_SAMEVALUE) != 0)) { + /* SameValue */ + return duk__js_samevalue_number(d1, d2); + } else { + /* equals and strict equals */ + return duk__js_equals_number(d1, d2); + } + } else if (DUK_TVAL_GET_TAG(tv_x) == DUK_TVAL_GET_TAG(tv_y)) { + switch (DUK_TVAL_GET_TAG(tv_x)) { + case DUK_TAG_UNDEFINED: + case DUK_TAG_NULL: { + return 1; + } + case DUK_TAG_BOOLEAN: { + return DUK_TVAL_GET_BOOLEAN(tv_x) == DUK_TVAL_GET_BOOLEAN(tv_y); + } + case DUK_TAG_POINTER: { + return DUK_TVAL_GET_POINTER(tv_x) == DUK_TVAL_GET_POINTER(tv_y); + } + case DUK_TAG_STRING: + case DUK_TAG_OBJECT: { + /* Heap pointer comparison suffices for strings and objects. + * Symbols compare equal if they have the same internal + * representation; again heap pointer comparison suffices. + */ + return DUK_TVAL_GET_HEAPHDR(tv_x) == DUK_TVAL_GET_HEAPHDR(tv_y); + } + case DUK_TAG_BUFFER: { + /* In Duktape 2.x plain buffers mimic Uint8Array objects + * so always compare by heap pointer. In Duktape 1.x + * strict comparison would compare heap pointers and + * non-strict would compare contents. + */ + return DUK_TVAL_GET_HEAPHDR(tv_x) == DUK_TVAL_GET_HEAPHDR(tv_y); + } + case DUK_TAG_LIGHTFUNC: { + /* At least 'magic' has a significant impact on function + * identity. + */ + duk_small_uint_t lf_flags_x; + duk_small_uint_t lf_flags_y; + duk_c_function func_x; + duk_c_function func_y; + + DUK_TVAL_GET_LIGHTFUNC(tv_x, func_x, lf_flags_x); + DUK_TVAL_GET_LIGHTFUNC(tv_y, func_y, lf_flags_y); + return ((func_x == func_y) && (lf_flags_x == lf_flags_y)) ? 1 : 0; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: { + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv_x)); + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv_y)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_x)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_y)); + DUK_UNREACHABLE(); + DUK_WO_UNREACHABLE(return 0;); + } + } + } + + if ((flags & (DUK_EQUALS_FLAG_STRICT | DUK_EQUALS_FLAG_SAMEVALUE)) != 0) { + return 0; + } + + DUK_ASSERT(flags == 0); /* non-strict equality from here on */ + + /* + * Types are different; various cases for non-strict comparison + * + * Since comparison is symmetric, we use a "swap trick" to reduce + * code size. + */ + + type_mask_x = duk_get_type_mask_tval(tv_x); + type_mask_y = duk_get_type_mask_tval(tv_y); + + /* Undefined/null are considered equal (e.g. "null == undefined" -> true). */ + if ((type_mask_x & (DUK_TYPE_MASK_UNDEFINED | DUK_TYPE_MASK_NULL)) && + (type_mask_y & (DUK_TYPE_MASK_NULL | DUK_TYPE_MASK_UNDEFINED))) { + return 1; + } + + /* Number/string -> coerce string to number (e.g. "'1.5' == 1.5" -> true). */ + if ((type_mask_x & DUK_TYPE_MASK_NUMBER) && (type_mask_y & DUK_TYPE_MASK_STRING)) { + if (!DUK_TVAL_STRING_IS_SYMBOL(tv_y)) { + duk_double_t d1, d2; + d1 = DUK_TVAL_GET_NUMBER(tv_x); + d2 = duk_to_number_tval(thr, tv_y); + return duk__js_equals_number(d1, d2); + } + } + if ((type_mask_x & DUK_TYPE_MASK_STRING) && (type_mask_y & DUK_TYPE_MASK_NUMBER)) { + if (!DUK_TVAL_STRING_IS_SYMBOL(tv_x)) { + duk_double_t d1, d2; + d1 = DUK_TVAL_GET_NUMBER(tv_y); + d2 = duk_to_number_tval(thr, tv_x); + return duk__js_equals_number(d1, d2); + } + } + + /* Boolean/any -> coerce boolean to number and try again. If boolean is + * compared to a pointer, the final comparison after coercion now always + * yields false (as pointer vs. number compares to false), but this is + * not special cased. + * + * ToNumber(bool) is +1.0 or 0.0. Tagged boolean value is always 0 or 1. + */ + if (type_mask_x & DUK_TYPE_MASK_BOOLEAN) { + DUK_ASSERT(DUK_TVAL_GET_BOOLEAN(tv_x) == 0 || DUK_TVAL_GET_BOOLEAN(tv_x) == 1); + duk_push_uint(thr, DUK_TVAL_GET_BOOLEAN(tv_x)); + duk_push_tval(thr, tv_y); + goto recursive_call; + } + if (type_mask_y & DUK_TYPE_MASK_BOOLEAN) { + DUK_ASSERT(DUK_TVAL_GET_BOOLEAN(tv_y) == 0 || DUK_TVAL_GET_BOOLEAN(tv_y) == 1); + duk_push_tval(thr, tv_x); + duk_push_uint(thr, DUK_TVAL_GET_BOOLEAN(tv_y)); + goto recursive_call; + } + + /* String-number-symbol/object -> coerce object to primitive (apparently without hint), then try again. */ + if ((type_mask_x & (DUK_TYPE_MASK_STRING | DUK_TYPE_MASK_NUMBER)) && (type_mask_y & DUK_TYPE_MASK_OBJECT)) { + /* No symbol check needed because symbols and strings are accepted. */ + duk_push_tval(thr, tv_x); + duk_push_tval(thr, tv_y); + duk_to_primitive(thr, -1, DUK_HINT_NONE); /* apparently no hint? */ + goto recursive_call; + } + if ((type_mask_x & DUK_TYPE_MASK_OBJECT) && (type_mask_y & (DUK_TYPE_MASK_STRING | DUK_TYPE_MASK_NUMBER))) { + /* No symbol check needed because symbols and strings are accepted. */ + duk_push_tval(thr, tv_x); + duk_push_tval(thr, tv_y); + duk_to_primitive(thr, -2, DUK_HINT_NONE); /* apparently no hint? */ + goto recursive_call; + } + + /* Nothing worked -> not equal. */ + return 0; + +recursive_call: + /* Shared code path to call the helper again with arguments on stack top. */ + { + duk_bool_t rc; + rc = duk_js_equals_helper(thr, DUK_GET_TVAL_NEGIDX(thr, -2), DUK_GET_TVAL_NEGIDX(thr, -1), 0 /*flags:nonstrict*/); + duk_pop_2_unsafe(thr); + return rc; + } +} + +/* + * Comparisons (x >= y, x > y, x <= y, x < y) + * + * E5 Section 11.8.5: implement 'x < y' and then use negate and eval_left_first + * flags to get the rest. + */ + +/* XXX: this should probably just operate on the stack top, because it + * needs to push stuff on the stack anyway... + */ + +DUK_INTERNAL duk_small_int_t duk_js_data_compare(const duk_uint8_t *buf1, + const duk_uint8_t *buf2, + duk_size_t len1, + duk_size_t len2) { + duk_size_t prefix_len; + duk_small_int_t rc; + + prefix_len = (len1 <= len2 ? len1 : len2); + + /* duk_memcmp() is guaranteed to return zero (equal) for zero length + * inputs. + */ + rc = duk_memcmp_unsafe((const void *) buf1, (const void *) buf2, (size_t) prefix_len); + + if (rc < 0) { + return -1; + } else if (rc > 0) { + return 1; + } + + /* prefix matches, lengths matter now */ + if (len1 < len2) { + /* e.g. "x" < "xx" */ + return -1; + } else if (len1 > len2) { + return 1; + } + + return 0; +} + +DUK_INTERNAL duk_small_int_t duk_js_string_compare(duk_hstring *h1, duk_hstring *h2) { + /* + * String comparison (E5 Section 11.8.5, step 4), which + * needs to compare codepoint by codepoint. + * + * However, UTF-8 allows us to use strcmp directly: the shared + * prefix will be encoded identically (UTF-8 has unique encoding) + * and the first differing character can be compared with a simple + * unsigned byte comparison (which strcmp does). + * + * This will not work properly for non-xutf-8 strings, but this + * is not an issue for compliance. + */ + + DUK_ASSERT(h1 != NULL); + DUK_ASSERT(h2 != NULL); + + return duk_js_data_compare((const duk_uint8_t *) DUK_HSTRING_GET_DATA(h1), + (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h2), + (duk_size_t) DUK_HSTRING_GET_BYTELEN(h1), + (duk_size_t) DUK_HSTRING_GET_BYTELEN(h2)); +} + +#if 0 /* unused */ +DUK_INTERNAL duk_small_int_t duk_js_buffer_compare(duk_heap *heap, duk_hbuffer *h1, duk_hbuffer *h2) { + /* Similar to String comparison. */ + + DUK_ASSERT(h1 != NULL); + DUK_ASSERT(h2 != NULL); + DUK_UNREF(heap); + + return duk_js_data_compare((const duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(heap, h1), + (const duk_uint8_t *) DUK_HBUFFER_GET_DATA_PTR(heap, h2), + (duk_size_t) DUK_HBUFFER_GET_SIZE(h1), + (duk_size_t) DUK_HBUFFER_GET_SIZE(h2)); +} +#endif + +#if defined(DUK_USE_FASTINT) +DUK_LOCAL duk_bool_t duk__compare_fastint(duk_bool_t retval, duk_int64_t v1, duk_int64_t v2) { + DUK_ASSERT(retval == 0 || retval == 1); + if (v1 < v2) { + return retval ^ 1; + } else { + return retval; + } +} +#endif + +#if defined(DUK_USE_PARANOID_MATH) +DUK_LOCAL duk_bool_t duk__compare_number(duk_bool_t retval, duk_double_t d1, duk_double_t d2) { + duk_small_int_t c1, s1, c2, s2; + + DUK_ASSERT(retval == 0 || retval == 1); + c1 = (duk_small_int_t) DUK_FPCLASSIFY(d1); + s1 = (duk_small_int_t) DUK_SIGNBIT(d1); + c2 = (duk_small_int_t) DUK_FPCLASSIFY(d2); + s2 = (duk_small_int_t) DUK_SIGNBIT(d2); + + if (c1 == DUK_FP_NAN || c2 == DUK_FP_NAN) { + return 0; /* Always false, regardless of negation. */ + } + + if (c1 == DUK_FP_ZERO && c2 == DUK_FP_ZERO) { + /* For all combinations: +0 < +0, +0 < -0, -0 < +0, -0 < -0, + * steps e, f, and g. + */ + return retval; /* false */ + } + + if (d1 == d2) { + return retval; /* false */ + } + + if (c1 == DUK_FP_INFINITE && s1 == 0) { + /* x == +Infinity */ + return retval; /* false */ + } + + if (c2 == DUK_FP_INFINITE && s2 == 0) { + /* y == +Infinity */ + return retval ^ 1; /* true */ + } + + if (c2 == DUK_FP_INFINITE && s2 != 0) { + /* y == -Infinity */ + return retval; /* false */ + } + + if (c1 == DUK_FP_INFINITE && s1 != 0) { + /* x == -Infinity */ + return retval ^ 1; /* true */ + } + + if (d1 < d2) { + return retval ^ 1; /* true */ + } + + return retval; /* false */ +} +#else /* DUK_USE_PARANOID_MATH */ +DUK_LOCAL duk_bool_t duk__compare_number(duk_bool_t retval, duk_double_t d1, duk_double_t d2) { + /* This comparison tree relies doesn't match the exact steps in + * E5 Section 11.8.5 but should produce the same results. The + * steps rely on exact IEEE semantics for NaNs, etc. + */ + + DUK_ASSERT(retval == 0 || retval == 1); + if (d1 < d2) { + /* In no case should both (d1 < d2) and (d2 < d1) be true. + * It's possible that neither is true though, and that's + * handled below. + */ + DUK_ASSERT(!(d2 < d1)); + + /* - d1 < d2, both d1/d2 are normals (not Infinity, not NaN) + * - d2 is +Infinity, d1 != +Infinity and NaN + * - d1 is -Infinity, d2 != -Infinity and NaN + */ + return retval ^ 1; + } else { + if (d2 < d1) { + /* - !(d1 < d2), both d1/d2 are normals (not Infinity, not NaN) + * - d1 is +Infinity, d2 != +Infinity and NaN + * - d2 is -Infinity, d1 != -Infinity and NaN + */ + return retval; + } else { + /* - d1 and/or d2 is NaN + * - d1 and d2 are both +/- 0 + * - d1 == d2 (including infinities) + */ + if (duk_double_is_nan(d1) || duk_double_is_nan(d2)) { + /* Note: undefined from Section 11.8.5 always + * results in false return (see e.g. Section + * 11.8.3) - hence special treatment here. + */ + return 0; /* zero regardless of negation */ + } else { + return retval; + } + } + } +} +#endif /* DUK_USE_PARANOID_MATH */ + +DUK_INTERNAL duk_bool_t duk_js_compare_helper(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y, duk_small_uint_t flags) { + duk_double_t d1, d2; + duk_small_int_t rc; + duk_bool_t retval; + + DUK_ASSERT(DUK_COMPARE_FLAG_NEGATE == 1); /* Rely on this flag being lowest. */ + retval = flags & DUK_COMPARE_FLAG_NEGATE; + DUK_ASSERT(retval == 0 || retval == 1); + + /* Fast path for fastints */ +#if defined(DUK_USE_FASTINT) + if (DUK_LIKELY(DUK_TVAL_IS_FASTINT(tv_x) && DUK_TVAL_IS_FASTINT(tv_y))) { + return duk__compare_fastint(retval, DUK_TVAL_GET_FASTINT(tv_x), DUK_TVAL_GET_FASTINT(tv_y)); + } +#endif /* DUK_USE_FASTINT */ + + /* Fast path for numbers (one of which may be a fastint) */ +#if !defined(DUK_USE_PREFER_SIZE) + if (DUK_LIKELY(DUK_TVAL_IS_NUMBER(tv_x) && DUK_TVAL_IS_NUMBER(tv_y))) { + return duk__compare_number(retval, DUK_TVAL_GET_NUMBER(tv_x), DUK_TVAL_GET_NUMBER(tv_y)); + } +#endif + + /* Slow path */ + + duk_push_tval(thr, tv_x); + duk_push_tval(thr, tv_y); + + if (flags & DUK_COMPARE_FLAG_EVAL_LEFT_FIRST) { + duk_to_primitive(thr, -2, DUK_HINT_NUMBER); + duk_to_primitive(thr, -1, DUK_HINT_NUMBER); + } else { + duk_to_primitive(thr, -1, DUK_HINT_NUMBER); + duk_to_primitive(thr, -2, DUK_HINT_NUMBER); + } + + /* Note: reuse variables */ + tv_x = DUK_GET_TVAL_NEGIDX(thr, -2); + tv_y = DUK_GET_TVAL_NEGIDX(thr, -1); + + if (DUK_TVAL_IS_STRING(tv_x) && DUK_TVAL_IS_STRING(tv_y)) { + duk_hstring *h1 = DUK_TVAL_GET_STRING(tv_x); + duk_hstring *h2 = DUK_TVAL_GET_STRING(tv_y); + DUK_ASSERT(h1 != NULL); + DUK_ASSERT(h2 != NULL); + + if (DUK_LIKELY(!DUK_HSTRING_HAS_SYMBOL(h1) && !DUK_HSTRING_HAS_SYMBOL(h2))) { + rc = duk_js_string_compare(h1, h2); + duk_pop_2_unsafe(thr); + if (rc < 0) { + return retval ^ 1; + } else { + return retval; + } + } + + /* One or both are Symbols: fall through to handle in the + * generic path. Concretely, ToNumber() will fail. + */ + } + + /* Ordering should not matter (E5 Section 11.8.5, step 3.a). */ +#if 0 + if (flags & DUK_COMPARE_FLAG_EVAL_LEFT_FIRST) { + d1 = duk_to_number_m2(thr); + d2 = duk_to_number_m1(thr); + } else { + d2 = duk_to_number_m1(thr); + d1 = duk_to_number_m2(thr); + } +#endif + d1 = duk_to_number_m2(thr); + d2 = duk_to_number_m1(thr); + + /* We want to duk_pop_2_unsafe(thr); because the values are numbers + * no decref check is needed. + */ +#if defined(DUK_USE_PREFER_SIZE) + duk_pop_2_nodecref_unsafe(thr); +#else + DUK_ASSERT(!DUK_TVAL_NEEDS_REFCOUNT_UPDATE(duk_get_tval(thr, -2))); + DUK_ASSERT(!DUK_TVAL_NEEDS_REFCOUNT_UPDATE(duk_get_tval(thr, -1))); + DUK_ASSERT(duk_get_top(thr) >= 2); + thr->valstack_top -= 2; + tv_x = thr->valstack_top; + tv_y = tv_x + 1; + DUK_TVAL_SET_UNDEFINED(tv_x); /* Value stack policy */ + DUK_TVAL_SET_UNDEFINED(tv_y); +#endif + + return duk__compare_number(retval, d1, d2); +} + +/* + * instanceof + */ + +/* + * ES2015 Section 7.3.19 describes the OrdinaryHasInstance() algorithm + * which covers both bound and non-bound functions; in effect the algorithm + * includes E5 Sections 11.8.6, 15.3.5.3, and 15.3.4.5.3. + * + * ES2015 Section 12.9.4 describes the instanceof operator which first + * checks @@hasInstance well-known symbol and falls back to + * OrdinaryHasInstance(). + * + * Limited Proxy support: don't support 'getPrototypeOf' trap but + * continue lookup in Proxy target if the value is a Proxy. + */ + +DUK_LOCAL duk_bool_t duk__js_instanceof_helper(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y, duk_bool_t skip_sym_check) { + duk_hobject *func; + duk_hobject *val; + duk_hobject *proto; + duk_tval *tv; + duk_bool_t skip_first; + duk_uint_t sanity; + + /* + * Get the values onto the stack first. It would be possible to cover + * some normal cases without resorting to the value stack. + * + * The right hand side could be a light function (as they generally + * behave like objects). Light functions never have a 'prototype' + * property so E5.1 Section 15.3.5.3 step 3 always throws a TypeError. + * Using duk_require_hobject() is thus correct (except for error msg). + */ + + duk_push_tval(thr, tv_x); + duk_push_tval(thr, tv_y); + func = duk_require_hobject(thr, -1); + DUK_ASSERT(func != NULL); + +#if defined(DUK_USE_SYMBOL_BUILTIN) + /* + * @@hasInstance check, ES2015 Section 12.9.4, Steps 2-4. + */ + if (!skip_sym_check) { + if (duk_get_method_stridx(thr, -1, DUK_STRIDX_WELLKNOWN_SYMBOL_HAS_INSTANCE)) { + /* [ ... lhs rhs func ] */ + duk_insert(thr, -3); /* -> [ ... func lhs rhs ] */ + duk_swap_top(thr, -2); /* -> [ ... func rhs(this) lhs ] */ + duk_call_method(thr, 1); + return duk_to_boolean_top_pop(thr); + } + } +#else + DUK_UNREF(skip_sym_check); +#endif + + /* + * For bound objects, [[HasInstance]] just calls the target function + * [[HasInstance]]. If that is again a bound object, repeat until + * we find a non-bound Function object. + * + * The bound function chain is now "collapsed" so there can be only + * one bound function in the chain. + */ + + if (!DUK_HOBJECT_IS_CALLABLE(func)) { + /* + * Note: of native ECMAScript objects, only Function instances + * have a [[HasInstance]] internal property. Custom objects might + * also have it, but not in current implementation. + * + * XXX: add a separate flag, DUK_HOBJECT_FLAG_ALLOW_INSTANCEOF? + */ + goto error_invalid_rval; + } + + if (DUK_HOBJECT_HAS_BOUNDFUNC(func)) { + duk_push_tval(thr, &((duk_hboundfunc *) (void *) func)->target); + duk_replace(thr, -2); + func = duk_require_hobject(thr, -1); /* lightfunc throws */ + + /* Rely on Function.prototype.bind() never creating bound + * functions whose target is not proper. + */ + DUK_ASSERT(func != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_CALLABLE(func)); + } + + /* + * 'func' is now a non-bound object which supports [[HasInstance]] + * (which here just means DUK_HOBJECT_FLAG_CALLABLE). Move on + * to execute E5 Section 15.3.5.3. + */ + + DUK_ASSERT(func != NULL); + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(func)); + DUK_ASSERT(DUK_HOBJECT_IS_CALLABLE(func)); + + /* [ ... lval rval(func) ] */ + + /* For lightfuncs, buffers, and pointers start the comparison directly + * from the virtual prototype object. + */ + skip_first = 0; + tv = DUK_GET_TVAL_NEGIDX(thr, -2); + switch (DUK_TVAL_GET_TAG(tv)) { + case DUK_TAG_LIGHTFUNC: + val = thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]; + DUK_ASSERT(val != NULL); + break; + case DUK_TAG_BUFFER: + val = thr->builtins[DUK_BIDX_UINT8ARRAY_PROTOTYPE]; + DUK_ASSERT(val != NULL); + break; + case DUK_TAG_POINTER: + val = thr->builtins[DUK_BIDX_POINTER_PROTOTYPE]; + DUK_ASSERT(val != NULL); + break; + case DUK_TAG_OBJECT: + skip_first = 1; /* Ignore object itself on first round. */ + val = DUK_TVAL_GET_OBJECT(tv); + DUK_ASSERT(val != NULL); + break; + default: + goto pop2_and_false; + } + DUK_ASSERT(val != NULL); /* Loop doesn't actually rely on this. */ + + /* Look up .prototype of rval. Leave it on the value stack in case it + * has been virtualized (e.g. getter, Proxy trap). + */ + duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_PROTOTYPE); /* -> [ ... lval rval rval.prototype ] */ +#if defined(DUK_USE_VERBOSE_ERRORS) + proto = duk_get_hobject(thr, -1); + if (proto == NULL) { + goto error_invalid_rval_noproto; + } +#else + proto = duk_require_hobject(thr, -1); +#endif + + sanity = DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY; + do { + /* + * Note: prototype chain is followed BEFORE first comparison. This + * means that the instanceof lval is never itself compared to the + * rval.prototype property. This is apparently intentional, see E5 + * Section 15.3.5.3, step 4.a. + * + * Also note: + * + * js> (function() {}) instanceof Function + * true + * js> Function instanceof Function + * true + * + * For the latter, h_proto will be Function.prototype, which is the + * built-in Function prototype. Because Function.[[Prototype]] is + * also the built-in Function prototype, the result is true. + */ + + if (!val) { + goto pop3_and_false; + } + + DUK_ASSERT(val != NULL); +#if defined(DUK_USE_ES6_PROXY) + val = duk_hobject_resolve_proxy_target(val); +#endif + + if (skip_first) { + skip_first = 0; + } else if (val == proto) { + goto pop3_and_true; + } + + DUK_ASSERT(val != NULL); + val = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, val); + } while (--sanity > 0); + + DUK_ASSERT(sanity == 0); + DUK_ERROR_RANGE(thr, DUK_STR_PROTOTYPE_CHAIN_LIMIT); + DUK_WO_NORETURN(return 0;); + +pop2_and_false: + duk_pop_2_unsafe(thr); + return 0; + +pop3_and_false: + duk_pop_3_unsafe(thr); + return 0; + +pop3_and_true: + duk_pop_3_unsafe(thr); + return 1; + +error_invalid_rval: + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_INSTANCEOF_RVAL); + DUK_WO_NORETURN(return 0;); + +#if defined(DUK_USE_VERBOSE_ERRORS) +error_invalid_rval_noproto: + DUK_ERROR_TYPE(thr, DUK_STR_INVALID_INSTANCEOF_RVAL_NOPROTO); + DUK_WO_NORETURN(return 0;); +#endif +} + +#if defined(DUK_USE_SYMBOL_BUILTIN) +DUK_INTERNAL duk_bool_t duk_js_instanceof_ordinary(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y) { + return duk__js_instanceof_helper(thr, tv_x, tv_y, 1 /*skip_sym_check*/); +} +#endif + +DUK_INTERNAL duk_bool_t duk_js_instanceof(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y) { + return duk__js_instanceof_helper(thr, tv_x, tv_y, 0 /*skip_sym_check*/); +} + +/* + * in + */ + +/* + * E5 Sections 11.8.7, 8.12.6. + * + * Basically just a property existence check using [[HasProperty]]. + */ + +DUK_INTERNAL duk_bool_t duk_js_in(duk_hthread *thr, duk_tval *tv_x, duk_tval *tv_y) { + duk_bool_t retval; + + /* + * Get the values onto the stack first. It would be possible to cover + * some normal cases without resorting to the value stack (e.g. if + * lval is already a string). + */ + + /* XXX: The ES5/5.1/6 specifications require that the key in 'key in obj' + * must be string coerced before the internal HasProperty() algorithm is + * invoked. A fast path skipping coercion could be safely implemented for + * numbers (as number-to-string coercion has no side effects). For ES2015 + * proxy behavior, the trap 'key' argument must be in a string coerced + * form (which is a shame). + */ + + /* TypeError if rval is not an object or object like (e.g. lightfunc + * or plain buffer). + */ + duk_push_tval(thr, tv_x); + duk_push_tval(thr, tv_y); + duk_require_type_mask(thr, -1, DUK_TYPE_MASK_OBJECT | DUK_TYPE_MASK_LIGHTFUNC | DUK_TYPE_MASK_BUFFER); + + (void) duk_to_property_key_hstring(thr, -2); + + retval = duk_hobject_hasprop(thr, DUK_GET_TVAL_NEGIDX(thr, -1), DUK_GET_TVAL_NEGIDX(thr, -2)); + + duk_pop_2_unsafe(thr); + return retval; +} + +/* + * typeof + * + * E5 Section 11.4.3. + * + * Very straightforward. The only question is what to return for our + * non-standard tag / object types. + * + * There is an unfortunate string constant define naming problem with + * typeof return values for e.g. "Object" and "object"; careful with + * the built-in string defines. The LC_XXX defines are used for the + * lowercase variants now. + */ + +DUK_INTERNAL duk_small_uint_t duk_js_typeof_stridx(duk_tval *tv_x) { + duk_small_uint_t stridx = 0; + + switch (DUK_TVAL_GET_TAG(tv_x)) { + case DUK_TAG_UNDEFINED: { + stridx = DUK_STRIDX_LC_UNDEFINED; + break; + } + case DUK_TAG_NULL: { + /* Note: not a typo, "object" is returned for a null value. */ + stridx = DUK_STRIDX_LC_OBJECT; + break; + } + case DUK_TAG_BOOLEAN: { + stridx = DUK_STRIDX_LC_BOOLEAN; + break; + } + case DUK_TAG_POINTER: { + /* Implementation specific. */ + stridx = DUK_STRIDX_LC_POINTER; + break; + } + case DUK_TAG_STRING: { + duk_hstring *str; + + /* All internal keys are identified as Symbols. */ + str = DUK_TVAL_GET_STRING(tv_x); + DUK_ASSERT(str != NULL); + if (DUK_UNLIKELY(DUK_HSTRING_HAS_SYMBOL(str))) { + stridx = DUK_STRIDX_LC_SYMBOL; + } else { + stridx = DUK_STRIDX_LC_STRING; + } + break; + } + case DUK_TAG_OBJECT: { + duk_hobject *obj = DUK_TVAL_GET_OBJECT(tv_x); + DUK_ASSERT(obj != NULL); + if (DUK_HOBJECT_IS_CALLABLE(obj)) { + stridx = DUK_STRIDX_LC_FUNCTION; + } else { + stridx = DUK_STRIDX_LC_OBJECT; + } + break; + } + case DUK_TAG_BUFFER: { + /* Implementation specific. In Duktape 1.x this would be + * 'buffer', in Duktape 2.x changed to 'object' because plain + * buffers now mimic Uint8Array objects. + */ + stridx = DUK_STRIDX_LC_OBJECT; + break; + } + case DUK_TAG_LIGHTFUNC: { + stridx = DUK_STRIDX_LC_FUNCTION; + break; + } +#if defined(DUK_USE_FASTINT) + case DUK_TAG_FASTINT: +#endif + default: { + /* number */ + DUK_ASSERT(!DUK_TVAL_IS_UNUSED(tv_x)); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv_x)); + stridx = DUK_STRIDX_LC_NUMBER; + break; + } + } + + DUK_ASSERT_STRIDX_VALID(stridx); + return stridx; +} + +/* + * IsArray() + */ + +DUK_INTERNAL duk_bool_t duk_js_isarray_hobject(duk_hobject *h) { + DUK_ASSERT(h != NULL); +#if defined(DUK_USE_ES6_PROXY) + h = duk_hobject_resolve_proxy_target(h); +#endif + return (DUK_HOBJECT_GET_CLASS_NUMBER(h) == DUK_HOBJECT_CLASS_ARRAY ? 1 : 0); +} + +DUK_INTERNAL duk_bool_t duk_js_isarray(duk_tval *tv) { + DUK_ASSERT(tv != NULL); + if (DUK_TVAL_IS_OBJECT(tv)) { + return duk_js_isarray_hobject(DUK_TVAL_GET_OBJECT(tv)); + } + return 0; +} + +/* + * Array index and length + * + * Array index: E5 Section 15.4 + * Array length: E5 Section 15.4.5.1 steps 3.c - 3.d (array length write) + */ + +/* Compure array index from string context, or return a "not array index" + * indicator. + */ +DUK_INTERNAL duk_uarridx_t duk_js_to_arrayindex_string(const duk_uint8_t *str, duk_uint32_t blen) { + duk_uarridx_t res; + + /* Only strings with byte length 1-10 can be 32-bit array indices. + * Leading zeroes (except '0' alone), plus/minus signs are not allowed. + * We could do a lot of prechecks here, but since most strings won't + * start with any digits, it's simpler to just parse the number and + * fail quickly. + */ + + res = 0; + if (blen == 0) { + goto parse_fail; + } + do { + duk_uarridx_t dig; + dig = (duk_uarridx_t) (*str++) - DUK_ASC_0; + + if (dig <= 9U) { + /* Careful overflow handling. When multiplying by 10: + * - 0x19999998 x 10 = 0xfffffff0: no overflow, and adding + * 0...9 is safe. + * - 0x19999999 x 10 = 0xfffffffa: no overflow, adding + * 0...5 is safe, 6...9 overflows. + * - 0x1999999a x 10 = 0x100000004: always overflow. + */ + if (DUK_UNLIKELY(res >= 0x19999999UL)) { + if (res >= 0x1999999aUL) { + /* Always overflow. */ + goto parse_fail; + } + DUK_ASSERT(res == 0x19999999UL); + if (dig >= 6U) { + goto parse_fail; + } + res = 0xfffffffaUL + dig; + DUK_ASSERT(res >= 0xfffffffaUL); + DUK_ASSERT_DISABLE(res <= 0xffffffffUL); /* range */ + } else { + res = res * 10U + dig; + if (DUK_UNLIKELY(res == 0)) { + /* If 'res' is 0, previous 'res' must + * have been 0 and we scanned in a zero. + * This is only allowed if blen == 1, + * i.e. the exact string '0'. + */ + if (blen == (duk_uint32_t) 1) { + return 0; + } + goto parse_fail; + } + } + } else { + /* Because 'dig' is unsigned, catches both values + * above '9' and below '0'. + */ + goto parse_fail; + } + } while (--blen > 0); + + return res; + +parse_fail: + return DUK_HSTRING_NO_ARRAY_INDEX; +} + +#if !defined(DUK_USE_HSTRING_ARRIDX) +/* Get array index for a string which is known to be an array index. This helper + * is needed when duk_hstring doesn't concretely store the array index, but strings + * are flagged as array indices at intern time. + */ +DUK_INTERNAL duk_uarridx_t duk_js_to_arrayindex_hstring_fast_known(duk_hstring *h) { + const duk_uint8_t *p; + duk_uarridx_t res; + duk_uint8_t t; + + DUK_ASSERT(h != NULL); + DUK_ASSERT(DUK_HSTRING_HAS_ARRIDX(h)); + + p = DUK_HSTRING_GET_DATA(h); + res = 0; + for (;;) { + t = *p++; + if (DUK_UNLIKELY(t == 0)) { + /* Scanning to NUL is always safe for interned strings. */ + break; + } + DUK_ASSERT(t >= (duk_uint8_t) DUK_ASC_0 && t <= (duk_uint8_t) DUK_ASC_9); + res = res * 10U + (duk_uarridx_t) t - (duk_uarridx_t) DUK_ASC_0; + } + return res; +} + +DUK_INTERNAL duk_uarridx_t duk_js_to_arrayindex_hstring_fast(duk_hstring *h) { + DUK_ASSERT(h != NULL); + if (!DUK_HSTRING_HAS_ARRIDX(h)) { + return DUK_HSTRING_NO_ARRAY_INDEX; + } + return duk_js_to_arrayindex_hstring_fast_known(h); +} +#endif /* DUK_USE_HSTRING_ARRIDX */ +#line 1 "duk_js_var.c" +/* + * Identifier access and function closure handling. + * + * Provides the primitives for slow path identifier accesses: GETVAR, + * PUTVAR, DELVAR, etc. The fast path, direct register accesses, should + * be used for most identifier accesses. Consequently, these slow path + * primitives should be optimized for maximum compactness. + * + * ECMAScript environment records (declarative and object) are represented + * as internal objects with control keys. Environment records have a + * parent record ("outer environment reference") which is represented by + * the implicit prototype for technical reasons (in other words, it is a + * convenient field). The prototype chain is not followed in the ordinary + * sense for variable lookups. + * + * See identifier-handling.rst for more details on the identifier algorithms + * and the internal representation. See function-objects.rst for details on + * what function templates and instances are expected to look like. + * + * Care must be taken to avoid duk_tval pointer invalidation caused by + * e.g. value stack or object resizing. + * + * TODO: properties for function instances could be initialized much more + * efficiently by creating a property allocation for a certain size and + * filling in keys and values directly (and INCREFing both with "bulk incref" + * primitives. + * + * XXX: duk_hobject_getprop() and duk_hobject_putprop() calls are a bit + * awkward (especially because they follow the prototype chain); rework + * if "raw" own property helpers are added. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Local result type for duk__get_identifier_reference() lookup. + */ + +typedef struct { + duk_hobject *env; + duk_hobject *holder; /* for object-bound identifiers */ + duk_tval *value; /* for register-bound and declarative env identifiers */ + duk_uint_t attrs; /* property attributes for identifier (relevant if value != NULL) */ + duk_bool_t has_this; /* for object-bound identifiers: provide 'this' binding */ +} duk__id_lookup_result; + +/* + * Create a new function object based on a "template function" which contains + * compiled bytecode, constants, etc, but lacks a lexical environment. + * + * ECMAScript requires that each created closure is a separate object, with + * its own set of editable properties. However, structured property values + * (such as the formal arguments list and the variable map) are shared. + * Also the bytecode, constants, and inner functions are shared. + * + * See E5 Section 13.2 for detailed requirements on the function objects; + * there are no similar requirements for function "templates" which are an + * implementation dependent internal feature. Also see function-objects.rst + * for a discussion on the function instance properties provided by this + * implementation. + * + * Notes: + * + * * Order of internal properties should match frequency of use, since the + * properties will be linearly scanned on lookup (functions usually don't + * have enough properties to warrant a hash part). + * + * * The created closure is independent of its template; they do share the + * same 'data' buffer object, but the template object itself can be freed + * even if the closure object remains reachable. + */ + +DUK_LOCAL void duk__inc_data_inner_refcounts(duk_hthread *thr, duk_hcompfunc *f) { + duk_tval *tv, *tv_end; + duk_hobject **funcs, **funcs_end; + + DUK_UNREF(thr); + + /* If function creation fails due to out-of-memory, the data buffer + * pointer may be NULL in some cases. That's actually possible for + * GC code, but shouldn't be possible here because the incomplete + * function will be unwound from the value stack and never instantiated. + */ + DUK_ASSERT(DUK_HCOMPFUNC_GET_DATA(thr->heap, f) != NULL); + + tv = DUK_HCOMPFUNC_GET_CONSTS_BASE(thr->heap, f); + tv_end = DUK_HCOMPFUNC_GET_CONSTS_END(thr->heap, f); + while (tv < tv_end) { + DUK_TVAL_INCREF(thr, tv); + tv++; + } + + funcs = DUK_HCOMPFUNC_GET_FUNCS_BASE(thr->heap, f); + funcs_end = DUK_HCOMPFUNC_GET_FUNCS_END(thr->heap, f); + while (funcs < funcs_end) { + DUK_HEAPHDR_INCREF(thr, (duk_heaphdr *) *funcs); + funcs++; + } +} + +/* Push a new closure on the stack. + * + * Note: if fun_temp has NEWENV, i.e. a new lexical and variable declaration + * is created when the function is called, only outer_lex_env matters + * (outer_var_env is ignored and may or may not be same as outer_lex_env). + */ + +DUK_LOCAL const duk_uint16_t duk__closure_copy_proplist[] = { + /* order: most frequent to least frequent */ + DUK_STRIDX_INT_VARMAP, + DUK_STRIDX_INT_FORMALS, +#if defined(DUK_USE_PC2LINE) + DUK_STRIDX_INT_PC2LINE, +#endif +#if defined(DUK_USE_FUNC_FILENAME_PROPERTY) + DUK_STRIDX_FILE_NAME, +#endif +#if defined(DUK_USE_NONSTD_FUNC_SOURCE_PROPERTY) + DUK_STRIDX_INT_SOURCE +#endif +}; + +DUK_INTERNAL +void duk_js_push_closure(duk_hthread *thr, + duk_hcompfunc *fun_temp, + duk_hobject *outer_var_env, + duk_hobject *outer_lex_env, + duk_bool_t add_auto_proto) { + duk_hcompfunc *fun_clos; + duk_harray *formals; + duk_small_uint_t i; + duk_uint_t len_value; + + DUK_ASSERT(fun_temp != NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_DATA(thr->heap, fun_temp) != NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_FUNCS(thr->heap, fun_temp) != NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_BYTECODE(thr->heap, fun_temp) != NULL); + DUK_ASSERT(outer_var_env != NULL); + DUK_ASSERT(outer_lex_env != NULL); + DUK_UNREF(len_value); + + DUK_STATS_INC(thr->heap, stats_envrec_pushclosure); + + fun_clos = duk_push_hcompfunc(thr); + DUK_ASSERT(fun_clos != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) fun_clos) == thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); + + duk_push_hobject(thr, &fun_temp->obj); /* -> [ ... closure template ] */ + + DUK_ASSERT(DUK_HOBJECT_IS_COMPFUNC((duk_hobject *) fun_clos)); + DUK_ASSERT(DUK_HCOMPFUNC_GET_DATA(thr->heap, fun_clos) == NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_FUNCS(thr->heap, fun_clos) == NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_BYTECODE(thr->heap, fun_clos) == NULL); + + DUK_HCOMPFUNC_SET_DATA(thr->heap, fun_clos, DUK_HCOMPFUNC_GET_DATA(thr->heap, fun_temp)); + DUK_HCOMPFUNC_SET_FUNCS(thr->heap, fun_clos, DUK_HCOMPFUNC_GET_FUNCS(thr->heap, fun_temp)); + DUK_HCOMPFUNC_SET_BYTECODE(thr->heap, fun_clos, DUK_HCOMPFUNC_GET_BYTECODE(thr->heap, fun_temp)); + + /* Note: all references inside 'data' need to get their refcounts + * upped too. This is the case because refcounts are decreased + * through every function referencing 'data' independently. + */ + + DUK_HBUFFER_INCREF(thr, DUK_HCOMPFUNC_GET_DATA(thr->heap, fun_clos)); + duk__inc_data_inner_refcounts(thr, fun_temp); + + fun_clos->nregs = fun_temp->nregs; + fun_clos->nargs = fun_temp->nargs; +#if defined(DUK_USE_DEBUGGER_SUPPORT) + fun_clos->start_line = fun_temp->start_line; + fun_clos->end_line = fun_temp->end_line; +#endif + + DUK_ASSERT(DUK_HCOMPFUNC_GET_DATA(thr->heap, fun_clos) != NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_FUNCS(thr->heap, fun_clos) != NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_BYTECODE(thr->heap, fun_clos) != NULL); + + /* XXX: Could also copy from template, but there's no way to have any + * other value here now (used code has no access to the template). + * Prototype is set by duk_push_hcompfunc(). + */ + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, &fun_clos->obj) == thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); +#if 0 + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, &fun_clos->obj, thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); +#endif + + /* Copy duk_hobject flags as is from the template using a mask. + * Leave out duk_heaphdr owned flags just in case (e.g. if there's + * some GC flag or similar). Some flags can then be adjusted + * separately if necessary. + */ + + /* DUK_HEAPHDR_SET_FLAGS() masks changes to non-duk_heaphdr flags only. */ + DUK_HEAPHDR_SET_FLAGS((duk_heaphdr *) fun_clos, DUK_HEAPHDR_GET_FLAGS_RAW((duk_heaphdr *) fun_temp)); + DUK_DD(DUK_DDPRINT("fun_temp heaphdr flags: 0x%08lx, fun_clos heaphdr flags: 0x%08lx", + (unsigned long) DUK_HEAPHDR_GET_FLAGS_RAW((duk_heaphdr *) fun_temp), + (unsigned long) DUK_HEAPHDR_GET_FLAGS_RAW((duk_heaphdr *) fun_clos))); + + DUK_ASSERT(DUK_HOBJECT_HAS_EXTENSIBLE(&fun_clos->obj)); + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(&fun_clos->obj)); + DUK_ASSERT(DUK_HOBJECT_HAS_COMPFUNC(&fun_clos->obj)); + DUK_ASSERT(!DUK_HOBJECT_HAS_NATFUNC(&fun_clos->obj)); + DUK_ASSERT(!DUK_HOBJECT_IS_THREAD(&fun_clos->obj)); + /* DUK_HOBJECT_FLAG_ARRAY_PART: don't care */ + /* DUK_HOBJECT_FLAG_NEWENV: handled below */ + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARRAY(&fun_clos->obj)); + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_STRINGOBJ(&fun_clos->obj)); + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARGUMENTS(&fun_clos->obj)); + + if (!DUK_HOBJECT_HAS_CONSTRUCTABLE(&fun_clos->obj)) { + /* If the template is not constructable don't add an automatic + * .prototype property. This is the case for e.g. ES2015 object + * literal getters/setters and method definitions. + */ + add_auto_proto = 0; + } + + /* + * Setup environment record properties based on the template and + * its flags. + * + * If DUK_HOBJECT_HAS_NEWENV(fun_temp) is true, the environment + * records represent identifiers "outside" the function; the + * "inner" environment records are created on demand. Otherwise, + * the environment records are those that will be directly used + * (e.g. for declarations). + * + * _Lexenv is always set; _Varenv defaults to _Lexenv if missing, + * so _Varenv is only set if _Lexenv != _Varenv. + * + * This is relatively complex, see doc/identifier-handling.rst. + */ + + if (DUK_HOBJECT_HAS_NEWENV(&fun_clos->obj)) { +#if defined(DUK_USE_FUNC_NAME_PROPERTY) + if (DUK_HOBJECT_HAS_NAMEBINDING(&fun_clos->obj)) { + duk_hobject *proto; + duk_hdecenv *new_env; + + /* + * Named function expression, name needs to be bound + * in an intermediate environment record. The "outer" + * lexical/variable environment will thus be: + * + * a) { funcname: , __prototype: outer_lex_env } + * b) { funcname: , __prototype: } (if outer_lex_env missing) + */ + + if (outer_lex_env) { + proto = outer_lex_env; + } else { + proto = thr->builtins[DUK_BIDX_GLOBAL_ENV]; + } + + /* -> [ ... closure template env ] */ + new_env = + duk_hdecenv_alloc(thr, + DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_DECENV)); + DUK_ASSERT(new_env != NULL); + duk_push_hobject(thr, (duk_hobject *) new_env); + + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) new_env) == NULL); + DUK_HOBJECT_SET_PROTOTYPE(thr->heap, (duk_hobject *) new_env, proto); + DUK_HOBJECT_INCREF_ALLOWNULL(thr, proto); + + DUK_ASSERT(new_env->thread == NULL); /* Closed. */ + DUK_ASSERT(new_env->varmap == NULL); + + /* It's important that duk_xdef_prop() is a 'raw define' so that any + * properties in an ancestor are never an issue (they should never be + * e.g. non-writable, but just in case). + * + * Because template objects are not visible to user code, the case + * where .name is missing shouldn't happen in practice. It it does, + * the name 'undefined' gets bound and maps to the closure (which is + * a bit odd, but safe). + */ + (void) duk_get_prop_stridx_short(thr, -2, DUK_STRIDX_NAME); + /* -> [ ... closure template env funcname ] */ + duk_dup_m4(thr); /* -> [ ... closure template env funcname closure ] */ + duk_xdef_prop(thr, -3, DUK_PROPDESC_FLAGS_NONE); /* -> [ ... closure template env ] */ + /* env[funcname] = closure */ + + /* [ ... closure template env ] */ + + DUK_HCOMPFUNC_SET_LEXENV(thr->heap, fun_clos, (duk_hobject *) new_env); + DUK_HCOMPFUNC_SET_VARENV(thr->heap, fun_clos, (duk_hobject *) new_env); + DUK_HOBJECT_INCREF(thr, (duk_hobject *) new_env); + DUK_HOBJECT_INCREF(thr, (duk_hobject *) new_env); + duk_pop_unsafe(thr); + + /* [ ... closure template ] */ + } else +#endif /* DUK_USE_FUNC_NAME_PROPERTY */ + { + /* + * Other cases (function declaration, anonymous function expression, + * strict direct eval code). The "outer" environment will be whatever + * the caller gave us. + */ + + DUK_HCOMPFUNC_SET_LEXENV(thr->heap, fun_clos, outer_lex_env); + DUK_HCOMPFUNC_SET_VARENV(thr->heap, fun_clos, outer_lex_env); + DUK_HOBJECT_INCREF(thr, outer_lex_env); + DUK_HOBJECT_INCREF(thr, outer_lex_env); + + /* [ ... closure template ] */ + } + } else { + /* + * Function gets no new environment when called. This is the + * case for global code, indirect eval code, and non-strict + * direct eval code. There is no direct correspondence to the + * E5 specification, as global/eval code is not exposed as a + * function. + */ + + DUK_ASSERT(!DUK_HOBJECT_HAS_NAMEBINDING(&fun_temp->obj)); + + DUK_HCOMPFUNC_SET_LEXENV(thr->heap, fun_clos, outer_lex_env); + DUK_HCOMPFUNC_SET_VARENV(thr->heap, fun_clos, outer_var_env); + DUK_HOBJECT_INCREF(thr, outer_lex_env); /* NULLs not allowed; asserted on entry */ + DUK_HOBJECT_INCREF(thr, outer_var_env); + } + DUK_DDD(DUK_DDDPRINT("closure varenv -> %!ipO, lexenv -> %!ipO", + (duk_heaphdr *) fun_clos->var_env, + (duk_heaphdr *) fun_clos->lex_env)); + + /* Call handling assumes this for all callable closures. */ + DUK_ASSERT(DUK_HCOMPFUNC_GET_LEXENV(thr->heap, fun_clos) != NULL); + DUK_ASSERT(DUK_HCOMPFUNC_GET_VARENV(thr->heap, fun_clos) != NULL); + + /* + * Copy some internal properties directly + * + * The properties will be non-writable and non-enumerable, but + * configurable. + * + * Function templates are bare objects, so inheritance of internal + * Symbols is not an issue here even when using ordinary property + * reads. The function instance created is not bare, so internal + * Symbols must be defined without inheritance checks. + */ + + /* [ ... closure template ] */ + + DUK_DDD(DUK_DDDPRINT("copying properties: closure=%!iT, template=%!iT", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + + for (i = 0; i < (duk_small_uint_t) (sizeof(duk__closure_copy_proplist) / sizeof(duk_uint16_t)); i++) { + duk_small_int_t stridx = (duk_small_int_t) duk__closure_copy_proplist[i]; + if (duk_xget_owndataprop_stridx_short(thr, -1, stridx)) { + /* [ ... closure template val ] */ + DUK_DDD(DUK_DDDPRINT("copying property, stridx=%ld -> found", (long) stridx)); + duk_xdef_prop_stridx_short(thr, -3, stridx, DUK_PROPDESC_FLAGS_C); + } else { + DUK_DDD(DUK_DDDPRINT("copying property, stridx=%ld -> not found", (long) stridx)); + duk_pop_unsafe(thr); + } + } + + /* + * "length" maps to number of formals (E5 Section 13.2) for function + * declarations/expressions (non-bound functions). Note that 'nargs' + * is NOT necessarily equal to the number of arguments. Use length + * of _Formals; if missing, assume nargs matches .length. + */ + + /* [ ... closure template ] */ + + formals = duk_hobject_get_formals(thr, (duk_hobject *) fun_temp); + if (formals) { + len_value = (duk_uint_t) formals->length; + DUK_DD(DUK_DDPRINT("closure length from _Formals -> %ld", (long) len_value)); + } else { + len_value = fun_temp->nargs; + DUK_DD(DUK_DDPRINT("closure length defaulted from nargs -> %ld", (long) len_value)); + } + + duk_push_uint(thr, len_value); /* [ ... closure template len_value ] */ + duk_xdef_prop_stridx_short(thr, -3, DUK_STRIDX_LENGTH, DUK_PROPDESC_FLAGS_C); + + /* + * "prototype" is, by default, a fresh object with the "constructor" + * property. + * + * Note that this creates a circular reference for every function + * instance (closure) which prevents refcount-based collection of + * function instances. + * + * XXX: Try to avoid creating the default prototype object, because + * many functions are not used as constructors and the default + * prototype is unnecessary. Perhaps it could be created on-demand + * when it is first accessed? + */ + + /* [ ... closure template ] */ + + if (add_auto_proto) { + duk_push_object(thr); /* -> [ ... closure template newobj ] */ + duk_dup_m3(thr); /* -> [ ... closure template newobj closure ] */ + duk_xdef_prop_stridx_short(thr, + -2, + DUK_STRIDX_CONSTRUCTOR, + DUK_PROPDESC_FLAGS_WC); /* -> [ ... closure template newobj ] */ + duk_compact(thr, -1); /* compact the prototype */ + duk_xdef_prop_stridx_short(thr, -3, DUK_STRIDX_PROTOTYPE, DUK_PROPDESC_FLAGS_W); /* -> [ ... closure template ] */ + } + + /* + * "arguments" and "caller" must be mapped to throwers for strict + * mode and bound functions (E5 Section 15.3.5). + * + * XXX: This is expensive to have for every strict function instance. + * Try to implement as virtual properties or on-demand created properties. + */ + + /* [ ... closure template ] */ + + if (DUK_HOBJECT_HAS_STRICT(&fun_clos->obj)) { + duk_xdef_prop_stridx_thrower(thr, -2, DUK_STRIDX_CALLER); + duk_xdef_prop_stridx_thrower(thr, -2, DUK_STRIDX_LC_ARGUMENTS); + } else { +#if defined(DUK_USE_NONSTD_FUNC_CALLER_PROPERTY) + DUK_DDD(DUK_DDDPRINT("function is non-strict and non-standard 'caller' property in use, add initial 'null' value")); + duk_push_null(thr); + duk_xdef_prop_stridx_short(thr, -3, DUK_STRIDX_CALLER, DUK_PROPDESC_FLAGS_NONE); +#else + DUK_DDD(DUK_DDDPRINT("function is non-strict and non-standard 'caller' property not used")); +#endif + } + + /* + * "name" used to be non-standard but is now defined by ES2015. + * In ES2015/ES2016 the .name property is configurable. + */ + + /* [ ... closure template ] */ + +#if defined(DUK_USE_FUNC_NAME_PROPERTY) + /* XXX: Look for own property only; doesn't matter much because + * templates are bare objects. + */ + if (duk_get_prop_stridx_short(thr, -1, DUK_STRIDX_NAME)) { + /* [ ... closure template name ] */ + DUK_ASSERT(duk_is_string(thr, -1)); + DUK_DD(DUK_DDPRINT("setting function instance name to %!T", duk_get_tval(thr, -1))); + duk_xdef_prop_stridx_short(thr, -3, DUK_STRIDX_NAME, DUK_PROPDESC_FLAGS_C); /* -> [ ... closure template ] */ + } else { + /* Anonymous functions don't have a .name in ES2015, so don't set + * it on the instance either. The instance will then inherit + * it from Function.prototype.name. + */ + DUK_DD(DUK_DDPRINT("not setting function instance .name")); + duk_pop_unsafe(thr); + } +#endif + + /* + * Compact the closure, in most cases no properties will be added later. + * Also, without this the closures end up having unused property slots + * (e.g. in Duktape 0.9.0, 8 slots would be allocated and only 7 used). + * A better future solution would be to allocate the closure directly + * to correct size (and setup the properties directly without going + * through the API). + */ + + duk_compact(thr, -2); + + /* + * Some assertions (E5 Section 13.2). + */ + + DUK_ASSERT(DUK_HOBJECT_GET_CLASS_NUMBER(&fun_clos->obj) == DUK_HOBJECT_CLASS_FUNCTION); + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, &fun_clos->obj) == thr->builtins[DUK_BIDX_FUNCTION_PROTOTYPE]); + DUK_ASSERT(DUK_HOBJECT_HAS_EXTENSIBLE(&fun_clos->obj)); + DUK_ASSERT(duk_has_prop_stridx(thr, -2, DUK_STRIDX_LENGTH) != 0); + DUK_ASSERT(add_auto_proto == 0 || duk_has_prop_stridx(thr, -2, DUK_STRIDX_PROTOTYPE) != 0); + /* May be missing .name */ + DUK_ASSERT(!DUK_HOBJECT_HAS_STRICT(&fun_clos->obj) || duk_has_prop_stridx(thr, -2, DUK_STRIDX_CALLER) != 0); + DUK_ASSERT(!DUK_HOBJECT_HAS_STRICT(&fun_clos->obj) || duk_has_prop_stridx(thr, -2, DUK_STRIDX_LC_ARGUMENTS) != 0); + + /* + * Finish + */ + + /* [ ... closure template ] */ + + DUK_DDD(DUK_DDDPRINT("created function instance: template=%!iT -> closure=%!iT", + (duk_tval *) duk_get_tval(thr, -1), + (duk_tval *) duk_get_tval(thr, -2))); + + duk_pop_unsafe(thr); + + /* [ ... closure ] */ +} + +/* + * Delayed activation environment record initialization (for functions + * with NEWENV). + * + * The non-delayed initialization is handled by duk_handle_call(). + */ + +DUK_LOCAL void duk__preallocate_env_entries(duk_hthread *thr, duk_hobject *varmap, duk_hobject *env) { + duk_uint_fast32_t i; + + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ENEXT(varmap); i++) { + duk_hstring *key; + + key = DUK_HOBJECT_E_GET_KEY(thr->heap, varmap, i); + DUK_ASSERT(key != NULL); /* assume keys are compact in _Varmap */ + DUK_ASSERT(!DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, varmap, i)); /* assume plain values */ + + /* Predefine as 'undefined' to reserve a property slot. + * This makes the unwind process (where register values + * are copied to the env object) safe against throwing. + * + * XXX: This could be made much faster by creating the + * property table directly. + */ + duk_push_undefined(thr); + DUK_DDD(DUK_DDDPRINT("preallocate env entry for key %!O", key)); + duk_hobject_define_property_internal(thr, env, key, DUK_PROPDESC_FLAGS_WE); + } +} + +/* shared helper */ +DUK_INTERNAL +duk_hobject *duk_create_activation_environment_record(duk_hthread *thr, duk_hobject *func, duk_size_t bottom_byteoff) { + duk_hdecenv *env; + duk_hobject *parent; + duk_hcompfunc *f; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(func != NULL); + + DUK_STATS_INC(thr->heap, stats_envrec_create); + + f = (duk_hcompfunc *) func; + parent = DUK_HCOMPFUNC_GET_LEXENV(thr->heap, f); + if (!parent) { + parent = thr->builtins[DUK_BIDX_GLOBAL_ENV]; + } + + env = duk_hdecenv_alloc(thr, DUK_HOBJECT_FLAG_EXTENSIBLE | DUK_HOBJECT_CLASS_AS_FLAGS(DUK_HOBJECT_CLASS_DECENV)); + DUK_ASSERT(env != NULL); + duk_push_hobject(thr, (duk_hobject *) env); + + DUK_ASSERT(DUK_HOBJECT_GET_PROTOTYPE(thr->heap, (duk_hobject *) env) == NULL); + DUK_HOBJECT_SET_PROTOTYPE(thr->heap, (duk_hobject *) env, parent); + DUK_HOBJECT_INCREF_ALLOWNULL(thr, parent); /* parent env is the prototype */ + + /* open scope information, for compiled functions only */ + + DUK_ASSERT(env->thread == NULL); + DUK_ASSERT(env->varmap == NULL); + DUK_ASSERT(env->regbase_byteoff == 0); + if (DUK_HOBJECT_IS_COMPFUNC(func)) { + duk_hobject *varmap; + + varmap = duk_hobject_get_varmap(thr, func); + if (varmap != NULL) { + env->varmap = varmap; + DUK_HOBJECT_INCREF(thr, varmap); + env->thread = thr; + DUK_HTHREAD_INCREF(thr, thr); + env->regbase_byteoff = bottom_byteoff; + + /* Preallocate env property table to avoid potential + * for out-of-memory on unwind when the env is closed. + */ + duk__preallocate_env_entries(thr, varmap, (duk_hobject *) env); + } else { + /* If function has no _Varmap, leave the environment closed. */ + DUK_ASSERT(env->thread == NULL); + DUK_ASSERT(env->varmap == NULL); + DUK_ASSERT(env->regbase_byteoff == 0); + } + } + + return (duk_hobject *) env; +} + +DUK_INTERNAL +void duk_js_init_activation_environment_records_delayed(duk_hthread *thr, duk_activation *act) { + duk_hobject *func; + duk_hobject *env; + + DUK_ASSERT(thr != NULL); + func = DUK_ACT_GET_FUNC(act); + DUK_ASSERT(func != NULL); + DUK_ASSERT(!DUK_HOBJECT_HAS_BOUNDFUNC(func)); /* bound functions are never in act 'func' */ + + /* + * Delayed initialization only occurs for 'NEWENV' functions. + */ + + DUK_ASSERT(DUK_HOBJECT_HAS_NEWENV(func)); + DUK_ASSERT(act->lex_env == NULL); + DUK_ASSERT(act->var_env == NULL); + + DUK_STATS_INC(thr->heap, stats_envrec_delayedcreate); + + env = duk_create_activation_environment_record(thr, func, act->bottom_byteoff); + DUK_ASSERT(env != NULL); + /* 'act' is a stable pointer, so still OK. */ + + DUK_DDD(DUK_DDDPRINT("created delayed fresh env: %!ipO", (duk_heaphdr *) env)); +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) + { + duk_hobject *p = env; + while (p) { + DUK_DDD(DUK_DDDPRINT(" -> %!ipO", (duk_heaphdr *) p)); + p = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, p); + } + } +#endif + + act->lex_env = env; + act->var_env = env; + DUK_HOBJECT_INCREF(thr, env); /* XXX: incref by count (here 2 times) */ + DUK_HOBJECT_INCREF(thr, env); + + duk_pop_unsafe(thr); +} + +/* + * Closing environment records. + * + * The environment record MUST be closed with the thread where its activation + * is; i.e. if 'env' is open, 'thr' must match env->thread, and the regbase + * and varmap must still be valid. On entry, 'env' must be reachable. + */ + +DUK_INTERNAL void duk_js_close_environment_record(duk_hthread *thr, duk_hobject *env) { + duk_uint_fast32_t i; + duk_hobject *varmap; + duk_hstring *key; + duk_tval *tv; + duk_uint_t regnum; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(env != NULL); + + if (DUK_UNLIKELY(!DUK_HOBJECT_IS_DECENV(env))) { + DUK_DDD(DUK_DDDPRINT("env not a declarative record: %!iO", (duk_heaphdr *) env)); + return; + } + + varmap = ((duk_hdecenv *) env)->varmap; + if (varmap == NULL) { + DUK_DDD(DUK_DDDPRINT("env already closed: %!iO", (duk_heaphdr *) env)); + + return; + } + DUK_ASSERT(((duk_hdecenv *) env)->thread != NULL); + DUK_HDECENV_ASSERT_VALID((duk_hdecenv *) env); + + DUK_DDD(DUK_DDDPRINT("closing env: %!iO", (duk_heaphdr *) env)); + DUK_DDD(DUK_DDDPRINT("varmap: %!O", (duk_heaphdr *) varmap)); + + /* Env must be closed in the same thread as where it runs. */ + DUK_ASSERT(((duk_hdecenv *) env)->thread == thr); + + /* XXX: additional conditions when to close variables? we don't want to do it + * unless the environment may have "escaped" (referenced in a function closure). + * With delayed environments, the existence is probably good enough of a check. + */ + + /* Note: we rely on the _Varmap having a bunch of nice properties, like: + * - being compacted and unmodified during this process + * - not containing an array part + * - having correct value types + */ + + DUK_DDD(DUK_DDDPRINT("copying bound register values, %ld bound regs", (long) DUK_HOBJECT_GET_ENEXT(varmap))); + + /* Copy over current variable values from value stack to the + * environment record. The scope object is empty but may + * inherit from another scope which has conflicting names. + */ + + /* XXX: Do this using a once allocated entry area, no side effects. + * Hash part would need special treatment however (maybe copy, and + * then realloc with hash part if large enough). + */ + for (i = 0; i < (duk_uint_fast32_t) DUK_HOBJECT_GET_ENEXT(varmap); i++) { + duk_size_t regbase_byteoff; + + key = DUK_HOBJECT_E_GET_KEY(thr->heap, varmap, i); + DUK_ASSERT(key != NULL); /* assume keys are compact in _Varmap */ + DUK_ASSERT(!DUK_HOBJECT_E_SLOT_IS_ACCESSOR(thr->heap, varmap, i)); /* assume plain values */ + + tv = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, varmap, i); + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + DUK_ASSERT(DUK_TVAL_GET_NUMBER(tv) <= (duk_double_t) DUK_UINT32_MAX); /* limits */ +#if defined(DUK_USE_FASTINT) + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv)); + regnum = (duk_uint_t) DUK_TVAL_GET_FASTINT_U32(tv); +#else + regnum = (duk_uint_t) DUK_TVAL_GET_NUMBER(tv); +#endif + + regbase_byteoff = ((duk_hdecenv *) env)->regbase_byteoff; + DUK_ASSERT((duk_uint8_t *) thr->valstack + regbase_byteoff + sizeof(duk_tval) * regnum >= + (duk_uint8_t *) thr->valstack); + DUK_ASSERT((duk_uint8_t *) thr->valstack + regbase_byteoff + sizeof(duk_tval) * regnum < + (duk_uint8_t *) thr->valstack_top); + + /* Write register value into env as named properties. + * If property already exists, overwrites silently. + * Property is writable, but not deletable (not configurable + * in terms of property attributes). + * + * This property write must not throw because we're unwinding + * and unwind code is not allowed to throw at present. The + * call itself has no such guarantees, but we've preallocated + * entries for each property when the env was created, so no + * out-of-memory error should be possible. If this guarantee + * is not provided, problems like GH-476 may happen. + */ + duk_push_tval(thr, + (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + regbase_byteoff + sizeof(duk_tval) * regnum)); + DUK_DDD(DUK_DDDPRINT("closing identifier %!O -> reg %ld, value %!T", + (duk_heaphdr *) key, + (long) regnum, + (duk_tval *) duk_get_tval(thr, -1))); + duk_hobject_define_property_internal(thr, env, key, DUK_PROPDESC_FLAGS_WE); + } + + /* NULL atomically to avoid inconsistent state + side effects. */ + DUK_HOBJECT_DECREF_NORZ(thr, ((duk_hdecenv *) env)->thread); + DUK_HOBJECT_DECREF_NORZ(thr, ((duk_hdecenv *) env)->varmap); + ((duk_hdecenv *) env)->thread = NULL; + ((duk_hdecenv *) env)->varmap = NULL; + + DUK_DDD(DUK_DDDPRINT("env after closing: %!O", (duk_heaphdr *) env)); +} + +/* + * GETIDREF: a GetIdentifierReference-like helper. + * + * Provides a parent traversing lookup and a single level lookup + * (for HasBinding). + * + * Instead of returning the value, returns a bunch of values allowing + * the caller to read, write, or delete the binding. Value pointers + * are duk_tval pointers which can be mutated directly as long as + * refcounts are properly updated. Note that any operation which may + * reallocate valstacks or compact objects may invalidate the returned + * duk_tval (but not object) pointers, so caller must be very careful. + * + * If starting environment record 'env' is given, 'act' is ignored. + * However, if 'env' is NULL, the caller may identify, in 'act', an + * activation which hasn't had its declarative environment initialized + * yet. The activation registers are then looked up, and its parent + * traversed normally. + * + * The 'out' structure values are only valid if the function returns + * success (non-zero). + */ + +/* lookup name from an open declarative record's registers */ +DUK_LOCAL +duk_bool_t duk__getid_open_decl_env_regs(duk_hthread *thr, duk_hstring *name, duk_hdecenv *env, duk__id_lookup_result *out) { + duk_tval *tv; + duk_size_t reg_rel; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(name != NULL); + DUK_ASSERT(env != NULL); + DUK_ASSERT(out != NULL); + + DUK_ASSERT(DUK_HOBJECT_IS_DECENV((duk_hobject *) env)); + DUK_HDECENV_ASSERT_VALID(env); + + if (env->thread == NULL) { + /* already closed */ + return 0; + } + DUK_ASSERT(env->varmap != NULL); + + tv = duk_hobject_find_entry_tval_ptr(thr->heap, env->varmap, name); + if (DUK_UNLIKELY(tv == NULL)) { + return 0; + } + + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + DUK_ASSERT(DUK_TVAL_GET_NUMBER(tv) <= (duk_double_t) DUK_UINT32_MAX); /* limits */ +#if defined(DUK_USE_FASTINT) + DUK_ASSERT(DUK_TVAL_IS_FASTINT(tv)); + reg_rel = (duk_size_t) DUK_TVAL_GET_FASTINT_U32(tv); +#else + reg_rel = (duk_size_t) DUK_TVAL_GET_NUMBER(tv); +#endif + DUK_ASSERT_DISABLE(reg_rel >= 0); /* unsigned */ + + tv = (duk_tval *) (void *) ((duk_uint8_t *) env->thread->valstack + env->regbase_byteoff + sizeof(duk_tval) * reg_rel); + DUK_ASSERT(tv >= env->thread->valstack && tv < env->thread->valstack_end); /* XXX: more accurate? */ + + out->value = tv; + out->attrs = DUK_PROPDESC_FLAGS_W; /* registers are mutable, non-deletable */ + out->env = (duk_hobject *) env; + out->holder = NULL; + out->has_this = 0; + return 1; +} + +/* lookup name from current activation record's functions' registers */ +DUK_LOCAL +duk_bool_t duk__getid_activation_regs(duk_hthread *thr, duk_hstring *name, duk_activation *act, duk__id_lookup_result *out) { + duk_tval *tv; + duk_hobject *func; + duk_hobject *varmap; + duk_size_t reg_rel; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(name != NULL); + DUK_ASSERT(act != NULL); + DUK_ASSERT(out != NULL); + + func = DUK_ACT_GET_FUNC(act); + DUK_ASSERT(func != NULL); + DUK_ASSERT(DUK_HOBJECT_HAS_NEWENV(func)); + + if (!DUK_HOBJECT_IS_COMPFUNC(func)) { + return 0; + } + + /* XXX: move varmap to duk_hcompfunc struct field? */ + varmap = duk_hobject_get_varmap(thr, func); + if (!varmap) { + return 0; + } + + tv = duk_hobject_find_entry_tval_ptr(thr->heap, varmap, name); + if (!tv) { + return 0; + } + DUK_ASSERT(DUK_TVAL_IS_NUMBER(tv)); + reg_rel = (duk_size_t) DUK_TVAL_GET_NUMBER(tv); + DUK_ASSERT_DISABLE(reg_rel >= 0); + DUK_ASSERT(reg_rel < ((duk_hcompfunc *) func)->nregs); + + tv = (duk_tval *) (void *) ((duk_uint8_t *) thr->valstack + act->bottom_byteoff); + tv += reg_rel; + + out->value = tv; + out->attrs = DUK_PROPDESC_FLAGS_W; /* registers are mutable, non-deletable */ + out->env = NULL; + out->holder = NULL; + out->has_this = 0; + return 1; +} + +DUK_LOCAL +duk_bool_t duk__get_identifier_reference(duk_hthread *thr, + duk_hobject *env, + duk_hstring *name, + duk_activation *act, + duk_bool_t parents, + duk__id_lookup_result *out) { + duk_tval *tv; + duk_uint_t sanity; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(env != NULL || act != NULL); + DUK_ASSERT(name != NULL); + DUK_ASSERT(out != NULL); + + DUK_ASSERT(!env || DUK_HOBJECT_IS_ENV(env)); + DUK_ASSERT(!env || !DUK_HOBJECT_HAS_ARRAY_PART(env)); + + /* + * Conceptually, we look for the identifier binding by starting from + * 'env' and following to chain of environment records (represented + * by the prototype chain). + * + * If 'env' is NULL, the current activation does not yet have an + * allocated declarative environment record; this should be treated + * exactly as if the environment record existed but had no bindings + * other than register bindings. + * + * Note: we assume that with the DUK_HOBJECT_FLAG_NEWENV cleared + * the environment will always be initialized immediately; hence + * a NULL 'env' should only happen with the flag set. This is the + * case for: (1) function calls, and (2) strict, direct eval calls. + */ + + if (env == NULL && act != NULL) { + duk_hobject *func; + duk_hcompfunc *f; + + DUK_DDD(DUK_DDDPRINT("duk__get_identifier_reference: env is NULL, activation is non-NULL -> " + "delayed env case, look up activation regs first")); + + /* + * Try registers + */ + + if (duk__getid_activation_regs(thr, name, act, out)) { + DUK_DDD(DUK_DDDPRINT("duk__get_identifier_reference successful: " + "name=%!O -> value=%!T, attrs=%ld, has_this=%ld, env=%!O, holder=%!O " + "(found from register bindings when env=NULL)", + (duk_heaphdr *) name, + (duk_tval *) out->value, + (long) out->attrs, + (long) out->has_this, + (duk_heaphdr *) out->env, + (duk_heaphdr *) out->holder)); + return 1; + } + + DUK_DDD(DUK_DDDPRINT("not found in current activation regs")); + + /* + * Not found in registers, proceed to the parent record. + * Here we need to determine what the parent would be, + * if 'env' was not NULL (i.e. same logic as when initializing + * the record). + * + * Note that environment initialization is only deferred when + * DUK_HOBJECT_HAS_NEWENV is set, and this only happens for: + * - Function code + * - Strict eval code + * + * We only need to check _Lexenv here; _Varenv exists only if it + * differs from _Lexenv (and thus _Lexenv will also be present). + */ + + if (!parents) { + DUK_DDD(DUK_DDDPRINT("duk__get_identifier_reference failed, no parent traversal " + "(not found from register bindings when env=NULL)")); + goto fail_not_found; + } + + func = DUK_ACT_GET_FUNC(act); + DUK_ASSERT(func != NULL); + DUK_ASSERT(DUK_HOBJECT_HAS_NEWENV(func)); + f = (duk_hcompfunc *) func; + + env = DUK_HCOMPFUNC_GET_LEXENV(thr->heap, f); + if (!env) { + env = thr->builtins[DUK_BIDX_GLOBAL_ENV]; + } + + DUK_DDD(DUK_DDDPRINT("continue lookup from env: %!iO", (duk_heaphdr *) env)); + } + + /* + * Prototype walking starting from 'env'. + * + * ('act' is not needed anywhere here.) + */ + + sanity = DUK_HOBJECT_PROTOTYPE_CHAIN_SANITY; + while (env != NULL) { + duk_small_uint_t cl; + duk_uint_t attrs; + + DUK_DDD(DUK_DDDPRINT("duk__get_identifier_reference, name=%!O, considering env=%p -> %!iO", + (duk_heaphdr *) name, + (void *) env, + (duk_heaphdr *) env)); + + DUK_ASSERT(env != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_ENV(env)); + DUK_ASSERT(!DUK_HOBJECT_HAS_ARRAY_PART(env)); + + cl = DUK_HOBJECT_GET_CLASS_NUMBER(env); + DUK_ASSERT(cl == DUK_HOBJECT_CLASS_OBJENV || cl == DUK_HOBJECT_CLASS_DECENV); + if (cl == DUK_HOBJECT_CLASS_DECENV) { + /* + * Declarative environment record. + * + * Identifiers can never be stored in ancestors and are + * always plain values, so we can use an internal helper + * and access the value directly with an duk_tval ptr. + * + * A closed environment is only indicated by it missing + * the "book-keeping" properties required for accessing + * register-bound variables. + */ + + DUK_HDECENV_ASSERT_VALID((duk_hdecenv *) env); + if (duk__getid_open_decl_env_regs(thr, name, (duk_hdecenv *) env, out)) { + DUK_DDD(DUK_DDDPRINT("duk__get_identifier_reference successful: " + "name=%!O -> value=%!T, attrs=%ld, has_this=%ld, env=%!O, holder=%!O " + "(declarative environment record, scope open, found in regs)", + (duk_heaphdr *) name, + (duk_tval *) out->value, + (long) out->attrs, + (long) out->has_this, + (duk_heaphdr *) out->env, + (duk_heaphdr *) out->holder)); + return 1; + } + + tv = duk_hobject_find_entry_tval_ptr_and_attrs(thr->heap, env, name, &attrs); + if (tv) { + out->value = tv; + out->attrs = attrs; + out->env = env; + out->holder = env; + out->has_this = 0; + + DUK_DDD(DUK_DDDPRINT("duk__get_identifier_reference successful: " + "name=%!O -> value=%!T, attrs=%ld, has_this=%ld, env=%!O, holder=%!O " + "(declarative environment record, found in properties)", + (duk_heaphdr *) name, + (duk_tval *) out->value, + (long) out->attrs, + (long) out->has_this, + (duk_heaphdr *) out->env, + (duk_heaphdr *) out->holder)); + return 1; + } + } else { + /* + * Object environment record. + * + * Binding (target) object is an external, uncontrolled object. + * Identifier may be bound in an ancestor property, and may be + * an accessor. Target can also be a Proxy which we must support + * here. + */ + + /* XXX: we could save space by using _Target OR _This. If _Target, assume + * this binding is undefined. If _This, assumes this binding is _This, and + * target is also _This. One property would then be enough. + */ + + duk_hobject *target; + duk_bool_t found; + + DUK_ASSERT(cl == DUK_HOBJECT_CLASS_OBJENV); + DUK_HOBJENV_ASSERT_VALID((duk_hobjenv *) env); + + target = ((duk_hobjenv *) env)->target; + DUK_ASSERT(target != NULL); + + /* Target may be a Proxy or property may be an accessor, so we must + * use an actual, Proxy-aware hasprop check here. + * + * out->holder is NOT set to the actual duk_hobject where the + * property is found, but rather the object binding target object. + */ + +#if defined(DUK_USE_ES6_PROXY) + if (DUK_UNLIKELY(DUK_HOBJECT_IS_PROXY(target))) { + duk_tval tv_name; + duk_tval tv_target_tmp; + + DUK_ASSERT(name != NULL); + DUK_TVAL_SET_STRING(&tv_name, name); + DUK_TVAL_SET_OBJECT(&tv_target_tmp, target); + + found = duk_hobject_hasprop(thr, &tv_target_tmp, &tv_name); + } else +#endif /* DUK_USE_ES6_PROXY */ + { + /* XXX: duk_hobject_hasprop() would be correct for + * non-Proxy objects too, but it is about ~20-25% + * slower at present so separate code paths for + * Proxy and non-Proxy now. + */ + found = duk_hobject_hasprop_raw(thr, target, name); + } + + if (found) { + out->value = NULL; /* can't get value, may be accessor */ + out->attrs = 0; /* irrelevant when out->value == NULL */ + out->env = env; + out->holder = target; + out->has_this = ((duk_hobjenv *) env)->has_this; + + DUK_DDD(DUK_DDDPRINT("duk__get_identifier_reference successful: " + "name=%!O -> value=%!T, attrs=%ld, has_this=%ld, env=%!O, holder=%!O " + "(object environment record)", + (duk_heaphdr *) name, + (duk_tval *) out->value, + (long) out->attrs, + (long) out->has_this, + (duk_heaphdr *) out->env, + (duk_heaphdr *) out->holder)); + return 1; + } + } + + if (!parents) { + DUK_DDD(DUK_DDDPRINT("duk__get_identifier_reference failed, no parent traversal " + "(not found from first traversed env)")); + goto fail_not_found; + } + + if (DUK_UNLIKELY(sanity-- == 0)) { + DUK_ERROR_RANGE(thr, DUK_STR_PROTOTYPE_CHAIN_LIMIT); + DUK_WO_NORETURN(return 0;); + } + env = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, env); + } + + /* + * Not found (even in global object) + */ + +fail_not_found: + return 0; +} + +/* + * HASVAR: check identifier binding from a given environment record + * without traversing its parents. + * + * This primitive is not exposed to user code as such, but is used + * internally for e.g. declaration binding instantiation. + * + * See E5 Sections: + * 10.2.1.1.1 HasBinding(N) + * 10.2.1.2.1 HasBinding(N) + * + * Note: strictness has no bearing on this check. Hence we don't take + * a 'strict' parameter. + */ + +#if 0 /*unused*/ +DUK_INTERNAL +duk_bool_t duk_js_hasvar_envrec(duk_hthread *thr, + duk_hobject *env, + duk_hstring *name) { + duk__id_lookup_result ref; + duk_bool_t parents; + + DUK_DDD(DUK_DDDPRINT("hasvar: thr=%p, env=%p, name=%!O " + "(env -> %!dO)", + (void *) thr, (void *) env, (duk_heaphdr *) name, + (duk_heaphdr *) env)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(env != NULL); + DUK_ASSERT(name != NULL); + + DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR(env); + DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR(name); + + DUK_ASSERT(DUK_HOBJECT_IS_ENV(env)); + DUK_ASSERT(!DUK_HOBJECT_HAS_ARRAY_PART(env)); + + /* lookup results is ignored */ + parents = 0; + return duk__get_identifier_reference(thr, env, name, NULL, parents, &ref); +} +#endif + +/* + * GETVAR + * + * See E5 Sections: + * 11.1.2 Identifier Reference + * 10.3.1 Identifier Resolution + * 11.13.1 Simple Assignment [example of where the Reference is GetValue'd] + * 8.7.1 GetValue (V) + * 8.12.1 [[GetOwnProperty]] (P) + * 8.12.2 [[GetProperty]] (P) + * 8.12.3 [[Get]] (P) + * + * If 'throw' is true, always leaves two values on top of stack: [val this]. + * + * If 'throw' is false, returns 0 if identifier cannot be resolved, and the + * stack will be unaffected in this case. If identifier is resolved, returns + * 1 and leaves [val this] on top of stack. + * + * Note: the 'strict' flag of a reference returned by GetIdentifierReference + * is ignored by GetValue. Hence we don't take a 'strict' parameter. + * + * The 'throw' flag is needed for implementing 'typeof' for an unreferenced + * identifier. An unreference identifier in other contexts generates a + * ReferenceError. + */ + +DUK_LOCAL +duk_bool_t duk__getvar_helper(duk_hthread *thr, duk_hobject *env, duk_activation *act, duk_hstring *name, duk_bool_t throw_flag) { + duk__id_lookup_result ref; + duk_tval tv_tmp_obj; + duk_tval tv_tmp_key; + duk_bool_t parents; + + DUK_DDD(DUK_DDDPRINT("getvar: thr=%p, env=%p, act=%p, name=%!O " + "(env -> %!dO)", + (void *) thr, + (void *) env, + (void *) act, + (duk_heaphdr *) name, + (duk_heaphdr *) env)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(name != NULL); + /* env and act may be NULL */ + + DUK_STATS_INC(thr->heap, stats_getvar_all); + + DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR(env); + DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR(name); + + parents = 1; /* follow parent chain */ + if (duk__get_identifier_reference(thr, env, name, act, parents, &ref)) { + if (ref.value) { + duk_push_tval(thr, ref.value); + duk_push_undefined(thr); + } else { + DUK_ASSERT(ref.holder != NULL); + + /* ref.holder is safe across the getprop call (even + * with side effects) because 'env' is reachable and + * ref.holder is a direct heap pointer. + */ + + DUK_TVAL_SET_OBJECT(&tv_tmp_obj, ref.holder); + DUK_TVAL_SET_STRING(&tv_tmp_key, name); + (void) duk_hobject_getprop(thr, &tv_tmp_obj, &tv_tmp_key); /* [value] */ + + if (ref.has_this) { + duk_push_hobject(thr, ref.holder); + } else { + duk_push_undefined(thr); + } + + /* [value this] */ + } + + return 1; + } else { + if (throw_flag) { + DUK_ERROR_FMT1(thr, + DUK_ERR_REFERENCE_ERROR, + "identifier '%s' undefined", + (const char *) DUK_HSTRING_GET_DATA(name)); + DUK_WO_NORETURN(return 0;); + } + + return 0; + } +} + +DUK_INTERNAL +duk_bool_t duk_js_getvar_envrec(duk_hthread *thr, duk_hobject *env, duk_hstring *name, duk_bool_t throw_flag) { + return duk__getvar_helper(thr, env, NULL, name, throw_flag); +} + +DUK_INTERNAL +duk_bool_t duk_js_getvar_activation(duk_hthread *thr, duk_activation *act, duk_hstring *name, duk_bool_t throw_flag) { + DUK_ASSERT(act != NULL); + return duk__getvar_helper(thr, act->lex_env, act, name, throw_flag); +} + +/* + * PUTVAR + * + * See E5 Sections: + * 11.1.2 Identifier Reference + * 10.3.1 Identifier Resolution + * 11.13.1 Simple Assignment [example of where the Reference is PutValue'd] + * 8.7.2 PutValue (V,W) [see especially step 3.b, undefined -> automatic global in non-strict mode] + * 8.12.4 [[CanPut]] (P) + * 8.12.5 [[Put]] (P) + * + * Note: may invalidate any valstack (or object) duk_tval pointers because + * putting a value may reallocate any object or any valstack. Caller beware. + */ + +DUK_LOCAL +void duk__putvar_helper(duk_hthread *thr, + duk_hobject *env, + duk_activation *act, + duk_hstring *name, + duk_tval *val, + duk_bool_t strict) { + duk__id_lookup_result ref; + duk_tval tv_tmp_val; + duk_tval tv_tmp_obj; + duk_tval tv_tmp_key; + duk_bool_t parents; + + DUK_STATS_INC(thr->heap, stats_putvar_all); + + DUK_DDD(DUK_DDDPRINT("putvar: thr=%p, env=%p, act=%p, name=%!O, val=%p, strict=%ld " + "(env -> %!dO, val -> %!T)", + (void *) thr, + (void *) env, + (void *) act, + (duk_heaphdr *) name, + (void *) val, + (long) strict, + (duk_heaphdr *) env, + (duk_tval *) val)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(name != NULL); + DUK_ASSERT(val != NULL); + /* env and act may be NULL */ + + DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR(env); + DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR(name); + DUK_ASSERT_REFCOUNT_NONZERO_TVAL(val); + + DUK_TVAL_SET_TVAL(&tv_tmp_val, val); /* Stabilize. */ + val = NULL; + + /* + * In strict mode E5 protects 'eval' and 'arguments' from being + * assigned to (or even declared anywhere). Attempt to do so + * should result in a compile time SyntaxError. See the internal + * design documentation for details. + * + * Thus, we should never come here, run-time, for strict code, + * and name 'eval' or 'arguments'. + */ + + DUK_ASSERT(!strict || (name != DUK_HTHREAD_STRING_EVAL(thr) && name != DUK_HTHREAD_STRING_LC_ARGUMENTS(thr))); + + /* + * Lookup variable and update in-place if found. + */ + + parents = 1; /* follow parent chain */ + + if (duk__get_identifier_reference(thr, env, name, act, parents, &ref)) { + if (ref.value && (ref.attrs & DUK_PROPDESC_FLAG_WRITABLE)) { + /* Update duk_tval in-place if pointer provided and the + * property is writable. If the property is not writable + * (immutable binding), use duk_hobject_putprop() which + * will respect mutability. + */ + duk_tval *tv_val; + + tv_val = ref.value; + DUK_ASSERT(tv_val != NULL); + DUK_TVAL_SET_TVAL_UPDREF(thr, tv_val, &tv_tmp_val); /* side effects */ + + /* ref.value invalidated here */ + } else { + DUK_ASSERT(ref.holder != NULL); + + DUK_TVAL_SET_OBJECT(&tv_tmp_obj, ref.holder); + DUK_TVAL_SET_STRING(&tv_tmp_key, name); + (void) duk_hobject_putprop(thr, &tv_tmp_obj, &tv_tmp_key, &tv_tmp_val, strict); + + /* ref.value invalidated here */ + } + + return; + } + + /* + * Not found: write to global object (non-strict) or ReferenceError + * (strict); see E5 Section 8.7.2, step 3. + */ + + if (strict) { + DUK_DDD(DUK_DDDPRINT("identifier binding not found, strict => reference error")); + DUK_ERROR_FMT1(thr, + DUK_ERR_REFERENCE_ERROR, + "identifier '%s' undefined", + (const char *) DUK_HSTRING_GET_DATA(name)); + DUK_WO_NORETURN(return;); + } + + DUK_DDD(DUK_DDDPRINT("identifier binding not found, not strict => set to global")); + + DUK_TVAL_SET_OBJECT(&tv_tmp_obj, thr->builtins[DUK_BIDX_GLOBAL]); + DUK_TVAL_SET_STRING(&tv_tmp_key, name); + (void) duk_hobject_putprop(thr, &tv_tmp_obj, &tv_tmp_key, &tv_tmp_val, 0); /* 0 = no throw */ + + /* NB: 'val' may be invalidated here because put_value may realloc valstack, + * caller beware. + */ +} + +DUK_INTERNAL +void duk_js_putvar_envrec(duk_hthread *thr, duk_hobject *env, duk_hstring *name, duk_tval *val, duk_bool_t strict) { + duk__putvar_helper(thr, env, NULL, name, val, strict); +} + +DUK_INTERNAL +void duk_js_putvar_activation(duk_hthread *thr, duk_activation *act, duk_hstring *name, duk_tval *val, duk_bool_t strict) { + DUK_ASSERT(act != NULL); + duk__putvar_helper(thr, act->lex_env, act, name, val, strict); +} + +/* + * DELVAR + * + * See E5 Sections: + * 11.4.1 The delete operator + * 10.2.1.1.5 DeleteBinding (N) [declarative environment record] + * 10.2.1.2.5 DeleteBinding (N) [object environment record] + * + * Variable bindings established inside eval() are deletable (configurable), + * other bindings are not, including variables declared in global level. + * Registers are always non-deletable, and the deletion of other bindings + * is controlled by the configurable flag. + * + * For strict mode code, the 'delete' operator should fail with a compile + * time SyntaxError if applied to identifiers. Hence, no strict mode + * run-time deletion of identifiers should ever happen. This function + * should never be called from strict mode code! + */ + +DUK_LOCAL +duk_bool_t duk__delvar_helper(duk_hthread *thr, duk_hobject *env, duk_activation *act, duk_hstring *name) { + duk__id_lookup_result ref; + duk_bool_t parents; + + DUK_DDD(DUK_DDDPRINT("delvar: thr=%p, env=%p, act=%p, name=%!O " + "(env -> %!dO)", + (void *) thr, + (void *) env, + (void *) act, + (duk_heaphdr *) name, + (duk_heaphdr *) env)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(name != NULL); + /* env and act may be NULL */ + + DUK_ASSERT_REFCOUNT_NONZERO_HEAPHDR(name); + + parents = 1; /* follow parent chain */ + + if (duk__get_identifier_reference(thr, env, name, act, parents, &ref)) { + if (ref.value && !(ref.attrs & DUK_PROPDESC_FLAG_CONFIGURABLE)) { + /* Identifier found in registers (always non-deletable) + * or declarative environment record and non-configurable. + */ + return 0; + } + DUK_ASSERT(ref.holder != NULL); + + return duk_hobject_delprop_raw(thr, ref.holder, name, 0); + } + + /* + * Not found (even in global object). + * + * In non-strict mode this is a silent SUCCESS (!), see E5 Section 11.4.1, + * step 3.b. In strict mode this case is a compile time SyntaxError so + * we should not come here. + */ + + DUK_DDD(DUK_DDDPRINT("identifier to be deleted not found: name=%!O " + "(treated as silent success)", + (duk_heaphdr *) name)); + return 1; +} + +#if 0 /*unused*/ +DUK_INTERNAL +duk_bool_t duk_js_delvar_envrec(duk_hthread *thr, + duk_hobject *env, + duk_hstring *name) { + return duk__delvar_helper(thr, env, NULL, name); +} +#endif + +DUK_INTERNAL +duk_bool_t duk_js_delvar_activation(duk_hthread *thr, duk_activation *act, duk_hstring *name) { + DUK_ASSERT(act != NULL); + return duk__delvar_helper(thr, act->lex_env, act, name); +} + +/* + * DECLVAR + * + * See E5 Sections: + * 10.4.3 Entering Function Code + * 10.5 Declaration Binding Instantion + * 12.2 Variable Statement + * 11.1.2 Identifier Reference + * 10.3.1 Identifier Resolution + * + * Variable declaration behavior is mainly discussed in Section 10.5, + * and is not discussed in the execution semantics (Sections 11-13). + * + * Conceptually declarations happen when code (global, eval, function) + * is entered, before any user code is executed. In practice, register- + * bound identifiers are 'declared' automatically (by virtue of being + * allocated to registers with the initial value 'undefined'). Other + * identifiers are declared in the function prologue with this primitive. + * + * Since non-register bindings eventually back to an internal object's + * properties, the 'prop_flags' argument is used to specify binding + * type: + * + * - Immutable binding: set DUK_PROPDESC_FLAG_WRITABLE to false + * - Non-deletable binding: set DUK_PROPDESC_FLAG_CONFIGURABLE to false + * - The flag DUK_PROPDESC_FLAG_ENUMERABLE should be set, although it + * doesn't really matter for internal objects + * + * All bindings are non-deletable mutable bindings except: + * + * - Declarations in eval code (mutable, deletable) + * - 'arguments' binding in strict function code (immutable) + * - Function name binding of a function expression (immutable) + * + * Declarations may go to declarative environment records (always + * so for functions), but may also go to object environment records + * (e.g. global code). The global object environment has special + * behavior when re-declaring a function (but not a variable); see + * E5.1 specification, Section 10.5, step 5.e. + * + * Declarations always go to the 'top-most' environment record, i.e. + * we never check the record chain. It's not an error even if a + * property (even an immutable or non-deletable one) of the same name + * already exists. + * + * If a declared variable already exists, its value needs to be updated + * (if possible). Returns 1 if a PUTVAR needs to be done by the caller; + * otherwise returns 0. + */ + +DUK_LOCAL +duk_bool_t duk__declvar_helper(duk_hthread *thr, + duk_hobject *env, + duk_hstring *name, + duk_tval *val, + duk_small_uint_t prop_flags, + duk_bool_t is_func_decl) { + duk_hobject *holder; + duk_bool_t parents; + duk__id_lookup_result ref; + duk_tval *tv; + + DUK_DDD(DUK_DDDPRINT("declvar: thr=%p, env=%p, name=%!O, val=%!T, prop_flags=0x%08lx, is_func_decl=%ld " + "(env -> %!iO)", + (void *) thr, + (void *) env, + (duk_heaphdr *) name, + (duk_tval *) val, + (unsigned long) prop_flags, + (unsigned int) is_func_decl, + (duk_heaphdr *) env)); + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(env != NULL); + DUK_ASSERT(name != NULL); + DUK_ASSERT(val != NULL); + + /* Note: in strict mode the compiler should reject explicit + * declaration of 'eval' or 'arguments'. However, internal + * bytecode may declare 'arguments' in the function prologue. + * We don't bother checking (or asserting) for these now. + */ + + /* Note: val is a stable duk_tval pointer. The caller makes + * a value copy into its stack frame, so 'tv_val' is not subject + * to side effects here. + */ + + /* + * Check whether already declared. + * + * We need to check whether the binding exists in the environment + * without walking its parents. However, we still need to check + * register-bound identifiers and the prototype chain of an object + * environment target object. + */ + + parents = 0; /* just check 'env' */ + if (duk__get_identifier_reference(thr, env, name, NULL, parents, &ref)) { + duk_int_t e_idx; + duk_int_t h_idx; + duk_small_uint_t flags; + + /* + * Variable already declared, ignore re-declaration. + * The only exception is the updated behavior of E5.1 for + * global function declarations, E5.1 Section 10.5, step 5.e. + * This behavior does not apply to global variable declarations. + */ + + if (!(is_func_decl && env == thr->builtins[DUK_BIDX_GLOBAL_ENV])) { + DUK_DDD(DUK_DDDPRINT("re-declare a binding, ignoring")); + return 1; /* 1 -> needs a PUTVAR */ + } + + /* + * Special behavior in E5.1. + * + * Note that even though parents == 0, the conflicting property + * may be an inherited property (currently our global object's + * prototype is Object.prototype). Step 5.e first operates on + * the existing property (which is potentially in an ancestor) + * and then defines a new property in the global object (and + * never modifies the ancestor). + * + * Also note that this logic would become even more complicated + * if the conflicting property might be a virtual one. Object + * prototype has no virtual properties, though. + * + * XXX: this is now very awkward, rework. + */ + + DUK_DDD(DUK_DDDPRINT("re-declare a function binding in global object, " + "updated E5.1 processing")); + + DUK_ASSERT(ref.holder != NULL); + holder = ref.holder; + + /* holder will be set to the target object, not the actual object + * where the property was found (see duk__get_identifier_reference()). + */ + DUK_ASSERT(DUK_HOBJECT_GET_CLASS_NUMBER(holder) == DUK_HOBJECT_CLASS_GLOBAL); + DUK_ASSERT(!DUK_HOBJECT_HAS_EXOTIC_ARRAY(holder)); /* global object doesn't have array part */ + + /* XXX: use a helper for prototype traversal; no loop check here */ + /* must be found: was found earlier, and cannot be inherited */ + for (;;) { + DUK_ASSERT(holder != NULL); + if (duk_hobject_find_entry(thr->heap, holder, name, &e_idx, &h_idx)) { + DUK_ASSERT(e_idx >= 0); + break; + } + /* SCANBUILD: NULL pointer dereference, doesn't actually trigger, + * asserted above. + */ + holder = DUK_HOBJECT_GET_PROTOTYPE(thr->heap, holder); + } + DUK_ASSERT(holder != NULL); + DUK_ASSERT(e_idx >= 0); + /* SCANBUILD: scan-build produces a NULL pointer dereference warning + * below; it never actually triggers because holder is actually never + * NULL. + */ + + /* ref.holder is global object, holder is the object with the + * conflicting property. + */ + + flags = DUK_HOBJECT_E_GET_FLAGS(thr->heap, holder, e_idx); + if (!(flags & DUK_PROPDESC_FLAG_CONFIGURABLE)) { + if (flags & DUK_PROPDESC_FLAG_ACCESSOR) { + DUK_DDD(DUK_DDDPRINT("existing property is a non-configurable " + "accessor -> reject")); + goto fail_existing_attributes; + } + if (!((flags & DUK_PROPDESC_FLAG_WRITABLE) && (flags & DUK_PROPDESC_FLAG_ENUMERABLE))) { + DUK_DDD(DUK_DDDPRINT("existing property is a non-configurable " + "plain property which is not writable and " + "enumerable -> reject")); + goto fail_existing_attributes; + } + + DUK_DDD(DUK_DDDPRINT("existing property is not configurable but " + "is plain, enumerable, and writable -> " + "allow redeclaration")); + } + + if (holder == ref.holder) { + /* XXX: if duk_hobject_define_property_internal() was updated + * to handle a pre-existing accessor property, this would be + * a simple call (like for the ancestor case). + */ + DUK_DDD(DUK_DDDPRINT("redefine, offending property in global object itself")); + + if (flags & DUK_PROPDESC_FLAG_ACCESSOR) { + duk_hobject *tmp; + + tmp = DUK_HOBJECT_E_GET_VALUE_GETTER(thr->heap, holder, e_idx); + DUK_HOBJECT_E_SET_VALUE_GETTER(thr->heap, holder, e_idx, NULL); + DUK_HOBJECT_DECREF_ALLOWNULL(thr, tmp); + DUK_UNREF(tmp); + tmp = DUK_HOBJECT_E_GET_VALUE_SETTER(thr->heap, holder, e_idx); + DUK_HOBJECT_E_SET_VALUE_SETTER(thr->heap, holder, e_idx, NULL); + DUK_HOBJECT_DECREF_ALLOWNULL(thr, tmp); + DUK_UNREF(tmp); + } else { + tv = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, holder, e_idx); + DUK_TVAL_SET_UNDEFINED_UPDREF(thr, tv); + } + + /* Here val would be potentially invalid if we didn't make + * a value copy at the caller. + */ + + tv = DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, holder, e_idx); + DUK_TVAL_SET_TVAL(tv, val); + DUK_TVAL_INCREF(thr, tv); + DUK_HOBJECT_E_SET_FLAGS(thr->heap, holder, e_idx, prop_flags); + + DUK_DDD(DUK_DDDPRINT("updated global binding, final result: " + "value -> %!T, prop_flags=0x%08lx", + (duk_tval *) DUK_HOBJECT_E_GET_VALUE_TVAL_PTR(thr->heap, holder, e_idx), + (unsigned long) prop_flags)); + } else { + DUK_DDD(DUK_DDDPRINT("redefine, offending property in ancestor")); + + DUK_ASSERT(ref.holder == thr->builtins[DUK_BIDX_GLOBAL]); + duk_push_tval(thr, val); + duk_hobject_define_property_internal(thr, ref.holder, name, prop_flags); + } + + return 0; + } + + /* + * Not found (in registers or record objects). Declare + * to current variable environment. + */ + + /* + * Get holder object + */ + + if (DUK_HOBJECT_IS_DECENV(env)) { + DUK_HDECENV_ASSERT_VALID((duk_hdecenv *) env); + holder = env; + } else { + DUK_HOBJENV_ASSERT_VALID((duk_hobjenv *) env); + holder = ((duk_hobjenv *) env)->target; + DUK_ASSERT(holder != NULL); + } + + /* + * Define new property + * + * Note: this may fail if the holder is not extensible. + */ + + /* XXX: this is awkward as we use an internal method which doesn't handle + * extensibility etc correctly. Basically we'd want to do a [[DefineOwnProperty]] + * or Object.defineProperty() here. + */ + + if (!DUK_HOBJECT_HAS_EXTENSIBLE(holder)) { + goto fail_not_extensible; + } + + duk_push_hobject(thr, holder); + duk_push_hstring(thr, name); + duk_push_tval(thr, val); + duk_xdef_prop(thr, -3, prop_flags); /* [holder name val] -> [holder] */ + duk_pop_unsafe(thr); + + return 0; + +fail_existing_attributes: +fail_not_extensible: + DUK_ERROR_TYPE(thr, "declaration failed"); + DUK_WO_NORETURN(return 0;); +} + +DUK_INTERNAL +duk_bool_t duk_js_declvar_activation(duk_hthread *thr, + duk_activation *act, + duk_hstring *name, + duk_tval *val, + duk_small_uint_t prop_flags, + duk_bool_t is_func_decl) { + duk_hobject *env; + duk_tval tv_val_copy; + + DUK_ASSERT(act != NULL); + + /* + * Make a value copy of the input val. This ensures that + * side effects cannot invalidate the pointer. + */ + + DUK_TVAL_SET_TVAL(&tv_val_copy, val); + val = &tv_val_copy; + + /* + * Delayed env creation check + */ + + if (!act->var_env) { + DUK_ASSERT(act->lex_env == NULL); + duk_js_init_activation_environment_records_delayed(thr, act); + /* 'act' is a stable pointer, so still OK. */ + } + DUK_ASSERT(act->lex_env != NULL); + DUK_ASSERT(act->var_env != NULL); + + env = act->var_env; + DUK_ASSERT(env != NULL); + DUK_ASSERT(DUK_HOBJECT_IS_ENV(env)); + + return duk__declvar_helper(thr, env, name, val, prop_flags, is_func_decl); +} +#line 1 "duk_lexer.c" +/* + * Lexer for source files, ToNumber() string conversions, RegExp expressions, + * and JSON. + * + * Provides a stream of ECMAScript tokens from an UTF-8/CESU-8 buffer. The + * caller can also rewind the token stream into a certain position which is + * needed by the compiler part for multi-pass scanning. Tokens are + * represented as duk_token structures, and contain line number information. + * Token types are identified with DUK_TOK_* defines. + * + * Characters are decoded into a fixed size lookup window consisting of + * decoded Unicode code points, with window positions past the end of the + * input filled with an invalid codepoint (-1). The tokenizer can thus + * perform multiple character lookups efficiently and with few sanity + * checks (such as access outside the end of the input), which keeps the + * tokenization code small at the cost of performance. + * + * Character data in tokens, such as identifier names and string literals, + * is encoded into CESU-8 format on-the-fly while parsing the token in + * question. The string data is made reachable to garbage collection by + * placing the token-related values in value stack entries allocated for + * this purpose by the caller. The characters exist in Unicode code point + * form only in the fixed size lookup window, which keeps character data + * expansion (of especially ASCII data) low. + * + * Token parsing supports the full range of Unicode characters as described + * in the E5 specification. Parsing has been optimized for ASCII characters + * because ordinary ECMAScript code consists almost entirely of ASCII + * characters. Matching of complex Unicode codepoint sets (such as in the + * IdentifierStart and IdentifierPart productions) is optimized for size, + * and is done using a linear scan of a bit-packed list of ranges. This is + * very slow, but should never be entered unless the source code actually + * contains Unicode characters. + * + * ECMAScript tokenization is partially context sensitive. First, + * additional future reserved words are recognized in strict mode (see E5 + * Section 7.6.1.2). Second, a forward slash character ('/') can be + * recognized either as starting a RegExp literal or as a division operator, + * depending on context. The caller must provide necessary context flags + * when requesting a new token. + * + * Future work: + * + * * Make line number tracking optional, as it consumes space. + * + * * Add a feature flag for disabling UTF-8 decoding of input, as most + * source code is ASCII. Because of Unicode escapes written in ASCII, + * this does not allow Unicode support to be removed from e.g. + * duk_unicode_is_identifier_start() nor does it allow removal of CESU-8 + * encoding of e.g. string literals. + * + * * Add a feature flag for disabling Unicode compliance of e.g. identifier + * names. This allows for a build more than a kilobyte smaller, because + * Unicode ranges needed by duk_unicode_is_identifier_start() and + * duk_unicode_is_identifier_part() can be dropped. String literals + * should still be allowed to contain escaped Unicode, so this still does + * not allow removal of CESU-8 encoding of e.g. string literals. + * + * * Character lookup tables for codepoints above BMP could be stripped. + * + * * Strictly speaking, E5 specification requires that source code consists + * of 16-bit code units, and if not, must be conceptually converted to + * that format first. The current lexer processes Unicode code points + * and allows characters outside the BMP. These should be converted to + * surrogate pairs while reading the source characters into the window, + * not after tokens have been formed (as is done now). However, the fix + * is not trivial because two characters are decoded from one codepoint. + * + * * Optimize for speed as well as size. Large if-else ladders are (at + * least potentially) slow. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Various defines and file specific helper macros + */ + +#define DUK__MAX_RE_DECESC_DIGITS 9 +#define DUK__MAX_RE_QUANT_DIGITS 9 /* Does not allow e.g. 2**31-1, but one more would allow overflows of u32. */ + +/* whether to use macros or helper function depends on call count */ +#define DUK__ISDIGIT(x) ((x) >= DUK_ASC_0 && (x) <= DUK_ASC_9) +#define DUK__ISHEXDIGIT(x) duk__is_hex_digit((x)) +#define DUK__ISOCTDIGIT(x) ((x) >= DUK_ASC_0 && (x) <= DUK_ASC_7) +#define DUK__ISDIGIT03(x) ((x) >= DUK_ASC_0 && (x) <= DUK_ASC_3) +#define DUK__ISDIGIT47(x) ((x) >= DUK_ASC_4 && (x) <= DUK_ASC_7) + +/* lexer character window helpers */ +#define DUK__LOOKUP(lex_ctx, idx) ((lex_ctx)->window[(idx)].codepoint) +#define DUK__ADVANCECHARS(lex_ctx, count) duk__advance_chars((lex_ctx), (count)) +#define DUK__ADVANCEBYTES(lex_ctx, count) duk__advance_bytes((lex_ctx), (count)) +#define DUK__INITBUFFER(lex_ctx) duk__initbuffer((lex_ctx)) +#define DUK__APPENDBUFFER(lex_ctx, x) duk__appendbuffer((lex_ctx), (duk_codepoint_t) (x)) +#define DUK__APPENDBUFFER_ASCII(lex_ctx, x) duk__appendbuffer_ascii((lex_ctx), (duk_codepoint_t) (x)) + +/* lookup shorthands (note: assume context variable is named 'lex_ctx') */ +#define DUK__L0() DUK__LOOKUP(lex_ctx, 0) +#define DUK__L1() DUK__LOOKUP(lex_ctx, 1) +#define DUK__L2() DUK__LOOKUP(lex_ctx, 2) +#define DUK__L3() DUK__LOOKUP(lex_ctx, 3) +#define DUK__L4() DUK__LOOKUP(lex_ctx, 4) +#define DUK__L5() DUK__LOOKUP(lex_ctx, 5) + +/* packed advance/token number macro used by multiple functions */ +#define DUK__ADVTOK(advbytes, tok) ((((advbytes) * sizeof(duk_lexer_codepoint)) << 8) + (tok)) + +/* + * Advance lookup window by N characters, filling in new characters as + * necessary. After returning caller is guaranteed a character window of + * at least DUK_LEXER_WINDOW_SIZE characters. + * + * The main function duk__advance_bytes() is called at least once per every + * token so it has a major lexer/compiler performance impact. There are two + * variants for the main duk__advance_bytes() algorithm: a sliding window + * approach which is slightly faster at the cost of larger code footprint, + * and a simple copying one. + * + * Decoding directly from the source string would be another lexing option. + * But the lookup window based approach has the advantage of hiding the + * source string and its encoding effectively which gives more flexibility + * going forward to e.g. support chunked streaming of source from flash. + * + * Decodes UTF-8/CESU-8 leniently with support for code points from U+0000 to + * U+10FFFF, causing an error if the input is unparseable. Leniency means: + * + * * Unicode code point validation is intentionally not performed, + * except to check that the codepoint does not exceed 0x10ffff. + * + * * In particular, surrogate pairs are allowed and not combined, which + * allows source files to represent all SourceCharacters with CESU-8. + * Broken surrogate pairs are allowed, as ECMAScript does not mandate + * their validation. + * + * * Allow non-shortest UTF-8 encodings. + * + * Leniency here causes few security concerns because all character data is + * decoded into Unicode codepoints before lexer processing, and is then + * re-encoded into CESU-8. The source can be parsed as strict UTF-8 with + * a compiler option. However, ECMAScript source characters include -all- + * 16-bit unsigned integer codepoints, so leniency seems to be appropriate. + * + * Note that codepoints above the BMP are not strictly SourceCharacters, + * but the lexer still accepts them as such. Before ending up in a string + * or an identifier name, codepoints above BMP are converted into surrogate + * pairs and then CESU-8 encoded, resulting in 16-bit Unicode data as + * expected by ECMAScript. + * + * An alternative approach to dealing with invalid or partial sequences + * would be to skip them and replace them with e.g. the Unicode replacement + * character U+FFFD. This has limited utility because a replacement character + * will most likely cause a parse error, unless it occurs inside a string. + * Further, ECMAScript source is typically pure ASCII. + * + * See: + * + * http://en.wikipedia.org/wiki/UTF-8 + * http://en.wikipedia.org/wiki/CESU-8 + * http://tools.ietf.org/html/rfc3629 + * http://en.wikipedia.org/wiki/UTF-8#Invalid_byte_sequences + * + * Future work: + * + * * Reject other invalid Unicode sequences (see Wikipedia entry for examples) + * in strict UTF-8 mode. + * + * * Size optimize. An attempt to use a 16-byte lookup table for the first + * byte resulted in a code increase though. + * + * * Is checking against maximum 0x10ffff really useful? 4-byte encoding + * imposes a certain limit anyway. + * + * * Support chunked streaming of source code. Can be implemented either + * by streaming chunks of bytes or chunks of codepoints. + */ + +#if defined(DUK_USE_LEXER_SLIDING_WINDOW) +DUK_LOCAL void duk__fill_lexer_buffer(duk_lexer_ctx *lex_ctx, duk_small_uint_t start_offset_bytes) { + duk_lexer_codepoint *cp, *cp_end; + duk_ucodepoint_t x; + duk_small_uint_t contlen; + const duk_uint8_t *p, *p_end; +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + duk_ucodepoint_t mincp; +#endif + duk_int_t input_line; + + /* Use temporaries and update lex_ctx only when finished. */ + input_line = lex_ctx->input_line; + p = lex_ctx->input + lex_ctx->input_offset; + p_end = lex_ctx->input + lex_ctx->input_length; + + cp = (duk_lexer_codepoint *) (void *) ((duk_uint8_t *) lex_ctx->buffer + start_offset_bytes); + cp_end = lex_ctx->buffer + DUK_LEXER_BUFFER_SIZE; + + for (; cp != cp_end; cp++) { + cp->offset = (duk_size_t) (p - lex_ctx->input); + cp->line = input_line; + + /* XXX: potential issue with signed pointers, p_end < p. */ + if (DUK_UNLIKELY(p >= p_end)) { + /* If input_offset were assigned a negative value, it would + * result in a large positive value. Most likely it would be + * larger than input_length and be caught here. In any case + * no memory unsafe behavior would happen. + */ + cp->codepoint = -1; + continue; + } + + x = (duk_ucodepoint_t) (*p++); + + /* Fast path. */ + + if (DUK_LIKELY(x < 0x80UL)) { + DUK_ASSERT(x != 0x2028UL && x != 0x2029UL); /* not LS/PS */ + if (DUK_UNLIKELY(x <= 0x000dUL)) { + if ((x == 0x000aUL) || ((x == 0x000dUL) && (p >= p_end || *p != 0x000aUL))) { + /* lookup for 0x000a above assumes shortest encoding now */ + + /* E5 Section 7.3, treat the following as newlines: + * LF + * CR [not followed by LF] + * LS + * PS + * + * For CR LF, CR is ignored if it is followed by LF, and the LF will bump + * the line number. + */ + input_line++; + } + } + + cp->codepoint = (duk_codepoint_t) x; + continue; + } + + /* Slow path. */ + + if (x < 0xc0UL) { + /* 10xx xxxx -> invalid */ + goto error_encoding; + } else if (x < 0xe0UL) { + /* 110x xxxx 10xx xxxx */ + contlen = 1; +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + mincp = 0x80UL; +#endif + x = x & 0x1fUL; + } else if (x < 0xf0UL) { + /* 1110 xxxx 10xx xxxx 10xx xxxx */ + contlen = 2; +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + mincp = 0x800UL; +#endif + x = x & 0x0fUL; + } else if (x < 0xf8UL) { + /* 1111 0xxx 10xx xxxx 10xx xxxx 10xx xxxx */ + contlen = 3; +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + mincp = 0x10000UL; +#endif + x = x & 0x07UL; + } else { + /* no point in supporting encodings of 5 or more bytes */ + goto error_encoding; + } + + DUK_ASSERT(p_end >= p); + if ((duk_size_t) contlen > (duk_size_t) (p_end - p)) { + goto error_clipped; + } + + while (contlen > 0) { + duk_small_uint_t y; + y = *p++; + if ((y & 0xc0U) != 0x80U) { + /* check that byte has the form 10xx xxxx */ + goto error_encoding; + } + x = x << 6; + x += y & 0x3fUL; + contlen--; + } + + /* check final character validity */ + + if (x > 0x10ffffUL) { + goto error_encoding; + } +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + if (x < mincp || (x >= 0xd800UL && x <= 0xdfffUL) || x == 0xfffeUL) { + goto error_encoding; + } +#endif + + DUK_ASSERT(x != 0x000aUL && x != 0x000dUL); + if ((x == 0x2028UL) || (x == 0x2029UL)) { + input_line++; + } + + cp->codepoint = (duk_codepoint_t) x; + } + + lex_ctx->input_offset = (duk_size_t) (p - lex_ctx->input); + lex_ctx->input_line = input_line; + return; + +error_clipped: /* clipped codepoint */ +error_encoding: /* invalid codepoint encoding or codepoint */ + lex_ctx->input_offset = (duk_size_t) (p - lex_ctx->input); + lex_ctx->input_line = input_line; + + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_SOURCE_DECODE_FAILED); + DUK_WO_NORETURN(return;); +} + +DUK_LOCAL void duk__advance_bytes(duk_lexer_ctx *lex_ctx, duk_small_uint_t count_bytes) { + duk_small_uint_t used_bytes, avail_bytes; + + DUK_ASSERT_DISABLE(count_bytes >= 0); /* unsigned */ + DUK_ASSERT(count_bytes <= (duk_small_uint_t) (DUK_LEXER_WINDOW_SIZE * sizeof(duk_lexer_codepoint))); + DUK_ASSERT(lex_ctx->window >= lex_ctx->buffer); + DUK_ASSERT(lex_ctx->window < lex_ctx->buffer + DUK_LEXER_BUFFER_SIZE); + DUK_ASSERT((duk_uint8_t *) lex_ctx->window + count_bytes <= + (duk_uint8_t *) lex_ctx->buffer + DUK_LEXER_BUFFER_SIZE * sizeof(duk_lexer_codepoint)); + + /* Zero 'count' is also allowed to make call sites easier. + * Arithmetic in bytes generates better code in GCC. + */ + + lex_ctx->window = (duk_lexer_codepoint *) (void *) ((duk_uint8_t *) lex_ctx->window + count_bytes); /* avoid multiply */ + used_bytes = (duk_small_uint_t) ((duk_uint8_t *) lex_ctx->window - (duk_uint8_t *) lex_ctx->buffer); + avail_bytes = DUK_LEXER_BUFFER_SIZE * sizeof(duk_lexer_codepoint) - used_bytes; + if (avail_bytes < (duk_small_uint_t) (DUK_LEXER_WINDOW_SIZE * sizeof(duk_lexer_codepoint))) { + /* Not enough data to provide a full window, so "scroll" window to + * start of buffer and fill up the rest. + */ + duk_memmove((void *) lex_ctx->buffer, (const void *) lex_ctx->window, (size_t) avail_bytes); + lex_ctx->window = lex_ctx->buffer; + duk__fill_lexer_buffer(lex_ctx, avail_bytes); + } +} + +DUK_LOCAL void duk__init_lexer_window(duk_lexer_ctx *lex_ctx) { + lex_ctx->window = lex_ctx->buffer; + duk__fill_lexer_buffer(lex_ctx, 0); +} +#else /* DUK_USE_LEXER_SLIDING_WINDOW */ +DUK_LOCAL duk_codepoint_t duk__read_char(duk_lexer_ctx *lex_ctx) { + duk_ucodepoint_t x; + duk_small_uint_t len; + duk_small_uint_t i; + const duk_uint8_t *p; +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + duk_ucodepoint_t mincp; +#endif + duk_size_t input_offset; + + input_offset = lex_ctx->input_offset; + if (DUK_UNLIKELY(input_offset >= lex_ctx->input_length)) { + /* If input_offset were assigned a negative value, it would + * result in a large positive value. Most likely it would be + * larger than input_length and be caught here. In any case + * no memory unsafe behavior would happen. + */ + return -1; + } + + p = lex_ctx->input + input_offset; + x = (duk_ucodepoint_t) (*p); + + if (DUK_LIKELY(x < 0x80UL)) { + /* 0xxx xxxx -> fast path */ + + /* input offset tracking */ + lex_ctx->input_offset++; + + DUK_ASSERT(x != 0x2028UL && x != 0x2029UL); /* not LS/PS */ + if (DUK_UNLIKELY(x <= 0x000dUL)) { + if ((x == 0x000aUL) || ((x == 0x000dUL) && (lex_ctx->input_offset >= lex_ctx->input_length || + lex_ctx->input[lex_ctx->input_offset] != 0x000aUL))) { + /* lookup for 0x000a above assumes shortest encoding now */ + + /* E5 Section 7.3, treat the following as newlines: + * LF + * CR [not followed by LF] + * LS + * PS + * + * For CR LF, CR is ignored if it is followed by LF, and the LF will bump + * the line number. + */ + lex_ctx->input_line++; + } + } + + return (duk_codepoint_t) x; + } + + /* Slow path. */ + + if (x < 0xc0UL) { + /* 10xx xxxx -> invalid */ + goto error_encoding; + } else if (x < 0xe0UL) { + /* 110x xxxx 10xx xxxx */ + len = 2; +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + mincp = 0x80UL; +#endif + x = x & 0x1fUL; + } else if (x < 0xf0UL) { + /* 1110 xxxx 10xx xxxx 10xx xxxx */ + len = 3; +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + mincp = 0x800UL; +#endif + x = x & 0x0fUL; + } else if (x < 0xf8UL) { + /* 1111 0xxx 10xx xxxx 10xx xxxx 10xx xxxx */ + len = 4; +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + mincp = 0x10000UL; +#endif + x = x & 0x07UL; + } else { + /* no point in supporting encodings of 5 or more bytes */ + goto error_encoding; + } + + DUK_ASSERT(lex_ctx->input_length >= lex_ctx->input_offset); + if ((duk_size_t) len > (duk_size_t) (lex_ctx->input_length - lex_ctx->input_offset)) { + goto error_clipped; + } + + p++; + for (i = 1; i < len; i++) { + duk_small_uint_t y; + y = *p++; + if ((y & 0xc0U) != 0x80U) { + /* check that byte has the form 10xx xxxx */ + goto error_encoding; + } + x = x << 6; + x += y & 0x3fUL; + } + + /* check final character validity */ + + if (x > 0x10ffffUL) { + goto error_encoding; + } +#if defined(DUK_USE_STRICT_UTF8_SOURCE) + if (x < mincp || (x >= 0xd800UL && x <= 0xdfffUL) || x == 0xfffeUL) { + goto error_encoding; + } +#endif + + /* input offset tracking */ + lex_ctx->input_offset += len; + + /* line tracking */ + DUK_ASSERT(x != 0x000aUL && x != 0x000dUL); + if ((x == 0x2028UL) || (x == 0x2029UL)) { + lex_ctx->input_line++; + } + + return (duk_codepoint_t) x; + +error_clipped: /* clipped codepoint */ +error_encoding: /* invalid codepoint encoding or codepoint */ + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_SOURCE_DECODE_FAILED); + DUK_WO_NORETURN(return 0;); +} + +DUK_LOCAL void duk__advance_bytes(duk_lexer_ctx *lex_ctx, duk_small_uint_t count_bytes) { + duk_small_uint_t keep_bytes; + duk_lexer_codepoint *cp, *cp_end; + + DUK_ASSERT_DISABLE(count_bytes >= 0); /* unsigned */ + DUK_ASSERT(count_bytes <= (duk_small_uint_t) (DUK_LEXER_WINDOW_SIZE * sizeof(duk_lexer_codepoint))); + + /* Zero 'count' is also allowed to make call sites easier. */ + + keep_bytes = DUK_LEXER_WINDOW_SIZE * sizeof(duk_lexer_codepoint) - count_bytes; + duk_memmove((void *) lex_ctx->window, (const void *) ((duk_uint8_t *) lex_ctx->window + count_bytes), (size_t) keep_bytes); + + cp = (duk_lexer_codepoint *) ((duk_uint8_t *) lex_ctx->window + keep_bytes); + cp_end = lex_ctx->window + DUK_LEXER_WINDOW_SIZE; + for (; cp != cp_end; cp++) { + cp->offset = lex_ctx->input_offset; + cp->line = lex_ctx->input_line; + cp->codepoint = duk__read_char(lex_ctx); + } +} + +DUK_LOCAL void duk__init_lexer_window(duk_lexer_ctx *lex_ctx) { + /* Call with count == DUK_LEXER_WINDOW_SIZE to fill buffer initially. */ + duk__advance_bytes(lex_ctx, DUK_LEXER_WINDOW_SIZE * sizeof(duk_lexer_codepoint)); /* fill window */ +} +#endif /* DUK_USE_LEXER_SLIDING_WINDOW */ + +DUK_LOCAL void duk__advance_chars(duk_lexer_ctx *lex_ctx, duk_small_uint_t count_chars) { + duk__advance_bytes(lex_ctx, count_chars * sizeof(duk_lexer_codepoint)); +} + +/* + * (Re)initialize the temporary byte buffer. May be called extra times + * with little impact. + */ + +DUK_LOCAL void duk__initbuffer(duk_lexer_ctx *lex_ctx) { + /* Reuse buffer as is unless buffer has grown large. */ + if (DUK_HBUFFER_DYNAMIC_GET_SIZE(lex_ctx->buf) < DUK_LEXER_TEMP_BUF_LIMIT) { + /* Keep current size */ + } else { + duk_hbuffer_resize(lex_ctx->thr, lex_ctx->buf, DUK_LEXER_TEMP_BUF_LIMIT); + } + + DUK_BW_INIT_WITHBUF(lex_ctx->thr, &lex_ctx->bw, lex_ctx->buf); +} + +/* + * Append a Unicode codepoint to the temporary byte buffer. Performs + * CESU-8 surrogate pair encoding for codepoints above the BMP. + * Existing surrogate pairs are allowed and also encoded into CESU-8. + */ + +DUK_LOCAL void duk__appendbuffer(duk_lexer_ctx *lex_ctx, duk_codepoint_t x) { + /* + * Since character data is only generated by decoding the source or by + * the compiler itself, we rely on the input codepoints being correct + * and avoid a check here. + * + * Character data can also come here through decoding of Unicode + * escapes ("\udead\ubeef") so all 16-but unsigned values can be + * present, even when the source file itself is strict UTF-8. + */ + DUK_ASSERT(x >= 0 && x <= 0x10ffffL); + + DUK_BW_WRITE_ENSURE_CESU8(lex_ctx->thr, &lex_ctx->bw, (duk_ucodepoint_t) x); +} + +DUK_LOCAL void duk__appendbuffer_ascii(duk_lexer_ctx *lex_ctx, duk_codepoint_t x) { + /* ASCII characters can be emitted as a single byte without encoding + * which matters for some fast paths. + */ + DUK_ASSERT(x >= 0 && x <= 0x7f); + + DUK_BW_WRITE_ENSURE_U8(lex_ctx->thr, &lex_ctx->bw, (duk_uint8_t) x); +} + +/* + * Intern the temporary byte buffer into a valstack slot + * (in practice, slot1 or slot2). + */ + +DUK_LOCAL duk_hstring *duk__internbuffer(duk_lexer_ctx *lex_ctx, duk_idx_t valstack_idx) { + DUK_ASSERT(valstack_idx == lex_ctx->slot1_idx || valstack_idx == lex_ctx->slot2_idx); + + DUK_BW_PUSH_AS_STRING(lex_ctx->thr, &lex_ctx->bw); + duk_replace(lex_ctx->thr, valstack_idx); + return duk_known_hstring(lex_ctx->thr, valstack_idx); +} + +/* + * Init lexer context + */ + +DUK_INTERNAL void duk_lexer_initctx(duk_lexer_ctx *lex_ctx) { + DUK_ASSERT(lex_ctx != NULL); + + duk_memzero(lex_ctx, sizeof(*lex_ctx)); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) +#if defined(DUK_USE_LEXER_SLIDING_WINDOW) + lex_ctx->window = NULL; +#endif + lex_ctx->thr = NULL; + lex_ctx->input = NULL; + lex_ctx->buf = NULL; +#endif +} + +/* + * Set lexer input position and reinitialize lookup window. + */ + +DUK_INTERNAL void duk_lexer_getpoint(duk_lexer_ctx *lex_ctx, duk_lexer_point *pt) { + pt->offset = lex_ctx->window[0].offset; + pt->line = lex_ctx->window[0].line; +} + +DUK_INTERNAL void duk_lexer_setpoint(duk_lexer_ctx *lex_ctx, duk_lexer_point *pt) { + DUK_ASSERT_DISABLE(pt->offset >= 0); /* unsigned */ + DUK_ASSERT(pt->line >= 1); + lex_ctx->input_offset = pt->offset; + lex_ctx->input_line = pt->line; + duk__init_lexer_window(lex_ctx); +} + +/* + * Lexing helpers + */ + +/* Numeric value of a hex digit (also covers octal and decimal digits) or + * -1 if not a valid hex digit. + */ +DUK_LOCAL duk_codepoint_t duk__hexval_validate(duk_codepoint_t x) { + duk_small_int_t t; + + /* Here 'x' is a Unicode codepoint */ + if (DUK_LIKELY(x >= 0 && x <= 0xff)) { + t = duk_hex_dectab[x]; + if (DUK_LIKELY(t >= 0)) { + return t; + } + } + + return -1; +} + +/* Just a wrapper for call sites where 'x' is known to be valid so + * we assert for it before decoding. + */ +DUK_LOCAL duk_codepoint_t duk__hexval(duk_codepoint_t x) { + duk_codepoint_t ret; + + DUK_ASSERT((x >= DUK_ASC_0 && x <= DUK_ASC_9) || (x >= DUK_ASC_LC_A && x <= DUK_ASC_LC_F) || + (x >= DUK_ASC_UC_A && x <= DUK_ASC_UC_F)); + ret = duk__hexval_validate(x); + DUK_ASSERT(ret >= 0 && ret <= 15); + return ret; +} + +/* having this as a separate function provided a size benefit */ +DUK_LOCAL duk_bool_t duk__is_hex_digit(duk_codepoint_t x) { + if (DUK_LIKELY(x >= 0 && x <= 0xff)) { + return (duk_hex_dectab[x] >= 0); + } + return 0; +} + +/* Parse a Unicode escape of the form \xHH, \uHHHH, or \u{H+}. Shared by + * source and RegExp parsing. + */ +DUK_LOCAL duk_codepoint_t duk__lexer_parse_escape(duk_lexer_ctx *lex_ctx, duk_bool_t allow_es6) { + duk_small_int_t digits; /* Initial value 2 or 4 for fixed length escapes, 0 for ES2015 \u{H+}. */ + duk_codepoint_t escval; + duk_codepoint_t x; + duk_small_uint_t adv; + + DUK_ASSERT(DUK__L0() == DUK_ASC_BACKSLASH); /* caller responsibilities */ + DUK_ASSERT(DUK__L1() == DUK_ASC_LC_X || DUK__L1() == DUK_ASC_LC_U); + DUK_UNREF(allow_es6); + + adv = 2; + digits = 2; + if (DUK__L1() == DUK_ASC_LC_U) { + digits = 4; +#if defined(DUK_USE_ES6_UNICODE_ESCAPE) + if (DUK__L2() == DUK_ASC_LCURLY && allow_es6) { + digits = 0; + adv = 3; + } +#endif + } + DUK__ADVANCECHARS(lex_ctx, adv); + + escval = 0; + for (;;) { + /* One of the escape forms: \xHH, \uHHHH, \u{H+}. + * The 'digits' variable tracks parsing state and is + * initialized to: + * + * \xHH 2 + * \uHH 4 + * \u{H+} 0 first time, updated to -1 to indicate + * at least one digit has been parsed + * + * Octal parsing is handled separately because it can be + * done with fixed lookahead and also has validation + * rules which depend on the escape length (which is + * variable). + * + * We don't need a specific check for x < 0 (end of + * input) or duk_unicode_is_line_terminator(x) + * because the 'dig' decode will fail and lead to a + * SyntaxError. + */ + duk_codepoint_t dig; + + x = DUK__L0(); + DUK__ADVANCECHARS(lex_ctx, 1); + + dig = duk__hexval_validate(x); + if (digits > 0) { + digits--; + if (dig < 0) { + goto fail_escape; + } + DUK_ASSERT(dig >= 0x00 && dig <= 0x0f); + escval = (escval << 4) + dig; + if (digits == 0) { + DUK_ASSERT(escval >= 0 && escval <= 0xffffL); + break; + } + } else { +#if defined(DUK_USE_ES6_UNICODE_ESCAPE) + DUK_ASSERT(digits == 0 /* first time */ || digits == -1 /* others */); + if (dig >= 0) { + DUK_ASSERT(dig >= 0x00 && dig <= 0x0f); + escval = (escval << 4) + dig; + if (escval > 0x10ffffL) { + goto fail_escape; + } + } else if (x == DUK_ASC_RCURLY) { + if (digits == 0) { + /* Empty escape, \u{}. */ + goto fail_escape; + } + DUK_ASSERT(escval >= 0 && escval <= 0x10ffffL); + break; + } else { + goto fail_escape; + } + digits = -1; /* Indicate we have at least one digit. */ +#else /* DUK_USE_ES6_UNICODE_ESCAPE */ + DUK_ASSERT(0); /* Never happens if \u{H+} support disabled. */ +#endif /* DUK_USE_ES6_UNICODE_ESCAPE */ + } + } + + return escval; + +fail_escape: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_ESCAPE); + DUK_WO_NORETURN(return 0;); +} + +/* Parse legacy octal escape of the form \N{1,3}, e.g. \0, \5, \0377. Maximum + * allowed value is \0377 (U+00FF), longest match is used. Used for both string + * RegExp octal escape parsing. Window[0] must be the slash '\' and the first + * digit must already be validated to be in [0-9] by the caller. + */ +DUK_LOCAL duk_codepoint_t duk__lexer_parse_legacy_octal(duk_lexer_ctx *lex_ctx, + duk_small_uint_t *out_adv, + duk_bool_t reject_annex_b) { + duk_codepoint_t cp; + duk_small_uint_t lookup_idx; + duk_small_uint_t adv; + duk_codepoint_t tmp; + + DUK_ASSERT(out_adv != NULL); + DUK_ASSERT(DUK__LOOKUP(lex_ctx, 0) == DUK_ASC_BACKSLASH); + DUK_ASSERT(DUK__LOOKUP(lex_ctx, 1) >= DUK_ASC_0 && DUK__LOOKUP(lex_ctx, 1) <= DUK_ASC_9); + + cp = 0; + tmp = 0; + for (lookup_idx = 1; lookup_idx <= 3; lookup_idx++) { + DUK_DDD(DUK_DDDPRINT("lookup_idx=%ld, cp=%ld", (long) lookup_idx, (long) cp)); + tmp = DUK__LOOKUP(lex_ctx, lookup_idx); + if (tmp < DUK_ASC_0 || tmp > DUK_ASC_7) { + /* No more valid digits. */ + break; + } + tmp = (cp << 3) + (tmp - DUK_ASC_0); + if (tmp > 0xff) { + /* Three digit octal escapes above \377 (= 0xff) + * are not allowed. + */ + break; + } + cp = tmp; + } + DUK_DDD(DUK_DDDPRINT("final lookup_idx=%ld, cp=%ld", (long) lookup_idx, (long) cp)); + + adv = lookup_idx; + if (lookup_idx == 1) { + DUK_DDD(DUK_DDDPRINT("\\8 or \\9 -> treat as literal, accept in strict mode too")); + DUK_ASSERT(tmp == DUK_ASC_8 || tmp == DUK_ASC_9); + cp = tmp; + adv++; /* correction to above, eat offending character */ + } else if (lookup_idx == 2 && cp == 0) { + /* Note: 'foo\0bar' is OK in strict mode, but 'foo\00bar' is not. + * It won't be interpreted as 'foo\u{0}0bar' but as a SyntaxError. + */ + DUK_DDD(DUK_DDDPRINT("\\0 -> accept in strict mode too")); + } else { + /* This clause also handles non-shortest zero, e.g. \00. */ + if (reject_annex_b) { + DUK_DDD(DUK_DDDPRINT("non-zero octal literal %ld -> reject in strict-mode", (long) cp)); + cp = -1; + } else { + DUK_DDD(DUK_DDDPRINT("non-zero octal literal %ld -> accepted", (long) cp)); + DUK_ASSERT(cp >= 0 && cp <= 0xff); + } + } + + *out_adv = adv; + + DUK_ASSERT((cp >= 0 && cp <= 0xff) || (cp == -1 && reject_annex_b)); + return cp; +} + +/* XXX: move strict mode to lex_ctx? */ +DUK_LOCAL void duk__lexer_parse_string_literal(duk_lexer_ctx *lex_ctx, + duk_token *out_token, + duk_small_int_t quote, + duk_bool_t strict_mode) { + duk_small_uint_t adv; + + for (adv = 1 /* initial quote */;;) { + duk_codepoint_t x; + + DUK__ADVANCECHARS(lex_ctx, adv); /* eat opening quote on first loop */ + x = DUK__L0(); + + adv = 1; + if (x == quote) { + DUK__ADVANCECHARS(lex_ctx, 1); /* eat closing quote */ + break; + } else if (x == '\\') { + /* DUK__L0 -> '\' char + * DUK__L1 ... DUK__L5 -> more lookup + */ + duk_small_int_t emitcp = -1; + + x = DUK__L1(); + + /* How much to advance before next loop. */ + adv = 2; /* note: long live range */ + + switch (x) { + case '\'': + emitcp = 0x0027; + break; + case '"': + emitcp = 0x0022; + break; + case '\\': + emitcp = 0x005c; + break; + case 'b': + emitcp = 0x0008; + break; + case 'f': + emitcp = 0x000c; + break; + case 'n': + emitcp = 0x000a; + break; + case 'r': + emitcp = 0x000d; + break; + case 't': + emitcp = 0x0009; + break; + case 'v': + emitcp = 0x000b; + break; + case 'x': + case 'u': { + duk_codepoint_t esc_cp; + esc_cp = duk__lexer_parse_escape(lex_ctx, 1 /*allow_es6*/); + DUK__APPENDBUFFER(lex_ctx, esc_cp); + adv = 0; + break; + } + default: { + if (duk_unicode_is_line_terminator(x)) { + /* line continuation */ + if (x == 0x000d && DUK__L2() == 0x000a) { + /* CR LF again a special case */ + adv = 3; /* line terminator, CR, LF */ + } + } else if (DUK__ISDIGIT(x)) { + /* + * Octal escape or zero escape: + * \0 (lookahead not OctalDigit) + * \1 ... \7 (lookahead not OctalDigit) + * \ZeroToThree OctalDigit (lookahead not OctalDigit) + * \FourToSeven OctalDigit (no lookahead restrictions) + * \ZeroToThree OctalDigit OctalDigit (no lookahead restrictions) + * + * Zero escape is part of the standard syntax. Octal escapes are + * defined in E5 Section B.1.2, and are only allowed in non-strict mode. + * Any other productions starting with a decimal digit are invalid + * but are in practice treated like identity escapes. + * + * Parse octal (up to 3 digits) from the lookup window. + */ + + emitcp = duk__lexer_parse_legacy_octal(lex_ctx, &adv, strict_mode /*reject_annex_b*/); + if (emitcp < 0) { + goto fail_escape; + } + } else if (x < 0) { + goto fail_unterminated; + } else { + /* escaped NonEscapeCharacter */ + DUK__APPENDBUFFER(lex_ctx, x); + } + } /* end default clause */ + } /* end switch */ + + /* Shared handling for single codepoint escapes. */ + if (emitcp >= 0) { + DUK__APPENDBUFFER(lex_ctx, emitcp); + } + + /* Track number of escapes; count not really needed but directive + * prologues need to detect whether there were any escapes or line + * continuations or not. + */ + out_token->num_escapes++; + } else if (x >= 0x20 && x <= 0x7f) { + /* Fast path for ASCII case, avoids line terminator + * check and CESU-8 encoding. + */ + DUK_ASSERT(x >= 0); + DUK_ASSERT(!duk_unicode_is_line_terminator(x)); + DUK_ASSERT(x != quote); + DUK_ASSERT(x != DUK_ASC_BACKSLASH); + DUK__APPENDBUFFER_ASCII(lex_ctx, x); + } else if (x < 0 || duk_unicode_is_line_terminator(x)) { + goto fail_unterminated; + } else { + /* Character which is part of the string but wasn't handled + * by the fast path. + */ + DUK__APPENDBUFFER(lex_ctx, x); + } + } /* string parse loop */ + + return; + +fail_escape: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_ESCAPE); + DUK_WO_NORETURN(return;); + +fail_unterminated: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_UNTERMINATED_STRING); + DUK_WO_NORETURN(return;); +} + +/* Skip to end-of-line (or end-of-file), used for single line comments. */ +DUK_LOCAL void duk__lexer_skip_to_endofline(duk_lexer_ctx *lex_ctx) { + for (;;) { + duk_codepoint_t x; + + x = DUK__L0(); + if (x < 0 || duk_unicode_is_line_terminator(x)) { + break; + } + DUK__ADVANCECHARS(lex_ctx, 1); + } +} + +/* + * Parse ECMAScript source InputElementDiv or InputElementRegExp + * (E5 Section 7), skipping whitespace, comments, and line terminators. + * + * Possible results are: + * (1) a token + * (2) a line terminator (skipped) + * (3) a comment (skipped) + * (4) EOF + * + * White space is automatically skipped from the current position (but + * not after the input element). If input has already ended, returns + * DUK_TOK_EOF indefinitely. If a parse error occurs, uses an DUK_ERROR() + * macro call (and hence a longjmp through current heap longjmp context). + * Comments and line terminator tokens are automatically skipped. + * + * The input element being matched is determined by regexp_mode; if set, + * parses a InputElementRegExp, otherwise a InputElementDiv. The + * difference between these are handling of productions starting with a + * forward slash. + * + * If strict_mode is set, recognizes additional future reserved words + * specific to strict mode, and refuses to parse octal literals. + * + * The matching strategy below is to (currently) use a six character + * lookup window to quickly determine which production is the -longest- + * matching one, and then parse that. The top-level if-else clauses + * match the first character, and the code blocks for each clause + * handle -all- alternatives for that first character. ECMAScript + * specification uses the "longest match wins" semantics, so the order + * of the if-clauses matters. + * + * Misc notes: + * + * * ECMAScript numeric literals do not accept a sign character. + * Consequently e.g. "-1.0" is parsed as two tokens: a negative + * sign and a positive numeric literal. The compiler performs + * the negation during compilation, so this has no adverse impact. + * + * * There is no token for "undefined": it is just a value available + * from the global object (or simply established by doing a reference + * to an undefined value). + * + * * Some contexts want Identifier tokens, which are IdentifierNames + * excluding reserved words, while some contexts want IdentifierNames + * directly. In the latter case e.g. "while" is interpreted as an + * identifier name, not a DUK_TOK_WHILE token. The solution here is + * to provide both token types: DUK_TOK_WHILE goes to 't' while + * DUK_TOK_IDENTIFIER goes to 't_nores', and 'slot1' always contains + * the identifier / keyword name. + * + * * Directive prologue needs to identify string literals such as + * "use strict" and 'use strict', which are sensitive to line + * continuations and escape sequences. For instance, "use\u0020strict" + * is a valid directive but is distinct from "use strict". The solution + * here is to decode escapes while tokenizing, but to keep track of the + * number of escapes. Directive detection can then check that the + * number of escapes is zero. + * + * * Multi-line comments with one or more internal LineTerminator are + * treated like a line terminator to comply with automatic semicolon + * insertion. + */ + +DUK_INTERNAL +void duk_lexer_parse_js_input_element(duk_lexer_ctx *lex_ctx, + duk_token *out_token, + duk_bool_t strict_mode, + duk_bool_t regexp_mode) { + duk_codepoint_t x; /* temporary, must be signed and 32-bit to hold Unicode code points */ + duk_small_uint_t advtok = 0; /* (advance << 8) + token_type, updated at function end, + * init is unnecessary but suppresses "may be used uninitialized" warnings. + */ + duk_bool_t got_lineterm = 0; /* got lineterm preceding non-whitespace, non-lineterm token */ + + if (++lex_ctx->token_count >= lex_ctx->token_limit) { + goto fail_token_limit; + } + + out_token->t = DUK_TOK_EOF; + out_token->t_nores = DUK_TOK_INVALID; /* marker: copy t if not changed */ +#if 0 /* not necessary to init, disabled for faster parsing */ + out_token->num = DUK_DOUBLE_NAN; + out_token->str1 = NULL; + out_token->str2 = NULL; +#endif + out_token->num_escapes = 0; + /* out_token->lineterm set by caller */ + + /* This would be nice, but parsing is faster without resetting the + * value slots. The only side effect is that references to temporary + * string values may linger until lexing is finished; they're then + * freed normally. + */ +#if 0 + duk_to_undefined(lex_ctx->thr, lex_ctx->slot1_idx); + duk_to_undefined(lex_ctx->thr, lex_ctx->slot2_idx); +#endif + + /* 'advtok' indicates how much to advance and which token id to assign + * at the end. This shared functionality minimizes code size. All + * code paths are required to set 'advtok' to some value, so no default + * init value is used. Code paths calling DUK_ERROR() never return so + * they don't need to set advtok. + */ + + /* + * Matching order: + * + * Punctuator first chars, also covers comments, regexps + * LineTerminator + * Identifier or reserved word, also covers null/true/false literals + * NumericLiteral + * StringLiteral + * EOF + * + * The order does not matter as long as the longest match is + * always correctly identified. There are order dependencies + * in the clauses, so it's not trivial to convert to a switch. + */ + +restart_lineupdate: + out_token->start_line = lex_ctx->window[0].line; + +restart: + out_token->start_offset = lex_ctx->window[0].offset; + + x = DUK__L0(); + + switch (x) { + case DUK_ASC_SPACE: + case DUK_ASC_HT: /* fast paths for space and tab */ + DUK__ADVANCECHARS(lex_ctx, 1); + goto restart; + case DUK_ASC_LF: /* LF line terminator; CR LF and Unicode lineterms are handled in slow path */ + DUK__ADVANCECHARS(lex_ctx, 1); + got_lineterm = 1; + goto restart_lineupdate; +#if defined(DUK_USE_SHEBANG_COMMENTS) + case DUK_ASC_HASH: /* '#' */ + if (DUK__L1() == DUK_ASC_EXCLAMATION && lex_ctx->window[0].offset == 0 && (lex_ctx->flags & DUK_COMPILE_SHEBANG)) { + /* "Shebang" comment ('#! ...') on first line. */ + /* DUK__ADVANCECHARS(lex_ctx, 2) would be correct here, but not necessary */ + duk__lexer_skip_to_endofline(lex_ctx); + goto restart; /* line terminator will be handled on next round */ + } + goto fail_token; +#endif /* DUK_USE_SHEBANG_COMMENTS */ + case DUK_ASC_SLASH: /* '/' */ + if (DUK__L1() == DUK_ASC_SLASH) { + /* + * E5 Section 7.4, allow SourceCharacter (which is any 16-bit + * code point). + */ + + /* DUK__ADVANCECHARS(lex_ctx, 2) would be correct here, but not necessary */ + duk__lexer_skip_to_endofline(lex_ctx); + goto restart; /* line terminator will be handled on next round */ + } else if (DUK__L1() == DUK_ASC_STAR) { + /* + * E5 Section 7.4. If the multi-line comment contains a newline, + * it is treated like a single line terminator for automatic + * semicolon insertion. + */ + + duk_bool_t last_asterisk = 0; + DUK__ADVANCECHARS(lex_ctx, 2); + for (;;) { + x = DUK__L0(); + if (x < 0) { + goto fail_unterm_comment; + } + DUK__ADVANCECHARS(lex_ctx, 1); + if (last_asterisk && x == DUK_ASC_SLASH) { + break; + } + if (duk_unicode_is_line_terminator(x)) { + got_lineterm = 1; + } + last_asterisk = (x == DUK_ASC_STAR); + } + goto restart_lineupdate; + } else if (regexp_mode) { +#if defined(DUK_USE_REGEXP_SUPPORT) + /* + * "/" followed by something in regexp mode. See E5 Section 7.8.5. + * + * RegExp parsing is a bit complex. First, the regexp body is delimited + * by forward slashes, but the body may also contain forward slashes as + * part of an escape sequence or inside a character class (delimited by + * square brackets). A mini state machine is used to implement these. + * + * Further, an early (parse time) error must be thrown if the regexp + * would cause a run-time error when used in the expression new RegExp(...). + * Parsing here simply extracts the (candidate) regexp, and also accepts + * invalid regular expressions (which are delimited properly). The caller + * (compiler) must perform final validation and regexp compilation. + * + * RegExp first char may not be '/' (single line comment) or '*' (multi- + * line comment). These have already been checked above, so there is no + * need below for special handling of the first regexp character as in + * the E5 productions. + * + * About unicode escapes within regexp literals: + * + * E5 Section 7.8.5 grammar does NOT accept \uHHHH escapes. + * However, Section 6 states that regexps accept the escapes, + * see paragraph starting with "In string literals...". + * The regexp grammar, which sees the decoded regexp literal + * (after lexical parsing) DOES have a \uHHHH unicode escape. + * So, for instance: + * + * /\u1234/ + * + * should first be parsed by the lexical grammar as: + * + * '\' 'u' RegularExpressionBackslashSequence + * '1' RegularExpressionNonTerminator + * '2' RegularExpressionNonTerminator + * '3' RegularExpressionNonTerminator + * '4' RegularExpressionNonTerminator + * + * and the escape itself is then parsed by the regexp engine. + * This is the current implementation. + * + * Minor spec inconsistency: + * + * E5 Section 7.8.5 RegularExpressionBackslashSequence is: + * + * \ RegularExpressionNonTerminator + * + * while Section A.1 RegularExpressionBackslashSequence is: + * + * \ NonTerminator + * + * The latter is not normative and a typo. + * + */ + + /* first, parse regexp body roughly */ + + duk_small_int_t state = 0; /* 0=base, 1=esc, 2=class, 3=class+esc */ + + DUK__INITBUFFER(lex_ctx); + for (;;) { + DUK__ADVANCECHARS(lex_ctx, 1); /* skip opening slash on first loop */ + x = DUK__L0(); + if (x < 0 || duk_unicode_is_line_terminator(x)) { + goto fail_unterm_regexp; + } + x = DUK__L0(); /* re-read to avoid spill / fetch */ + if (state == 0) { + if (x == DUK_ASC_SLASH) { + DUK__ADVANCECHARS(lex_ctx, 1); /* eat closing slash */ + break; + } else if (x == DUK_ASC_BACKSLASH) { + state = 1; + } else if (x == DUK_ASC_LBRACKET) { + state = 2; + } + } else if (state == 1) { + state = 0; + } else if (state == 2) { + if (x == DUK_ASC_RBRACKET) { + state = 0; + } else if (x == DUK_ASC_BACKSLASH) { + state = 3; + } + } else { /* state == 3 */ + state = 2; + } + DUK__APPENDBUFFER(lex_ctx, x); + } + out_token->str1 = duk__internbuffer(lex_ctx, lex_ctx->slot1_idx); + + /* second, parse flags */ + + DUK__INITBUFFER(lex_ctx); + for (;;) { + x = DUK__L0(); + if (!duk_unicode_is_identifier_part(x)) { + break; + } + x = DUK__L0(); /* re-read to avoid spill / fetch */ + DUK__APPENDBUFFER(lex_ctx, x); + DUK__ADVANCECHARS(lex_ctx, 1); + } + out_token->str2 = duk__internbuffer(lex_ctx, lex_ctx->slot2_idx); + + DUK__INITBUFFER(lex_ctx); /* free some memory */ + + /* validation of the regexp is caller's responsibility */ + + advtok = DUK__ADVTOK(0, DUK_TOK_REGEXP); +#else /* DUK_USE_REGEXP_SUPPORT */ + goto fail_regexp_support; +#endif /* DUK_USE_REGEXP_SUPPORT */ + } else if (DUK__L1() == DUK_ASC_EQUALS) { + /* "/=" and not in regexp mode */ + advtok = DUK__ADVTOK(2, DUK_TOK_DIV_EQ); + } else { + /* "/" and not in regexp mode */ + advtok = DUK__ADVTOK(1, DUK_TOK_DIV); + } + break; + case DUK_ASC_LCURLY: /* '{' */ + advtok = DUK__ADVTOK(1, DUK_TOK_LCURLY); + break; + case DUK_ASC_RCURLY: /* '}' */ + advtok = DUK__ADVTOK(1, DUK_TOK_RCURLY); + break; + case DUK_ASC_LPAREN: /* '(' */ + advtok = DUK__ADVTOK(1, DUK_TOK_LPAREN); + break; + case DUK_ASC_RPAREN: /* ')' */ + advtok = DUK__ADVTOK(1, DUK_TOK_RPAREN); + break; + case DUK_ASC_LBRACKET: /* '[' */ + advtok = DUK__ADVTOK(1, DUK_TOK_LBRACKET); + break; + case DUK_ASC_RBRACKET: /* ']' */ + advtok = DUK__ADVTOK(1, DUK_TOK_RBRACKET); + break; + case DUK_ASC_PERIOD: /* '.' */ + if (DUK__ISDIGIT(DUK__L1())) { + /* Period followed by a digit can only start DecimalLiteral + * (handled in slow path). We could jump straight into the + * DecimalLiteral handling but should avoid goto to inside + * a block. + */ + goto slow_path; + } + advtok = DUK__ADVTOK(1, DUK_TOK_PERIOD); + break; + case DUK_ASC_SEMICOLON: /* ';' */ + advtok = DUK__ADVTOK(1, DUK_TOK_SEMICOLON); + break; + case DUK_ASC_COMMA: /* ',' */ + advtok = DUK__ADVTOK(1, DUK_TOK_COMMA); + break; + case DUK_ASC_LANGLE: /* '<' */ +#if defined(DUK_USE_HTML_COMMENTS) + if (DUK__L1() == DUK_ASC_EXCLAMATION && DUK__L2() == DUK_ASC_MINUS && DUK__L3() == DUK_ASC_MINUS) { + /* + * ES2015: B.1.3, handle "" SingleLineHTMLCloseComment + * Only allowed: + * - on new line + * - preceded only by whitespace + * - preceded by end of multiline comment and optional whitespace + * + * Since whitespace generates no tokens, and multiline comments + * are treated as a line ending, consulting `got_lineterm` is + * sufficient to test for these three options. + */ + + /* DUK__ADVANCECHARS(lex_ctx, 3) would be correct here, but not necessary */ + duk__lexer_skip_to_endofline(lex_ctx); + goto restart; /* line terminator will be handled on next round */ + } else +#endif /* DUK_USE_HTML_COMMENTS */ + if (DUK__L1() == DUK_ASC_MINUS) { + advtok = DUK__ADVTOK(2, DUK_TOK_DECREMENT); + } else if (DUK__L1() == DUK_ASC_EQUALS) { + advtok = DUK__ADVTOK(2, DUK_TOK_SUB_EQ); + } else { + advtok = DUK__ADVTOK(1, DUK_TOK_SUB); + } + break; + case DUK_ASC_STAR: /* '*' */ +#if defined(DUK_USE_ES7_EXP_OPERATOR) + if (DUK__L1() == DUK_ASC_STAR && DUK__L2() == DUK_ASC_EQUALS) { + advtok = DUK__ADVTOK(3, DUK_TOK_EXP_EQ); + } else if (DUK__L1() == DUK_ASC_STAR) { + advtok = DUK__ADVTOK(2, DUK_TOK_EXP); + } else +#endif + if (DUK__L1() == DUK_ASC_EQUALS) { + advtok = DUK__ADVTOK(2, DUK_TOK_MUL_EQ); + } else { + advtok = DUK__ADVTOK(1, DUK_TOK_MUL); + } + break; + case DUK_ASC_PERCENT: /* '%' */ + if (DUK__L1() == DUK_ASC_EQUALS) { + advtok = DUK__ADVTOK(2, DUK_TOK_MOD_EQ); + } else { + advtok = DUK__ADVTOK(1, DUK_TOK_MOD); + } + break; + case DUK_ASC_AMP: /* '&' */ + if (DUK__L1() == DUK_ASC_AMP) { + advtok = DUK__ADVTOK(2, DUK_TOK_LAND); + } else if (DUK__L1() == DUK_ASC_EQUALS) { + advtok = DUK__ADVTOK(2, DUK_TOK_BAND_EQ); + } else { + advtok = DUK__ADVTOK(1, DUK_TOK_BAND); + } + break; + case DUK_ASC_PIPE: /* '|' */ + if (DUK__L1() == DUK_ASC_PIPE) { + advtok = DUK__ADVTOK(2, DUK_TOK_LOR); + } else if (DUK__L1() == DUK_ASC_EQUALS) { + advtok = DUK__ADVTOK(2, DUK_TOK_BOR_EQ); + } else { + advtok = DUK__ADVTOK(1, DUK_TOK_BOR); + } + break; + case DUK_ASC_CARET: /* '^' */ + if (DUK__L1() == DUK_ASC_EQUALS) { + advtok = DUK__ADVTOK(2, DUK_TOK_BXOR_EQ); + } else { + advtok = DUK__ADVTOK(1, DUK_TOK_BXOR); + } + break; + case DUK_ASC_TILDE: /* '~' */ + advtok = DUK__ADVTOK(1, DUK_TOK_BNOT); + break; + case DUK_ASC_QUESTION: /* '?' */ + advtok = DUK__ADVTOK(1, DUK_TOK_QUESTION); + break; + case DUK_ASC_COLON: /* ':' */ + advtok = DUK__ADVTOK(1, DUK_TOK_COLON); + break; + case DUK_ASC_DOUBLEQUOTE: /* '"' */ + case DUK_ASC_SINGLEQUOTE: { /* '\'' */ + DUK__INITBUFFER(lex_ctx); + duk__lexer_parse_string_literal(lex_ctx, out_token, x /*quote*/, strict_mode); + duk__internbuffer(lex_ctx, lex_ctx->slot1_idx); + out_token->str1 = duk_known_hstring(lex_ctx->thr, lex_ctx->slot1_idx); + + DUK__INITBUFFER(lex_ctx); /* free some memory */ + + advtok = DUK__ADVTOK(0, DUK_TOK_STRING); + break; + } + default: + goto slow_path; + } /* switch */ + + goto skip_slow_path; + +slow_path: + if (duk_unicode_is_line_terminator(x)) { + if (x == 0x000d && DUK__L1() == 0x000a) { + /* + * E5 Section 7.3: CR LF is detected as a single line terminator for + * line numbers. Here we also detect it as a single line terminator + * token. + */ + DUK__ADVANCECHARS(lex_ctx, 2); + } else { + DUK__ADVANCECHARS(lex_ctx, 1); + } + got_lineterm = 1; + goto restart_lineupdate; + } else if (duk_unicode_is_identifier_start(x) || x == DUK_ASC_BACKSLASH) { + /* + * Parse an identifier and then check whether it is: + * - reserved word (keyword or other reserved word) + * - "null" (NullLiteral) + * - "true" (BooleanLiteral) + * - "false" (BooleanLiteral) + * - anything else => identifier + * + * This does not follow the E5 productions cleanly, but is + * useful and compact. + * + * Note that identifiers may contain Unicode escapes, + * see E5 Sections 6 and 7.6. They must be decoded first, + * and the result checked against allowed characters. + * The above if-clause accepts an identifier start and an + * '\' character -- no other token can begin with a '\'. + * + * Note that "get" and "set" are not reserved words in E5 + * specification so they are recognized as plain identifiers + * (the tokens DUK_TOK_GET and DUK_TOK_SET are actually not + * used now). The compiler needs to work around this. + * + * Strictly speaking, following ECMAScript longest match + * specification, an invalid escape for the first character + * should cause a syntax error. However, an invalid escape + * for IdentifierParts should just terminate the identifier + * early (longest match), and let the next tokenization + * fail. For instance Rhino croaks with 'foo\z' when + * parsing the identifier. This has little practical impact. + */ + + duk_small_uint_t i, i_end; + duk_bool_t first = 1; + duk_hstring *str; + + DUK__INITBUFFER(lex_ctx); + for (;;) { + /* re-lookup first char on first loop */ + if (DUK__L0() == DUK_ASC_BACKSLASH) { + duk_codepoint_t esc_cp; + if (DUK__L1() != DUK_ASC_LC_U) { + goto fail_escape; + } + esc_cp = duk__lexer_parse_escape(lex_ctx, 1 /*allow_es6*/); + DUK__APPENDBUFFER(lex_ctx, esc_cp); + + /* IdentifierStart is stricter than IdentifierPart, so if the first + * character is escaped, must have a stricter check here. + */ + if (!(first ? duk_unicode_is_identifier_start(esc_cp) : duk_unicode_is_identifier_part(esc_cp))) { + goto fail_escape; + } + + /* Track number of escapes: necessary for proper keyword + * detection. + */ + out_token->num_escapes++; + } else { + /* Note: first character is checked against this. But because + * IdentifierPart includes all IdentifierStart characters, and + * the first character (if unescaped) has already been checked + * in the if condition, this is OK. + */ + if (!duk_unicode_is_identifier_part(DUK__L0())) { + break; + } + DUK__APPENDBUFFER(lex_ctx, DUK__L0()); + DUK__ADVANCECHARS(lex_ctx, 1); + } + first = 0; + } + + out_token->str1 = duk__internbuffer(lex_ctx, lex_ctx->slot1_idx); + str = out_token->str1; + out_token->t_nores = DUK_TOK_IDENTIFIER; + + DUK__INITBUFFER(lex_ctx); /* free some memory */ + + /* + * Interned identifier is compared against reserved words, which are + * currently interned into the heap context. See genbuiltins.py. + * + * Note that an escape in the identifier disables recognition of + * keywords; e.g. "\u0069f = 1;" is a valid statement (assigns to + * identifier named "if"). This is not necessarily compliant, + * see test-dec-escaped-char-in-keyword.js. + * + * Note: "get" and "set" are awkward. They are not officially + * ReservedWords (and indeed e.g. "var set = 1;" is valid), and + * must come out as DUK_TOK_IDENTIFIER. The compiler needs to + * work around this a bit. + */ + + /* XXX: optimize by adding the token numbers directly into the + * always interned duk_hstring objects (there should be enough + * flag bits free for that)? + */ + + i_end = (strict_mode ? DUK_STRIDX_END_RESERVED : DUK_STRIDX_START_STRICT_RESERVED); + + advtok = DUK__ADVTOK(0, DUK_TOK_IDENTIFIER); + if (out_token->num_escapes == 0) { + for (i = DUK_STRIDX_START_RESERVED; i < i_end; i++) { + DUK_ASSERT_DISABLE(i >= 0); /* unsigned */ + DUK_ASSERT(i < DUK_HEAP_NUM_STRINGS); + if (DUK_HTHREAD_GET_STRING(lex_ctx->thr, i) == str) { + advtok = DUK__ADVTOK(0, DUK_STRIDX_TO_TOK(i)); + break; + } + } + } + } else if (DUK__ISDIGIT(x) || (x == DUK_ASC_PERIOD)) { + /* Note: decimal number may start with a period, but must be followed by a digit */ + + /* + * Pre-parsing for decimal, hex, octal (both legacy and ES2015), + * and binary literals, followed by an actual parser step + * provided by numconv. + * + * Note: the leading sign character ('+' or '-') is -not- part of + * the production in E5 grammar, and that the a DecimalLiteral + * starting with a '0' must be followed by a non-digit. + * + * XXX: the two step parsing process is quite awkward, it would + * be more straightforward to allow numconv to parse the longest + * valid prefix (it already does that, it only needs to indicate + * where the input ended). However, the lexer decodes characters + * using a limited lookup window, so this is not a trivial change. + */ + + /* XXX: because of the final check below (that the literal is not + * followed by a digit), this could maybe be simplified, if we bail + * out early from a leading zero (and if there are no periods etc). + * Maybe too complex. + */ + + duk_double_t val; + duk_bool_t legacy_oct = 0; + duk_small_int_t state; /* 0=before period/exp, + * 1=after period, before exp + * 2=after exp, allow '+' or '-' + * 3=after exp and exp sign + */ + duk_small_uint_t s2n_flags; + duk_codepoint_t y, z; + duk_small_int_t s2n_radix = 10; + duk_small_uint_t pre_adv = 0; + + DUK__INITBUFFER(lex_ctx); + y = DUK__L1(); + + if (x == DUK_ASC_0) { + z = DUK_LOWERCASE_CHAR_ASCII(y); + + pre_adv = 2; /* default for 0xNNN, 0oNNN, 0bNNN. */ + if (z == DUK_ASC_LC_X) { + s2n_radix = 16; + } else if (z == DUK_ASC_LC_O) { + s2n_radix = 8; + } else if (z == DUK_ASC_LC_B) { + s2n_radix = 2; + } else { + pre_adv = 0; + if (DUK__ISDIGIT(y)) { + if (strict_mode) { + /* Reject octal like \07 but also octal-lookalike + * decimal like \08 in strict mode. + */ + goto fail_number_literal; + } else { + /* Legacy OctalIntegerLiteral or octal-lookalice + * decimal. Deciding between the two happens below + * in digit scanning. + */ + DUK__APPENDBUFFER(lex_ctx, x); + pre_adv = 1; + legacy_oct = 1; + s2n_radix = 8; /* tentative unless conflicting digits found */ + } + } + } + } + + DUK__ADVANCECHARS(lex_ctx, pre_adv); + + /* XXX: we could parse integers here directly, and fall back + * to numconv only when encountering a fractional expression + * or when an octal literal turned out to be decimal (0778 etc). + */ + state = 0; + for (;;) { + x = DUK__L0(); /* re-lookup curr char on first round */ + if (DUK__ISDIGIT(x)) { + /* Note: intentionally allow leading zeroes here, as the + * actual parser will check for them. + */ + if (state == 0 && legacy_oct && (x == DUK_ASC_8 || x == DUK_ASC_9)) { + /* Started out as an octal-lookalike + * but interpreted as decimal, e.g. + * '0779' -> 779. This also means + * that fractions are allowed, e.g. + * '0779.123' is allowed but '0777.123' + * is not! + */ + s2n_radix = 10; + } + if (state == 2) { + state = 3; + } + } else if (s2n_radix == 16 && DUK__ISHEXDIGIT(x)) { + /* Note: 'e' and 'E' are also accepted here. */ + ; + } else if (x == DUK_ASC_PERIOD) { + if (state >= 1 || s2n_radix != 10) { + break; + } else { + state = 1; + } + } else if (x == DUK_ASC_LC_E || x == DUK_ASC_UC_E) { + if (state >= 2 || s2n_radix != 10) { + break; + } else { + state = 2; + } + } else if (x == DUK_ASC_MINUS || x == DUK_ASC_PLUS) { + if (state != 2) { + break; + } else { + state = 3; + } + } else { + break; + } + DUK__APPENDBUFFER(lex_ctx, x); + DUK__ADVANCECHARS(lex_ctx, 1); + } + + /* XXX: better coercion */ + (void) duk__internbuffer(lex_ctx, lex_ctx->slot1_idx); + + if (s2n_radix != 10) { + /* For bases other than 10, integer only. */ + s2n_flags = DUK_S2N_FLAG_ALLOW_LEADING_ZERO; + } else { + s2n_flags = DUK_S2N_FLAG_ALLOW_EXP | DUK_S2N_FLAG_ALLOW_FRAC | DUK_S2N_FLAG_ALLOW_NAKED_FRAC | + DUK_S2N_FLAG_ALLOW_EMPTY_FRAC | DUK_S2N_FLAG_ALLOW_LEADING_ZERO; + } + + duk_dup(lex_ctx->thr, lex_ctx->slot1_idx); + duk_numconv_parse(lex_ctx->thr, s2n_radix, s2n_flags); + val = duk_to_number_m1(lex_ctx->thr); + if (DUK_ISNAN(val)) { + goto fail_number_literal; + } + duk_replace(lex_ctx->thr, lex_ctx->slot1_idx); /* could also just pop? */ + + DUK__INITBUFFER(lex_ctx); /* free some memory */ + + /* Section 7.8.3 (note): NumericLiteral must be followed by something other than + * IdentifierStart or DecimalDigit. + */ + + if (DUK__ISDIGIT(DUK__L0()) || duk_unicode_is_identifier_start(DUK__L0())) { + goto fail_number_literal; + } + + out_token->num = val; + advtok = DUK__ADVTOK(0, DUK_TOK_NUMBER); + } else if (duk_unicode_is_whitespace(DUK__LOOKUP(lex_ctx, 0))) { + DUK__ADVANCECHARS(lex_ctx, 1); + goto restart; + } else if (x < 0) { + advtok = DUK__ADVTOK(0, DUK_TOK_EOF); + } else { + goto fail_token; + } +skip_slow_path: + + /* + * Shared exit path + */ + + DUK__ADVANCEBYTES(lex_ctx, advtok >> 8); + out_token->t = advtok & 0xff; + if (out_token->t_nores == DUK_TOK_INVALID) { + out_token->t_nores = out_token->t; + } + out_token->lineterm = got_lineterm; + + /* Automatic semicolon insertion is allowed if a token is preceded + * by line terminator(s), or terminates a statement list (right curly + * or EOF). + */ + if (got_lineterm || out_token->t == DUK_TOK_RCURLY || out_token->t == DUK_TOK_EOF) { + out_token->allow_auto_semi = 1; + } else { + out_token->allow_auto_semi = 0; + } + + return; + +fail_token_limit: + DUK_ERROR_RANGE(lex_ctx->thr, DUK_STR_TOKEN_LIMIT); + DUK_WO_NORETURN(return;); + +fail_token: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_TOKEN); + DUK_WO_NORETURN(return;); + +fail_number_literal: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_NUMBER_LITERAL); + DUK_WO_NORETURN(return;); + +fail_escape: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_ESCAPE); + DUK_WO_NORETURN(return;); + +fail_unterm_regexp: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_UNTERMINATED_REGEXP); + DUK_WO_NORETURN(return;); + +fail_unterm_comment: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_UNTERMINATED_COMMENT); + DUK_WO_NORETURN(return;); + +#if !defined(DUK_USE_REGEXP_SUPPORT) +fail_regexp_support: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_REGEXP_SUPPORT_DISABLED); + DUK_WO_NORETURN(return;); +#endif +} + +#if defined(DUK_USE_REGEXP_SUPPORT) + +/* + * Parse a RegExp token. The grammar is described in E5 Section 15.10. + * Terminal constructions (such as quantifiers) are parsed directly here. + * + * 0xffffffffU is used as a marker for "infinity" in quantifiers. Further, + * DUK__MAX_RE_QUANT_DIGITS limits the maximum number of digits that + * will be accepted for a quantifier. + */ + +DUK_INTERNAL void duk_lexer_parse_re_token(duk_lexer_ctx *lex_ctx, duk_re_token *out_token) { + duk_small_uint_t advtok = 0; /* init is unnecessary but suppresses "may be used uninitialized" warnings */ + duk_codepoint_t x, y; + + if (++lex_ctx->token_count >= lex_ctx->token_limit) { + goto fail_token_limit; + } + + duk_memzero(out_token, sizeof(*out_token)); + + x = DUK__L0(); + y = DUK__L1(); + + DUK_DDD(DUK_DDDPRINT("parsing regexp token, L0=%ld, L1=%ld", (long) x, (long) y)); + + switch (x) { + case DUK_ASC_PIPE: { + advtok = DUK__ADVTOK(1, DUK_RETOK_DISJUNCTION); + break; + } + case DUK_ASC_CARET: { + advtok = DUK__ADVTOK(1, DUK_RETOK_ASSERT_START); + break; + } + case DUK_ASC_DOLLAR: { + advtok = DUK__ADVTOK(1, DUK_RETOK_ASSERT_END); + break; + } + case DUK_ASC_QUESTION: { + out_token->qmin = 0; + out_token->qmax = 1; + if (y == DUK_ASC_QUESTION) { + advtok = DUK__ADVTOK(2, DUK_RETOK_QUANTIFIER); + out_token->greedy = 0; + } else { + advtok = DUK__ADVTOK(1, DUK_RETOK_QUANTIFIER); + out_token->greedy = 1; + } + break; + } + case DUK_ASC_STAR: { + out_token->qmin = 0; + out_token->qmax = DUK_RE_QUANTIFIER_INFINITE; + if (y == DUK_ASC_QUESTION) { + advtok = DUK__ADVTOK(2, DUK_RETOK_QUANTIFIER); + out_token->greedy = 0; + } else { + advtok = DUK__ADVTOK(1, DUK_RETOK_QUANTIFIER); + out_token->greedy = 1; + } + break; + } + case DUK_ASC_PLUS: { + out_token->qmin = 1; + out_token->qmax = DUK_RE_QUANTIFIER_INFINITE; + if (y == DUK_ASC_QUESTION) { + advtok = DUK__ADVTOK(2, DUK_RETOK_QUANTIFIER); + out_token->greedy = 0; + } else { + advtok = DUK__ADVTOK(1, DUK_RETOK_QUANTIFIER); + out_token->greedy = 1; + } + break; + } + case DUK_ASC_LCURLY: { + /* Production allows 'DecimalDigits', including leading zeroes */ + duk_uint32_t val1 = 0; + duk_uint32_t val2 = DUK_RE_QUANTIFIER_INFINITE; + duk_small_int_t digits = 0; +#if defined(DUK_USE_ES6_REGEXP_SYNTAX) + duk_lexer_point lex_pt; +#endif + +#if defined(DUK_USE_ES6_REGEXP_SYNTAX) + /* Store lexer position, restoring if quantifier is invalid. */ + DUK_LEXER_GETPOINT(lex_ctx, &lex_pt); +#endif + + for (;;) { + DUK__ADVANCECHARS(lex_ctx, 1); /* eat '{' on entry */ + x = DUK__L0(); + if (DUK__ISDIGIT(x)) { + digits++; + val1 = val1 * 10 + (duk_uint32_t) duk__hexval(x); + } else if (x == DUK_ASC_COMMA) { + if (digits > DUK__MAX_RE_QUANT_DIGITS) { + goto invalid_quantifier; + } + if (val2 != DUK_RE_QUANTIFIER_INFINITE) { + goto invalid_quantifier; + } + if (DUK__L1() == DUK_ASC_RCURLY) { + /* form: { DecimalDigits , }, val1 = min count */ + if (digits == 0) { + goto invalid_quantifier; + } + out_token->qmin = val1; + out_token->qmax = DUK_RE_QUANTIFIER_INFINITE; + DUK__ADVANCECHARS(lex_ctx, 2); + break; + } + val2 = val1; + val1 = 0; + digits = 0; /* not strictly necessary because of lookahead '}' above */ + } else if (x == DUK_ASC_RCURLY) { + if (digits > DUK__MAX_RE_QUANT_DIGITS) { + goto invalid_quantifier; + } + if (digits == 0) { + goto invalid_quantifier; + } + if (val2 != DUK_RE_QUANTIFIER_INFINITE) { + /* val2 = min count, val1 = max count */ + out_token->qmin = val2; + out_token->qmax = val1; + } else { + /* val1 = count */ + out_token->qmin = val1; + out_token->qmax = val1; + } + DUK__ADVANCECHARS(lex_ctx, 1); + break; + } else { + goto invalid_quantifier; + } + } + if (DUK__L0() == DUK_ASC_QUESTION) { + out_token->greedy = 0; + DUK__ADVANCECHARS(lex_ctx, 1); + } else { + out_token->greedy = 1; + } + advtok = DUK__ADVTOK(0, DUK_RETOK_QUANTIFIER); + break; + invalid_quantifier: +#if defined(DUK_USE_ES6_REGEXP_SYNTAX) + /* Failed to match the quantifier, restore lexer and parse + * opening brace as a literal. + */ + DUK_LEXER_SETPOINT(lex_ctx, &lex_pt); + advtok = DUK__ADVTOK(1, DUK_RETOK_ATOM_CHAR); + out_token->num = DUK_ASC_LCURLY; +#else + goto fail_quantifier; +#endif + break; + } + case DUK_ASC_PERIOD: { + advtok = DUK__ADVTOK(1, DUK_RETOK_ATOM_PERIOD); + break; + } + case DUK_ASC_BACKSLASH: { + /* The E5.1 specification does not seem to allow IdentifierPart characters + * to be used as identity escapes. Unfortunately this includes '$', which + * cannot be escaped as '\$'; it needs to be escaped e.g. as '\u0024'. + * Many other implementations (including V8 and Rhino, for instance) do + * accept '\$' as a valid identity escape, which is quite pragmatic, and + * ES2015 Annex B relaxes the rules to allow these (and other) real world forms. + */ + + advtok = DUK__ADVTOK(2, DUK_RETOK_ATOM_CHAR); /* default: char escape (two chars) */ + if (y == DUK_ASC_LC_B) { + advtok = DUK__ADVTOK(2, DUK_RETOK_ASSERT_WORD_BOUNDARY); + } else if (y == DUK_ASC_UC_B) { + advtok = DUK__ADVTOK(2, DUK_RETOK_ASSERT_NOT_WORD_BOUNDARY); + } else if (y == DUK_ASC_LC_F) { + out_token->num = 0x000c; + } else if (y == DUK_ASC_LC_N) { + out_token->num = 0x000a; + } else if (y == DUK_ASC_LC_T) { + out_token->num = 0x0009; + } else if (y == DUK_ASC_LC_R) { + out_token->num = 0x000d; + } else if (y == DUK_ASC_LC_V) { + out_token->num = 0x000b; + } else if (y == DUK_ASC_LC_C) { + x = DUK__L2(); + if ((x >= DUK_ASC_LC_A && x <= DUK_ASC_LC_Z) || (x >= DUK_ASC_UC_A && x <= DUK_ASC_UC_Z)) { + out_token->num = (duk_uint32_t) (x % 32); + advtok = DUK__ADVTOK(3, DUK_RETOK_ATOM_CHAR); + } else { + goto fail_escape; + } + } else if (y == DUK_ASC_LC_X || y == DUK_ASC_LC_U) { + /* The token value is the Unicode codepoint without + * it being decode into surrogate pair characters + * here. The \u{H+} is only allowed in Unicode mode + * which we don't support yet. + */ + out_token->num = (duk_uint32_t) duk__lexer_parse_escape(lex_ctx, 0 /*allow_es6*/); + advtok = DUK__ADVTOK(0, DUK_RETOK_ATOM_CHAR); + } else if (y == DUK_ASC_LC_D) { + advtok = DUK__ADVTOK(2, DUK_RETOK_ATOM_DIGIT); + } else if (y == DUK_ASC_UC_D) { + advtok = DUK__ADVTOK(2, DUK_RETOK_ATOM_NOT_DIGIT); + } else if (y == DUK_ASC_LC_S) { + advtok = DUK__ADVTOK(2, DUK_RETOK_ATOM_WHITE); + } else if (y == DUK_ASC_UC_S) { + advtok = DUK__ADVTOK(2, DUK_RETOK_ATOM_NOT_WHITE); + } else if (y == DUK_ASC_LC_W) { + advtok = DUK__ADVTOK(2, DUK_RETOK_ATOM_WORD_CHAR); + } else if (y == DUK_ASC_UC_W) { + advtok = DUK__ADVTOK(2, DUK_RETOK_ATOM_NOT_WORD_CHAR); + } else if (DUK__ISDIGIT(y)) { + /* E5 Section 15.10.2.11 */ + if (y == DUK_ASC_0) { + if (DUK__ISDIGIT(DUK__L2())) { + goto fail_escape; + } + out_token->num = 0x0000; + advtok = DUK__ADVTOK(2, DUK_RETOK_ATOM_CHAR); + } else { + /* XXX: shared parsing? */ + duk_uint32_t val = 0; + duk_small_int_t i; + for (i = 0;; i++) { + if (i >= DUK__MAX_RE_DECESC_DIGITS) { + goto fail_escape; + } + DUK__ADVANCECHARS(lex_ctx, 1); /* eat backslash on entry */ + x = DUK__L0(); + if (!DUK__ISDIGIT(x)) { + break; + } + val = val * 10 + (duk_uint32_t) duk__hexval(x); + } + /* DUK__L0() cannot be a digit, because the loop doesn't terminate if it is */ + advtok = DUK__ADVTOK(0, DUK_RETOK_ATOM_BACKREFERENCE); + out_token->num = val; + } +#if defined(DUK_USE_ES6_REGEXP_SYNTAX) + } else if (y >= 0) { + /* For ES2015 Annex B, accept any source character as identity + * escape except 'c' which is used for control characters. + * http://www.ecma-international.org/ecma-262/6.0/#sec-regular-expressions-patterns + * Careful not to match end-of-buffer (<0) here. + * This is not yet full ES2015 Annex B because cases above + * (like hex escape) won't backtrack. + */ + DUK_ASSERT(y != DUK_ASC_LC_C); /* covered above */ +#else /* DUK_USE_ES6_REGEXP_SYNTAX */ + } else if ((y >= 0 && !duk_unicode_is_identifier_part(y)) || y == DUK_UNICODE_CP_ZWNJ || y == DUK_UNICODE_CP_ZWJ) { + /* For ES5.1 identity escapes are not allowed for identifier + * parts. This conflicts with a lot of real world code as this + * doesn't e.g. allow escaping a dollar sign as /\$/, see + * test-regexp-identity-escape-dollar.js. + */ +#endif /* DUK_USE_ES6_REGEXP_SYNTAX */ + out_token->num = (duk_uint32_t) y; + } else { + goto fail_escape; + } + break; + } + case DUK_ASC_LPAREN: { + /* XXX: naming is inconsistent: ATOM_END_GROUP ends an ASSERT_START_LOOKAHEAD */ + + if (y == DUK_ASC_QUESTION) { + if (DUK__L2() == DUK_ASC_EQUALS) { + /* (?= */ + advtok = DUK__ADVTOK(3, DUK_RETOK_ASSERT_START_POS_LOOKAHEAD); + } else if (DUK__L2() == DUK_ASC_EXCLAMATION) { + /* (?! */ + advtok = DUK__ADVTOK(3, DUK_RETOK_ASSERT_START_NEG_LOOKAHEAD); + } else if (DUK__L2() == DUK_ASC_COLON) { + /* (?: */ + advtok = DUK__ADVTOK(3, DUK_RETOK_ATOM_START_NONCAPTURE_GROUP); + } else { + goto fail_group; + } + } else { + /* ( */ + advtok = DUK__ADVTOK(1, DUK_RETOK_ATOM_START_CAPTURE_GROUP); + } + break; + } + case DUK_ASC_RPAREN: { + advtok = DUK__ADVTOK(1, DUK_RETOK_ATOM_END_GROUP); + break; + } + case DUK_ASC_LBRACKET: { + /* + * To avoid creating a heavy intermediate value for the list of ranges, + * only the start token ('[' or '[^') is parsed here. The regexp + * compiler parses the ranges itself. + */ + + /* XXX: with DUK_USE_ES6_REGEXP_SYNTAX we should allow left bracket + * literal too, but it's not easy to parse without backtracking. + */ + + advtok = DUK__ADVTOK(1, DUK_RETOK_ATOM_START_CHARCLASS); + if (y == DUK_ASC_CARET) { + advtok = DUK__ADVTOK(2, DUK_RETOK_ATOM_START_CHARCLASS_INVERTED); + } + break; + } +#if !defined(DUK_USE_ES6_REGEXP_SYNTAX) + case DUK_ASC_RCURLY: + case DUK_ASC_RBRACKET: { + /* Although these could be parsed as PatternCharacters unambiguously (here), + * E5 Section 15.10.1 grammar explicitly forbids these as PatternCharacters. + */ + goto fail_invalid_char; + break; + } +#endif + case -1: { + /* EOF */ + advtok = DUK__ADVTOK(0, DUK_TOK_EOF); + break; + } + default: { + /* PatternCharacter, all excluded characters are matched by cases above */ + advtok = DUK__ADVTOK(1, DUK_RETOK_ATOM_CHAR); + out_token->num = (duk_uint32_t) x; + break; + } + } + + /* + * Shared exit path + */ + + DUK__ADVANCEBYTES(lex_ctx, advtok >> 8); + out_token->t = advtok & 0xff; + return; + +fail_token_limit: + DUK_ERROR_RANGE(lex_ctx->thr, DUK_STR_TOKEN_LIMIT); + DUK_WO_NORETURN(return;); + +fail_escape: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_REGEXP_ESCAPE); + DUK_WO_NORETURN(return;); + +fail_group: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_REGEXP_GROUP); + DUK_WO_NORETURN(return;); + +#if !defined(DUK_USE_ES6_REGEXP_SYNTAX) +fail_invalid_char: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_REGEXP_CHARACTER); + DUK_WO_NORETURN(return;); + +fail_quantifier: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_QUANTIFIER); + DUK_WO_NORETURN(return;); +#endif +} + +/* + * Special parser for character classes; calls callback for every + * range parsed and returns the number of ranges present. + */ + +/* XXX: this duplicates functionality in duk_regexp.c where a similar loop is + * required anyway. We could use that BUT we need to update the regexp compiler + * 'nranges' too. Work this out a bit more cleanly to save space. + */ + +/* XXX: the handling of character range detection is a bit convoluted. + * Try to simplify and make smaller. + */ + +/* XXX: logic for handling character ranges is now incorrect, it will accept + * e.g. [\d-z] whereas it should croak from it? SMJS accepts this too, though. + * + * Needs a read through and a lot of additional tests. + */ + +DUK_LOCAL +void duk__emit_u16_direct_ranges(duk_lexer_ctx *lex_ctx, + duk_re_range_callback gen_range, + void *userdata, + const duk_uint16_t *ranges, + duk_small_int_t num) { + const duk_uint16_t *ranges_end; + + DUK_UNREF(lex_ctx); + + ranges_end = ranges + num; + while (ranges < ranges_end) { + /* mark range 'direct', bypass canonicalization (see Wiki) */ + gen_range(userdata, (duk_codepoint_t) ranges[0], (duk_codepoint_t) ranges[1], 1); + ranges += 2; + } +} + +DUK_INTERNAL void duk_lexer_parse_re_ranges(duk_lexer_ctx *lex_ctx, duk_re_range_callback gen_range, void *userdata) { + duk_codepoint_t start = -1; + duk_codepoint_t ch; + duk_codepoint_t x; + duk_bool_t dash = 0; + duk_small_uint_t adv = 0; + + DUK_DD(DUK_DDPRINT("parsing regexp ranges")); + + for (;;) { + DUK__ADVANCECHARS(lex_ctx, adv); + adv = 1; + + x = DUK__L0(); + + ch = -1; /* not strictly necessary, but avoids "uninitialized variable" warnings */ + DUK_UNREF(ch); + + if (x < 0) { + goto fail_unterm_charclass; + } else if (x == DUK_ASC_RBRACKET) { + if (start >= 0) { + gen_range(userdata, start, start, 0); + } + DUK__ADVANCECHARS(lex_ctx, 1); /* eat ']' before finishing */ + break; + } else if (x == DUK_ASC_MINUS) { + if (start >= 0 && !dash && DUK__L1() != DUK_ASC_RBRACKET) { + /* '-' as a range indicator */ + dash = 1; + continue; + } else { + /* '-' verbatim */ + ch = x; + } + } else if (x == DUK_ASC_BACKSLASH) { + /* + * The escapes are same as outside a character class, except that \b has a + * different meaning, and \B and backreferences are prohibited (see E5 + * Section 15.10.2.19). However, it's difficult to share code because we + * handle e.g. "\n" very differently: here we generate a single character + * range for it. + */ + + /* XXX: ES2015 surrogate pair handling. */ + + x = DUK__L1(); + + adv = 2; + + if (x == DUK_ASC_LC_B) { + /* Note: '\b' in char class is different than outside (assertion), + * '\B' is not allowed and is caught by the duk_unicode_is_identifier_part() + * check below. + */ + ch = 0x0008; + } else if (x == DUK_ASC_LC_F) { + ch = 0x000c; + } else if (x == DUK_ASC_LC_N) { + ch = 0x000a; + } else if (x == DUK_ASC_LC_T) { + ch = 0x0009; + } else if (x == DUK_ASC_LC_R) { + ch = 0x000d; + } else if (x == DUK_ASC_LC_V) { + ch = 0x000b; + } else if (x == DUK_ASC_LC_C) { + x = DUK__L2(); + adv = 3; + if ((x >= DUK_ASC_LC_A && x <= DUK_ASC_LC_Z) || (x >= DUK_ASC_UC_A && x <= DUK_ASC_UC_Z)) { + ch = (x % 32); + } else { + goto fail_escape; + } + } else if (x == DUK_ASC_LC_X || x == DUK_ASC_LC_U) { + /* The \u{H+} form is only allowed in Unicode mode which + * we don't support yet. + */ + ch = duk__lexer_parse_escape(lex_ctx, 0 /*allow_es6*/); + adv = 0; + } else if (x == DUK_ASC_LC_D) { + duk__emit_u16_direct_ranges(lex_ctx, + gen_range, + userdata, + duk_unicode_re_ranges_digit, + sizeof(duk_unicode_re_ranges_digit) / sizeof(duk_uint16_t)); + ch = -1; + } else if (x == DUK_ASC_UC_D) { + duk__emit_u16_direct_ranges(lex_ctx, + gen_range, + userdata, + duk_unicode_re_ranges_not_digit, + sizeof(duk_unicode_re_ranges_not_digit) / sizeof(duk_uint16_t)); + ch = -1; + } else if (x == DUK_ASC_LC_S) { + duk__emit_u16_direct_ranges(lex_ctx, + gen_range, + userdata, + duk_unicode_re_ranges_white, + sizeof(duk_unicode_re_ranges_white) / sizeof(duk_uint16_t)); + ch = -1; + } else if (x == DUK_ASC_UC_S) { + duk__emit_u16_direct_ranges(lex_ctx, + gen_range, + userdata, + duk_unicode_re_ranges_not_white, + sizeof(duk_unicode_re_ranges_not_white) / sizeof(duk_uint16_t)); + ch = -1; + } else if (x == DUK_ASC_LC_W) { + duk__emit_u16_direct_ranges(lex_ctx, + gen_range, + userdata, + duk_unicode_re_ranges_wordchar, + sizeof(duk_unicode_re_ranges_wordchar) / sizeof(duk_uint16_t)); + ch = -1; + } else if (x == DUK_ASC_UC_W) { + duk__emit_u16_direct_ranges(lex_ctx, + gen_range, + userdata, + duk_unicode_re_ranges_not_wordchar, + sizeof(duk_unicode_re_ranges_not_wordchar) / sizeof(duk_uint16_t)); + ch = -1; + } else if (DUK__ISDIGIT(x)) { + /* DecimalEscape, only \0 is allowed, no leading + * zeroes are allowed. + * + * ES2015 Annex B also allows (maximal match) legacy + * octal escapes up to \377 and \8 and \9 are + * accepted as literal '8' and '9', also in strict mode. + */ + +#if defined(DUK_USE_ES6_REGEXP_SYNTAX) + ch = duk__lexer_parse_legacy_octal(lex_ctx, &adv, 0 /*reject_annex_b*/); + DUK_ASSERT(ch >= 0); /* no rejections */ +#else + if (x == DUK_ASC_0 && !DUK__ISDIGIT(DUK__L2())) { + ch = 0x0000; + } else { + goto fail_escape; + } +#endif +#if defined(DUK_USE_ES6_REGEXP_SYNTAX) + } else if (x >= 0) { + /* IdentityEscape: ES2015 Annex B allows almost all + * source characters here. Match anything except + * EOF here. + */ + ch = x; +#else /* DUK_USE_ES6_REGEXP_SYNTAX */ + } else if (!duk_unicode_is_identifier_part(x)) { + /* IdentityEscape: ES5.1 doesn't allow identity escape + * for identifier part characters, which conflicts with + * some real world code. For example, it doesn't allow + * /[\$]/ which is awkward. + */ + ch = x; +#endif /* DUK_USE_ES6_REGEXP_SYNTAX */ + } else { + goto fail_escape; + } + } else { + /* character represents itself */ + ch = x; + } + + /* ch is a literal character here or -1 if parsed entity was + * an escape such as "\s". + */ + + if (ch < 0) { + /* multi-character sets not allowed as part of ranges, see + * E5 Section 15.10.2.15, abstract operation CharacterRange. + */ + if (start >= 0) { + if (dash) { + goto fail_range; + } else { + gen_range(userdata, start, start, 0); + start = -1; + /* dash is already 0 */ + } + } + } else { + if (start >= 0) { + if (dash) { + if (start > ch) { + goto fail_range; + } + gen_range(userdata, start, ch, 0); + start = -1; + dash = 0; + } else { + gen_range(userdata, start, start, 0); + start = ch; + /* dash is already 0 */ + } + } else { + start = ch; + } + } + } + + return; + +fail_escape: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_REGEXP_ESCAPE); + DUK_WO_NORETURN(return;); + +fail_range: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_INVALID_RANGE); + DUK_WO_NORETURN(return;); + +fail_unterm_charclass: + DUK_ERROR_SYNTAX(lex_ctx->thr, DUK_STR_UNTERMINATED_CHARCLASS); + DUK_WO_NORETURN(return;); +} + +#endif /* DUK_USE_REGEXP_SUPPORT */ + +/* automatic undefs */ +#undef DUK__ADVANCEBYTES +#undef DUK__ADVANCECHARS +#undef DUK__ADVTOK +#undef DUK__APPENDBUFFER +#undef DUK__APPENDBUFFER_ASCII +#undef DUK__INITBUFFER +#undef DUK__ISDIGIT +#undef DUK__ISDIGIT03 +#undef DUK__ISDIGIT47 +#undef DUK__ISHEXDIGIT +#undef DUK__ISOCTDIGIT +#undef DUK__L0 +#undef DUK__L1 +#undef DUK__L2 +#undef DUK__L3 +#undef DUK__L4 +#undef DUK__L5 +#undef DUK__LOOKUP +#undef DUK__MAX_RE_DECESC_DIGITS +#undef DUK__MAX_RE_QUANT_DIGITS +#line 1 "duk_numconv.c" +/* + * Number-to-string and string-to-number conversions. + * + * Slow path number-to-string and string-to-number conversion is based on + * a Dragon4 variant, with fast paths for small integers. Big integer + * arithmetic is needed for guaranteeing that the conversion is correct + * and uses a minimum number of digits. The big number arithmetic has a + * fixed maximum size and does not require dynamic allocations. + * + * See: doc/number-conversion.rst. + */ + +/* #include duk_internal.h -> already included */ + +#define DUK__IEEE_DOUBLE_EXP_BIAS 1023 +#define DUK__IEEE_DOUBLE_EXP_MIN (-1022) /* biased exp == 0 -> denormal, exp -1022 */ + +#define DUK__DIGITCHAR(x) duk_lc_digits[(x)] + +/* + * Tables generated with util/gennumdigits.py. + * + * duk__str2num_digits_for_radix indicates, for each radix, how many input + * digits should be considered significant for string-to-number conversion. + * The input is also padded to this many digits to give the Dragon4 + * conversion enough (apparent) precision to work with. + * + * duk__str2num_exp_limits indicates, for each radix, the radix-specific + * minimum/maximum exponent values (for a Dragon4 integer mantissa) + * below and above which the number is guaranteed to underflow to zero + * or overflow to Infinity. This allows parsing to keep bigint values + * bounded. + */ + +DUK_LOCAL const duk_uint8_t duk__str2num_digits_for_radix[] = { + 69, 44, 35, 30, 27, 25, 23, 22, 20, 20, /* 2 to 11 */ + 20, 19, 19, 18, 18, 17, 17, 17, 16, 16, /* 12 to 21 */ + 16, 16, 16, 15, 15, 15, 15, 15, 15, 14, /* 22 to 31 */ + 14, 14, 14, 14, 14 /* 31 to 36 */ +}; + +typedef struct { + duk_int16_t upper; + duk_int16_t lower; +} duk__exp_limits; + +DUK_LOCAL const duk__exp_limits duk__str2num_exp_limits[] = { + { 957, -1147 }, { 605, -725 }, { 479, -575 }, { 414, -496 }, { 372, -446 }, { 342, -411 }, { 321, -384 }, + { 304, -364 }, { 291, -346 }, { 279, -334 }, { 268, -323 }, { 260, -312 }, { 252, -304 }, { 247, -296 }, + { 240, -289 }, { 236, -283 }, { 231, -278 }, { 227, -273 }, { 223, -267 }, { 220, -263 }, { 216, -260 }, + { 213, -256 }, { 210, -253 }, { 208, -249 }, { 205, -246 }, { 203, -244 }, { 201, -241 }, { 198, -239 }, + { 196, -237 }, { 195, -234 }, { 193, -232 }, { 191, -230 }, { 190, -228 }, { 188, -226 }, { 187, -225 }, +}; + +/* + * Limited functionality bigint implementation. + * + * Restricted to non-negative numbers with less than 32 * DUK__BI_MAX_PARTS bits, + * with the caller responsible for ensuring this is never exceeded. No memory + * allocation (except stack) is needed for bigint computation. Operations + * have been tailored for number conversion needs. + * + * Argument order is "assignment order", i.e. target first, then arguments: + * x <- y * z --> duk__bi_mul(x, y, z); + */ + +/* This upper value has been experimentally determined; debug build will check + * bigint size with assertions. + */ +#define DUK__BI_MAX_PARTS 37 /* 37x32 = 1184 bits */ + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) +#define DUK__BI_PRINT(name, x) duk__bi_print((name), (x)) +#else +#define DUK__BI_PRINT(name, x) +#endif + +/* Current size is about 152 bytes. */ +typedef struct { + duk_small_int_t n; + duk_uint32_t v[DUK__BI_MAX_PARTS]; /* low to high */ +} duk__bigint; + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) +DUK_LOCAL void duk__bi_print(const char *name, duk__bigint *x) { + /* Overestimate required size; debug code so not critical to be tight. */ + char buf[DUK__BI_MAX_PARTS * 9 + 64]; + char *p = buf; + duk_small_int_t i; + + /* No NUL term checks in this debug code. */ + p += DUK_SPRINTF(p, "%p n=%ld", (void *) x, (long) x->n); + if (x->n == 0) { + p += DUK_SPRINTF(p, " 0"); + } + for (i = x->n - 1; i >= 0; i--) { + p += DUK_SPRINTF(p, " %08lx", (unsigned long) x->v[i]); + } + + DUK_DDD(DUK_DDDPRINT("%s: %s", (const char *) name, (const char *) buf)); +} +#endif + +#if defined(DUK_USE_ASSERTIONS) +DUK_LOCAL duk_small_int_t duk__bi_is_valid(duk__bigint *x) { + return (duk_small_int_t) (((x->n >= 0) && (x->n <= DUK__BI_MAX_PARTS)) /* is valid size */ && + ((x->n == 0) || (x->v[x->n - 1] != 0)) /* is normalized */); +} +#endif + +DUK_LOCAL void duk__bi_normalize(duk__bigint *x) { + duk_small_int_t i; + + for (i = x->n - 1; i >= 0; i--) { + if (x->v[i] != 0) { + break; + } + } + + /* Note: if 'x' is zero, x->n becomes 0 here */ + x->n = i + 1; + DUK_ASSERT(duk__bi_is_valid(x)); +} + +/* x <- y */ +DUK_LOCAL void duk__bi_copy(duk__bigint *x, duk__bigint *y) { + duk_small_int_t n; + + n = y->n; + x->n = n; + /* No need to special case n == 0. */ + duk_memcpy((void *) x->v, (const void *) y->v, (size_t) (sizeof(duk_uint32_t) * (size_t) n)); +} + +DUK_LOCAL void duk__bi_set_small(duk__bigint *x, duk_uint32_t v) { + if (v == 0U) { + x->n = 0; + } else { + x->n = 1; + x->v[0] = v; + } + DUK_ASSERT(duk__bi_is_valid(x)); +} + +/* Return value: <0 <=> x < y + * 0 <=> x == y + * >0 <=> x > y + */ +DUK_LOCAL int duk__bi_compare(duk__bigint *x, duk__bigint *y) { + duk_small_int_t i, nx, ny; + duk_uint32_t tx, ty; + + DUK_ASSERT(duk__bi_is_valid(x)); + DUK_ASSERT(duk__bi_is_valid(y)); + + nx = x->n; + ny = y->n; + if (nx > ny) { + goto ret_gt; + } + if (nx < ny) { + goto ret_lt; + } + for (i = nx - 1; i >= 0; i--) { + tx = x->v[i]; + ty = y->v[i]; + + if (tx > ty) { + goto ret_gt; + } + if (tx < ty) { + goto ret_lt; + } + } + + return 0; + +ret_gt: + return 1; + +ret_lt: + return -1; +} + +/* x <- y + z */ +#if defined(DUK_USE_64BIT_OPS) +DUK_LOCAL void duk__bi_add(duk__bigint *x, duk__bigint *y, duk__bigint *z) { + duk_uint64_t tmp; + duk_small_int_t i, ny, nz; + + DUK_ASSERT(duk__bi_is_valid(y)); + DUK_ASSERT(duk__bi_is_valid(z)); + + if (z->n > y->n) { + duk__bigint *t; + t = y; + y = z; + z = t; + } + DUK_ASSERT(y->n >= z->n); + + ny = y->n; + nz = z->n; + tmp = 0U; + for (i = 0; i < ny; i++) { + DUK_ASSERT(i < DUK__BI_MAX_PARTS); + tmp += y->v[i]; + if (i < nz) { + tmp += z->v[i]; + } + x->v[i] = (duk_uint32_t) (tmp & 0xffffffffUL); + tmp = tmp >> 32; + } + if (tmp != 0U) { + DUK_ASSERT(i < DUK__BI_MAX_PARTS); + x->v[i++] = (duk_uint32_t) tmp; + } + x->n = i; + DUK_ASSERT(x->n <= DUK__BI_MAX_PARTS); + + /* no need to normalize */ + DUK_ASSERT(duk__bi_is_valid(x)); +} +#else /* DUK_USE_64BIT_OPS */ +DUK_LOCAL void duk__bi_add(duk__bigint *x, duk__bigint *y, duk__bigint *z) { + duk_uint32_t carry, tmp1, tmp2; + duk_small_int_t i, ny, nz; + + DUK_ASSERT(duk__bi_is_valid(y)); + DUK_ASSERT(duk__bi_is_valid(z)); + + if (z->n > y->n) { + duk__bigint *t; + t = y; + y = z; + z = t; + } + DUK_ASSERT(y->n >= z->n); + + ny = y->n; + nz = z->n; + carry = 0U; + for (i = 0; i < ny; i++) { + /* Carry is detected based on wrapping which relies on exact 32-bit + * types. + */ + DUK_ASSERT(i < DUK__BI_MAX_PARTS); + tmp1 = y->v[i]; + tmp2 = tmp1; + if (i < nz) { + tmp2 += z->v[i]; + } + + /* Careful with carry condition: + * - If carry not added: 0x12345678 + 0 + 0xffffffff = 0x12345677 (< 0x12345678) + * - If carry added: 0x12345678 + 1 + 0xffffffff = 0x12345678 (== 0x12345678) + */ + if (carry) { + tmp2++; + carry = (tmp2 <= tmp1 ? 1U : 0U); + } else { + carry = (tmp2 < tmp1 ? 1U : 0U); + } + + x->v[i] = tmp2; + } + if (carry) { + DUK_ASSERT(i < DUK__BI_MAX_PARTS); + DUK_ASSERT(carry == 1U); + x->v[i++] = carry; + } + x->n = i; + DUK_ASSERT(x->n <= DUK__BI_MAX_PARTS); + + /* no need to normalize */ + DUK_ASSERT(duk__bi_is_valid(x)); +} +#endif /* DUK_USE_64BIT_OPS */ + +/* x <- y + z */ +DUK_LOCAL void duk__bi_add_small(duk__bigint *x, duk__bigint *y, duk_uint32_t z) { + duk__bigint tmp; + + DUK_ASSERT(duk__bi_is_valid(y)); + + /* XXX: this could be optimized; there is only one call site now though */ + duk__bi_set_small(&tmp, z); + duk__bi_add(x, y, &tmp); + + DUK_ASSERT(duk__bi_is_valid(x)); +} + +#if 0 /* unused */ +/* x <- x + y, use t as temp */ +DUK_LOCAL void duk__bi_add_copy(duk__bigint *x, duk__bigint *y, duk__bigint *t) { + duk__bi_add(t, x, y); + duk__bi_copy(x, t); +} +#endif + +/* x <- y - z, require x >= y => z >= 0, i.e. y >= z */ +#if defined(DUK_USE_64BIT_OPS) +DUK_LOCAL void duk__bi_sub(duk__bigint *x, duk__bigint *y, duk__bigint *z) { + duk_small_int_t i, ny, nz; + duk_uint32_t ty, tz; + duk_int64_t tmp; + + DUK_ASSERT(duk__bi_is_valid(y)); + DUK_ASSERT(duk__bi_is_valid(z)); + DUK_ASSERT(duk__bi_compare(y, z) >= 0); + DUK_ASSERT(y->n >= z->n); + + ny = y->n; + nz = z->n; + tmp = 0; + for (i = 0; i < ny; i++) { + ty = y->v[i]; + if (i < nz) { + tz = z->v[i]; + } else { + tz = 0; + } + tmp = (duk_int64_t) ty - (duk_int64_t) tz + tmp; + x->v[i] = (duk_uint32_t) ((duk_uint64_t) tmp & 0xffffffffUL); + tmp = tmp >> 32; /* 0 or -1 */ + } + DUK_ASSERT(tmp == 0); + + x->n = i; + duk__bi_normalize(x); /* need to normalize, may even cancel to 0 */ + DUK_ASSERT(duk__bi_is_valid(x)); +} +#else +DUK_LOCAL void duk__bi_sub(duk__bigint *x, duk__bigint *y, duk__bigint *z) { + duk_small_int_t i, ny, nz; + duk_uint32_t tmp1, tmp2, borrow; + + DUK_ASSERT(duk__bi_is_valid(y)); + DUK_ASSERT(duk__bi_is_valid(z)); + DUK_ASSERT(duk__bi_compare(y, z) >= 0); + DUK_ASSERT(y->n >= z->n); + + ny = y->n; + nz = z->n; + borrow = 0U; + for (i = 0; i < ny; i++) { + /* Borrow is detected based on wrapping which relies on exact 32-bit + * types. + */ + tmp1 = y->v[i]; + tmp2 = tmp1; + if (i < nz) { + tmp2 -= z->v[i]; + } + + /* Careful with borrow condition: + * - If borrow not subtracted: 0x12345678 - 0 - 0xffffffff = 0x12345679 (> 0x12345678) + * - If borrow subtracted: 0x12345678 - 1 - 0xffffffff = 0x12345678 (== 0x12345678) + */ + if (borrow) { + tmp2--; + borrow = (tmp2 >= tmp1 ? 1U : 0U); + } else { + borrow = (tmp2 > tmp1 ? 1U : 0U); + } + + x->v[i] = tmp2; + } + DUK_ASSERT(borrow == 0U); + + x->n = i; + duk__bi_normalize(x); /* need to normalize, may even cancel to 0 */ + DUK_ASSERT(duk__bi_is_valid(x)); +} +#endif + +#if 0 /* unused */ +/* x <- y - z */ +DUK_LOCAL void duk__bi_sub_small(duk__bigint *x, duk__bigint *y, duk_uint32_t z) { + duk__bigint tmp; + + DUK_ASSERT(duk__bi_is_valid(y)); + + /* XXX: this could be optimized */ + duk__bi_set_small(&tmp, z); + duk__bi_sub(x, y, &tmp); + + DUK_ASSERT(duk__bi_is_valid(x)); +} +#endif + +/* x <- x - y, use t as temp */ +DUK_LOCAL void duk__bi_sub_copy(duk__bigint *x, duk__bigint *y, duk__bigint *t) { + duk__bi_sub(t, x, y); + duk__bi_copy(x, t); +} + +/* x <- y * z */ +DUK_LOCAL void duk__bi_mul(duk__bigint *x, duk__bigint *y, duk__bigint *z) { + duk_small_int_t i, j, nx, nz; + + DUK_ASSERT(duk__bi_is_valid(y)); + DUK_ASSERT(duk__bi_is_valid(z)); + + nx = y->n + z->n; /* max possible */ + DUK_ASSERT(nx <= DUK__BI_MAX_PARTS); + + if (nx == 0) { + /* Both inputs are zero; cases where only one is zero can go + * through main algorithm. + */ + x->n = 0; + return; + } + + duk_memzero((void *) x->v, (size_t) (sizeof(duk_uint32_t) * (size_t) nx)); + x->n = nx; + + nz = z->n; + for (i = 0; i < y->n; i++) { +#if defined(DUK_USE_64BIT_OPS) + duk_uint64_t tmp = 0U; + for (j = 0; j < nz; j++) { + tmp += (duk_uint64_t) y->v[i] * (duk_uint64_t) z->v[j] + x->v[i + j]; + x->v[i + j] = (duk_uint32_t) (tmp & 0xffffffffUL); + tmp = tmp >> 32; + } + if (tmp > 0) { + DUK_ASSERT(i + j < nx); + DUK_ASSERT(i + j < DUK__BI_MAX_PARTS); + DUK_ASSERT(x->v[i + j] == 0U); + x->v[i + j] = (duk_uint32_t) tmp; + } +#else + /* + * Multiply + add + carry for 32-bit components using only 16x16->32 + * multiplies and carry detection based on unsigned overflow. + * + * 1st mult, 32-bit: (A*2^16 + B) + * 2nd mult, 32-bit: (C*2^16 + D) + * 3rd add, 32-bit: E + * 4th add, 32-bit: F + * + * (AC*2^16 + B) * (C*2^16 + D) + E + F + * = AC*2^32 + AD*2^16 + BC*2^16 + BD + E + F + * = AC*2^32 + (AD + BC)*2^16 + (BD + E + F) + * = AC*2^32 + AD*2^16 + BC*2^16 + (BD + E + F) + */ + duk_uint32_t a, b, c, d, e, f; + duk_uint32_t r, s, t; + + a = y->v[i]; + b = a & 0xffffUL; + a = a >> 16; + + f = 0; + for (j = 0; j < nz; j++) { + c = z->v[j]; + d = c & 0xffffUL; + c = c >> 16; + e = x->v[i + j]; + + /* build result as: (r << 32) + s: start with (BD + E + F) */ + r = 0; + s = b * d; + + /* add E */ + t = s + e; + if (t < s) { + r++; + } /* carry */ + s = t; + + /* add F */ + t = s + f; + if (t < s) { + r++; + } /* carry */ + s = t; + + /* add BC*2^16 */ + t = b * c; + r += (t >> 16); + t = s + ((t & 0xffffUL) << 16); + if (t < s) { + r++; + } /* carry */ + s = t; + + /* add AD*2^16 */ + t = a * d; + r += (t >> 16); + t = s + ((t & 0xffffUL) << 16); + if (t < s) { + r++; + } /* carry */ + s = t; + + /* add AC*2^32 */ + t = a * c; + r += t; + + DUK_DDD(DUK_DDDPRINT("ab=%08lx cd=%08lx ef=%08lx -> rs=%08lx %08lx", + (unsigned long) y->v[i], + (unsigned long) z->v[j], + (unsigned long) x->v[i + j], + (unsigned long) r, + (unsigned long) s)); + + x->v[i + j] = s; + f = r; + } + if (f > 0U) { + DUK_ASSERT(i + j < nx); + DUK_ASSERT(i + j < DUK__BI_MAX_PARTS); + DUK_ASSERT(x->v[i + j] == 0U); + x->v[i + j] = (duk_uint32_t) f; + } +#endif /* DUK_USE_64BIT_OPS */ + } + + duk__bi_normalize(x); + DUK_ASSERT(duk__bi_is_valid(x)); +} + +/* x <- y * z */ +DUK_LOCAL void duk__bi_mul_small(duk__bigint *x, duk__bigint *y, duk_uint32_t z) { + duk__bigint tmp; + + DUK_ASSERT(duk__bi_is_valid(y)); + + /* XXX: this could be optimized */ + duk__bi_set_small(&tmp, z); + duk__bi_mul(x, y, &tmp); + + DUK_ASSERT(duk__bi_is_valid(x)); +} + +/* x <- x * y, use t as temp */ +DUK_LOCAL void duk__bi_mul_copy(duk__bigint *x, duk__bigint *y, duk__bigint *t) { + duk__bi_mul(t, x, y); + duk__bi_copy(x, t); +} + +/* x <- x * y, use t as temp */ +DUK_LOCAL void duk__bi_mul_small_copy(duk__bigint *x, duk_uint32_t y, duk__bigint *t) { + duk__bi_mul_small(t, x, y); + duk__bi_copy(x, t); +} + +DUK_LOCAL int duk__bi_is_even(duk__bigint *x) { + DUK_ASSERT(duk__bi_is_valid(x)); + return (x->n == 0) || ((x->v[0] & 0x01) == 0); +} + +DUK_LOCAL int duk__bi_is_zero(duk__bigint *x) { + DUK_ASSERT(duk__bi_is_valid(x)); + return (x->n == 0); /* this is the case for normalized numbers */ +} + +/* Bigint is 2^52. Used to detect normalized IEEE double mantissa values + * which are at the lowest edge (next floating point value downwards has + * a different exponent). The lowest mantissa has the form: + * + * 1000........000 (52 zeroes; only "hidden bit" is set) + */ +DUK_LOCAL duk_small_int_t duk__bi_is_2to52(duk__bigint *x) { + DUK_ASSERT(duk__bi_is_valid(x)); + return (duk_small_int_t) (x->n == 2) && (x->v[0] == 0U) && (x->v[1] == (1U << (52 - 32))); +} + +/* x <- (1< 0); + r = y % 32; + duk_memzero((void *) x->v, sizeof(duk_uint32_t) * (size_t) n); + x->n = n; + x->v[n - 1] = (((duk_uint32_t) 1) << r); +} + +/* x <- b^y; use t1 and t2 as temps */ +DUK_LOCAL void duk__bi_exp_small(duk__bigint *x, duk_small_int_t b, duk_small_int_t y, duk__bigint *t1, duk__bigint *t2) { + /* Fast path the binary case */ + + DUK_ASSERT(x != t1 && x != t2 && t1 != t2); /* distinct bignums, easy mistake to make */ + DUK_ASSERT(b >= 0); + DUK_ASSERT(y >= 0); + + if (b == 2) { + duk__bi_twoexp(x, y); + return; + } + + /* http://en.wikipedia.org/wiki/Exponentiation_by_squaring */ + + DUK_DDD(DUK_DDDPRINT("exp_small: b=%ld, y=%ld", (long) b, (long) y)); + + duk__bi_set_small(x, 1); + duk__bi_set_small(t1, (duk_uint32_t) b); + for (;;) { + /* Loop structure ensures that we don't compute t1^2 unnecessarily + * on the final round, as that might create a bignum exceeding the + * current DUK__BI_MAX_PARTS limit. + */ + if (y & 0x01) { + duk__bi_mul_copy(x, t1, t2); + } + y = y >> 1; + if (y == 0) { + break; + } + duk__bi_mul_copy(t1, t1, t2); + } + + DUK__BI_PRINT("exp_small result", x); +} + +/* + * A Dragon4 number-to-string variant, based on: + * + * Guy L. Steele Jr., Jon L. White: "How to Print Floating-Point Numbers + * Accurately" + * + * Robert G. Burger, R. Kent Dybvig: "Printing Floating-Point Numbers + * Quickly and Accurately" + * + * The current algorithm is based on Figure 1 of the Burger-Dybvig paper, + * i.e. the base implementation without logarithm estimation speedups + * (these would increase code footprint considerably). Fixed-format output + * does not follow the suggestions in the paper; instead, we generate an + * extra digit and round-with-carry. + * + * The same algorithm is used for number parsing (with b=10 and B=2) + * by generating one extra digit and doing rounding manually. + * + * See doc/number-conversion.rst for limitations. + */ + +/* Maximum number of digits generated. */ +#define DUK__MAX_OUTPUT_DIGITS 1040 /* (Number.MAX_VALUE).toString(2).length == 1024, + slack */ + +/* Maximum number of characters in formatted value. */ +#define DUK__MAX_FORMATTED_LENGTH 1040 /* (-Number.MAX_VALUE).toString(2).length == 1025, + slack */ + +/* Number and (minimum) size of bigints in the nc_ctx structure. */ +#define DUK__NUMCONV_CTX_NUM_BIGINTS 7 +#define DUK__NUMCONV_CTX_BIGINTS_SIZE (sizeof(duk__bigint) * DUK__NUMCONV_CTX_NUM_BIGINTS) + +typedef struct { + /* Currently about 7*152 = 1064 bytes. The space for these + * duk__bigints is used also as a temporary buffer for generating + * the final string. This is a bit awkard; a union would be + * more correct. + */ + duk__bigint f, r, s, mp, mm, t1, t2; + + duk_small_int_t is_s2n; /* if 1, doing a string-to-number; else doing a number-to-string */ + duk_small_int_t is_fixed; /* if 1, doing a fixed format output (not free format) */ + duk_small_int_t req_digits; /* requested number of output digits; 0 = free-format */ + duk_small_int_t abs_pos; /* digit position is absolute, not relative */ + duk_small_int_t e; /* exponent for 'f' */ + duk_small_int_t b; /* input radix */ + duk_small_int_t B; /* output radix */ + duk_small_int_t k; /* see algorithm */ + duk_small_int_t low_ok; /* see algorithm */ + duk_small_int_t high_ok; /* see algorithm */ + duk_small_int_t unequal_gaps; /* m+ != m- (very rarely) */ + + /* Buffer used for generated digits, values are in the range [0,B-1]. */ + duk_uint8_t digits[DUK__MAX_OUTPUT_DIGITS]; + duk_small_int_t count; /* digit count */ +} duk__numconv_stringify_ctx; + +/* Note: computes with 'idx' in assertions, so caller beware. + * 'idx' is preincremented, i.e. '1' on first call, because it + * is more convenient for the caller. + */ +#define DUK__DRAGON4_OUTPUT_PREINC(nc_ctx, preinc_idx, x) \ + do { \ + DUK_ASSERT((preinc_idx) -1 >= 0); \ + DUK_ASSERT((preinc_idx) -1 < DUK__MAX_OUTPUT_DIGITS); \ + ((nc_ctx)->digits[(preinc_idx) -1]) = (duk_uint8_t) (x); \ + } while (0) + +DUK_LOCAL duk_size_t duk__dragon4_format_uint32(duk_uint8_t *buf, duk_uint32_t x, duk_small_int_t radix) { + duk_uint8_t *p; + duk_size_t len; + duk_small_int_t dig; + duk_uint32_t t; + + DUK_ASSERT(buf != NULL); + DUK_ASSERT(radix >= 2 && radix <= 36); + + /* A 32-bit unsigned integer formats to at most 32 digits (the + * worst case happens with radix == 2). Output the digits backwards, + * and use a memmove() to get them in the right place. + */ + + p = buf + 32; + for (;;) { + t = x / (duk_uint32_t) radix; + dig = (duk_small_int_t) (x - t * (duk_uint32_t) radix); + x = t; + + DUK_ASSERT(dig >= 0 && dig < 36); + *(--p) = DUK__DIGITCHAR(dig); + + if (x == 0) { + break; + } + } + len = (duk_size_t) ((buf + 32) - p); + + duk_memmove((void *) buf, (const void *) p, (size_t) len); + + return len; +} + +DUK_LOCAL void duk__dragon4_prepare(duk__numconv_stringify_ctx *nc_ctx) { + duk_small_int_t lowest_mantissa; + +#if 1 + /* Assume IEEE round-to-even, so that shorter encoding can be used + * when round-to-even would produce correct result. By removing + * this check (and having low_ok == high_ok == 0) the results would + * still be accurate but in some cases longer than necessary. + */ + if (duk__bi_is_even(&nc_ctx->f)) { + DUK_DDD(DUK_DDDPRINT("f is even")); + nc_ctx->low_ok = 1; + nc_ctx->high_ok = 1; + } else { + DUK_DDD(DUK_DDDPRINT("f is odd")); + nc_ctx->low_ok = 0; + nc_ctx->high_ok = 0; + } +#else + /* Note: not honoring round-to-even should work but now generates incorrect + * results. For instance, 1e23 serializes to "a000...", i.e. the first digit + * equals the radix (10). Scaling stops one step too early in this case. + * Don't know why this is the case, but since this code path is unused, it + * doesn't matter. + */ + nc_ctx->low_ok = 0; + nc_ctx->high_ok = 0; +#endif + + /* For string-to-number, pretend we never have the lowest mantissa as there + * is no natural "precision" for inputs. Having lowest_mantissa == 0, we'll + * fall into the base cases for both e >= 0 and e < 0. + */ + if (nc_ctx->is_s2n) { + lowest_mantissa = 0; + } else { + lowest_mantissa = duk__bi_is_2to52(&nc_ctx->f); + } + + nc_ctx->unequal_gaps = 0; + if (nc_ctx->e >= 0) { + /* exponent non-negative (and thus not minimum exponent) */ + + if (lowest_mantissa) { + /* (>= e 0) AND (= f (expt b (- p 1))) + * + * be <- (expt b e) == b^e + * be1 <- (* be b) == (expt b (+ e 1)) == b^(e+1) + * r <- (* f be1 2) == 2 * f * b^(e+1) [if b==2 -> f * b^(e+2)] + * s <- (* b 2) [if b==2 -> 4] + * m+ <- be1 == b^(e+1) + * m- <- be == b^e + * k <- 0 + * B <- B + * low_ok <- round + * high_ok <- round + */ + + DUK_DDD(DUK_DDDPRINT("non-negative exponent (not smallest exponent); " + "lowest mantissa value for this exponent -> " + "unequal gaps")); + + duk__bi_exp_small(&nc_ctx->mm, nc_ctx->b, nc_ctx->e, &nc_ctx->t1, &nc_ctx->t2); /* mm <- b^e */ + duk__bi_mul_small(&nc_ctx->mp, &nc_ctx->mm, (duk_uint32_t) nc_ctx->b); /* mp <- b^(e+1) */ + duk__bi_mul_small(&nc_ctx->t1, &nc_ctx->f, 2); + duk__bi_mul(&nc_ctx->r, &nc_ctx->t1, &nc_ctx->mp); /* r <- (2 * f) * b^(e+1) */ + duk__bi_set_small(&nc_ctx->s, (duk_uint32_t) (nc_ctx->b * 2)); /* s <- 2 * b */ + nc_ctx->unequal_gaps = 1; + } else { + /* (>= e 0) AND (not (= f (expt b (- p 1)))) + * + * be <- (expt b e) == b^e + * r <- (* f be 2) == 2 * f * b^e [if b==2 -> f * b^(e+1)] + * s <- 2 + * m+ <- be == b^e + * m- <- be == b^e + * k <- 0 + * B <- B + * low_ok <- round + * high_ok <- round + */ + + DUK_DDD(DUK_DDDPRINT("non-negative exponent (not smallest exponent); " + "not lowest mantissa for this exponent -> " + "equal gaps")); + + duk__bi_exp_small(&nc_ctx->mm, nc_ctx->b, nc_ctx->e, &nc_ctx->t1, &nc_ctx->t2); /* mm <- b^e */ + duk__bi_copy(&nc_ctx->mp, &nc_ctx->mm); /* mp <- b^e */ + duk__bi_mul_small(&nc_ctx->t1, &nc_ctx->f, 2); + duk__bi_mul(&nc_ctx->r, &nc_ctx->t1, &nc_ctx->mp); /* r <- (2 * f) * b^e */ + duk__bi_set_small(&nc_ctx->s, 2); /* s <- 2 */ + } + } else { + /* When doing string-to-number, lowest_mantissa is always 0 so + * the exponent check, while incorrect, won't matter. + */ + if (nc_ctx->e > DUK__IEEE_DOUBLE_EXP_MIN /*not minimum exponent*/ && + lowest_mantissa /* lowest mantissa for this exponent*/) { + /* r <- (* f b 2) [if b==2 -> (* f 4)] + * s <- (* (expt b (- 1 e)) 2) == b^(1-e) * 2 [if b==2 -> b^(2-e)] + * m+ <- b == 2 + * m- <- 1 + * k <- 0 + * B <- B + * low_ok <- round + * high_ok <- round + */ + + DUK_DDD(DUK_DDDPRINT("negative exponent; not minimum exponent and " + "lowest mantissa for this exponent -> " + "unequal gaps")); + + duk__bi_mul_small(&nc_ctx->r, &nc_ctx->f, (duk_uint32_t) (nc_ctx->b * 2)); /* r <- (2 * b) * f */ + duk__bi_exp_small(&nc_ctx->t1, + nc_ctx->b, + 1 - nc_ctx->e, + &nc_ctx->s, + &nc_ctx->t2); /* NB: use 's' as temp on purpose */ + duk__bi_mul_small(&nc_ctx->s, &nc_ctx->t1, 2); /* s <- b^(1-e) * 2 */ + duk__bi_set_small(&nc_ctx->mp, 2); + duk__bi_set_small(&nc_ctx->mm, 1); + nc_ctx->unequal_gaps = 1; + } else { + /* r <- (* f 2) + * s <- (* (expt b (- e)) 2) == b^(-e) * 2 [if b==2 -> b^(1-e)] + * m+ <- 1 + * m- <- 1 + * k <- 0 + * B <- B + * low_ok <- round + * high_ok <- round + */ + + DUK_DDD(DUK_DDDPRINT("negative exponent; minimum exponent or not " + "lowest mantissa for this exponent -> " + "equal gaps")); + + duk__bi_mul_small(&nc_ctx->r, &nc_ctx->f, 2); /* r <- 2 * f */ + duk__bi_exp_small(&nc_ctx->t1, + nc_ctx->b, + -nc_ctx->e, + &nc_ctx->s, + &nc_ctx->t2); /* NB: use 's' as temp on purpose */ + duk__bi_mul_small(&nc_ctx->s, &nc_ctx->t1, 2); /* s <- b^(-e) * 2 */ + duk__bi_set_small(&nc_ctx->mp, 1); + duk__bi_set_small(&nc_ctx->mm, 1); + } + } +} + +DUK_LOCAL void duk__dragon4_scale(duk__numconv_stringify_ctx *nc_ctx) { + duk_small_int_t k = 0; + + /* This is essentially the 'scale' algorithm, with recursion removed. + * Note that 'k' is either correct immediately, or will move in one + * direction in the loop. There's no need to do the low/high checks + * on every round (like the Scheme algorithm does). + * + * The scheme algorithm finds 'k' and updates 's' simultaneously, + * while the logical algorithm finds 'k' with 's' having its initial + * value, after which 's' is updated separately (see the Burger-Dybvig + * paper, Section 3.1, steps 2 and 3). + * + * The case where m+ == m- (almost always) is optimized for, because + * it reduces the bigint operations considerably and almost always + * applies. The scale loop only needs to work with m+, so this works. + */ + + /* XXX: this algorithm could be optimized quite a lot by using e.g. + * a logarithm based estimator for 'k' and performing B^n multiplication + * using a lookup table or using some bit-representation based exp + * algorithm. Currently we just loop, with significant performance + * impact for very large and very small numbers. + */ + + DUK_DDD( + DUK_DDDPRINT("scale: B=%ld, low_ok=%ld, high_ok=%ld", (long) nc_ctx->B, (long) nc_ctx->low_ok, (long) nc_ctx->high_ok)); + DUK__BI_PRINT("r(init)", &nc_ctx->r); + DUK__BI_PRINT("s(init)", &nc_ctx->s); + DUK__BI_PRINT("mp(init)", &nc_ctx->mp); + DUK__BI_PRINT("mm(init)", &nc_ctx->mm); + + for (;;) { + DUK_DDD(DUK_DDDPRINT("scale loop (inc k), k=%ld", (long) k)); + DUK__BI_PRINT("r", &nc_ctx->r); + DUK__BI_PRINT("s", &nc_ctx->s); + DUK__BI_PRINT("m+", &nc_ctx->mp); + DUK__BI_PRINT("m-", &nc_ctx->mm); + + duk__bi_add(&nc_ctx->t1, &nc_ctx->r, &nc_ctx->mp); /* t1 = (+ r m+) */ + if (duk__bi_compare(&nc_ctx->t1, &nc_ctx->s) >= (nc_ctx->high_ok ? 0 : 1)) { + DUK_DDD(DUK_DDDPRINT("k is too low")); + /* r <- r + * s <- (* s B) + * m+ <- m+ + * m- <- m- + * k <- (+ k 1) + */ + + duk__bi_mul_small_copy(&nc_ctx->s, (duk_uint32_t) nc_ctx->B, &nc_ctx->t1); + k++; + } else { + break; + } + } + + /* k > 0 -> k was too low, and cannot be too high */ + if (k > 0) { + goto skip_dec_k; + } + + for (;;) { + DUK_DDD(DUK_DDDPRINT("scale loop (dec k), k=%ld", (long) k)); + DUK__BI_PRINT("r", &nc_ctx->r); + DUK__BI_PRINT("s", &nc_ctx->s); + DUK__BI_PRINT("m+", &nc_ctx->mp); + DUK__BI_PRINT("m-", &nc_ctx->mm); + + duk__bi_add(&nc_ctx->t1, &nc_ctx->r, &nc_ctx->mp); /* t1 = (+ r m+) */ + duk__bi_mul_small(&nc_ctx->t2, &nc_ctx->t1, (duk_uint32_t) nc_ctx->B); /* t2 = (* (+ r m+) B) */ + if (duk__bi_compare(&nc_ctx->t2, &nc_ctx->s) <= (nc_ctx->high_ok ? -1 : 0)) { + DUK_DDD(DUK_DDDPRINT("k is too high")); + /* r <- (* r B) + * s <- s + * m+ <- (* m+ B) + * m- <- (* m- B) + * k <- (- k 1) + */ + duk__bi_mul_small_copy(&nc_ctx->r, (duk_uint32_t) nc_ctx->B, &nc_ctx->t1); + duk__bi_mul_small_copy(&nc_ctx->mp, (duk_uint32_t) nc_ctx->B, &nc_ctx->t1); + if (nc_ctx->unequal_gaps) { + DUK_DDD(DUK_DDDPRINT("m+ != m- -> need to update m- too")); + duk__bi_mul_small_copy(&nc_ctx->mm, (duk_uint32_t) nc_ctx->B, &nc_ctx->t1); + } + k--; + } else { + break; + } + } + +skip_dec_k: + + if (!nc_ctx->unequal_gaps) { + DUK_DDD(DUK_DDDPRINT("equal gaps, copy m- from m+")); + duk__bi_copy(&nc_ctx->mm, &nc_ctx->mp); /* mm <- mp */ + } + nc_ctx->k = k; + + DUK_DDD(DUK_DDDPRINT("final k: %ld", (long) k)); + DUK__BI_PRINT("r(final)", &nc_ctx->r); + DUK__BI_PRINT("s(final)", &nc_ctx->s); + DUK__BI_PRINT("mp(final)", &nc_ctx->mp); + DUK__BI_PRINT("mm(final)", &nc_ctx->mm); +} + +DUK_LOCAL void duk__dragon4_generate(duk__numconv_stringify_ctx *nc_ctx) { + duk_small_int_t tc1, tc2; /* terminating conditions */ + duk_small_int_t d; /* current digit */ + duk_small_int_t count = 0; /* digit count */ + + /* + * Digit generation loop. + * + * Different termination conditions: + * + * 1. Free format output. Terminate when shortest accurate + * representation found. + * + * 2. Fixed format output, with specific number of digits. + * Ignore termination conditions, terminate when digits + * generated. Caller requests an extra digit and rounds. + * + * 3. Fixed format output, with a specific absolute cut-off + * position (e.g. 10 digits after decimal point). Note + * that we always generate at least one digit, even if + * the digit is below the cut-off point already. + */ + + for (;;) { + DUK_DDD(DUK_DDDPRINT("generate loop, count=%ld, k=%ld, B=%ld, low_ok=%ld, high_ok=%ld", + (long) count, + (long) nc_ctx->k, + (long) nc_ctx->B, + (long) nc_ctx->low_ok, + (long) nc_ctx->high_ok)); + DUK__BI_PRINT("r", &nc_ctx->r); + DUK__BI_PRINT("s", &nc_ctx->s); + DUK__BI_PRINT("m+", &nc_ctx->mp); + DUK__BI_PRINT("m-", &nc_ctx->mm); + + /* (quotient-remainder (* r B) s) using a dummy subtraction loop */ + duk__bi_mul_small(&nc_ctx->t1, &nc_ctx->r, (duk_uint32_t) nc_ctx->B); /* t1 <- (* r B) */ + d = 0; + for (;;) { + if (duk__bi_compare(&nc_ctx->t1, &nc_ctx->s) < 0) { + break; + } + duk__bi_sub_copy(&nc_ctx->t1, &nc_ctx->s, &nc_ctx->t2); /* t1 <- t1 - s */ + d++; + } + duk__bi_copy(&nc_ctx->r, &nc_ctx->t1); /* r <- (remainder (* r B) s) */ + /* d <- (quotient (* r B) s) (in range 0...B-1) */ + DUK_DDD(DUK_DDDPRINT("-> d(quot)=%ld", (long) d)); + DUK__BI_PRINT("r(rem)", &nc_ctx->r); + + duk__bi_mul_small_copy(&nc_ctx->mp, (duk_uint32_t) nc_ctx->B, &nc_ctx->t2); /* m+ <- (* m+ B) */ + duk__bi_mul_small_copy(&nc_ctx->mm, (duk_uint32_t) nc_ctx->B, &nc_ctx->t2); /* m- <- (* m- B) */ + DUK__BI_PRINT("mp(upd)", &nc_ctx->mp); + DUK__BI_PRINT("mm(upd)", &nc_ctx->mm); + + /* Terminating conditions. For fixed width output, we just ignore the + * terminating conditions (and pretend that tc1 == tc2 == false). The + * the current shortcut for fixed-format output is to generate a few + * extra digits and use rounding (with carry) to finish the output. + */ + + if (nc_ctx->is_fixed == 0) { + /* free-form */ + tc1 = (duk__bi_compare(&nc_ctx->r, &nc_ctx->mm) <= (nc_ctx->low_ok ? 0 : -1)); + + duk__bi_add(&nc_ctx->t1, &nc_ctx->r, &nc_ctx->mp); /* t1 <- (+ r m+) */ + tc2 = (duk__bi_compare(&nc_ctx->t1, &nc_ctx->s) >= (nc_ctx->high_ok ? 0 : 1)); + + DUK_DDD(DUK_DDDPRINT("tc1=%ld, tc2=%ld", (long) tc1, (long) tc2)); + } else { + /* fixed-format */ + tc1 = 0; + tc2 = 0; + } + + /* Count is incremented before DUK__DRAGON4_OUTPUT_PREINC() call + * on purpose, which is taken into account by the macro. + */ + count++; + + if (tc1) { + if (tc2) { + /* tc1 = true, tc2 = true */ + duk__bi_mul_small(&nc_ctx->t1, &nc_ctx->r, 2); + if (duk__bi_compare(&nc_ctx->t1, &nc_ctx->s) < 0) { /* (< (* r 2) s) */ + DUK_DDD(DUK_DDDPRINT("tc1=true, tc2=true, 2r > s: output d --> %ld (k=%ld)", + (long) d, + (long) nc_ctx->k)); + DUK__DRAGON4_OUTPUT_PREINC(nc_ctx, count, d); + } else { + DUK_DDD(DUK_DDDPRINT("tc1=true, tc2=true, 2r <= s: output d+1 --> %ld (k=%ld)", + (long) (d + 1), + (long) nc_ctx->k)); + DUK__DRAGON4_OUTPUT_PREINC(nc_ctx, count, d + 1); + } + break; + } else { + /* tc1 = true, tc2 = false */ + DUK_DDD(DUK_DDDPRINT("tc1=true, tc2=false: output d --> %ld (k=%ld)", (long) d, (long) nc_ctx->k)); + DUK__DRAGON4_OUTPUT_PREINC(nc_ctx, count, d); + break; + } + } else { + if (tc2) { + /* tc1 = false, tc2 = true */ + DUK_DDD(DUK_DDDPRINT("tc1=false, tc2=true: output d+1 --> %ld (k=%ld)", + (long) (d + 1), + (long) nc_ctx->k)); + DUK__DRAGON4_OUTPUT_PREINC(nc_ctx, count, d + 1); + break; + } else { + /* tc1 = false, tc2 = false */ + DUK_DDD(DUK_DDDPRINT("tc1=false, tc2=false: output d --> %ld (k=%ld)", (long) d, (long) nc_ctx->k)); + DUK__DRAGON4_OUTPUT_PREINC(nc_ctx, count, d); + + /* r <- r (updated above: r <- (remainder (* r B) s) + * s <- s + * m+ <- m+ (updated above: m+ <- (* m+ B) + * m- <- m- (updated above: m- <- (* m- B) + * B, low_ok, high_ok are fixed + */ + + /* fall through and continue for-loop */ + } + } + + /* fixed-format termination conditions */ + if (nc_ctx->is_fixed) { + if (nc_ctx->abs_pos) { + int pos = nc_ctx->k - count + 1; /* count is already incremented, take into account */ + DUK_DDD(DUK_DDDPRINT("fixed format, absolute: abs pos=%ld, k=%ld, count=%ld, req=%ld", + (long) pos, + (long) nc_ctx->k, + (long) count, + (long) nc_ctx->req_digits)); + if (pos <= nc_ctx->req_digits) { + DUK_DDD(DUK_DDDPRINT("digit position reached req_digits, end generate loop")); + break; + } + } else { + DUK_DDD(DUK_DDDPRINT("fixed format, relative: k=%ld, count=%ld, req=%ld", + (long) nc_ctx->k, + (long) count, + (long) nc_ctx->req_digits)); + if (count >= nc_ctx->req_digits) { + DUK_DDD(DUK_DDDPRINT("digit count reached req_digits, end generate loop")); + break; + } + } + } + } /* for */ + + nc_ctx->count = count; + + DUK_DDD(DUK_DDDPRINT("generate finished")); + +#if defined(DUK_USE_DEBUG_LEVEL) && (DUK_USE_DEBUG_LEVEL >= 2) + { + duk_uint8_t buf[2048]; + duk_small_int_t i, t; + duk_memzero(buf, sizeof(buf)); + for (i = 0; i < nc_ctx->count; i++) { + t = nc_ctx->digits[i]; + if (t < 0 || t > 36) { + buf[i] = (duk_uint8_t) '?'; + } else { + buf[i] = (duk_uint8_t) DUK__DIGITCHAR(t); + } + } + DUK_DDD(DUK_DDDPRINT("-> generated digits; k=%ld, digits='%s'", (long) nc_ctx->k, (const char *) buf)); + } +#endif +} + +/* Round up digits to a given position. If position is out-of-bounds, + * does nothing. If carry propagates over the first digit, a '1' is + * prepended to digits and 'k' will be updated. Return value indicates + * whether carry propagated over the first digit. + * + * Note that nc_ctx->count is NOT updated based on the rounding position + * (it is updated only if carry overflows over the first digit and an + * extra digit is prepended). + */ +DUK_LOCAL duk_small_int_t duk__dragon4_fixed_format_round(duk__numconv_stringify_ctx *nc_ctx, duk_small_int_t round_idx) { + duk_small_int_t t; + duk_uint8_t *p; + duk_uint8_t roundup_limit; + duk_small_int_t ret = 0; + + /* + * round_idx points to the digit which is considered for rounding; the + * digit to its left is the final digit of the rounded value. If round_idx + * is zero, rounding will be performed; the result will either be an empty + * rounded value or if carry happens a '1' digit is generated. + */ + + if (round_idx >= nc_ctx->count) { + DUK_DDD(DUK_DDDPRINT("round_idx out of bounds (%ld >= %ld (count)) -> no rounding", + (long) round_idx, + (long) nc_ctx->count)); + return 0; + } else if (round_idx < 0) { + DUK_DDD(DUK_DDDPRINT("round_idx out of bounds (%ld < 0) -> no rounding", (long) round_idx)); + return 0; + } + + /* + * Round-up limit. + * + * For even values, divides evenly, e.g. 10 -> roundup_limit=5. + * + * For odd values, rounds up, e.g. 3 -> roundup_limit=2. + * If radix is 3, 0/3 -> down, 1/3 -> down, 2/3 -> up. + */ + roundup_limit = (duk_uint8_t) ((nc_ctx->B + 1) / 2); + + p = &nc_ctx->digits[round_idx]; + if (*p >= roundup_limit) { + DUK_DDD(DUK_DDDPRINT("fixed-format rounding carry required")); + /* carry */ + for (;;) { + *p = 0; + if (p == &nc_ctx->digits[0]) { + DUK_DDD(DUK_DDDPRINT("carry propagated to first digit -> special case handling")); + duk_memmove((void *) (&nc_ctx->digits[1]), + (const void *) (&nc_ctx->digits[0]), + (size_t) (sizeof(char) * (size_t) nc_ctx->count)); + nc_ctx->digits[0] = 1; /* don't increase 'count' */ + nc_ctx->k++; /* position of highest digit changed */ + nc_ctx->count++; /* number of digits changed */ + ret = 1; + break; + } + + DUK_DDD(DUK_DDDPRINT("fixed-format rounding carry: B=%ld, roundup_limit=%ld, p=%p, digits=%p", + (long) nc_ctx->B, + (long) roundup_limit, + (void *) p, + (void *) nc_ctx->digits)); + p--; + t = *p; + DUK_DDD(DUK_DDDPRINT("digit before carry: %ld", (long) t)); + if (++t < nc_ctx->B) { + DUK_DDD(DUK_DDDPRINT("rounding carry terminated")); + *p = (duk_uint8_t) t; + break; + } + + DUK_DDD(DUK_DDDPRINT("wraps, carry to next digit")); + } + } + + return ret; +} + +#define DUK__NO_EXP (65536) /* arbitrary marker, outside valid exp range */ + +DUK_LOCAL void duk__dragon4_convert_and_push(duk__numconv_stringify_ctx *nc_ctx, + duk_hthread *thr, + duk_small_int_t radix, + duk_small_int_t digits, + duk_small_uint_t flags, + duk_small_int_t neg) { + duk_small_int_t k; + duk_small_int_t pos, pos_end; + duk_small_int_t expt; + duk_small_int_t dig; + duk_uint8_t *q; + duk_uint8_t *buf; + + /* + * The string conversion here incorporates all the necessary ECMAScript + * semantics without attempting to be generic. nc_ctx->digits contains + * nc_ctx->count digits (>= 1), with the topmost digit's 'position' + * indicated by nc_ctx->k as follows: + * + * digits="123" count=3 k=0 --> 0.123 + * digits="123" count=3 k=1 --> 1.23 + * digits="123" count=3 k=5 --> 12300 + * digits="123" count=3 k=-1 --> 0.0123 + * + * Note that the identifier names used for format selection are different + * in Burger-Dybvig paper and ECMAScript specification (quite confusingly + * so, because e.g. 'k' has a totally different meaning in each). See + * documentation for discussion. + * + * ECMAScript doesn't specify any specific behavior for format selection + * (e.g. when to use exponent notation) for non-base-10 numbers. + * + * The bigint space in the context is reused for string output, as there + * is more than enough space for that (>1kB at the moment), and we avoid + * allocating even more stack. + */ + + DUK_ASSERT(DUK__NUMCONV_CTX_BIGINTS_SIZE >= DUK__MAX_FORMATTED_LENGTH); + DUK_ASSERT(nc_ctx->count >= 1); + + k = nc_ctx->k; + buf = (duk_uint8_t *) &nc_ctx->f; /* XXX: union would be more correct */ + q = buf; + + /* Exponent handling: if exponent format is used, record exponent value and + * fake k such that one leading digit is generated (e.g. digits=123 -> "1.23"). + * + * toFixed() prevents exponent use; otherwise apply a set of criteria to + * match the other API calls (toString(), toPrecision, etc). + */ + + expt = DUK__NO_EXP; + if (!nc_ctx->abs_pos /* toFixed() */) { + if ((flags & DUK_N2S_FLAG_FORCE_EXP) || /* exponential notation forced */ + ((flags & DUK_N2S_FLAG_NO_ZERO_PAD) && /* fixed precision and zero padding would be required */ + (k - digits >= 1)) || /* (e.g. k=3, digits=2 -> "12X") */ + ((k > 21 || k <= -6) && (radix == 10))) { /* toString() conditions */ + DUK_DDD(DUK_DDDPRINT("use exponential notation: k=%ld -> expt=%ld", (long) k, (long) (k - 1))); + expt = k - 1; /* e.g. 12.3 -> digits="123" k=2 -> 1.23e1 */ + k = 1; /* generate mantissa with a single leading whole number digit */ + } + } + + if (neg) { + *q++ = '-'; + } + + /* Start position (inclusive) and end position (exclusive) */ + pos = (k >= 1 ? k : 1); + if (nc_ctx->is_fixed) { + if (nc_ctx->abs_pos) { + /* toFixed() */ + pos_end = -digits; + } else { + pos_end = k - digits; + } + } else { + pos_end = k - nc_ctx->count; + } + if (pos_end > 0) { + pos_end = 0; + } + + DUK_DDD(DUK_DDDPRINT("expt=%ld, k=%ld, count=%ld, pos=%ld, pos_end=%ld, is_fixed=%ld, " + "digits=%ld, abs_pos=%ld", + (long) expt, + (long) k, + (long) nc_ctx->count, + (long) pos, + (long) pos_end, + (long) nc_ctx->is_fixed, + (long) digits, + (long) nc_ctx->abs_pos)); + + /* Digit generation */ + while (pos > pos_end) { + DUK_DDD(DUK_DDDPRINT("digit generation: pos=%ld, pos_end=%ld", (long) pos, (long) pos_end)); + if (pos == 0) { + *q++ = (duk_uint8_t) '.'; + } + if (pos > k) { + *q++ = (duk_uint8_t) '0'; + } else if (pos <= k - nc_ctx->count) { + *q++ = (duk_uint8_t) '0'; + } else { + dig = nc_ctx->digits[k - pos]; + DUK_ASSERT(dig >= 0 && dig < nc_ctx->B); + *q++ = (duk_uint8_t) DUK__DIGITCHAR(dig); + } + + pos--; + } + DUK_ASSERT(pos <= 1); + + /* Exponent */ + if (expt != DUK__NO_EXP) { + /* + * Exponent notation for non-base-10 numbers isn't specified in ECMAScript + * specification, as it never explicitly turns up: non-decimal numbers can + * only be formatted with Number.prototype.toString([radix]) and for that, + * behavior is not explicitly specified. + * + * Logical choices include formatting the exponent as decimal (e.g. binary + * 100000 as 1e+5) or in current radix (e.g. binary 100000 as 1e+101). + * The Dragon4 algorithm (in the original paper) prints the exponent value + * in the target radix B. However, for radix values 15 and above, the + * exponent separator 'e' is no longer easily parseable. Consider, for + * instance, the number "1.faecee+1c". + */ + + duk_size_t len; + char expt_sign; + + *q++ = 'e'; + if (expt >= 0) { + expt_sign = '+'; + } else { + expt_sign = '-'; + expt = -expt; + } + *q++ = (duk_uint8_t) expt_sign; + len = duk__dragon4_format_uint32(q, (duk_uint32_t) expt, radix); + q += len; + } + + duk_push_lstring(thr, (const char *) buf, (size_t) (q - buf)); +} + +/* + * Conversion helpers + */ + +DUK_LOCAL void duk__dragon4_double_to_ctx(duk__numconv_stringify_ctx *nc_ctx, duk_double_t x) { + duk_double_union u; + duk_uint32_t tmp; + duk_small_int_t expt; + + /* + * seeeeeee eeeeffff ffffffff ffffffff ffffffff ffffffff ffffffff ffffffff + * A B C D E F G H + * + * s sign bit + * eee... exponent field + * fff... fraction + * + * ieee value = 1.ffff... * 2^(e - 1023) (normal) + * = 0.ffff... * 2^(-1022) (denormal) + * + * algorithm v = f * b^e + */ + + DUK_DBLUNION_SET_DOUBLE(&u, x); + + nc_ctx->f.n = 2; + + tmp = DUK_DBLUNION_GET_LOW32(&u); + nc_ctx->f.v[0] = tmp; + tmp = DUK_DBLUNION_GET_HIGH32(&u); + nc_ctx->f.v[1] = tmp & 0x000fffffUL; + expt = (duk_small_int_t) ((tmp >> 20) & 0x07ffUL); + + if (expt == 0) { + /* denormal */ + expt = DUK__IEEE_DOUBLE_EXP_MIN - 52; + duk__bi_normalize(&nc_ctx->f); + } else { + /* normal: implicit leading 1-bit */ + nc_ctx->f.v[1] |= 0x00100000UL; + expt = expt - DUK__IEEE_DOUBLE_EXP_BIAS - 52; + DUK_ASSERT(duk__bi_is_valid(&nc_ctx->f)); /* true, because v[1] has at least one bit set */ + } + + DUK_ASSERT(duk__bi_is_valid(&nc_ctx->f)); + + nc_ctx->e = expt; +} + +DUK_LOCAL void duk__dragon4_ctx_to_double(duk__numconv_stringify_ctx *nc_ctx, duk_double_t *x) { + duk_double_union u; + duk_small_int_t expt; + duk_small_int_t i; + duk_small_int_t bitstart; + duk_small_int_t bitround; + duk_small_int_t bitidx; + duk_small_int_t skip_round; + duk_uint32_t t, v; + + DUK_ASSERT(nc_ctx->count == 53 + 1); + + /* Sometimes this assert is not true right now; it will be true after + * rounding. See: test-bug-numconv-mantissa-assert.js. + */ + DUK_ASSERT_DISABLE(nc_ctx->digits[0] == 1); /* zero handled by caller */ + + /* Should not be required because the code below always sets both high + * and low parts, but at least gcc-4.4.5 fails to deduce this correctly + * (perhaps because the low part is set (seemingly) conditionally in a + * loop), so this is here to avoid the bogus warning. + */ + duk_memzero((void *) &u, sizeof(u)); + + /* + * Figure out how generated digits match up with the mantissa, + * and then perform rounding. If mantissa overflows, need to + * recompute the exponent (it is bumped and may overflow to + * infinity). + * + * For normal numbers the leading '1' is hidden and ignored, + * and the last bit is used for rounding: + * + * rounding pt + * <--------52------->| + * 1 x x x x ... x x x x|y ==> x x x x ... x x x x + * + * For denormals, the leading '1' is included in the number, + * and the rounding point is different: + * + * rounding pt + * <--52 or less--->| + * 1 x x x x ... x x|x x y ==> 0 0 ... 1 x x ... x x + * + * The largest denormals will have a mantissa beginning with + * a '1' (the explicit leading bit); smaller denormals will + * have leading zero bits. + * + * If the exponent would become too high, the result becomes + * Infinity. If the exponent is so small that the entire + * mantissa becomes zero, the result becomes zero. + * + * Note: the Dragon4 'k' is off-by-one with respect to the IEEE + * exponent. For instance, k==0 indicates that the leading '1' + * digit is at the first binary fraction position (0.1xxx...); + * the corresponding IEEE exponent would be -1. + */ + + skip_round = 0; + +recheck_exp: + + expt = nc_ctx->k - 1; /* IEEE exp without bias */ + if (expt > 1023) { + /* Infinity */ + bitstart = -255; /* needed for inf: causes mantissa to become zero, + * and rounding to be skipped. + */ + expt = 2047; + } else if (expt >= -1022) { + /* normal */ + bitstart = 1; /* skip leading digit */ + expt += DUK__IEEE_DOUBLE_EXP_BIAS; + DUK_ASSERT(expt >= 1 && expt <= 2046); + } else { + /* denormal or zero */ + bitstart = 1023 + expt; /* expt==-1023 -> bitstart=0 (leading 1); + * expt==-1024 -> bitstart=-1 (one left of leading 1), etc + */ + expt = 0; + } + bitround = bitstart + 52; + + DUK_DDD(DUK_DDDPRINT("ieee expt=%ld, bitstart=%ld, bitround=%ld", (long) expt, (long) bitstart, (long) bitround)); + + if (!skip_round) { + if (duk__dragon4_fixed_format_round(nc_ctx, bitround)) { + /* Corner case: see test-numconv-parse-mant-carry.js. We could + * just bump the exponent and update bitstart, but it's more robust + * to recompute (but avoid rounding twice). + */ + DUK_DDD(DUK_DDDPRINT("rounding caused exponent to be bumped, recheck exponent")); + skip_round = 1; + goto recheck_exp; + } + } + + /* + * Create mantissa + */ + + t = 0; + for (i = 0; i < 52; i++) { + bitidx = bitstart + 52 - 1 - i; + if (bitidx >= nc_ctx->count) { + v = 0; + } else if (bitidx < 0) { + v = 0; + } else { + v = nc_ctx->digits[bitidx]; + } + DUK_ASSERT(v == 0 || v == 1); + t += v << (i % 32); + if (i == 31) { + /* low 32 bits is complete */ + DUK_DBLUNION_SET_LOW32(&u, t); + t = 0; + } + } + /* t has high mantissa */ + + DUK_DDD(DUK_DDDPRINT("mantissa is complete: %08lx %08lx", (unsigned long) t, (unsigned long) DUK_DBLUNION_GET_LOW32(&u))); + + DUK_ASSERT(expt >= 0 && expt <= 0x7ffL); + t += ((duk_uint32_t) expt) << 20; +#if 0 /* caller handles sign change */ + if (negative) { + t |= 0x80000000U; + } +#endif + DUK_DBLUNION_SET_HIGH32(&u, t); + + DUK_DDD(DUK_DDDPRINT("number is complete: %08lx %08lx", + (unsigned long) DUK_DBLUNION_GET_HIGH32(&u), + (unsigned long) DUK_DBLUNION_GET_LOW32(&u))); + + *x = DUK_DBLUNION_GET_DOUBLE(&u); +} + +/* + * Exposed number-to-string API + * + * Input: [ number ] + * Output: [ string ] + */ + +DUK_LOCAL DUK_NOINLINE void duk__numconv_stringify_raw(duk_hthread *thr, + duk_small_int_t radix, + duk_small_int_t digits, + duk_small_uint_t flags) { + duk_double_t x; + duk_small_int_t c; + duk_small_int_t neg; + duk_uint32_t uval; + duk__numconv_stringify_ctx nc_ctx_alloc; /* large context; around 2kB now */ + duk__numconv_stringify_ctx *nc_ctx = &nc_ctx_alloc; + + x = (duk_double_t) duk_require_number(thr, -1); + duk_pop(thr); + + /* + * Handle special cases (NaN, infinity, zero). + */ + + c = (duk_small_int_t) DUK_FPCLASSIFY(x); + if (DUK_SIGNBIT((double) x)) { + x = -x; + neg = 1; + } else { + neg = 0; + } + + /* NaN sign bit is platform specific with unpacked, un-normalized NaNs */ + DUK_ASSERT(c == DUK_FP_NAN || DUK_SIGNBIT((double) x) == 0); + + if (c == DUK_FP_NAN) { + duk_push_hstring_stridx(thr, DUK_STRIDX_NAN); + return; + } else if (c == DUK_FP_INFINITE) { + if (neg) { + /* -Infinity */ + duk_push_hstring_stridx(thr, DUK_STRIDX_MINUS_INFINITY); + } else { + /* Infinity */ + duk_push_hstring_stridx(thr, DUK_STRIDX_INFINITY); + } + return; + } else if (c == DUK_FP_ZERO) { + /* We can't shortcut zero here if it goes through special formatting + * (such as forced exponential notation). + */ + ; + } + + /* + * Handle integers in 32-bit range (that is, [-(2**32-1),2**32-1]) + * specially, as they're very likely for embedded programs. This + * is now done for all radix values. We must be careful not to use + * the fast path when special formatting (e.g. forced exponential) + * is in force. + * + * XXX: could save space by supporting radix 10 only and using + * sprintf "%lu" for the fast path and for exponent formatting. + */ + + uval = duk_double_to_uint32_t(x); + if (duk_double_equals((double) uval, x) && /* integer number in range */ + flags == 0) { /* no special formatting */ + /* use bigint area as a temp */ + duk_uint8_t *buf = (duk_uint8_t *) (&nc_ctx->f); + duk_uint8_t *p = buf; + + DUK_ASSERT(DUK__NUMCONV_CTX_BIGINTS_SIZE >= 32 + 1); /* max size: radix=2 + sign */ + if (neg && uval != 0) { + /* no negative sign for zero */ + *p++ = (duk_uint8_t) '-'; + } + p += duk__dragon4_format_uint32(p, uval, radix); + duk_push_lstring(thr, (const char *) buf, (duk_size_t) (p - buf)); + return; + } + + /* + * Dragon4 setup. + * + * Convert double from IEEE representation for conversion; + * normal finite values have an implicit leading 1-bit. The + * slow path algorithm doesn't handle zero, so zero is special + * cased here but still creates a valid nc_ctx, and goes + * through normal formatting in case special formatting has + * been requested (e.g. forced exponential format: 0 -> "0e+0"). + */ + + /* Would be nice to bulk clear the allocation, but the context + * is 1-2 kilobytes and nothing should rely on it being zeroed. + */ +#if 0 + duk_memzero((void *) nc_ctx, sizeof(*nc_ctx)); /* slow init, do only for slow path cases */ +#endif + + nc_ctx->is_s2n = 0; + nc_ctx->b = 2; + nc_ctx->B = radix; + nc_ctx->abs_pos = 0; + if (flags & DUK_N2S_FLAG_FIXED_FORMAT) { + nc_ctx->is_fixed = 1; + if (flags & DUK_N2S_FLAG_FRACTION_DIGITS) { + /* absolute req_digits; e.g. digits = 1 -> last digit is 0, + * but add an extra digit for rounding. + */ + nc_ctx->abs_pos = 1; + nc_ctx->req_digits = (-digits + 1) - 1; + } else { + nc_ctx->req_digits = digits + 1; + } + } else { + nc_ctx->is_fixed = 0; + nc_ctx->req_digits = 0; + } + + if (c == DUK_FP_ZERO) { + /* Zero special case: fake requested number of zero digits; ensure + * no sign bit is printed. Relative and absolute fixed format + * require separate handling. + */ + duk_small_int_t count; + if (nc_ctx->is_fixed) { + if (nc_ctx->abs_pos) { + count = digits + 2; /* lead zero + 'digits' fractions + 1 for rounding */ + } else { + count = digits + 1; /* + 1 for rounding */ + } + } else { + count = 1; + } + DUK_DDD(DUK_DDDPRINT("count=%ld", (long) count)); + DUK_ASSERT(count >= 1); + duk_memzero((void *) nc_ctx->digits, (size_t) count); + nc_ctx->count = count; + nc_ctx->k = 1; /* 0.000... */ + neg = 0; + goto zero_skip; + } + + duk__dragon4_double_to_ctx(nc_ctx, x); /* -> sets 'f' and 'e' */ + DUK__BI_PRINT("f", &nc_ctx->f); + DUK_DDD(DUK_DDDPRINT("e=%ld", (long) nc_ctx->e)); + + /* + * Dragon4 slow path digit generation. + */ + + duk__dragon4_prepare(nc_ctx); /* setup many variables in nc_ctx */ + + DUK_DDD(DUK_DDDPRINT("after prepare:")); + DUK__BI_PRINT("r", &nc_ctx->r); + DUK__BI_PRINT("s", &nc_ctx->s); + DUK__BI_PRINT("mp", &nc_ctx->mp); + DUK__BI_PRINT("mm", &nc_ctx->mm); + + duk__dragon4_scale(nc_ctx); + + DUK_DDD(DUK_DDDPRINT("after scale; k=%ld", (long) nc_ctx->k)); + DUK__BI_PRINT("r", &nc_ctx->r); + DUK__BI_PRINT("s", &nc_ctx->s); + DUK__BI_PRINT("mp", &nc_ctx->mp); + DUK__BI_PRINT("mm", &nc_ctx->mm); + + duk__dragon4_generate(nc_ctx); + + /* + * Convert and push final string. + */ + +zero_skip: + + if (flags & DUK_N2S_FLAG_FIXED_FORMAT) { + /* Perform fixed-format rounding. */ + duk_small_int_t roundpos; + if (flags & DUK_N2S_FLAG_FRACTION_DIGITS) { + /* 'roundpos' is relative to nc_ctx->k and increases to the right + * (opposite of how 'k' changes). + */ + roundpos = -digits; /* absolute position for digit considered for rounding */ + roundpos = nc_ctx->k - roundpos; + } else { + roundpos = digits; + } + DUK_DDD(DUK_DDDPRINT("rounding: k=%ld, count=%ld, digits=%ld, roundpos=%ld", + (long) nc_ctx->k, + (long) nc_ctx->count, + (long) digits, + (long) roundpos)); + (void) duk__dragon4_fixed_format_round(nc_ctx, roundpos); + + /* Note: 'count' is currently not adjusted by rounding (i.e. the + * digits are not "chopped off". That shouldn't matter because + * the digit position (absolute or relative) is passed on to the + * convert-and-push function. + */ + } + + duk__dragon4_convert_and_push(nc_ctx, thr, radix, digits, flags, neg); +} + +DUK_INTERNAL void duk_numconv_stringify(duk_hthread *thr, duk_small_int_t radix, duk_small_int_t digits, duk_small_uint_t flags) { + duk_native_stack_check(thr); + duk__numconv_stringify_raw(thr, radix, digits, flags); +} + +/* + * Exposed string-to-number API + * + * Input: [ string ] + * Output: [ number ] + * + * If number parsing fails, a NaN is pushed as the result. If number parsing + * fails due to an internal error, an InternalError is thrown. + */ + +DUK_LOCAL DUK_NOINLINE void duk__numconv_parse_raw(duk_hthread *thr, duk_small_int_t radix, duk_small_uint_t flags) { + duk__numconv_stringify_ctx nc_ctx_alloc; /* large context; around 2kB now */ + duk__numconv_stringify_ctx *nc_ctx = &nc_ctx_alloc; + duk_double_t res; + duk_hstring *h_str; + duk_int_t expt; + duk_bool_t expt_neg; + duk_small_int_t expt_adj; + duk_small_int_t neg; + duk_small_int_t dig; + duk_small_int_t dig_whole; + duk_small_int_t dig_lzero; + duk_small_int_t dig_frac; + duk_small_int_t dig_expt; + duk_small_int_t dig_prec; + const duk__exp_limits *explim; + const duk_uint8_t *p; + duk_small_int_t ch; + + DUK_DDD(DUK_DDDPRINT("parse number: %!T, radix=%ld, flags=0x%08lx", + (duk_tval *) duk_get_tval(thr, -1), + (long) radix, + (unsigned long) flags)); + + DUK_ASSERT(radix >= 2 && radix <= 36); + DUK_ASSERT(radix - 2 < (duk_small_int_t) sizeof(duk__str2num_digits_for_radix)); + + /* + * Preliminaries: trim, sign, Infinity check + * + * We rely on the interned string having a NUL terminator, which will + * cause a parse failure wherever it is encountered. As a result, we + * don't need separate pointer checks. + * + * There is no special parsing for 'NaN' in the specification although + * 'Infinity' (with an optional sign) is allowed in some contexts. + * Some contexts allow plus/minus sign, while others only allow the + * minus sign (like JSON.parse()). + * + * Automatic hex number detection (leading '0x' or '0X') and octal + * number detection (leading '0' followed by at least one octal digit) + * is done here too. + * + * Symbols are not explicitly rejected here (that's up to the caller). + * If a symbol were passed here, it should ultimately safely fail + * parsing due to a syntax error. + */ + + if (flags & DUK_S2N_FLAG_TRIM_WHITE) { + /* Leading / trailing whitespace is sometimes accepted and + * sometimes not. After white space trimming, all valid input + * characters are pure ASCII. + */ + duk_trim(thr, -1); + } + h_str = duk_require_hstring(thr, -1); + DUK_ASSERT(h_str != NULL); + p = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_str); + + neg = 0; + ch = *p; + if (ch == (duk_small_int_t) '+') { + if ((flags & DUK_S2N_FLAG_ALLOW_PLUS) == 0) { + DUK_DDD(DUK_DDDPRINT("parse failed: leading plus sign not allowed")); + goto parse_fail; + } + p++; + } else if (ch == (duk_small_int_t) '-') { + if ((flags & DUK_S2N_FLAG_ALLOW_MINUS) == 0) { + DUK_DDD(DUK_DDDPRINT("parse failed: leading minus sign not allowed")); + goto parse_fail; + } + p++; + neg = 1; + } + + if ((flags & DUK_S2N_FLAG_ALLOW_INF) && DUK_STRNCMP((const char *) p, "Infinity", 8) == 0) { + /* Don't check for Infinity unless the context allows it. + * 'Infinity' is a valid integer literal in e.g. base-36: + * + * parseInt('Infinity', 36) + * 1461559270678 + */ + + if ((flags & DUK_S2N_FLAG_ALLOW_GARBAGE) == 0 && p[8] != DUK_ASC_NUL) { + DUK_DDD(DUK_DDDPRINT("parse failed: trailing garbage after matching 'Infinity' not allowed")); + goto parse_fail; + } else { + res = DUK_DOUBLE_INFINITY; + goto negcheck_and_ret; + } + } + ch = *p; + if (ch == (duk_small_int_t) '0') { + duk_small_int_t detect_radix = 0; + ch = DUK_LOWERCASE_CHAR_ASCII(p[1]); /* 'x' or 'X' -> 'x' */ + if ((flags & DUK_S2N_FLAG_ALLOW_AUTO_HEX_INT) && ch == DUK_ASC_LC_X) { + DUK_DDD(DUK_DDDPRINT("detected 0x/0X hex prefix, changing radix and preventing fractions and exponent")); + detect_radix = 16; +#if 0 + } else if ((flags & DUK_S2N_FLAG_ALLOW_AUTO_LEGACY_OCT_INT) && + (ch >= (duk_small_int_t) '0' && ch <= (duk_small_int_t) '9')) { + DUK_DDD(DUK_DDDPRINT("detected 0n oct prefix, changing radix and preventing fractions and exponent")); + detect_radix = 8; + + /* NOTE: if this legacy octal case is added back, it has + * different flags and 'p' advance so this needs to be + * reworked. + */ + flags |= DUK_S2N_FLAG_ALLOW_EMPTY_AS_ZERO; /* interpret e.g. '09' as '0', not NaN */ + p += 1; +#endif + } else if ((flags & DUK_S2N_FLAG_ALLOW_AUTO_OCT_INT) && ch == DUK_ASC_LC_O) { + DUK_DDD(DUK_DDDPRINT("detected 0o oct prefix, changing radix and preventing fractions and exponent")); + detect_radix = 8; + } else if ((flags & DUK_S2N_FLAG_ALLOW_AUTO_BIN_INT) && ch == DUK_ASC_LC_B) { + DUK_DDD(DUK_DDDPRINT("detected 0b bin prefix, changing radix and preventing fractions and exponent")); + detect_radix = 2; + } + if (detect_radix > 0) { + radix = detect_radix; + /* Clear empty as zero flag: interpret e.g. '0x' and '0xg' as a NaN (= parse error) */ + flags &= ~(DUK_S2N_FLAG_ALLOW_EXP | DUK_S2N_FLAG_ALLOW_EMPTY_FRAC | DUK_S2N_FLAG_ALLOW_FRAC | + DUK_S2N_FLAG_ALLOW_NAKED_FRAC | DUK_S2N_FLAG_ALLOW_EMPTY_AS_ZERO); + flags |= DUK_S2N_FLAG_ALLOW_LEADING_ZERO; /* allow e.g. '0x0009' and '0b00010001' */ + p += 2; + } + } + + /* + * Scan number and setup for Dragon4. + * + * The fast path case is detected during setup: an integer which + * can be converted without rounding, no net exponent. The fast + * path could be implemented as a separate scan, but may not really + * be worth it: the multiplications for building 'f' are not + * expensive when 'f' is small. + * + * The significand ('f') must contain enough bits of (apparent) + * accuracy, so that Dragon4 will generate enough binary output digits. + * For decimal numbers, this means generating a 20-digit significand, + * which should yield enough practical accuracy to parse IEEE doubles. + * In fact, the ECMAScript specification explicitly allows an + * implementation to treat digits beyond 20 as zeroes (and even + * to round the 20th digit upwards). For non-decimal numbers, the + * appropriate number of digits has been precomputed for comparable + * accuracy. + * + * Digit counts: + * + * [ dig_lzero ] + * | + * .+-..---[ dig_prec ]----. + * | || | + * 0000123.456789012345678901234567890e+123456 + * | | | | | | + * `--+--' `------[ dig_frac ]-------' `-+--' + * | | + * [ dig_whole ] [ dig_expt ] + * + * dig_frac and dig_expt are -1 if not present + * dig_lzero is only computed for whole number part + * + * Parsing state + * + * Parsing whole part dig_frac < 0 AND dig_expt < 0 + * Parsing fraction part dig_frac >= 0 AND dig_expt < 0 + * Parsing exponent part dig_expt >= 0 (dig_frac may be < 0 or >= 0) + * + * Note: in case we hit an implementation limit (like exponent range), + * we should throw an error, NOT return NaN or Infinity. Even with + * very large exponent (or significand) values the final result may be + * finite, so NaN/Infinity would be incorrect. + */ + + duk__bi_set_small(&nc_ctx->f, 0); + dig_prec = 0; + dig_lzero = 0; + dig_whole = 0; + dig_frac = -1; + dig_expt = -1; + expt = 0; + expt_adj = 0; /* essentially tracks digit position of lowest 'f' digit */ + expt_neg = 0; + for (;;) { + ch = *p++; + + DUK_DDD(DUK_DDDPRINT("parse digits: p=%p, ch='%c' (%ld), expt=%ld, expt_adj=%ld, " + "dig_whole=%ld, dig_frac=%ld, dig_expt=%ld, dig_lzero=%ld, dig_prec=%ld", + (const void *) p, + (int) ((ch >= 0x20 && ch <= 0x7e) ? ch : '?'), + (long) ch, + (long) expt, + (long) expt_adj, + (long) dig_whole, + (long) dig_frac, + (long) dig_expt, + (long) dig_lzero, + (long) dig_prec)); + DUK__BI_PRINT("f", &nc_ctx->f); + + /* Most common cases first. */ + if (ch >= (duk_small_int_t) '0' && ch <= (duk_small_int_t) '9') { + dig = (duk_small_int_t) ch - '0' + 0; + } else if (ch == (duk_small_int_t) '.') { + /* A leading digit is not required in some cases, e.g. accept ".123". + * In other cases (JSON.parse()) a leading digit is required. This + * is checked for after the loop. + */ + if (dig_frac >= 0 || dig_expt >= 0) { + if (flags & DUK_S2N_FLAG_ALLOW_GARBAGE) { + DUK_DDD(DUK_DDDPRINT("garbage termination (invalid period)")); + break; + } else { + DUK_DDD(DUK_DDDPRINT("parse failed: period not allowed")); + goto parse_fail; + } + } + + if ((flags & DUK_S2N_FLAG_ALLOW_FRAC) == 0) { + /* Some contexts don't allow fractions at all; this can't be a + * post-check because the state ('f' and expt) would be incorrect. + */ + if (flags & DUK_S2N_FLAG_ALLOW_GARBAGE) { + DUK_DDD(DUK_DDDPRINT("garbage termination (invalid first period)")); + break; + } else { + DUK_DDD(DUK_DDDPRINT("parse failed: fraction part not allowed")); + } + } + + DUK_DDD(DUK_DDDPRINT("start fraction part")); + dig_frac = 0; + continue; + } else if (ch == (duk_small_int_t) 0) { + DUK_DDD(DUK_DDDPRINT("NUL termination")); + break; + } else if ((flags & DUK_S2N_FLAG_ALLOW_EXP) && dig_expt < 0 && + (ch == (duk_small_int_t) 'e' || ch == (duk_small_int_t) 'E')) { + /* Note: we don't parse back exponent notation for anything else + * than radix 10, so this is not an ambiguous check (e.g. hex + * exponent values may have 'e' either as a significand digit + * or as an exponent separator). + * + * If the exponent separator occurs twice, 'e' will be interpreted + * as a digit (= 14) and will be rejected as an invalid decimal + * digit. + */ + + DUK_DDD(DUK_DDDPRINT("start exponent part")); + + /* Exponent without a sign or with a +/- sign is accepted + * by all call sites (even JSON.parse()). + */ + ch = *p; + if (ch == (duk_small_int_t) '-') { + expt_neg = 1; + p++; + } else if (ch == (duk_small_int_t) '+') { + p++; + } + dig_expt = 0; + continue; + } else if (ch >= (duk_small_int_t) 'a' && ch <= (duk_small_int_t) 'z') { + dig = (duk_small_int_t) (ch - (duk_small_int_t) 'a' + 0x0a); + } else if (ch >= (duk_small_int_t) 'A' && ch <= (duk_small_int_t) 'Z') { + dig = (duk_small_int_t) (ch - (duk_small_int_t) 'A' + 0x0a); + } else { + dig = 255; /* triggers garbage digit check below */ + } + DUK_ASSERT((dig >= 0 && dig <= 35) || dig == 255); + + if (dig >= radix) { + if (flags & DUK_S2N_FLAG_ALLOW_GARBAGE) { + DUK_DDD(DUK_DDDPRINT("garbage termination")); + break; + } else { + DUK_DDD(DUK_DDDPRINT("parse failed: trailing garbage or invalid digit")); + goto parse_fail; + } + } + + if (dig_expt < 0) { + /* whole or fraction digit */ + + if (dig_prec < duk__str2num_digits_for_radix[radix - 2]) { + /* significant from precision perspective */ + + duk_small_int_t f_zero = duk__bi_is_zero(&nc_ctx->f); + if (f_zero && dig == 0) { + /* Leading zero is not counted towards precision digits; not + * in the integer part, nor in the fraction part. + */ + if (dig_frac < 0) { + dig_lzero++; + } + } else { + /* XXX: join these ops (multiply-accumulate), but only if + * code footprint decreases. + */ + duk__bi_mul_small(&nc_ctx->t1, &nc_ctx->f, (duk_uint32_t) radix); + duk__bi_add_small(&nc_ctx->f, &nc_ctx->t1, (duk_uint32_t) dig); + dig_prec++; + } + } else { + /* Ignore digits beyond a radix-specific limit, but note them + * in expt_adj. + */ + expt_adj++; + } + + if (dig_frac >= 0) { + dig_frac++; + expt_adj--; + } else { + dig_whole++; + } + } else { + /* exponent digit */ + + DUK_ASSERT(radix == 10); + expt = expt * radix + dig; + if (expt > DUK_S2N_MAX_EXPONENT) { + /* Impose a reasonable exponent limit, so that exp + * doesn't need to get tracked using a bigint. + */ + DUK_DDD(DUK_DDDPRINT("parse failed: exponent too large")); + goto parse_explimit_error; + } + dig_expt++; + } + } + + /* Leading zero. */ + + if (dig_lzero > 0 && dig_whole > 1) { + if ((flags & DUK_S2N_FLAG_ALLOW_LEADING_ZERO) == 0) { + DUK_DDD(DUK_DDDPRINT("parse failed: leading zeroes not allowed in integer part")); + goto parse_fail; + } + } + + /* Validity checks for various fraction formats ("0.1", ".1", "1.", "."). */ + + if (dig_whole == 0) { + if (dig_frac == 0) { + /* "." is not accepted in any format */ + DUK_DDD(DUK_DDDPRINT("parse failed: plain period without leading or trailing digits")); + goto parse_fail; + } else if (dig_frac > 0) { + /* ".123" */ + if ((flags & DUK_S2N_FLAG_ALLOW_NAKED_FRAC) == 0) { + DUK_DDD(DUK_DDDPRINT("parse failed: fraction part not allowed without " + "leading integer digit(s)")); + goto parse_fail; + } + } else { + /* Empty ("") is allowed in some formats (e.g. Number(''), as zero, + * but it must not have a leading +/- sign (GH-2019). Note that + * for Number(), h_str is already trimmed so we can check for zero + * length and still get Number(' + ') == NaN. + */ + if ((flags & DUK_S2N_FLAG_ALLOW_EMPTY_AS_ZERO) == 0) { + DUK_DDD(DUK_DDDPRINT("parse failed: empty string not allowed (as zero)")); + goto parse_fail; + } else if (DUK_HSTRING_GET_BYTELEN(h_str) != 0) { + DUK_DDD(DUK_DDDPRINT("parse failed: no digits, but not empty (had a +/- sign)")); + goto parse_fail; + } + } + } else { + if (dig_frac == 0) { + /* "123." is allowed in some formats */ + if ((flags & DUK_S2N_FLAG_ALLOW_EMPTY_FRAC) == 0) { + DUK_DDD(DUK_DDDPRINT("parse failed: empty fractions")); + goto parse_fail; + } + } else if (dig_frac > 0) { + /* "123.456" */ + ; + } else { + /* "123" */ + ; + } + } + + /* Exponent without digits (e.g. "1e" or "1e+"). If trailing garbage is + * allowed, ignore exponent part as garbage (= parse as "1", i.e. exp 0). + */ + + if (dig_expt == 0) { + if ((flags & DUK_S2N_FLAG_ALLOW_GARBAGE) == 0) { + DUK_DDD(DUK_DDDPRINT("parse failed: empty exponent")); + goto parse_fail; + } + DUK_ASSERT(expt == 0); + } + + if (expt_neg) { + expt = -expt; + } + DUK_DDD( + DUK_DDDPRINT("expt=%ld, expt_adj=%ld, net exponent -> %ld", (long) expt, (long) expt_adj, (long) (expt + expt_adj))); + expt += expt_adj; + + /* Fast path check. */ + + if (nc_ctx->f.n <= 1 && /* 32-bit value */ + expt == 0 /* no net exponent */) { + /* Fast path is triggered for no exponent and also for balanced exponent + * and fraction parts, e.g. for "1.23e2" == "123". Remember to respect + * zero sign. + */ + + /* XXX: could accept numbers larger than 32 bits, e.g. up to 53 bits? */ + DUK_DDD(DUK_DDDPRINT("fast path number parse")); + if (nc_ctx->f.n == 1) { + res = (double) nc_ctx->f.v[0]; + } else { + res = 0.0; + } + goto negcheck_and_ret; + } + + /* Significand ('f') padding. */ + + while (dig_prec < duk__str2num_digits_for_radix[radix - 2]) { + /* Pad significand with "virtual" zero digits so that Dragon4 will + * have enough (apparent) precision to work with. + */ + DUK_DDD(DUK_DDDPRINT("dig_prec=%ld, pad significand with zero", (long) dig_prec)); + duk__bi_mul_small_copy(&nc_ctx->f, (duk_uint32_t) radix, &nc_ctx->t1); + DUK__BI_PRINT("f", &nc_ctx->f); + expt--; + dig_prec++; + } + + DUK_DDD(DUK_DDDPRINT("final exponent: %ld", (long) expt)); + + /* Detect zero special case. */ + + if (nc_ctx->f.n == 0) { + /* This may happen even after the fast path check, if exponent is + * not balanced (e.g. "0e1"). Remember to respect zero sign. + */ + DUK_DDD(DUK_DDDPRINT("significand is zero")); + res = 0.0; + goto negcheck_and_ret; + } + + /* Quick reject of too large or too small exponents. This check + * would be incorrect for zero (e.g. "0e1000" is zero, not Infinity) + * so zero check must be above. + */ + + explim = &duk__str2num_exp_limits[radix - 2]; + if (expt > explim->upper) { + DUK_DDD(DUK_DDDPRINT("exponent too large -> infinite")); + res = (duk_double_t) DUK_DOUBLE_INFINITY; + goto negcheck_and_ret; + } else if (expt < explim->lower) { + DUK_DDD(DUK_DDDPRINT("exponent too small -> zero")); + res = (duk_double_t) 0.0; + goto negcheck_and_ret; + } + + nc_ctx->is_s2n = 1; + nc_ctx->e = expt; + nc_ctx->b = radix; + nc_ctx->B = 2; + nc_ctx->is_fixed = 1; + nc_ctx->abs_pos = 0; + nc_ctx->req_digits = 53 + 1; + + DUK__BI_PRINT("f", &nc_ctx->f); + DUK_DDD(DUK_DDDPRINT("e=%ld", (long) nc_ctx->e)); + + /* + * Dragon4 slow path (binary) digit generation. + * An extra digit is generated for rounding. + */ + + duk__dragon4_prepare(nc_ctx); /* setup many variables in nc_ctx */ + + DUK_DDD(DUK_DDDPRINT("after prepare:")); + DUK__BI_PRINT("r", &nc_ctx->r); + DUK__BI_PRINT("s", &nc_ctx->s); + DUK__BI_PRINT("mp", &nc_ctx->mp); + DUK__BI_PRINT("mm", &nc_ctx->mm); + + duk__dragon4_scale(nc_ctx); + + DUK_DDD(DUK_DDDPRINT("after scale; k=%ld", (long) nc_ctx->k)); + DUK__BI_PRINT("r", &nc_ctx->r); + DUK__BI_PRINT("s", &nc_ctx->s); + DUK__BI_PRINT("mp", &nc_ctx->mp); + DUK__BI_PRINT("mm", &nc_ctx->mm); + + duk__dragon4_generate(nc_ctx); + + DUK_ASSERT(nc_ctx->count == 53 + 1); + + /* + * Convert binary digits into an IEEE double. Need to handle + * denormals and rounding correctly. + * + * Some call sites currently assume the result is always a + * non-fastint double. If this is changed, check all call + * sites. + */ + + duk__dragon4_ctx_to_double(nc_ctx, &res); + goto negcheck_and_ret; + +negcheck_and_ret: + if (neg) { + res = -res; + } + duk_pop(thr); + duk_push_number(thr, (double) res); + DUK_DDD(DUK_DDDPRINT("result: %!T", (duk_tval *) duk_get_tval(thr, -1))); + return; + +parse_fail: + DUK_DDD(DUK_DDDPRINT("parse failed")); + duk_pop(thr); + duk_push_nan(thr); + return; + +parse_explimit_error: + DUK_DDD(DUK_DDDPRINT("parse failed, internal error, can't return a value")); + DUK_ERROR_RANGE(thr, "exponent too large"); + DUK_WO_NORETURN(return;); +} + +DUK_INTERNAL void duk_numconv_parse(duk_hthread *thr, duk_small_int_t radix, duk_small_uint_t flags) { + duk_native_stack_check(thr); + duk__numconv_parse_raw(thr, radix, flags); +} + +/* automatic undefs */ +#undef DUK__BI_MAX_PARTS +#undef DUK__BI_PRINT +#undef DUK__DIGITCHAR +#undef DUK__DRAGON4_OUTPUT_PREINC +#undef DUK__IEEE_DOUBLE_EXP_BIAS +#undef DUK__IEEE_DOUBLE_EXP_MIN +#undef DUK__MAX_FORMATTED_LENGTH +#undef DUK__MAX_OUTPUT_DIGITS +#undef DUK__NO_EXP +#undef DUK__NUMCONV_CTX_BIGINTS_SIZE +#undef DUK__NUMCONV_CTX_NUM_BIGINTS +#line 1 "duk_regexp_compiler.c" +/* + * Regexp compilation. + * + * See doc/regexp.rst for a discussion of the compilation approach and + * current limitations. + * + * Regexp bytecode assumes jumps can be expressed with signed 32-bit + * integers. Consequently the bytecode size must not exceed 0x7fffffffL. + * The implementation casts duk_size_t (buffer size) to duk_(u)int32_t + * in many places. Although this could be changed, the bytecode format + * limit would still prevent regexps exceeding the signed 32-bit limit + * from working. + * + * XXX: The implementation does not prevent bytecode from exceeding the + * maximum supported size. This could be done by limiting the maximum + * input string size (assuming an upper bound can be computed for number + * of bytecode bytes emitted per input byte) or checking buffer maximum + * size when emitting bytecode (slower). + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_REGEXP_SUPPORT) + +/* + * Helper macros + */ + +#define DUK__RE_INITIAL_BUFSIZE 64 + +#define DUK__RE_BUFLEN(re_ctx) DUK_BW_GET_SIZE(re_ctx->thr, &re_ctx->bw) + +/* + * Disjunction struct: result of parsing a disjunction + */ + +typedef struct { + /* Number of characters that the atom matches (e.g. 3 for 'abc'), + * -1 if atom is complex and number of matched characters either + * varies or is not known. + */ + duk_int32_t charlen; + +#if 0 + /* These are not needed to implement quantifier capture handling, + * but might be needed at some point. + */ + + /* re_ctx->captures at start and end of atom parsing. + * Since 'captures' indicates highest capture number emitted + * so far in a DUK_REOP_SAVE, the captures numbers saved by + * the atom are: ]start_captures,end_captures]. + */ + duk_uint32_t start_captures; + duk_uint32_t end_captures; +#endif +} duk__re_disjunction_info; + +/* + * Encoding helpers + * + * Some of the typing is bytecode based, e.g. slice sizes are unsigned 32-bit + * even though the buffer operations will use duk_size_t. + */ + +/* XXX: the insert helpers should ensure that the bytecode result is not + * larger than expected (or at least assert for it). Many things in the + * bytecode, like skip offsets, won't work correctly if the bytecode is + * larger than say 2G. + */ + +DUK_LOCAL duk_uint32_t duk__encode_i32(duk_int32_t x) { + if (x < 0) { + return ((duk_uint32_t) (-x)) * 2 + 1; + } else { + return ((duk_uint32_t) x) * 2; + } +} + +/* XXX: return type should probably be duk_size_t, or explicit checks are needed for + * maximum size. + */ +DUK_LOCAL duk_uint32_t duk__insert_u32(duk_re_compiler_ctx *re_ctx, duk_uint32_t offset, duk_uint32_t x) { + duk_uint8_t buf[DUK_UNICODE_MAX_XUTF8_LENGTH]; + duk_small_int_t len; + + len = duk_unicode_encode_xutf8((duk_ucodepoint_t) x, buf); + DUK_ASSERT(len >= 0); + DUK_BW_INSERT_ENSURE_BYTES(re_ctx->thr, &re_ctx->bw, offset, buf, (duk_size_t) len); + return (duk_uint32_t) len; +} + +DUK_LOCAL void duk__append_u32(duk_re_compiler_ctx *re_ctx, duk_uint32_t x) { + DUK_BW_WRITE_ENSURE_XUTF8(re_ctx->thr, &re_ctx->bw, x); +} + +DUK_LOCAL void duk__append_7bit(duk_re_compiler_ctx *re_ctx, duk_uint32_t x) { +#if defined(DUK_USE_PREFER_SIZE) + duk__append_u32(re_ctx, x); +#else + DUK_ASSERT(x <= 0x7fU); + DUK_BW_WRITE_ENSURE_U8(re_ctx->thr, &re_ctx->bw, (duk_uint8_t) x); +#endif +} + +#if 0 +DUK_LOCAL void duk__append_2bytes(duk_re_compiler_ctx *re_ctx, duk_uint8_t x, duk_uint8_t y) { + DUK_BW_WRITE_ENSURE_U8_2(re_ctx->thr, &re_ctx->bw, x, y); +} +#endif + +DUK_LOCAL duk_uint32_t duk__insert_i32(duk_re_compiler_ctx *re_ctx, duk_uint32_t offset, duk_int32_t x) { + return duk__insert_u32(re_ctx, offset, duk__encode_i32(x)); +} + +DUK_LOCAL void duk__append_reop(duk_re_compiler_ctx *re_ctx, duk_uint32_t reop) { + DUK_ASSERT(reop <= 0x7fU); + (void) duk__append_7bit(re_ctx, reop); +} + +#if 0 /* unused */ +DUK_LOCAL void duk__append_i32(duk_re_compiler_ctx *re_ctx, duk_int32_t x) { + duk__append_u32(re_ctx, duk__encode_i32(x)); +} +#endif + +/* special helper for emitting u16 lists (used for character ranges for built-in char classes) */ +DUK_LOCAL void duk__append_u16_list(duk_re_compiler_ctx *re_ctx, const duk_uint16_t *values, duk_uint32_t count) { + /* Call sites don't need the result length so it's not accumulated. */ + while (count-- > 0) { + duk__append_u32(re_ctx, (duk_uint32_t) (*values++)); + } +} + +DUK_LOCAL void duk__insert_slice(duk_re_compiler_ctx *re_ctx, + duk_uint32_t offset, + duk_uint32_t data_offset, + duk_uint32_t data_length) { + DUK_BW_INSERT_ENSURE_SLICE(re_ctx->thr, &re_ctx->bw, offset, data_offset, data_length); +} + +DUK_LOCAL void duk__append_slice(duk_re_compiler_ctx *re_ctx, duk_uint32_t data_offset, duk_uint32_t data_length) { + DUK_BW_WRITE_ENSURE_SLICE(re_ctx->thr, &re_ctx->bw, data_offset, data_length); +} + +DUK_LOCAL void duk__remove_slice(duk_re_compiler_ctx *re_ctx, duk_uint32_t data_offset, duk_uint32_t data_length) { + DUK_BW_REMOVE_ENSURE_SLICE(re_ctx->thr, &re_ctx->bw, data_offset, data_length); +} + +/* + * Insert a jump offset at 'offset' to complete an instruction + * (the jump offset is always the last component of an instruction). + * The 'skip' argument must be computed relative to 'offset', + * -without- taking into account the skip field being inserted. + * + * ... A B C ins X Y Z ... (ins may be a JUMP, SPLIT1/SPLIT2, etc) + * => ... A B C ins SKIP X Y Z + * + * Computing the final (adjusted) skip value, which is relative to the + * first byte of the next instruction, is a bit tricky because of the + * variable length UTF-8 encoding. See doc/regexp.rst for discussion. + */ +DUK_LOCAL duk_uint32_t duk__insert_jump_offset(duk_re_compiler_ctx *re_ctx, duk_uint32_t offset, duk_int32_t skip) { +#if 0 + /* Iterative solution. */ + if (skip < 0) { + duk_small_int_t len; + /* two encoding attempts suffices */ + len = duk_unicode_get_xutf8_length((duk_codepoint_t) duk__encode_i32(skip)); + len = duk_unicode_get_xutf8_length((duk_codepoint_t) duk__encode_i32(skip - (duk_int32_t) len)); + DUK_ASSERT(duk_unicode_get_xutf8_length(duk__encode_i32(skip - (duk_int32_t) len)) == len); /* no change */ + skip -= (duk_int32_t) len; + } +#endif + +#if defined(DUK_USE_PREFER_SIZE) + /* Closed form solution, this produces smallest code. + * See re_neg_jump_offset (closed2). + */ + if (skip < 0) { + skip--; + if (skip < -0x3fL) { + skip--; + } + if (skip < -0x3ffL) { + skip--; + } + if (skip < -0x7fffL) { + skip--; + } + if (skip < -0xfffffL) { + skip--; + } + if (skip < -0x1ffffffL) { + skip--; + } + if (skip < -0x3fffffffL) { + skip--; + } + } +#else /* DUK_USE_PREFER_SIZE */ + /* Closed form solution, this produces fastest code. + * See re_neg_jump_offset (closed1). + */ + if (skip < 0) { + if (skip >= -0x3eL) { + skip -= 1; + } else if (skip >= -0x3fdL) { + skip -= 2; + } else if (skip >= -0x7ffcL) { + skip -= 3; + } else if (skip >= -0xffffbL) { + skip -= 4; + } else if (skip >= -0x1fffffaL) { + skip -= 5; + } else if (skip >= -0x3ffffff9L) { + skip -= 6; + } else { + skip -= 7; + } + } +#endif /* DUK_USE_PREFER_SIZE */ + + return duk__insert_i32(re_ctx, offset, skip); +} + +DUK_LOCAL duk_uint32_t duk__append_jump_offset(duk_re_compiler_ctx *re_ctx, duk_int32_t skip) { + return (duk_uint32_t) duk__insert_jump_offset(re_ctx, (duk_uint32_t) DUK__RE_BUFLEN(re_ctx), skip); +} + +/* + * duk_re_range_callback for generating character class ranges. + * + * When ignoreCase is false, the range is simply emitted as is. We don't, + * for instance, eliminate duplicates or overlapping ranges in a character + * class. + * + * When ignoreCase is true but the 'direct' flag is set, the caller knows + * that the range canonicalizes to itself for case insensitive matching, + * so the range is emitted as is. This is mainly useful for built-in ranges + * like \W. + * + * Otherwise, when ignoreCase is true, the range needs to be normalized + * through canonicalization. Unfortunately a canonicalized version of a + * continuous range is not necessarily continuous (e.g. [x-{] is continuous + * but [X-{] is not). As a result, a single input range may expand to a lot + * of output ranges. The current algorithm creates the canonicalized ranges + * footprint efficiently at the cost of compile time execution time; see + * doc/regexp.rst for discussion, and some more details below. + * + * Note that the ctx->nranges is a context-wide temporary value. This is OK + * because there cannot be multiple character classes being parsed + * simultaneously. + * + * More detail on canonicalization: + * + * Conceptually, a range is canonicalized by scanning the entire range, + * normalizing each codepoint by converting it to uppercase, and generating + * a set of result ranges. + * + * Ideally a minimal set of output ranges would be emitted by merging all + * possible ranges even if they're emitted out of sequence. Because the + * input string is also case normalized during matching, some codepoints + * never occur at runtime; these "don't care" codepoints can be included or + * excluded from ranges when merging/optimizing ranges. + * + * The current algorithm does not do optimal range merging. Rather, output + * codepoints are generated in sequence, and when the output codepoints are + * continuous (CP, CP+1, CP+2, ...), they are merged locally into as large a + * range as possible. A small canonicalization bitmap is used to reduce + * actual codepoint canonicalizations which are quite slow at present. The + * bitmap provides a "codepoint block is continuous with respect to + * canonicalization" for N-codepoint blocks. This allows blocks to be + * skipped quickly. + * + * There are a number of shortcomings and future work here: + * + * - Individual codepoint normalizations are slow because they involve + * walking bit-packed rules without a lookup index. + * + * - The conceptual algorithm needs to canonicalize every codepoint in the + * input range to figure out the output range(s). Even with the small + * canonicalization bitmap the algorithm runs quite slowly for worst case + * inputs. There are many data structure alternatives to improve this. + * + * - While the current algorithm generates maximal output ranges when the + * output codepoints are emitted linearly, output ranges are not sorted or + * merged otherwise. In the worst case a lot of ranges are emitted when + * most of the ranges could be merged. In this process one could take + * advantage of "don't care" codepoints, which are never matched against at + * runtime due to canonicalization of input codepoints before comparison, + * to merge otherwise discontinuous output ranges. + * + * - The runtime data structure is just a linear list of ranges to match + * against. This can be quite slow if there are a lot of output ranges. + * There are various ways to make matching against the ranges faster, + * e.g. sorting the ranges and using a binary search; skip lists; tree + * based representations; full or approximate codepoint bitmaps, etc. + * + * - Only BMP is supported, codepoints above BMP are assumed to canonicalize + * to themselves. For now this is one place where we don't want to + * support chars outside the BMP, because the exhaustive search would be + * massively larger. It would be possible to support non-BMP with a + * different algorithm, or perhaps doing case normalization only at match + * time. + */ + +DUK_LOCAL void duk__regexp_emit_range(duk_re_compiler_ctx *re_ctx, duk_codepoint_t r1, duk_codepoint_t r2) { + DUK_ASSERT(r2 >= r1); + duk__append_u32(re_ctx, (duk_uint32_t) r1); + duk__append_u32(re_ctx, (duk_uint32_t) r2); + re_ctx->nranges++; +} + +#if defined(DUK_USE_REGEXP_CANON_BITMAP) +/* Find next canonicalization discontinuity (conservative estimate) starting + * from 'start', not exceeding 'end'. If continuity is fine up to 'end' + * inclusive, returns end. Minimum possible return value is start. + */ +DUK_LOCAL duk_codepoint_t duk__re_canon_next_discontinuity(duk_codepoint_t start, duk_codepoint_t end) { + duk_uint_t start_blk; + duk_uint_t end_blk; + duk_uint_t blk; + duk_uint_t offset; + duk_uint8_t mask; + + /* Inclusive block range. */ + DUK_ASSERT(start >= 0); + DUK_ASSERT(end >= 0); + DUK_ASSERT(end >= start); + start_blk = (duk_uint_t) (start >> DUK_CANON_BITMAP_BLKSHIFT); + end_blk = (duk_uint_t) (end >> DUK_CANON_BITMAP_BLKSHIFT); + + for (blk = start_blk; blk <= end_blk; blk++) { + offset = blk >> 3; + mask = 1U << (blk & 0x07); + if (offset >= sizeof(duk_unicode_re_canon_bitmap)) { + /* Reached non-BMP range which is assumed continuous. */ + return end; + } + DUK_ASSERT(offset < sizeof(duk_unicode_re_canon_bitmap)); + if ((duk_unicode_re_canon_bitmap[offset] & mask) == 0) { + /* Block is discontinuous, continuity is guaranteed + * only up to end of previous block (+1 for exclusive + * return value => start of current block). Start + * block requires special handling. + */ + if (blk > start_blk) { + return (duk_codepoint_t) (blk << DUK_CANON_BITMAP_BLKSHIFT); + } else { + return start; + } + } + } + DUK_ASSERT(blk == end_blk + 1); /* Reached end block which is continuous. */ + return end; +} +#else /* DUK_USE_REGEXP_CANON_BITMAP */ +DUK_LOCAL duk_codepoint_t duk__re_canon_next_discontinuity(duk_codepoint_t start, duk_codepoint_t end) { + DUK_ASSERT(start >= 0); + DUK_ASSERT(end >= 0); + DUK_ASSERT(end >= start); + if (start >= 0x10000) { + /* Even without the bitmap, treat non-BMP as continuous. */ + return end; + } + return start; +} +#endif /* DUK_USE_REGEXP_CANON_BITMAP */ + +DUK_LOCAL void duk__regexp_generate_ranges(void *userdata, duk_codepoint_t r1, duk_codepoint_t r2, duk_bool_t direct) { + duk_re_compiler_ctx *re_ctx = (duk_re_compiler_ctx *) userdata; + duk_codepoint_t r_start; + duk_codepoint_t r_end; + duk_codepoint_t i; + duk_codepoint_t t; + duk_codepoint_t r_disc; + + DUK_DD(DUK_DDPRINT("duk__regexp_generate_ranges(): re_ctx=%p, range=[%ld,%ld] direct=%ld", + (void *) re_ctx, + (long) r1, + (long) r2, + (long) direct)); + + DUK_ASSERT(r2 >= r1); /* SyntaxError for out of order range. */ + + if (direct || (re_ctx->re_flags & DUK_RE_FLAG_IGNORE_CASE) == 0) { + DUK_DD(DUK_DDPRINT("direct or not case sensitive, emit range: [%ld,%ld]", (long) r1, (long) r2)); + duk__regexp_emit_range(re_ctx, r1, r2); + return; + } + + DUK_DD(DUK_DDPRINT("case sensitive, process range: [%ld,%ld]", (long) r1, (long) r2)); + + r_start = duk_unicode_re_canonicalize_char(re_ctx->thr, r1); + r_end = r_start; + + for (i = r1 + 1; i <= r2;) { + /* Input codepoint space processed up to i-1, and + * current range in r_{start,end} is up-to-date + * (inclusive) and may either break or continue. + */ + r_disc = duk__re_canon_next_discontinuity(i, r2); + DUK_ASSERT(r_disc >= i); + DUK_ASSERT(r_disc <= r2); + + r_end += r_disc - i; /* May be zero. */ + t = duk_unicode_re_canonicalize_char(re_ctx->thr, r_disc); + if (t == r_end + 1) { + /* Not actually a discontinuity, continue range + * to r_disc and recheck. + */ + r_end = t; + } else { + duk__regexp_emit_range(re_ctx, r_start, r_end); + r_start = t; + r_end = t; + } + i = r_disc + 1; /* Guarantees progress. */ + } + duk__regexp_emit_range(re_ctx, r_start, r_end); + +#if 0 /* Exhaustive search, very slow. */ + r_start = duk_unicode_re_canonicalize_char(re_ctx->thr, r1); + r_end = r_start; + for (i = r1 + 1; i <= r2; i++) { + t = duk_unicode_re_canonicalize_char(re_ctx->thr, i); + if (t == r_end + 1) { + r_end = t; + } else { + DUK_DD(DUK_DDPRINT("canonicalized, emit range: [%ld,%ld]", (long) r_start, (long) r_end)); + duk__append_u32(re_ctx, (duk_uint32_t) r_start); + duk__append_u32(re_ctx, (duk_uint32_t) r_end); + re_ctx->nranges++; + r_start = t; + r_end = t; + } + } + DUK_DD(DUK_DDPRINT("canonicalized, emit range: [%ld,%ld]", (long) r_start, (long) r_end)); + duk__append_u32(re_ctx, (duk_uint32_t) r_start); + duk__append_u32(re_ctx, (duk_uint32_t) r_end); + re_ctx->nranges++; +#endif +} + +/* + * Parse regexp Disjunction. Most of regexp compilation happens here. + * + * Handles Disjunction, Alternative, and Term productions directly without + * recursion. The only constructs requiring recursion are positive/negative + * lookaheads, capturing parentheses, and non-capturing parentheses. + * + * The function determines whether the entire disjunction is a 'simple atom' + * (see doc/regexp.rst discussion on 'simple quantifiers') and if so, + * returns the atom character length which is needed by the caller to keep + * track of its own atom character length. A disjunction with more than one + * alternative is never considered a simple atom (although in some cases + * that might be the case). + * + * Return value: simple atom character length or < 0 if not a simple atom. + * Appends the bytecode for the disjunction matcher to the end of the temp + * buffer. + * + * Regexp top level structure is: + * + * Disjunction = Term* + * | Term* | Disjunction + * + * Term = Assertion + * | Atom + * | Atom Quantifier + * + * An empty Term sequence is a valid disjunction alternative (e.g. /|||c||/). + * + * Notes: + * + * * Tracking of the 'simple-ness' of the current atom vs. the entire + * disjunction are separate matters. For instance, the disjunction + * may be complex, but individual atoms may be simple. Furthermore, + * simple quantifiers are used whenever possible, even if the + * disjunction as a whole is complex. + * + * * The estimate of whether an atom is simple is conservative now, + * and it would be possible to expand it. For instance, captures + * cause the disjunction to be marked complex, even though captures + * -can- be handled by simple quantifiers with some minor modifications. + * + * * Disjunction 'tainting' as 'complex' is handled at the end of the + * main for loop collectively for atoms. Assertions, quantifiers, + * and '|' tokens need to taint the result manually if necessary. + * Assertions cannot add to result char length, only atoms (and + * quantifiers) can; currently quantifiers will taint the result + * as complex though. + */ + +DUK_LOCAL const duk_uint16_t * const duk__re_range_lookup1[3] = { duk_unicode_re_ranges_digit, + duk_unicode_re_ranges_white, + duk_unicode_re_ranges_wordchar }; +DUK_LOCAL const duk_uint8_t duk__re_range_lookup2[3] = { sizeof(duk_unicode_re_ranges_digit) / (2 * sizeof(duk_uint16_t)), + sizeof(duk_unicode_re_ranges_white) / (2 * sizeof(duk_uint16_t)), + sizeof(duk_unicode_re_ranges_wordchar) / (2 * sizeof(duk_uint16_t)) }; + +DUK_LOCAL void duk__append_range_atom_matcher(duk_re_compiler_ctx *re_ctx, + duk_small_uint_t re_op, + const duk_uint16_t *ranges, + duk_small_uint_t count) { +#if 0 + DUK_ASSERT(re_op <= 0x7fUL); + DUK_ASSERT(count <= 0x7fUL); + duk__append_2bytes(re_ctx, (duk_uint8_t) re_op, (duk_uint8_t) count); +#endif + duk__append_reop(re_ctx, re_op); + duk__append_7bit(re_ctx, count); + duk__append_u16_list(re_ctx, ranges, count * 2); +} + +DUK_LOCAL void duk__parse_disjunction(duk_re_compiler_ctx *re_ctx, duk_bool_t expect_eof, duk__re_disjunction_info *out_atom_info) { + duk_int32_t atom_start_offset = -1; /* negative -> no atom matched on previous round */ + duk_int32_t atom_char_length = 0; /* negative -> complex atom */ + duk_uint32_t atom_start_captures = re_ctx->captures; /* value of re_ctx->captures at start of atom */ + duk_int32_t unpatched_disjunction_split = -1; + duk_int32_t unpatched_disjunction_jump = -1; + duk_uint32_t entry_offset = (duk_uint32_t) DUK__RE_BUFLEN(re_ctx); + duk_int32_t res_charlen = 0; /* -1 if disjunction is complex, char length if simple */ + duk__re_disjunction_info tmp_disj; + + DUK_ASSERT(out_atom_info != NULL); + + duk_native_stack_check(re_ctx->thr); + if (re_ctx->recursion_depth >= re_ctx->recursion_limit) { + DUK_ERROR_RANGE(re_ctx->thr, DUK_STR_REGEXP_COMPILER_RECURSION_LIMIT); + DUK_WO_NORETURN(return;); + } + re_ctx->recursion_depth++; + +#if 0 + out_atom_info->start_captures = re_ctx->captures; +#endif + + for (;;) { + /* atom_char_length, atom_start_offset, atom_start_offset reflect the + * atom matched on the previous loop. If a quantifier is encountered + * on this loop, these are needed to handle the quantifier correctly. + * new_atom_char_length etc are for the atom parsed on this round; + * they're written to atom_char_length etc at the end of the round. + */ + duk_int32_t new_atom_char_length; /* char length of the atom parsed in this loop */ + duk_int32_t new_atom_start_offset; /* bytecode start offset of the atom parsed in this loop + * (allows quantifiers to copy the atom bytecode) + */ + duk_uint32_t new_atom_start_captures; /* re_ctx->captures at the start of the atom parsed in this loop */ + + duk_lexer_parse_re_token(&re_ctx->lex, &re_ctx->curr_token); + + DUK_DD(DUK_DDPRINT( + "re token: %ld (num=%ld, char=%c)", + (long) re_ctx->curr_token.t, + (long) re_ctx->curr_token.num, + (re_ctx->curr_token.num >= 0x20 && re_ctx->curr_token.num <= 0x7e) ? (int) re_ctx->curr_token.num : (int) '?')); + + /* set by atom case clauses */ + new_atom_start_offset = -1; + new_atom_char_length = -1; + new_atom_start_captures = re_ctx->captures; + + switch (re_ctx->curr_token.t) { + case DUK_RETOK_DISJUNCTION: { + /* + * The handling here is a bit tricky. If a previous '|' has been processed, + * we have a pending split1 and a pending jump (for a previous match). These + * need to be back-patched carefully. See docs for a detailed example. + */ + + /* patch pending jump and split */ + if (unpatched_disjunction_jump >= 0) { + duk_uint32_t offset; + + DUK_ASSERT(unpatched_disjunction_split >= 0); + offset = (duk_uint32_t) unpatched_disjunction_jump; + offset += duk__insert_jump_offset(re_ctx, offset, (duk_int32_t) (DUK__RE_BUFLEN(re_ctx) - offset)); + /* offset is now target of the pending split (right after jump) */ + duk__insert_jump_offset(re_ctx, + (duk_uint32_t) unpatched_disjunction_split, + (duk_int32_t) offset - unpatched_disjunction_split); + } + + /* add a new pending split to the beginning of the entire disjunction */ + (void) duk__insert_u32(re_ctx, entry_offset, DUK_REOP_SPLIT1); /* prefer direct execution */ + unpatched_disjunction_split = (duk_int32_t) (entry_offset + 1); /* +1 for opcode */ + + /* add a new pending match jump for latest finished alternative */ + duk__append_reop(re_ctx, DUK_REOP_JUMP); + unpatched_disjunction_jump = (duk_int32_t) DUK__RE_BUFLEN(re_ctx); + + /* 'taint' result as complex */ + res_charlen = -1; + break; + } + case DUK_RETOK_QUANTIFIER: { + if (atom_start_offset < 0) { + DUK_ERROR_SYNTAX(re_ctx->thr, DUK_STR_INVALID_QUANTIFIER_NO_ATOM); + DUK_WO_NORETURN(return;); + } + if (re_ctx->curr_token.qmin > re_ctx->curr_token.qmax) { + DUK_ERROR_SYNTAX(re_ctx->thr, DUK_STR_INVALID_QUANTIFIER_VALUES); + DUK_WO_NORETURN(return;); + } + if (atom_char_length >= 0) { + /* + * Simple atom + * + * If atom_char_length is zero, we'll have unbounded execution time for e.g. + * /()*x/.exec('x'). We can't just skip the match because it might have some + * side effects (for instance, if we allowed captures in simple atoms, the + * capture needs to happen). The simple solution below is to force the + * quantifier to match at most once, since the additional matches have no effect. + * + * With a simple atom there can be no capture groups, so no captures need + * to be reset. + */ + duk_int32_t atom_code_length; + duk_uint32_t offset; + duk_uint32_t qmin, qmax; + + qmin = re_ctx->curr_token.qmin; + qmax = re_ctx->curr_token.qmax; + if (atom_char_length == 0) { + /* qmin and qmax will be 0 or 1 */ + if (qmin > 1) { + qmin = 1; + } + if (qmax > 1) { + qmax = 1; + } + } + + duk__append_reop(re_ctx, DUK_REOP_MATCH); /* complete 'sub atom' */ + atom_code_length = (duk_int32_t) (DUK__RE_BUFLEN(re_ctx) - (duk_size_t) atom_start_offset); + + offset = (duk_uint32_t) atom_start_offset; + if (re_ctx->curr_token.greedy) { + offset += duk__insert_u32(re_ctx, offset, DUK_REOP_SQGREEDY); + offset += duk__insert_u32(re_ctx, offset, qmin); + offset += duk__insert_u32(re_ctx, offset, qmax); + offset += duk__insert_u32(re_ctx, offset, (duk_uint32_t) atom_char_length); + offset += duk__insert_jump_offset(re_ctx, offset, atom_code_length); + } else { + offset += duk__insert_u32(re_ctx, offset, DUK_REOP_SQMINIMAL); + offset += duk__insert_u32(re_ctx, offset, qmin); + offset += duk__insert_u32(re_ctx, offset, qmax); + offset += duk__insert_jump_offset(re_ctx, offset, atom_code_length); + } + DUK_UNREF(offset); /* silence scan-build warning */ + } else { + /* + * Complex atom + * + * The original code is used as a template, and removed at the end + * (this differs from the handling of simple quantifiers). + * + * NOTE: there is no current solution for empty atoms in complex + * quantifiers. This would need some sort of a 'progress' instruction. + * + * XXX: impose limit on maximum result size, i.e. atom_code_len * atom_copies? + */ + duk_int32_t atom_code_length; + duk_uint32_t atom_copies; + duk_uint32_t tmp_qmin, tmp_qmax; + + /* pre-check how many atom copies we're willing to make (atom_copies not needed below) */ + atom_copies = (re_ctx->curr_token.qmax == DUK_RE_QUANTIFIER_INFINITE) ? re_ctx->curr_token.qmin : + re_ctx->curr_token.qmax; + if (atom_copies > DUK_RE_MAX_ATOM_COPIES) { + DUK_ERROR_RANGE(re_ctx->thr, DUK_STR_QUANTIFIER_TOO_MANY_COPIES); + DUK_WO_NORETURN(return;); + } + + /* wipe the capture range made by the atom (if any) */ + DUK_ASSERT(atom_start_captures <= re_ctx->captures); + if (atom_start_captures != re_ctx->captures) { + DUK_ASSERT(atom_start_captures < re_ctx->captures); + DUK_DDD(DUK_DDDPRINT("must wipe ]atom_start_captures,re_ctx->captures]: ]%ld,%ld]", + (long) atom_start_captures, + (long) re_ctx->captures)); + + /* insert (DUK_REOP_WIPERANGE, start, count) in reverse order so the order ends up right */ + duk__insert_u32(re_ctx, + (duk_uint32_t) atom_start_offset, + (re_ctx->captures - atom_start_captures) * 2U); + duk__insert_u32(re_ctx, (duk_uint32_t) atom_start_offset, (atom_start_captures + 1) * 2); + duk__insert_u32(re_ctx, (duk_uint32_t) atom_start_offset, DUK_REOP_WIPERANGE); + } else { + DUK_DDD( + DUK_DDDPRINT("no need to wipe captures: atom_start_captures == re_ctx->captures == %ld", + (long) atom_start_captures)); + } + + atom_code_length = (duk_int32_t) DUK__RE_BUFLEN(re_ctx) - atom_start_offset; + + /* insert the required matches (qmin) by copying the atom */ + tmp_qmin = re_ctx->curr_token.qmin; + tmp_qmax = re_ctx->curr_token.qmax; + while (tmp_qmin > 0) { + duk__append_slice(re_ctx, + (duk_uint32_t) atom_start_offset, + (duk_uint32_t) atom_code_length); + tmp_qmin--; + if (tmp_qmax != DUK_RE_QUANTIFIER_INFINITE) { + tmp_qmax--; + } + } + DUK_ASSERT(tmp_qmin == 0); + + /* insert code for matching the remainder - infinite or finite */ + if (tmp_qmax == DUK_RE_QUANTIFIER_INFINITE) { + /* reuse last emitted atom for remaining 'infinite' quantifier */ + + if (re_ctx->curr_token.qmin == 0) { + /* Special case: original qmin was zero so there is nothing + * to repeat. Emit an atom copy but jump over it here. + */ + duk__append_reop(re_ctx, DUK_REOP_JUMP); + duk__append_jump_offset(re_ctx, atom_code_length); + duk__append_slice(re_ctx, + (duk_uint32_t) atom_start_offset, + (duk_uint32_t) atom_code_length); + } + if (re_ctx->curr_token.greedy) { + duk__append_reop(re_ctx, DUK_REOP_SPLIT2); /* prefer jump */ + } else { + duk__append_reop(re_ctx, DUK_REOP_SPLIT1); /* prefer direct */ + } + duk__append_jump_offset(re_ctx, -atom_code_length - 1); /* -1 for opcode */ + } else { + /* + * The remaining matches are emitted as sequence of SPLITs and atom + * copies; the SPLITs skip the remaining copies and match the sequel. + * This sequence needs to be emitted starting from the last copy + * because the SPLITs are variable length due to the variable length + * skip offset. This causes a lot of memory copying now. + * + * Example structure (greedy, match maximum # atoms): + * + * SPLIT1 LSEQ + * (atom) + * SPLIT1 LSEQ ; <- the byte length of this instruction is needed + * (atom) ; to encode the above SPLIT1 correctly + * ... + * LSEQ: + */ + duk_uint32_t offset = (duk_uint32_t) DUK__RE_BUFLEN(re_ctx); + while (tmp_qmax > 0) { + duk__insert_slice(re_ctx, + offset, + (duk_uint32_t) atom_start_offset, + (duk_uint32_t) atom_code_length); + if (re_ctx->curr_token.greedy) { + duk__insert_u32(re_ctx, offset, DUK_REOP_SPLIT1); /* prefer direct */ + } else { + duk__insert_u32(re_ctx, offset, DUK_REOP_SPLIT2); /* prefer jump */ + } + duk__insert_jump_offset(re_ctx, + offset + 1, /* +1 for opcode */ + (duk_int32_t) (DUK__RE_BUFLEN(re_ctx) - (offset + 1))); + tmp_qmax--; + } + } + + /* remove the original 'template' atom */ + duk__remove_slice(re_ctx, (duk_uint32_t) atom_start_offset, (duk_uint32_t) atom_code_length); + } + + /* 'taint' result as complex */ + res_charlen = -1; + break; + } + case DUK_RETOK_ASSERT_START: { + duk__append_reop(re_ctx, DUK_REOP_ASSERT_START); + break; + } + case DUK_RETOK_ASSERT_END: { + duk__append_reop(re_ctx, DUK_REOP_ASSERT_END); + break; + } + case DUK_RETOK_ASSERT_WORD_BOUNDARY: { + duk__append_reop(re_ctx, DUK_REOP_ASSERT_WORD_BOUNDARY); + break; + } + case DUK_RETOK_ASSERT_NOT_WORD_BOUNDARY: { + duk__append_reop(re_ctx, DUK_REOP_ASSERT_NOT_WORD_BOUNDARY); + break; + } + case DUK_RETOK_ASSERT_START_POS_LOOKAHEAD: + case DUK_RETOK_ASSERT_START_NEG_LOOKAHEAD: { + duk_uint32_t offset; + duk_uint32_t opcode = + (re_ctx->curr_token.t == DUK_RETOK_ASSERT_START_POS_LOOKAHEAD) ? DUK_REOP_LOOKPOS : DUK_REOP_LOOKNEG; + + offset = (duk_uint32_t) DUK__RE_BUFLEN(re_ctx); + duk__parse_disjunction(re_ctx, 0, &tmp_disj); + duk__append_reop(re_ctx, DUK_REOP_MATCH); + + (void) duk__insert_u32(re_ctx, offset, opcode); + (void) duk__insert_jump_offset(re_ctx, + offset + 1, /* +1 for opcode */ + (duk_int32_t) (DUK__RE_BUFLEN(re_ctx) - (offset + 1))); + + /* 'taint' result as complex -- this is conservative, + * as lookaheads do not backtrack. + */ + res_charlen = -1; + break; + } + case DUK_RETOK_ATOM_PERIOD: { + new_atom_char_length = 1; + new_atom_start_offset = (duk_int32_t) DUK__RE_BUFLEN(re_ctx); + duk__append_reop(re_ctx, DUK_REOP_PERIOD); + break; + } + case DUK_RETOK_ATOM_CHAR: { + /* Note: successive characters could be joined into string matches + * but this is not trivial (consider e.g. '/xyz+/); see docs for + * more discussion. + * + * No support for \u{H+} yet. While only BMP Unicode escapes are + * supported for RegExps at present, 'ch' may still be a non-BMP + * codepoint if it is decoded straight from source text UTF-8. + * There's no non-BMP support yet so this is handled simply by + * matching the non-BMP character (which is custom behavior). + */ + duk_uint32_t ch; + + new_atom_char_length = 1; + new_atom_start_offset = (duk_int32_t) DUK__RE_BUFLEN(re_ctx); + duk__append_reop(re_ctx, DUK_REOP_CHAR); + ch = re_ctx->curr_token.num; + if (re_ctx->re_flags & DUK_RE_FLAG_IGNORE_CASE) { + ch = (duk_uint32_t) duk_unicode_re_canonicalize_char(re_ctx->thr, (duk_codepoint_t) ch); + } + duk__append_u32(re_ctx, ch); + break; + } + case DUK_RETOK_ATOM_DIGIT: + case DUK_RETOK_ATOM_NOT_DIGIT: + case DUK_RETOK_ATOM_WHITE: + case DUK_RETOK_ATOM_NOT_WHITE: + case DUK_RETOK_ATOM_WORD_CHAR: + case DUK_RETOK_ATOM_NOT_WORD_CHAR: { + duk_small_uint_t re_op; + duk_small_uint_t idx; + + new_atom_char_length = 1; + new_atom_start_offset = (duk_int32_t) DUK__RE_BUFLEN(re_ctx); + + DUK_ASSERT((DUK_RETOK_ATOM_DIGIT & 0x01) != 0); + DUK_ASSERT((DUK_RETOK_ATOM_WHITE & 0x01) != 0); + DUK_ASSERT((DUK_RETOK_ATOM_WORD_CHAR & 0x01) != 0); + DUK_ASSERT((DUK_RETOK_ATOM_NOT_DIGIT & 0x01) == 0); + DUK_ASSERT((DUK_RETOK_ATOM_NOT_WHITE & 0x01) == 0); + DUK_ASSERT((DUK_RETOK_ATOM_NOT_WORD_CHAR & 0x01) == 0); + re_op = (re_ctx->curr_token.t & 0x01) ? DUK_REOP_RANGES : DUK_REOP_INVRANGES; + + DUK_ASSERT(DUK_RETOK_ATOM_WHITE == DUK_RETOK_ATOM_DIGIT + 2); + DUK_ASSERT(DUK_RETOK_ATOM_WORD_CHAR == DUK_RETOK_ATOM_DIGIT + 4); + idx = (duk_small_uint_t) ((re_ctx->curr_token.t - DUK_RETOK_ATOM_DIGIT) >> 1U); + DUK_ASSERT(idx <= 2U); /* Assume continuous token numbers; also checks negative underflow. */ + + duk__append_range_atom_matcher(re_ctx, re_op, duk__re_range_lookup1[idx], duk__re_range_lookup2[idx]); + break; + } + case DUK_RETOK_ATOM_BACKREFERENCE: { + duk_uint32_t backref = (duk_uint32_t) re_ctx->curr_token.num; + if (backref > re_ctx->highest_backref) { + re_ctx->highest_backref = backref; + } + new_atom_char_length = -1; /* mark as complex */ + new_atom_start_offset = (duk_int32_t) DUK__RE_BUFLEN(re_ctx); + duk__append_reop(re_ctx, DUK_REOP_BACKREFERENCE); + duk__append_u32(re_ctx, backref); + break; + } + case DUK_RETOK_ATOM_START_CAPTURE_GROUP: { + duk_uint32_t cap; + + new_atom_char_length = -1; /* mark as complex (capture handling) */ + new_atom_start_offset = (duk_int32_t) DUK__RE_BUFLEN(re_ctx); + cap = ++re_ctx->captures; + duk__append_reop(re_ctx, DUK_REOP_SAVE); + duk__append_u32(re_ctx, cap * 2); + duk__parse_disjunction(re_ctx, + 0, + &tmp_disj); /* retval (sub-atom char length) unused, tainted as complex above */ + duk__append_reop(re_ctx, DUK_REOP_SAVE); + duk__append_u32(re_ctx, cap * 2 + 1); + break; + } + case DUK_RETOK_ATOM_START_NONCAPTURE_GROUP: { + new_atom_start_offset = (duk_int32_t) DUK__RE_BUFLEN(re_ctx); + duk__parse_disjunction(re_ctx, 0, &tmp_disj); + new_atom_char_length = tmp_disj.charlen; + break; + } + case DUK_RETOK_ATOM_START_CHARCLASS: + case DUK_RETOK_ATOM_START_CHARCLASS_INVERTED: { + /* + * Range parsing is done with a special lexer function which calls + * us for every range parsed. This is different from how rest of + * the parsing works, but avoids a heavy, arbitrary size intermediate + * value type to hold the ranges. + * + * Another complication is the handling of character ranges when + * case insensitive matching is used (see docs for discussion). + * The range handler callback given to the lexer takes care of this + * as well. + * + * Note that duplicate ranges are not eliminated when parsing character + * classes, so that canonicalization of + * + * [0-9a-fA-Fx-{] + * + * creates the result (note the duplicate ranges): + * + * [0-9A-FA-FX-Z{-{] + * + * where [x-{] is split as a result of canonicalization. The duplicate + * ranges are not a semantics issue: they work correctly. + */ + + duk_uint32_t offset; + + DUK_DD(DUK_DDPRINT("character class")); + + /* insert ranges instruction, range count patched in later */ + new_atom_char_length = 1; + new_atom_start_offset = (duk_int32_t) DUK__RE_BUFLEN(re_ctx); + duk__append_reop(re_ctx, + (re_ctx->curr_token.t == DUK_RETOK_ATOM_START_CHARCLASS) ? DUK_REOP_RANGES : + DUK_REOP_INVRANGES); + offset = (duk_uint32_t) DUK__RE_BUFLEN(re_ctx); /* patch in range count later */ + + /* parse ranges until character class ends */ + re_ctx->nranges = 0; /* note: ctx-wide temporary */ + duk_lexer_parse_re_ranges(&re_ctx->lex, duk__regexp_generate_ranges, (void *) re_ctx); + + /* insert range count */ + duk__insert_u32(re_ctx, offset, re_ctx->nranges); + break; + } + case DUK_RETOK_ATOM_END_GROUP: { + if (expect_eof) { + DUK_ERROR_SYNTAX(re_ctx->thr, DUK_STR_UNEXPECTED_CLOSING_PAREN); + DUK_WO_NORETURN(return;); + } + goto done; + } + case DUK_RETOK_EOF: { + if (!expect_eof) { + DUK_ERROR_SYNTAX(re_ctx->thr, DUK_STR_UNEXPECTED_END_OF_PATTERN); + DUK_WO_NORETURN(return;); + } + goto done; + } + default: { + DUK_ERROR_SYNTAX(re_ctx->thr, DUK_STR_UNEXPECTED_REGEXP_TOKEN); + DUK_WO_NORETURN(return;); + } + } + + /* a complex (new) atom taints the result */ + if (new_atom_start_offset >= 0) { + if (new_atom_char_length < 0) { + res_charlen = -1; + } else if (res_charlen >= 0) { + /* only advance if not tainted */ + res_charlen += new_atom_char_length; + } + } + + /* record previous atom info in case next token is a quantifier */ + atom_start_offset = new_atom_start_offset; + atom_char_length = new_atom_char_length; + atom_start_captures = new_atom_start_captures; + } + +done: + + /* finish up pending jump and split for last alternative */ + if (unpatched_disjunction_jump >= 0) { + duk_uint32_t offset; + + DUK_ASSERT(unpatched_disjunction_split >= 0); + offset = (duk_uint32_t) unpatched_disjunction_jump; + offset += duk__insert_jump_offset(re_ctx, offset, (duk_int32_t) (DUK__RE_BUFLEN(re_ctx) - offset)); + /* offset is now target of the pending split (right after jump) */ + duk__insert_jump_offset(re_ctx, + (duk_uint32_t) unpatched_disjunction_split, + (duk_int32_t) offset - unpatched_disjunction_split); + } + +#if 0 + out_atom_info->end_captures = re_ctx->captures; +#endif + out_atom_info->charlen = res_charlen; + DUK_DDD(DUK_DDDPRINT("parse disjunction finished: charlen=%ld", (long) out_atom_info->charlen)); + + re_ctx->recursion_depth--; +} + +/* + * Flags parsing (see E5 Section 15.10.4.1). + */ + +DUK_LOCAL duk_uint32_t duk__parse_regexp_flags(duk_hthread *thr, duk_hstring *h) { + const duk_uint8_t *p; + const duk_uint8_t *p_end; + duk_uint32_t flags = 0; + + p = DUK_HSTRING_GET_DATA(h); + p_end = p + DUK_HSTRING_GET_BYTELEN(h); + + /* Note: can be safely scanned as bytes (undecoded) */ + + while (p < p_end) { + duk_uint8_t c = *p++; + switch (c) { + case (duk_uint8_t) 'g': { + if (flags & DUK_RE_FLAG_GLOBAL) { + goto flags_error; + } + flags |= DUK_RE_FLAG_GLOBAL; + break; + } + case (duk_uint8_t) 'i': { + if (flags & DUK_RE_FLAG_IGNORE_CASE) { + goto flags_error; + } + flags |= DUK_RE_FLAG_IGNORE_CASE; + break; + } + case (duk_uint8_t) 'm': { + if (flags & DUK_RE_FLAG_MULTILINE) { + goto flags_error; + } + flags |= DUK_RE_FLAG_MULTILINE; + break; + } + default: { + goto flags_error; + } + } + } + + return flags; + +flags_error: + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_REGEXP_FLAGS); + DUK_WO_NORETURN(return 0U;); +} + +/* + * Create escaped RegExp source (E5 Section 15.10.3). + * + * The current approach is to special case the empty RegExp + * ('' -> '(?:)') and otherwise replace unescaped '/' characters + * with '\/' regardless of where they occur in the regexp. + * + * Note that normalization does not seem to be necessary for + * RegExp literals (e.g. '/foo/') because to be acceptable as + * a RegExp literal, the text between forward slashes must + * already match the escaping requirements (e.g. must not contain + * unescaped forward slashes or be empty). Escaping IS needed + * for expressions like 'new Regexp("...", "")' however. + * Currently, we re-escape in either case. + * + * Also note that we process the source here in UTF-8 encoded + * form. This is correct, because any non-ASCII characters are + * passed through without change. + */ + +DUK_LOCAL void duk__create_escaped_source(duk_hthread *thr, int idx_pattern) { + duk_hstring *h; + const duk_uint8_t *p; + duk_bufwriter_ctx bw_alloc; + duk_bufwriter_ctx *bw; + duk_uint8_t *q; + duk_size_t i, n; + duk_uint_fast8_t c_prev, c; + + h = duk_known_hstring(thr, idx_pattern); + p = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h); + n = (duk_size_t) DUK_HSTRING_GET_BYTELEN(h); + + if (n == 0) { + duk_push_literal(thr, "(?:)"); + return; + } + + bw = &bw_alloc; + DUK_BW_INIT_PUSHBUF(thr, bw, n); + q = DUK_BW_GET_PTR(thr, bw); + + c_prev = (duk_uint_fast8_t) 0; + + for (i = 0; i < n; i++) { + c = p[i]; + + q = DUK_BW_ENSURE_RAW(thr, bw, 2, q); + + if (c == (duk_uint_fast8_t) '/' && c_prev != (duk_uint_fast8_t) '\\') { + /* Unescaped '/' ANYWHERE in the regexp (in disjunction, + * inside a character class, ...) => same escape works. + */ + *q++ = DUK_ASC_BACKSLASH; + } + *q++ = (duk_uint8_t) c; + + c_prev = c; + } + + DUK_BW_SETPTR_AND_COMPACT(thr, bw, q); + (void) duk_buffer_to_string(thr, -1); /* Safe if input is safe. */ + + /* [ ... escaped_source ] */ +} + +/* + * Exposed regexp compilation primitive. + * + * Sets up a regexp compilation context, and calls duk__parse_disjunction() to do the + * actual parsing. Handles generation of the compiled regexp header and the + * "boilerplate" capture of the matching substring (save 0 and 1). Also does some + * global level regexp checks after recursive compilation has finished. + * + * An escaped version of the regexp source, suitable for use as a RegExp instance + * 'source' property (see E5 Section 15.10.3), is also left on the stack. + * + * Input stack: [ pattern flags ] + * Output stack: [ bytecode escaped_source ] (both as strings) + */ + +DUK_INTERNAL void duk_regexp_compile(duk_hthread *thr) { + duk_re_compiler_ctx re_ctx; + duk_lexer_point lex_point; + duk_hstring *h_pattern; + duk_hstring *h_flags; + duk__re_disjunction_info ign_disj; + + DUK_ASSERT(thr != NULL); + + /* + * Args validation + */ + + /* TypeError if fails */ + h_pattern = duk_require_hstring_notsymbol(thr, -2); + h_flags = duk_require_hstring_notsymbol(thr, -1); + + /* + * Create normalized 'source' property (E5 Section 15.10.3). + */ + + /* [ ... pattern flags ] */ + + duk__create_escaped_source(thr, -2); + + /* [ ... pattern flags escaped_source ] */ + + /* + * Init compilation context + */ + + /* [ ... pattern flags escaped_source buffer ] */ + + duk_memzero(&re_ctx, sizeof(re_ctx)); + DUK_LEXER_INITCTX(&re_ctx.lex); /* duplicate zeroing, expect for (possible) NULL inits */ + re_ctx.thr = thr; + re_ctx.lex.thr = thr; + re_ctx.lex.input = DUK_HSTRING_GET_DATA(h_pattern); + re_ctx.lex.input_length = DUK_HSTRING_GET_BYTELEN(h_pattern); + re_ctx.lex.token_limit = DUK_RE_COMPILE_TOKEN_LIMIT; + re_ctx.recursion_limit = DUK_USE_REGEXP_COMPILER_RECLIMIT; + re_ctx.re_flags = duk__parse_regexp_flags(thr, h_flags); + + DUK_BW_INIT_PUSHBUF(thr, &re_ctx.bw, DUK__RE_INITIAL_BUFSIZE); + + DUK_DD(DUK_DDPRINT("regexp compiler ctx initialized, flags=0x%08lx, recursion_limit=%ld", + (unsigned long) re_ctx.re_flags, + (long) re_ctx.recursion_limit)); + + /* + * Init lexer + */ + + lex_point.offset = 0; /* expensive init, just want to fill window */ + lex_point.line = 1; + DUK_LEXER_SETPOINT(&re_ctx.lex, &lex_point); + + /* + * Compilation + */ + + DUK_DD(DUK_DDPRINT("starting regexp compilation")); + + duk__append_reop(&re_ctx, DUK_REOP_SAVE); + duk__append_7bit(&re_ctx, 0); + duk__parse_disjunction(&re_ctx, 1 /*expect_eof*/, &ign_disj); + duk__append_reop(&re_ctx, DUK_REOP_SAVE); + duk__append_7bit(&re_ctx, 1); + duk__append_reop(&re_ctx, DUK_REOP_MATCH); + + /* + * Check for invalid backreferences; note that it is NOT an error + * to back-reference a capture group which has not yet been introduced + * in the pattern (as in /\1(foo)/); in fact, the backreference will + * always match! It IS an error to back-reference a capture group + * which will never be introduced in the pattern. Thus, we can check + * for such references only after parsing is complete. + */ + + if (re_ctx.highest_backref > re_ctx.captures) { + DUK_ERROR_SYNTAX(thr, DUK_STR_INVALID_BACKREFS); + DUK_WO_NORETURN(return;); + } + + /* + * Emit compiled regexp header: flags, ncaptures + * (insertion order inverted on purpose) + */ + + duk__insert_u32(&re_ctx, 0, (re_ctx.captures + 1) * 2); + duk__insert_u32(&re_ctx, 0, re_ctx.re_flags); + + /* [ ... pattern flags escaped_source buffer ] */ + + DUK_BW_COMPACT(thr, &re_ctx.bw); + (void) duk_buffer_to_string(thr, -1); /* Safe because flags is at most 7 bit. */ + + /* [ ... pattern flags escaped_source bytecode ] */ + + /* + * Finalize stack + */ + + duk_remove(thr, -4); /* -> [ ... flags escaped_source bytecode ] */ + duk_remove(thr, -3); /* -> [ ... escaped_source bytecode ] */ + + DUK_DD(DUK_DDPRINT("regexp compilation successful, bytecode: %!T, escaped source: %!T", + (duk_tval *) duk_get_tval(thr, -1), + (duk_tval *) duk_get_tval(thr, -2))); +} + +/* + * Create a RegExp instance (E5 Section 15.10.7). + * + * Note: the output stack left by duk_regexp_compile() is directly compatible + * with the input here. + * + * Input stack: [ escaped_source bytecode ] (both as strings) + * Output stack: [ RegExp ] + */ + +DUK_INTERNAL void duk_regexp_create_instance(duk_hthread *thr) { + duk_hobject *h; + + /* [ ... escaped_source bytecode ] */ + + duk_push_object(thr); + h = duk_known_hobject(thr, -1); + duk_insert(thr, -3); + + /* [ ... regexp_object escaped_source bytecode ] */ + + DUK_HOBJECT_SET_CLASS_NUMBER(h, DUK_HOBJECT_CLASS_REGEXP); + DUK_HOBJECT_SET_PROTOTYPE_UPDREF(thr, h, thr->builtins[DUK_BIDX_REGEXP_PROTOTYPE]); + + duk_xdef_prop_stridx_short(thr, -3, DUK_STRIDX_INT_BYTECODE, DUK_PROPDESC_FLAGS_NONE); + + /* [ ... regexp_object escaped_source ] */ + + /* In ES2015 .source, and the .global, .multiline, etc flags are + * inherited getters. Store the escaped source as an internal + * property for the getter. + */ + + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_INT_SOURCE, DUK_PROPDESC_FLAGS_NONE); + + /* [ ... regexp_object ] */ + + duk_push_int(thr, 0); + duk_xdef_prop_stridx_short(thr, -2, DUK_STRIDX_LAST_INDEX, DUK_PROPDESC_FLAGS_W); + + /* [ ... regexp_object ] */ +} + +#else /* DUK_USE_REGEXP_SUPPORT */ + +/* regexp support disabled */ + +#endif /* DUK_USE_REGEXP_SUPPORT */ + +/* automatic undefs */ +#undef DUK__RE_BUFLEN +#undef DUK__RE_INITIAL_BUFSIZE +#line 1 "duk_regexp_executor.c" +/* + * Regexp executor. + * + * Safety: the ECMAScript executor should prevent user from reading and + * replacing regexp bytecode. Even so, the executor must validate all + * memory accesses etc. When an invalid access is detected (e.g. a 'save' + * opcode to invalid, unallocated index) it should fail with an internal + * error but not cause a segmentation fault. + * + * Notes: + * + * - Backtrack counts are limited to unsigned 32 bits but should + * technically be duk_size_t for strings longer than 4G chars. + * This also requires a regexp bytecode change. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_REGEXP_SUPPORT) + +/* + * Helpers for UTF-8 handling + * + * For bytecode readers the duk_uint32_t and duk_int32_t types are correct + * because they're used for more than just codepoints. + */ + +DUK_LOCAL duk_uint32_t duk__bc_get_u32(duk_re_matcher_ctx *re_ctx, const duk_uint8_t **pc) { + return (duk_uint32_t) duk_unicode_decode_xutf8_checked(re_ctx->thr, pc, re_ctx->bytecode, re_ctx->bytecode_end); +} + +DUK_LOCAL duk_int32_t duk__bc_get_i32(duk_re_matcher_ctx *re_ctx, const duk_uint8_t **pc) { + duk_uint32_t t; + + /* signed integer encoding needed to work with UTF-8 */ + t = (duk_uint32_t) duk_unicode_decode_xutf8_checked(re_ctx->thr, pc, re_ctx->bytecode, re_ctx->bytecode_end); + if (t & 1) { + return -((duk_int32_t) (t >> 1)); + } else { + return (duk_int32_t) (t >> 1); + } +} + +DUK_LOCAL const duk_uint8_t *duk__utf8_backtrack(duk_hthread *thr, + const duk_uint8_t **ptr, + const duk_uint8_t *ptr_start, + const duk_uint8_t *ptr_end, + duk_uint_fast32_t count) { + const duk_uint8_t *p; + + /* Note: allow backtracking from p == ptr_end */ + p = *ptr; + if (p < ptr_start || p > ptr_end) { + goto fail; + } + + while (count > 0) { + for (;;) { + p--; + if (p < ptr_start) { + goto fail; + } + if ((*p & 0xc0) != 0x80) { + /* utf-8 continuation bytes have the form 10xx xxxx */ + break; + } + } + count--; + } + *ptr = p; + return p; + +fail: + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return NULL;); +} + +DUK_LOCAL const duk_uint8_t *duk__utf8_advance(duk_hthread *thr, + const duk_uint8_t **ptr, + const duk_uint8_t *ptr_start, + const duk_uint8_t *ptr_end, + duk_uint_fast32_t count) { + const duk_uint8_t *p; + + p = *ptr; + if (p < ptr_start || p >= ptr_end) { + goto fail; + } + + while (count > 0) { + for (;;) { + p++; + + /* Note: if encoding ends by hitting end of input, we don't check that + * the encoding is valid, we just assume it is. + */ + if (p >= ptr_end || ((*p & 0xc0) != 0x80)) { + /* utf-8 continuation bytes have the form 10xx xxxx */ + break; + } + } + count--; + } + + *ptr = p; + return p; + +fail: + DUK_ERROR_INTERNAL(thr); + DUK_WO_NORETURN(return NULL;); +} + +/* + * Helpers for dealing with the input string + */ + +/* Get a (possibly canonicalized) input character from current sp. The input + * itself is never modified, and captures always record non-canonicalized + * characters even in case-insensitive matching. Return <0 if out of input. + */ +DUK_LOCAL duk_codepoint_t duk__inp_get_cp(duk_re_matcher_ctx *re_ctx, const duk_uint8_t **sp) { + duk_codepoint_t res; + + if (*sp >= re_ctx->input_end) { + return -1; + } + res = (duk_codepoint_t) duk_unicode_decode_xutf8_checked(re_ctx->thr, sp, re_ctx->input, re_ctx->input_end); + if (re_ctx->re_flags & DUK_RE_FLAG_IGNORE_CASE) { + res = duk_unicode_re_canonicalize_char(re_ctx->thr, res); + } + return res; +} + +DUK_LOCAL const duk_uint8_t *duk__inp_backtrack(duk_re_matcher_ctx *re_ctx, const duk_uint8_t **sp, duk_uint_fast32_t count) { + return duk__utf8_backtrack(re_ctx->thr, sp, re_ctx->input, re_ctx->input_end, count); +} + +/* Backtrack utf-8 input and return a (possibly canonicalized) input character. */ +DUK_LOCAL duk_codepoint_t duk__inp_get_prev_cp(duk_re_matcher_ctx *re_ctx, const duk_uint8_t *sp) { + /* note: caller 'sp' is intentionally not updated here */ + (void) duk__inp_backtrack(re_ctx, &sp, (duk_uint_fast32_t) 1); + return duk__inp_get_cp(re_ctx, &sp); +} + +/* + * Regexp recursive matching function. + * + * Returns 'sp' on successful match (points to character after last matched one), + * NULL otherwise. + * + * The C recursion depth limit check is only performed in this function, this + * suffices because the function is present in all true recursion required by + * regexp execution. + */ + +DUK_LOCAL const duk_uint8_t *duk__match_regexp(duk_re_matcher_ctx *re_ctx, const duk_uint8_t *pc, const duk_uint8_t *sp) { + duk_native_stack_check(re_ctx->thr); + if (re_ctx->recursion_depth >= re_ctx->recursion_limit) { + DUK_ERROR_RANGE(re_ctx->thr, DUK_STR_REGEXP_EXECUTOR_RECURSION_LIMIT); + DUK_WO_NORETURN(return NULL;); + } + re_ctx->recursion_depth++; + + for (;;) { + duk_small_int_t op; + + if (re_ctx->steps_count >= re_ctx->steps_limit) { + DUK_ERROR_RANGE(re_ctx->thr, DUK_STR_REGEXP_EXECUTOR_STEP_LIMIT); + DUK_WO_NORETURN(return NULL;); + } + re_ctx->steps_count++; + + /* Opcodes are at most 7 bits now so they encode to one byte. If this + * were not the case or 'pc' is invalid here (due to a bug etc) we'll + * still fail safely through the switch default case. + */ + DUK_ASSERT(pc[0] <= 0x7fU); +#if 0 + op = (duk_small_int_t) duk__bc_get_u32(re_ctx, &pc); +#endif + op = *pc++; + + DUK_DDD(DUK_DDDPRINT("match: rec=%ld, steps=%ld, pc (after op)=%ld, sp=%ld, op=%ld", + (long) re_ctx->recursion_depth, + (long) re_ctx->steps_count, + (long) (pc - re_ctx->bytecode), + (long) (sp - re_ctx->input), + (long) op)); + + switch (op) { + case DUK_REOP_MATCH: { + goto match; + } + case DUK_REOP_CHAR: { + /* + * Byte-based matching would be possible for case-sensitive + * matching but not for case-insensitive matching. So, we + * match by decoding the input and bytecode character normally. + * + * Bytecode characters are assumed to be already canonicalized. + * Input characters are canonicalized automatically by + * duk__inp_get_cp() if necessary. + * + * There is no opcode for matching multiple characters. The + * regexp compiler has trouble joining strings efficiently + * during compilation. See doc/regexp.rst for more discussion. + */ + duk_codepoint_t c1, c2; + + c1 = (duk_codepoint_t) duk__bc_get_u32(re_ctx, &pc); + DUK_ASSERT(!(re_ctx->re_flags & DUK_RE_FLAG_IGNORE_CASE) || + c1 == duk_unicode_re_canonicalize_char(re_ctx->thr, c1)); /* canonicalized by compiler */ + c2 = duk__inp_get_cp(re_ctx, &sp); + /* No need to check for c2 < 0 (end of input): because c1 >= 0, it + * will fail the match below automatically and cause goto fail. + */ +#if 0 + if (c2 < 0) { + goto fail; + } +#endif + DUK_ASSERT(c1 >= 0); + + DUK_DDD(DUK_DDDPRINT("char match, c1=%ld, c2=%ld", (long) c1, (long) c2)); + if (c1 != c2) { + goto fail; + } + break; + } + case DUK_REOP_PERIOD: { + duk_codepoint_t c; + + c = duk__inp_get_cp(re_ctx, &sp); + if (c < 0 || duk_unicode_is_line_terminator(c)) { + /* E5 Sections 15.10.2.8, 7.3 */ + goto fail; + } + break; + } + case DUK_REOP_RANGES: + case DUK_REOP_INVRANGES: { + duk_uint32_t n; + duk_codepoint_t c; + duk_small_int_t match; + + n = duk__bc_get_u32(re_ctx, &pc); + c = duk__inp_get_cp(re_ctx, &sp); + if (c < 0) { + goto fail; + } + + match = 0; + while (n) { + duk_codepoint_t r1, r2; + r1 = (duk_codepoint_t) duk__bc_get_u32(re_ctx, &pc); + r2 = (duk_codepoint_t) duk__bc_get_u32(re_ctx, &pc); + DUK_DDD(DUK_DDDPRINT("matching ranges/invranges, n=%ld, r1=%ld, r2=%ld, c=%ld", + (long) n, + (long) r1, + (long) r2, + (long) c)); + if (c >= r1 && c <= r2) { + /* Note: don't bail out early, we must read all the ranges from + * bytecode. Another option is to skip them efficiently after + * breaking out of here. Prefer smallest code. + */ + match = 1; + } + n--; + } + + if (op == DUK_REOP_RANGES) { + if (!match) { + goto fail; + } + } else { + DUK_ASSERT(op == DUK_REOP_INVRANGES); + if (match) { + goto fail; + } + } + break; + } + case DUK_REOP_ASSERT_START: { + duk_codepoint_t c; + + if (sp <= re_ctx->input) { + break; + } + if (!(re_ctx->re_flags & DUK_RE_FLAG_MULTILINE)) { + goto fail; + } + c = duk__inp_get_prev_cp(re_ctx, sp); + if (duk_unicode_is_line_terminator(c)) { + /* E5 Sections 15.10.2.8, 7.3 */ + break; + } + goto fail; + } + case DUK_REOP_ASSERT_END: { + duk_codepoint_t c; + const duk_uint8_t *tmp_sp; + + tmp_sp = sp; + c = duk__inp_get_cp(re_ctx, &tmp_sp); + if (c < 0) { + break; + } + if (!(re_ctx->re_flags & DUK_RE_FLAG_MULTILINE)) { + goto fail; + } + if (duk_unicode_is_line_terminator(c)) { + /* E5 Sections 15.10.2.8, 7.3 */ + break; + } + goto fail; + } + case DUK_REOP_ASSERT_WORD_BOUNDARY: + case DUK_REOP_ASSERT_NOT_WORD_BOUNDARY: { + /* + * E5 Section 15.10.2.6. The previous and current character + * should -not- be canonicalized as they are now. However, + * canonicalization does not affect the result of IsWordChar() + * (which depends on Unicode characters never canonicalizing + * into ASCII characters) so this does not matter. + */ + duk_small_int_t w1, w2; + + if (sp <= re_ctx->input) { + w1 = 0; /* not a wordchar */ + } else { + duk_codepoint_t c; + c = duk__inp_get_prev_cp(re_ctx, sp); + w1 = duk_unicode_re_is_wordchar(c); + } + if (sp >= re_ctx->input_end) { + w2 = 0; /* not a wordchar */ + } else { + const duk_uint8_t *tmp_sp = sp; /* dummy so sp won't get updated */ + duk_codepoint_t c; + c = duk__inp_get_cp(re_ctx, &tmp_sp); + w2 = duk_unicode_re_is_wordchar(c); + } + + if (op == DUK_REOP_ASSERT_WORD_BOUNDARY) { + if (w1 == w2) { + goto fail; + } + } else { + DUK_ASSERT(op == DUK_REOP_ASSERT_NOT_WORD_BOUNDARY); + if (w1 != w2) { + goto fail; + } + } + break; + } + case DUK_REOP_JUMP: { + duk_int32_t skip; + + skip = duk__bc_get_i32(re_ctx, &pc); + pc += skip; + break; + } + case DUK_REOP_SPLIT1: { + /* split1: prefer direct execution (no jump) */ + const duk_uint8_t *sub_sp; + duk_int32_t skip; + + skip = duk__bc_get_i32(re_ctx, &pc); + sub_sp = duk__match_regexp(re_ctx, pc, sp); + if (sub_sp) { + sp = sub_sp; + goto match; + } + pc += skip; + break; + } + case DUK_REOP_SPLIT2: { + /* split2: prefer jump execution (not direct) */ + const duk_uint8_t *sub_sp; + duk_int32_t skip; + + skip = duk__bc_get_i32(re_ctx, &pc); + sub_sp = duk__match_regexp(re_ctx, pc + skip, sp); + if (sub_sp) { + sp = sub_sp; + goto match; + } + break; + } + case DUK_REOP_SQMINIMAL: { + duk_uint32_t q, qmin, qmax; + duk_int32_t skip; + const duk_uint8_t *sub_sp; + + qmin = duk__bc_get_u32(re_ctx, &pc); + qmax = duk__bc_get_u32(re_ctx, &pc); + skip = duk__bc_get_i32(re_ctx, &pc); + DUK_DDD(DUK_DDDPRINT("minimal quantifier, qmin=%lu, qmax=%lu, skip=%ld", + (unsigned long) qmin, + (unsigned long) qmax, + (long) skip)); + + q = 0; + while (q <= qmax) { + if (q >= qmin) { + sub_sp = duk__match_regexp(re_ctx, pc + skip, sp); + if (sub_sp) { + sp = sub_sp; + goto match; + } + } + sub_sp = duk__match_regexp(re_ctx, pc, sp); + if (!sub_sp) { + break; + } + sp = sub_sp; + q++; + } + goto fail; + } + case DUK_REOP_SQGREEDY: { + duk_uint32_t q, qmin, qmax, atomlen; + duk_int32_t skip; + const duk_uint8_t *sub_sp; + + qmin = duk__bc_get_u32(re_ctx, &pc); + qmax = duk__bc_get_u32(re_ctx, &pc); + atomlen = duk__bc_get_u32(re_ctx, &pc); + skip = duk__bc_get_i32(re_ctx, &pc); + DUK_DDD(DUK_DDDPRINT("greedy quantifier, qmin=%lu, qmax=%lu, atomlen=%lu, skip=%ld", + (unsigned long) qmin, + (unsigned long) qmax, + (unsigned long) atomlen, + (long) skip)); + + q = 0; + while (q < qmax) { + sub_sp = duk__match_regexp(re_ctx, pc, sp); + if (!sub_sp) { + break; + } + sp = sub_sp; + q++; + } + while (q >= qmin) { + sub_sp = duk__match_regexp(re_ctx, pc + skip, sp); + if (sub_sp) { + sp = sub_sp; + goto match; + } + if (q == qmin) { + break; + } + + /* Note: if atom were to contain e.g. captures, we would need to + * re-match the atom to get correct captures. Simply quantifiers + * do not allow captures in their atom now, so this is not an issue. + */ + + DUK_DDD(DUK_DDDPRINT("greedy quantifier, backtrack %ld characters (atomlen)", (long) atomlen)); + sp = duk__inp_backtrack(re_ctx, &sp, (duk_uint_fast32_t) atomlen); + q--; + } + goto fail; + } + case DUK_REOP_SAVE: { + duk_uint32_t idx; + const duk_uint8_t *old; + const duk_uint8_t *sub_sp; + + idx = duk__bc_get_u32(re_ctx, &pc); + if (idx >= re_ctx->nsaved) { + /* idx is unsigned, < 0 check is not necessary */ + DUK_D(DUK_DPRINT("internal error, regexp save index insane: idx=%ld", (long) idx)); + goto internal_error; + } + old = re_ctx->saved[idx]; + re_ctx->saved[idx] = sp; + sub_sp = duk__match_regexp(re_ctx, pc, sp); + if (sub_sp) { + sp = sub_sp; + goto match; + } + re_ctx->saved[idx] = old; + goto fail; + } + case DUK_REOP_WIPERANGE: { + /* Wipe capture range and save old values for backtracking. + * + * XXX: this typically happens with a relatively small idx_count. + * It might be useful to handle cases where the count is small + * (say <= 8) by saving the values in stack instead. This would + * reduce memory churn and improve performance, at the cost of a + * slightly higher code footprint. + */ + duk_uint32_t idx_start, idx_count; +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + duk_uint32_t idx_end, idx; +#endif + duk_uint8_t **range_save; + const duk_uint8_t *sub_sp; + + idx_start = duk__bc_get_u32(re_ctx, &pc); + idx_count = duk__bc_get_u32(re_ctx, &pc); + DUK_DDD(DUK_DDDPRINT("wipe saved range: start=%ld, count=%ld -> [%ld,%ld] (captures [%ld,%ld])", + (long) idx_start, + (long) idx_count, + (long) idx_start, + (long) (idx_start + idx_count - 1), + (long) (idx_start / 2), + (long) ((idx_start + idx_count - 1) / 2))); + if (idx_start + idx_count > re_ctx->nsaved || idx_count == 0) { + /* idx is unsigned, < 0 check is not necessary */ + DUK_D(DUK_DPRINT("internal error, regexp wipe indices insane: idx_start=%ld, idx_count=%ld", + (long) idx_start, + (long) idx_count)); + goto internal_error; + } + DUK_ASSERT(idx_count > 0); + + duk_require_stack(re_ctx->thr, 1); + range_save = (duk_uint8_t **) duk_push_fixed_buffer_nozero(re_ctx->thr, sizeof(duk_uint8_t *) * idx_count); + DUK_ASSERT(range_save != NULL); + duk_memcpy(range_save, re_ctx->saved + idx_start, sizeof(duk_uint8_t *) * idx_count); +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + idx_end = idx_start + idx_count; + for (idx = idx_start; idx < idx_end; idx++) { + re_ctx->saved[idx] = NULL; + } +#else + duk_memzero((void *) (re_ctx->saved + idx_start), sizeof(duk_uint8_t *) * idx_count); +#endif + + sub_sp = duk__match_regexp(re_ctx, pc, sp); + if (sub_sp) { + /* match: keep wiped/resaved values */ + DUK_DDD(DUK_DDDPRINT("match: keep wiped/resaved values [%ld,%ld] (captures [%ld,%ld])", + (long) idx_start, + (long) (idx_start + idx_count - 1), + (long) (idx_start / 2), + (long) ((idx_start + idx_count - 1) / 2))); + duk_pop_unsafe(re_ctx->thr); + sp = sub_sp; + goto match; + } + + /* fail: restore saves */ + DUK_DDD(DUK_DDDPRINT("fail: restore wiped/resaved values [%ld,%ld] (captures [%ld,%ld])", + (long) idx_start, + (long) (idx_start + idx_count - 1), + (long) (idx_start / 2), + (long) ((idx_start + idx_count - 1) / 2))); + duk_memcpy((void *) (re_ctx->saved + idx_start), + (const void *) range_save, + sizeof(duk_uint8_t *) * idx_count); + duk_pop_unsafe(re_ctx->thr); + goto fail; + } + case DUK_REOP_LOOKPOS: + case DUK_REOP_LOOKNEG: { + /* + * Needs a save of multiple saved[] entries depending on what range + * may be overwritten. Because the regexp parser does no such analysis, + * we currently save the entire saved array here. Lookaheads are thus + * a bit expensive. Note that the saved array is not needed for just + * the lookahead sub-match, but for the matching of the entire sequel. + * + * The temporary save buffer is pushed on to the valstack to handle + * errors correctly. Each lookahead causes a C recursion and pushes + * more stuff on the value stack. If the C recursion limit is less + * than the value stack slack, there is no need to check the stack. + * We do so regardless, just in case. + */ + + duk_int32_t skip; + duk_uint8_t **full_save; + const duk_uint8_t *sub_sp; + + DUK_ASSERT(re_ctx->nsaved > 0); + + duk_require_stack(re_ctx->thr, 1); + full_save = + (duk_uint8_t **) duk_push_fixed_buffer_nozero(re_ctx->thr, sizeof(duk_uint8_t *) * re_ctx->nsaved); + DUK_ASSERT(full_save != NULL); + duk_memcpy(full_save, re_ctx->saved, sizeof(duk_uint8_t *) * re_ctx->nsaved); + + skip = duk__bc_get_i32(re_ctx, &pc); + sub_sp = duk__match_regexp(re_ctx, pc, sp); + if (op == DUK_REOP_LOOKPOS) { + if (!sub_sp) { + goto lookahead_fail; + } + } else { + if (sub_sp) { + goto lookahead_fail; + } + } + sub_sp = duk__match_regexp(re_ctx, pc + skip, sp); + if (sub_sp) { + /* match: keep saves */ + duk_pop_unsafe(re_ctx->thr); + sp = sub_sp; + goto match; + } + + /* fall through */ + + lookahead_fail: + /* fail: restore saves */ + duk_memcpy((void *) re_ctx->saved, (const void *) full_save, sizeof(duk_uint8_t *) * re_ctx->nsaved); + duk_pop_unsafe(re_ctx->thr); + goto fail; + } + case DUK_REOP_BACKREFERENCE: { + /* + * Byte matching for back-references would be OK in case- + * sensitive matching. In case-insensitive matching we need + * to canonicalize characters, so back-reference matching needs + * to be done with codepoints instead. So, we just decode + * everything normally here, too. + * + * Note: back-reference index which is 0 or higher than + * NCapturingParens (= number of capturing parens in the + * -entire- regexp) is a compile time error. However, a + * backreference referring to a valid capture which has + * not matched anything always succeeds! See E5 Section + * 15.10.2.9, step 5, sub-step 3. + */ + duk_uint32_t idx; + const duk_uint8_t *p; + + idx = duk__bc_get_u32(re_ctx, &pc); + idx = idx << 1; /* backref n -> saved indices [n*2, n*2+1] */ + if (idx < 2 || idx + 1 >= re_ctx->nsaved) { + /* regexp compiler should catch these */ + DUK_D(DUK_DPRINT("internal error, backreference index insane")); + goto internal_error; + } + if (!re_ctx->saved[idx] || !re_ctx->saved[idx + 1]) { + /* capture is 'undefined', always matches! */ + DUK_DDD(DUK_DDDPRINT("backreference: saved[%ld,%ld] not complete, always match", + (long) idx, + (long) (idx + 1))); + break; + } + DUK_DDD(DUK_DDDPRINT("backreference: match saved[%ld,%ld]", (long) idx, (long) (idx + 1))); + + p = re_ctx->saved[idx]; + while (p < re_ctx->saved[idx + 1]) { + duk_codepoint_t c1, c2; + + /* Note: not necessary to check p against re_ctx->input_end: + * the memory access is checked by duk__inp_get_cp(), while + * valid compiled regexps cannot write a saved[] entry + * which points to outside the string. + */ + c1 = duk__inp_get_cp(re_ctx, &p); + DUK_ASSERT(c1 >= 0); + c2 = duk__inp_get_cp(re_ctx, &sp); + /* No need for an explicit c2 < 0 check: because c1 >= 0, + * the comparison will always fail if c2 < 0. + */ +#if 0 + if (c2 < 0) { + goto fail; + } +#endif + if (c1 != c2) { + goto fail; + } + } + break; + } + default: { + DUK_D(DUK_DPRINT("internal error, regexp opcode error: %ld", (long) op)); + goto internal_error; + } + } + } + +match: + re_ctx->recursion_depth--; + return sp; + +fail: + re_ctx->recursion_depth--; + return NULL; + +internal_error: + DUK_ERROR_INTERNAL(re_ctx->thr); + DUK_WO_NORETURN(return NULL;); +} + +/* + * Exposed matcher function which provides the semantics of RegExp.prototype.exec(). + * + * RegExp.prototype.test() has the same semantics as exec() but does not return the + * result object (which contains the matching string and capture groups). Currently + * there is no separate test() helper, so a temporary result object is created and + * discarded if test() is needed. This is intentional, to save code space. + * + * Input stack: [ ... re_obj input ] + * Output stack: [ ... result ] + */ + +DUK_LOCAL void duk__regexp_match_helper(duk_hthread *thr, duk_small_int_t force_global) { + duk_re_matcher_ctx re_ctx; + duk_hobject *h_regexp; + duk_hstring *h_bytecode; + duk_hstring *h_input; + duk_uint8_t *p_buf; + const duk_uint8_t *pc; + const duk_uint8_t *sp; + duk_small_int_t match = 0; + duk_small_int_t global; + duk_uint_fast32_t i; + double d; + duk_uint32_t char_offset; + + DUK_ASSERT(thr != NULL); + + DUK_DD(DUK_DDPRINT("regexp match: regexp=%!T, input=%!T", + (duk_tval *) duk_get_tval(thr, -2), + (duk_tval *) duk_get_tval(thr, -1))); + + /* + * Regexp instance check, bytecode check, input coercion. + * + * See E5 Section 15.10.6. + */ + + /* TypeError if wrong; class check, see E5 Section 15.10.6 */ + h_regexp = duk_require_hobject_with_class(thr, -2, DUK_HOBJECT_CLASS_REGEXP); + DUK_ASSERT(h_regexp != NULL); + DUK_ASSERT(DUK_HOBJECT_GET_CLASS_NUMBER(h_regexp) == DUK_HOBJECT_CLASS_REGEXP); + DUK_UNREF(h_regexp); + + h_input = duk_to_hstring(thr, -1); + DUK_ASSERT(h_input != NULL); + + duk_xget_owndataprop_stridx_short(thr, -2, DUK_STRIDX_INT_BYTECODE); /* [ ... re_obj input ] -> [ ... re_obj input bc ] */ + h_bytecode = + duk_require_hstring(thr, -1); /* no regexp instance should exist without a non-configurable bytecode property */ + DUK_ASSERT(h_bytecode != NULL); + + /* + * Basic context initialization. + * + * Some init values are read from the bytecode header + * whose format is (UTF-8 codepoints): + * + * uint flags + * uint nsaved (even, 2n+2 where n = num captures) + */ + + /* [ ... re_obj input bc ] */ + + duk_memzero(&re_ctx, sizeof(re_ctx)); + + re_ctx.thr = thr; + re_ctx.input = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_input); + re_ctx.input_end = re_ctx.input + DUK_HSTRING_GET_BYTELEN(h_input); + re_ctx.bytecode = (const duk_uint8_t *) DUK_HSTRING_GET_DATA(h_bytecode); + re_ctx.bytecode_end = re_ctx.bytecode + DUK_HSTRING_GET_BYTELEN(h_bytecode); + re_ctx.saved = NULL; + re_ctx.recursion_limit = DUK_USE_REGEXP_EXECUTOR_RECLIMIT; + re_ctx.steps_limit = DUK_RE_EXECUTE_STEPS_LIMIT; + + /* read header */ + pc = re_ctx.bytecode; + re_ctx.re_flags = duk__bc_get_u32(&re_ctx, &pc); + re_ctx.nsaved = duk__bc_get_u32(&re_ctx, &pc); + re_ctx.bytecode = pc; + + DUK_ASSERT(DUK_RE_FLAG_GLOBAL < 0x10000UL); /* must fit into duk_small_int_t */ + global = (duk_small_int_t) (force_global | (duk_small_int_t) (re_ctx.re_flags & DUK_RE_FLAG_GLOBAL)); + + DUK_ASSERT(re_ctx.nsaved >= 2); + DUK_ASSERT((re_ctx.nsaved % 2) == 0); + + p_buf = (duk_uint8_t *) duk_push_fixed_buffer(thr, sizeof(duk_uint8_t *) * re_ctx.nsaved); /* rely on zeroing */ + DUK_UNREF(p_buf); + re_ctx.saved = (const duk_uint8_t **) duk_get_buffer(thr, -1, NULL); + DUK_ASSERT(re_ctx.saved != NULL); + + /* [ ... re_obj input bc saved_buf ] */ + +#if defined(DUK_USE_EXPLICIT_NULL_INIT) + for (i = 0; i < re_ctx.nsaved; i++) { + re_ctx.saved[i] = (duk_uint8_t *) NULL; + } +#elif defined(DUK_USE_ZERO_BUFFER_DATA) + /* buffer is automatically zeroed */ +#else + duk_memzero((void *) p_buf, sizeof(duk_uint8_t *) * re_ctx.nsaved); +#endif + + DUK_DDD(DUK_DDDPRINT("regexp ctx initialized, flags=0x%08lx, nsaved=%ld, recursion_limit=%ld, steps_limit=%ld", + (unsigned long) re_ctx.re_flags, + (long) re_ctx.nsaved, + (long) re_ctx.recursion_limit, + (long) re_ctx.steps_limit)); + + /* + * Get starting character offset for match, and initialize 'sp' based on it. + * + * Note: lastIndex is non-configurable so it must be present (we check the + * internal class of the object above, so we know it is). User code can set + * its value to an arbitrary (garbage) value though; E5 requires that lastIndex + * be coerced to a number before using. The code below works even if the + * property is missing: the value will then be coerced to zero. + * + * Note: lastIndex may be outside Uint32 range even after ToInteger() coercion. + * For instance, ToInteger(+Infinity) = +Infinity. We track the match offset + * as an integer, but pre-check it to be inside the 32-bit range before the loop. + * If not, the check in E5 Section 15.10.6.2, step 9.a applies. + */ + + /* XXX: lastIndex handling produces a lot of asm */ + + /* [ ... re_obj input bc saved_buf ] */ + + duk_get_prop_stridx_short(thr, -4, DUK_STRIDX_LAST_INDEX); /* -> [ ... re_obj input bc saved_buf lastIndex ] */ + (void) duk_to_int(thr, -1); /* ToInteger(lastIndex) */ + d = duk_get_number(thr, -1); /* integer, but may be +/- Infinite, +/- zero (not NaN, though) */ + duk_pop_nodecref_unsafe(thr); + + if (global) { + if (d < 0.0 || d > (double) DUK_HSTRING_GET_CHARLEN(h_input)) { + /* match fail */ + char_offset = 0; /* not really necessary */ + DUK_ASSERT(match == 0); + goto match_over; + } + char_offset = (duk_uint32_t) d; + } else { + /* lastIndex must be ignored for non-global regexps, but get the + * value for (theoretical) side effects. No side effects can + * really occur, because lastIndex is a normal property and is + * always non-configurable for RegExp instances. + */ + char_offset = (duk_uint32_t) 0; + } + + DUK_ASSERT(char_offset <= DUK_HSTRING_GET_CHARLEN(h_input)); + sp = re_ctx.input + duk_heap_strcache_offset_char2byte(thr, h_input, char_offset); + + /* + * Match loop. + * + * Try matching at different offsets until match found or input exhausted. + */ + + /* [ ... re_obj input bc saved_buf ] */ + + DUK_ASSERT(match == 0); + + for (;;) { + /* char offset in [0, h_input->clen] (both ends inclusive), checked before entry */ + DUK_ASSERT_DISABLE(char_offset >= 0); + DUK_ASSERT(char_offset <= DUK_HSTRING_GET_CHARLEN(h_input)); + + /* Note: re_ctx.steps is intentionally not reset, it applies to the entire unanchored match */ + DUK_ASSERT(re_ctx.recursion_depth == 0); + + DUK_DDD(DUK_DDDPRINT("attempt match at char offset %ld; %p [%p,%p]", + (long) char_offset, + (const void *) sp, + (const void *) re_ctx.input, + (const void *) re_ctx.input_end)); + + /* + * Note: + * + * - duk__match_regexp() is required not to longjmp() in ordinary "non-match" + * conditions; a longjmp() will terminate the entire matching process. + * + * - Clearing saved[] is not necessary because backtracking does it + * + * - Backtracking also rewinds re_ctx.recursion back to zero, unless an + * internal/limit error occurs (which causes a longjmp()) + * + * - If we supported anchored matches, we would break out here + * unconditionally; however, ECMAScript regexps don't have anchored + * matches. It might make sense to implement a fast bail-out if + * the regexp begins with '^' and sp is not 0: currently we'll just + * run through the entire input string, trivially failing the match + * at every non-zero offset. + */ + + if (duk__match_regexp(&re_ctx, re_ctx.bytecode, sp) != NULL) { + DUK_DDD(DUK_DDDPRINT("match at offset %ld", (long) char_offset)); + match = 1; + break; + } + + /* advance by one character (code point) and one char_offset */ + char_offset++; + if (char_offset > DUK_HSTRING_GET_CHARLEN(h_input)) { + /* + * Note: + * + * - Intentionally attempt (empty) match at char_offset == k_input->clen + * + * - Negative char_offsets have been eliminated and char_offset is duk_uint32_t + * -> no need or use for a negative check + */ + + DUK_DDD(DUK_DDDPRINT("no match after trying all sp offsets")); + break; + } + + /* avoid calling at end of input, will DUK_ERROR (above check suffices to avoid this) */ + (void) duk__utf8_advance(thr, &sp, re_ctx.input, re_ctx.input_end, (duk_uint_fast32_t) 1); + } + +match_over: + + /* + * Matching complete, create result array or return a 'null'. Update lastIndex + * if necessary. See E5 Section 15.10.6.2. + * + * Because lastIndex is a character (not byte) offset, we need the character + * length of the match which we conveniently get as a side effect of interning + * the matching substring (0th index of result array). + * + * saved[0] start pointer (~ byte offset) of current match + * saved[1] end pointer (~ byte offset) of current match (exclusive) + * char_offset start character offset of current match (-> .index of result) + * char_end_offset end character offset (computed below) + */ + + /* [ ... re_obj input bc saved_buf ] */ + + if (match) { +#if defined(DUK_USE_ASSERTIONS) + duk_hobject *h_res; +#endif + duk_uint32_t char_end_offset = 0; + + DUK_DDD(DUK_DDDPRINT("regexp matches at char_offset %ld", (long) char_offset)); + + DUK_ASSERT(re_ctx.nsaved >= 2); /* must have start and end */ + DUK_ASSERT((re_ctx.nsaved % 2) == 0); /* and even number */ + + /* XXX: Array size is known before and (2 * re_ctx.nsaved) but not taken + * advantage of now. The array is not compacted either, as regexp match + * objects are usually short lived. + */ + + duk_push_array(thr); + +#if defined(DUK_USE_ASSERTIONS) + h_res = duk_require_hobject(thr, -1); + DUK_ASSERT(DUK_HOBJECT_HAS_EXTENSIBLE(h_res)); + DUK_ASSERT(DUK_HOBJECT_HAS_EXOTIC_ARRAY(h_res)); + DUK_ASSERT(DUK_HOBJECT_GET_CLASS_NUMBER(h_res) == DUK_HOBJECT_CLASS_ARRAY); +#endif + + /* [ ... re_obj input bc saved_buf res_obj ] */ + + duk_push_u32(thr, char_offset); + duk_xdef_prop_stridx_short_wec(thr, -2, DUK_STRIDX_INDEX); + + duk_dup_m4(thr); + duk_xdef_prop_stridx_short_wec(thr, -2, DUK_STRIDX_INPUT); + + for (i = 0; i < re_ctx.nsaved; i += 2) { + /* Captures which are undefined have NULL pointers and are returned + * as 'undefined'. The same is done when saved[] pointers are insane + * (this should, of course, never happen in practice). + */ + duk_push_uarridx(thr, (duk_uarridx_t) (i / 2)); + + if (re_ctx.saved[i] && re_ctx.saved[i + 1] && re_ctx.saved[i + 1] >= re_ctx.saved[i]) { + duk_push_lstring(thr, + (const char *) re_ctx.saved[i], + (duk_size_t) (re_ctx.saved[i + 1] - re_ctx.saved[i])); + if (i == 0) { + /* Assumes that saved[0] and saved[1] are always + * set by regexp bytecode (if not, char_end_offset + * will be zero). Also assumes clen reflects the + * correct char length. + */ + char_end_offset = char_offset + (duk_uint32_t) duk_get_length(thr, -1); /* add charlen */ + } + } else { + duk_push_undefined(thr); + } + + /* [ ... re_obj input bc saved_buf res_obj idx val ] */ + duk_def_prop(thr, -3, DUK_DEFPROP_HAVE_VALUE | DUK_DEFPROP_SET_WEC); + } + + /* [ ... re_obj input bc saved_buf res_obj ] */ + + /* NB: 'length' property is automatically updated by the array setup loop */ + + if (global) { + /* global regexp: lastIndex updated on match */ + duk_push_u32(thr, char_end_offset); + duk_put_prop_stridx_short(thr, -6, DUK_STRIDX_LAST_INDEX); + } else { + /* non-global regexp: lastIndex never updated on match */ + ; + } + } else { + /* + * No match, E5 Section 15.10.6.2, step 9.a.i - 9.a.ii apply, regardless + * of 'global' flag of the RegExp. In particular, if lastIndex is invalid + * initially, it is reset to zero. + */ + + DUK_DDD(DUK_DDDPRINT("regexp does not match")); + + duk_push_null(thr); + + /* [ ... re_obj input bc saved_buf res_obj ] */ + + duk_push_int(thr, 0); + duk_put_prop_stridx_short(thr, -6, DUK_STRIDX_LAST_INDEX); + } + + /* [ ... re_obj input bc saved_buf res_obj ] */ + + duk_insert(thr, -5); + + /* [ ... res_obj re_obj input bc saved_buf ] */ + + duk_pop_n_unsafe(thr, 4); + + /* [ ... res_obj ] */ + + /* XXX: these last tricks are unnecessary if the function is made + * a genuine native function. + */ +} + +DUK_INTERNAL void duk_regexp_match(duk_hthread *thr) { + duk__regexp_match_helper(thr, 0 /*force_global*/); +} + +/* This variant is needed by String.prototype.split(); it needs to perform + * global-style matching on a cloned RegExp which is potentially non-global. + */ +DUK_INTERNAL void duk_regexp_match_force_global(duk_hthread *thr) { + duk__regexp_match_helper(thr, 1 /*force_global*/); +} + +#else /* DUK_USE_REGEXP_SUPPORT */ + +/* regexp support disabled */ + +#endif /* DUK_USE_REGEXP_SUPPORT */ +#line 1 "duk_selftest.c" +/* + * Self tests to ensure execution environment is sane. Intended to catch + * compiler/platform problems which cannot be detected at compile time. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_SELF_TESTS) + +/* + * Unions and structs for self tests + */ + +typedef union { + double d; + duk_uint8_t x[8]; +} duk__test_double_union; + +/* Self test failed. Expects a local variable 'error_count' to exist. */ +#define DUK__FAILED(msg) \ + do { \ + DUK_D(DUK_DPRINT("self test failed: " #msg " at " DUK_FILE_MACRO ":" DUK_MACRO_STRINGIFY(DUK_LINE_MACRO))); \ + error_count++; \ + } while (0) + +#define DUK__DBLUNION_CMP_TRUE(a, b) \ + do { \ + if (duk_memcmp((const void *) (a), (const void *) (b), sizeof(duk__test_double_union)) != 0) { \ + DUK__FAILED("double union compares false (expected true)"); \ + } \ + } while (0) + +#define DUK__DBLUNION_CMP_FALSE(a, b) \ + do { \ + if (duk_memcmp((const void *) (a), (const void *) (b), sizeof(duk__test_double_union)) == 0) { \ + DUK__FAILED("double union compares true (expected false)"); \ + } \ + } while (0) + +typedef union { + duk_uint32_t i; + duk_uint8_t x[8]; +} duk__test_u32_union; + +#if defined(DUK_USE_INTEGER_LE) +#define DUK__U32_INIT(u, a, b, c, d) \ + do { \ + (u)->x[0] = (d); \ + (u)->x[1] = (c); \ + (u)->x[2] = (b); \ + (u)->x[3] = (a); \ + } while (0) +#elif defined(DUK_USE_INTEGER_ME) +#error integer mixed endian not supported now +#elif defined(DUK_USE_INTEGER_BE) +#define DUK__U32_INIT(u, a, b, c, d) \ + do { \ + (u)->x[0] = (a); \ + (u)->x[1] = (b); \ + (u)->x[2] = (c); \ + (u)->x[3] = (d); \ + } while (0) +#else +#error unknown integer endianness +#endif + +#if defined(DUK_USE_DOUBLE_LE) +#define DUK__DOUBLE_INIT(u, a, b, c, d, e, f, g, h) \ + do { \ + (u)->x[0] = (h); \ + (u)->x[1] = (g); \ + (u)->x[2] = (f); \ + (u)->x[3] = (e); \ + (u)->x[4] = (d); \ + (u)->x[5] = (c); \ + (u)->x[6] = (b); \ + (u)->x[7] = (a); \ + } while (0) +#define DUK__DOUBLE_COMPARE(u, a, b, c, d, e, f, g, h) \ + ((u)->x[0] == (h) && (u)->x[1] == (g) && (u)->x[2] == (f) && (u)->x[3] == (e) && (u)->x[4] == (d) && (u)->x[5] == (c) && \ + (u)->x[6] == (b) && (u)->x[7] == (a)) +#elif defined(DUK_USE_DOUBLE_ME) +#define DUK__DOUBLE_INIT(u, a, b, c, d, e, f, g, h) \ + do { \ + (u)->x[0] = (d); \ + (u)->x[1] = (c); \ + (u)->x[2] = (b); \ + (u)->x[3] = (a); \ + (u)->x[4] = (h); \ + (u)->x[5] = (g); \ + (u)->x[6] = (f); \ + (u)->x[7] = (e); \ + } while (0) +#define DUK__DOUBLE_COMPARE(u, a, b, c, d, e, f, g, h) \ + ((u)->x[0] == (d) && (u)->x[1] == (c) && (u)->x[2] == (b) && (u)->x[3] == (a) && (u)->x[4] == (h) && (u)->x[5] == (g) && \ + (u)->x[6] == (f) && (u)->x[7] == (e)) +#elif defined(DUK_USE_DOUBLE_BE) +#define DUK__DOUBLE_INIT(u, a, b, c, d, e, f, g, h) \ + do { \ + (u)->x[0] = (a); \ + (u)->x[1] = (b); \ + (u)->x[2] = (c); \ + (u)->x[3] = (d); \ + (u)->x[4] = (e); \ + (u)->x[5] = (f); \ + (u)->x[6] = (g); \ + (u)->x[7] = (h); \ + } while (0) +#define DUK__DOUBLE_COMPARE(u, a, b, c, d, e, f, g, h) \ + ((u)->x[0] == (a) && (u)->x[1] == (b) && (u)->x[2] == (c) && (u)->x[3] == (d) && (u)->x[4] == (e) && (u)->x[5] == (f) && \ + (u)->x[6] == (g) && (u)->x[7] == (h)) +#else +#error unknown double endianness +#endif + +/* + * Various sanity checks for typing + */ + +DUK_LOCAL duk_uint_t duk__selftest_types(void) { + duk_uint_t error_count = 0; + + if (!(sizeof(duk_int8_t) == 1 && sizeof(duk_uint8_t) == 1 && sizeof(duk_int16_t) == 2 && sizeof(duk_uint16_t) == 2 && + sizeof(duk_int32_t) == 4 && sizeof(duk_uint32_t) == 4)) { + DUK__FAILED("duk_(u)int{8,16,32}_t size"); + } +#if defined(DUK_USE_64BIT_OPS) + if (!(sizeof(duk_int64_t) == 8 && sizeof(duk_uint64_t) == 8)) { + DUK__FAILED("duk_(u)int64_t size"); + } +#endif + + if (!(sizeof(duk_size_t) >= sizeof(duk_uint_t))) { + /* Some internal code now assumes that all duk_uint_t values + * can be expressed with a duk_size_t. + */ + DUK__FAILED("duk_size_t is smaller than duk_uint_t"); + } + if (!(sizeof(duk_int_t) >= 4)) { + DUK__FAILED("duk_int_t is not 32 bits"); + } + + return error_count; +} + +/* + * Packed tval sanity + */ + +DUK_LOCAL duk_uint_t duk__selftest_packed_tval(void) { + duk_uint_t error_count = 0; + +#if defined(DUK_USE_PACKED_TVAL) + if (sizeof(void *) > 4) { + DUK__FAILED("packed duk_tval in use but sizeof(void *) > 4"); + } +#endif + + return error_count; +} + +/* + * Two's complement arithmetic. + */ + +DUK_LOCAL duk_uint_t duk__selftest_twos_complement(void) { + duk_uint_t error_count = 0; + volatile int test; + test = -1; + + /* Note that byte order doesn't affect this test: all bytes in + * 'test' will be 0xFF for two's complement. + */ + if (((volatile duk_uint8_t *) &test)[0] != (duk_uint8_t) 0xff) { + DUK__FAILED("two's complement arithmetic"); + } + + return error_count; +} + +/* + * Byte order. Important to self check, because on some exotic platforms + * there is no actual detection but rather assumption based on platform + * defines. + */ + +DUK_LOCAL duk_uint_t duk__selftest_byte_order(void) { + duk_uint_t error_count = 0; + duk__test_u32_union u1; + duk__test_double_union u2; + + /* + * >>> struct.pack('>d', 102030405060).encode('hex') + * '4237c17c6dc40000' + */ + + DUK__U32_INIT(&u1, 0xde, 0xad, 0xbe, 0xef); + DUK__DOUBLE_INIT(&u2, 0x42, 0x37, 0xc1, 0x7c, 0x6d, 0xc4, 0x00, 0x00); + + if (u1.i != (duk_uint32_t) 0xdeadbeefUL) { + DUK__FAILED("duk_uint32_t byte order"); + } + + if (!duk_double_equals(u2.d, 102030405060.0)) { + DUK__FAILED("double byte order"); + } + + return error_count; +} + +/* + * DUK_BSWAP macros + */ + +DUK_LOCAL duk_uint_t duk__selftest_bswap_macros(void) { + duk_uint_t error_count = 0; + volatile duk_uint32_t x32_input, x32_output; + duk_uint32_t x32; + volatile duk_uint16_t x16_input, x16_output; + duk_uint16_t x16; + duk_double_union du; + duk_double_t du_diff; +#if defined(DUK_BSWAP64) + volatile duk_uint64_t x64_input, x64_output; + duk_uint64_t x64; +#endif + + /* Cover both compile time and runtime bswap operations, as these + * may have different bugs. + */ + + x16_input = 0xbeefUL; + x16 = x16_input; + x16 = DUK_BSWAP16(x16); + x16_output = x16; + if (x16_output != (duk_uint16_t) 0xefbeUL) { + DUK__FAILED("DUK_BSWAP16"); + } + + x16 = 0xbeefUL; + x16 = DUK_BSWAP16(x16); + if (x16 != (duk_uint16_t) 0xefbeUL) { + DUK__FAILED("DUK_BSWAP16"); + } + + x32_input = 0xdeadbeefUL; + x32 = x32_input; + x32 = DUK_BSWAP32(x32); + x32_output = x32; + if (x32_output != (duk_uint32_t) 0xefbeaddeUL) { + DUK__FAILED("DUK_BSWAP32"); + } + + x32 = 0xdeadbeefUL; + x32 = DUK_BSWAP32(x32); + if (x32 != (duk_uint32_t) 0xefbeaddeUL) { + DUK__FAILED("DUK_BSWAP32"); + } + +#if defined(DUK_BSWAP64) + x64_input = DUK_U64_CONSTANT(0x8899aabbccddeeff); + x64 = x64_input; + x64 = DUK_BSWAP64(x64); + x64_output = x64; + if (x64_output != (duk_uint64_t) DUK_U64_CONSTANT(0xffeeddccbbaa9988)) { + DUK__FAILED("DUK_BSWAP64"); + } + + x64 = DUK_U64_CONSTANT(0x8899aabbccddeeff); + x64 = DUK_BSWAP64(x64); + if (x64 != (duk_uint64_t) DUK_U64_CONSTANT(0xffeeddccbbaa9988)) { + DUK__FAILED("DUK_BSWAP64"); + } +#endif + + /* >>> struct.unpack('>d', '4000112233445566'.decode('hex')) + * (2.008366013071895,) + */ + + du.uc[0] = 0x40; + du.uc[1] = 0x00; + du.uc[2] = 0x11; + du.uc[3] = 0x22; + du.uc[4] = 0x33; + du.uc[5] = 0x44; + du.uc[6] = 0x55; + du.uc[7] = 0x66; + DUK_DBLUNION_DOUBLE_NTOH(&du); + du_diff = du.d - 2.008366013071895; +#if 0 + DUK_D(DUK_DPRINT("du_diff: %lg\n", (double) du_diff)); +#endif + if (du_diff > 1e-15) { + /* Allow very small lenience because some compilers won't parse + * exact IEEE double constants (happened in matrix testing with + * Linux gcc-4.8 -m32 at least). + */ +#if 0 + DUK_D(DUK_DPRINT("Result of DUK_DBLUNION_DOUBLE_NTOH: %02x %02x %02x %02x %02x %02x %02x %02x\n", + (unsigned int) du.uc[0], (unsigned int) du.uc[1], + (unsigned int) du.uc[2], (unsigned int) du.uc[3], + (unsigned int) du.uc[4], (unsigned int) du.uc[5], + (unsigned int) du.uc[6], (unsigned int) du.uc[7])); +#endif + DUK__FAILED("DUK_DBLUNION_DOUBLE_NTOH"); + } + + return error_count; +} + +/* + * Basic double / byte union memory layout. + */ + +DUK_LOCAL duk_uint_t duk__selftest_double_union_size(void) { + duk_uint_t error_count = 0; + + if (sizeof(duk__test_double_union) != 8) { + DUK__FAILED("invalid union size"); + } + + return error_count; +} + +/* + * Union aliasing, see misc/clang_aliasing.c. + */ + +DUK_LOCAL duk_uint_t duk__selftest_double_aliasing(void) { + /* This testcase fails when Emscripten-generated code runs on Firefox. + * It's not an issue because the failure should only affect packed + * duk_tval representation, which is not used with Emscripten. + */ +#if defined(DUK_USE_PACKED_TVAL) + duk_uint_t error_count = 0; + duk__test_double_union a, b; + + /* Test signaling NaN and alias assignment in all endianness combinations. + */ + + /* little endian */ + a.x[0] = 0x11; + a.x[1] = 0x22; + a.x[2] = 0x33; + a.x[3] = 0x44; + a.x[4] = 0x00; + a.x[5] = 0x00; + a.x[6] = 0xf1; + a.x[7] = 0xff; + b = a; + DUK__DBLUNION_CMP_TRUE(&a, &b); + + /* big endian */ + a.x[0] = 0xff; + a.x[1] = 0xf1; + a.x[2] = 0x00; + a.x[3] = 0x00; + a.x[4] = 0x44; + a.x[5] = 0x33; + a.x[6] = 0x22; + a.x[7] = 0x11; + b = a; + DUK__DBLUNION_CMP_TRUE(&a, &b); + + /* mixed endian */ + a.x[0] = 0x00; + a.x[1] = 0x00; + a.x[2] = 0xf1; + a.x[3] = 0xff; + a.x[4] = 0x11; + a.x[5] = 0x22; + a.x[6] = 0x33; + a.x[7] = 0x44; + b = a; + DUK__DBLUNION_CMP_TRUE(&a, &b); + + return error_count; +#else + DUK_D(DUK_DPRINT("skip double aliasing self test when duk_tval is not packed")); + return 0; +#endif +} + +/* + * Zero sign, see misc/tcc_zerosign2.c. + */ + +DUK_LOCAL duk_uint_t duk__selftest_double_zero_sign(void) { + duk_uint_t error_count = 0; + duk__test_double_union a, b; + + a.d = 0.0; + b.d = -a.d; + DUK__DBLUNION_CMP_FALSE(&a, &b); + + return error_count; +} + +/* + * Rounding mode: Duktape assumes round-to-nearest, check that this is true. + * If we had C99 fenv.h we could check that fegetround() == FE_TONEAREST, + * but we don't want to rely on that header; and even if we did, it's good + * to ensure the rounding actually works. + */ + +DUK_LOCAL duk_uint_t duk__selftest_double_rounding(void) { + duk_uint_t error_count = 0; + duk__test_double_union a, b, c; + +#if 0 + /* Include and test manually; these trigger failures: */ + fesetround(FE_UPWARD); + fesetround(FE_DOWNWARD); + fesetround(FE_TOWARDZERO); + + /* This is the default and passes. */ + fesetround(FE_TONEAREST); +#endif + + /* Rounding tests check that none of the other modes (round to + * +Inf, round to -Inf, round to zero) can be active: + * http://www.gnu.org/software/libc/manual/html_node/Rounding.html + */ + + /* 1.0 + 2^(-53): result is midway between 1.0 and 1.0 + ulp. + * Round to nearest: 1.0 + * Round to +Inf: 1.0 + ulp + * Round to -Inf: 1.0 + * Round to zero: 1.0 + * => Correct result eliminates round to +Inf. + */ + DUK__DOUBLE_INIT(&a, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00); + DUK__DOUBLE_INIT(&b, 0x3c, 0xa0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00); + duk_memset((void *) &c, 0, sizeof(c)); + c.d = a.d + b.d; + if (!DUK__DOUBLE_COMPARE(&c, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00)) { + DUK_D(DUK_DPRINT("broken result (native endiannesss): %02x %02x %02x %02x %02x %02x %02x %02x", + (unsigned int) c.x[0], + (unsigned int) c.x[1], + (unsigned int) c.x[2], + (unsigned int) c.x[3], + (unsigned int) c.x[4], + (unsigned int) c.x[5], + (unsigned int) c.x[6], + (unsigned int) c.x[7])); + DUK__FAILED("invalid result from 1.0 + 0.5ulp"); + } + + /* (1.0 + ulp) + 2^(-53): result is midway between 1.0 + ulp and 1.0 + 2*ulp. + * Round to nearest: 1.0 + 2*ulp (round to even mantissa) + * Round to +Inf: 1.0 + 2*ulp + * Round to -Inf: 1.0 + ulp + * Round to zero: 1.0 + ulp + * => Correct result eliminates round to -Inf and round to zero. + */ + DUK__DOUBLE_INIT(&a, 0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01); + DUK__DOUBLE_INIT(&b, 0x3c, 0xa0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00); + duk_memset((void *) &c, 0, sizeof(c)); + c.d = a.d + b.d; + if (!DUK__DOUBLE_COMPARE(&c, 0x3f, 0xf0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x02)) { + DUK_D(DUK_DPRINT("broken result (native endiannesss): %02x %02x %02x %02x %02x %02x %02x %02x", + (unsigned int) c.x[0], + (unsigned int) c.x[1], + (unsigned int) c.x[2], + (unsigned int) c.x[3], + (unsigned int) c.x[4], + (unsigned int) c.x[5], + (unsigned int) c.x[6], + (unsigned int) c.x[7])); + DUK__FAILED("invalid result from (1.0 + ulp) + 0.5ulp"); + } + + /* Could do negative number testing too, but the tests above should + * differentiate between IEEE 754 rounding modes. + */ + return error_count; +} + +/* + * fmod(): often a portability issue in embedded or bare platform targets. + * Check for at least minimally correct behavior. Unlike some other math + * functions (like cos()) Duktape relies on fmod() internally too. + */ + +DUK_LOCAL duk_uint_t duk__selftest_fmod(void) { + duk_uint_t error_count = 0; + duk__test_double_union u1, u2; + volatile duk_double_t t1, t2, t3; + + /* fmod() with integer argument and exponent 2^32 is used by e.g. + * ToUint32() and some Duktape internals. + */ + u1.d = DUK_FMOD(10.0, 4294967296.0); + u2.d = 10.0; + DUK__DBLUNION_CMP_TRUE(&u1, &u2); + + u1.d = DUK_FMOD(4294967306.0, 4294967296.0); + u2.d = 10.0; + DUK__DBLUNION_CMP_TRUE(&u1, &u2); + + u1.d = DUK_FMOD(73014444042.0, 4294967296.0); + u2.d = 10.0; + DUK__DBLUNION_CMP_TRUE(&u1, &u2); + + /* 52-bit integer split into two parts: + * >>> 0x1fedcba9876543 + * 8987183256397123 + * >>> float(0x1fedcba9876543) / float(2**53) + * 0.9977777777777778 + */ + u1.d = DUK_FMOD(8987183256397123.0, 4294967296.0); + u2.d = (duk_double_t) 0xa9876543UL; + DUK__DBLUNION_CMP_TRUE(&u1, &u2); + t1 = 8987183256397123.0; + t2 = 4294967296.0; + t3 = t1 / t2; + u1.d = DUK_FLOOR(t3); + u2.d = (duk_double_t) 0x1fedcbUL; + DUK__DBLUNION_CMP_TRUE(&u1, &u2); + + /* C99 behavior is for fmod() result sign to mathc argument sign. */ + u1.d = DUK_FMOD(-10.0, 4294967296.0); + u2.d = -10.0; + DUK__DBLUNION_CMP_TRUE(&u1, &u2); + + u1.d = DUK_FMOD(-4294967306.0, 4294967296.0); + u2.d = -10.0; + DUK__DBLUNION_CMP_TRUE(&u1, &u2); + + u1.d = DUK_FMOD(-73014444042.0, 4294967296.0); + u2.d = -10.0; + DUK__DBLUNION_CMP_TRUE(&u1, &u2); + + return error_count; +} + +/* + * Struct size/alignment if platform requires it + * + * There are some compiler specific struct padding pragmas etc in use, this + * selftest ensures they're correctly detected and used. + */ + +DUK_LOCAL duk_uint_t duk__selftest_struct_align(void) { + duk_uint_t error_count = 0; + +#if (DUK_USE_ALIGN_BY == 4) + if ((sizeof(duk_hbuffer_fixed) % 4) != 0) { + DUK__FAILED("sizeof(duk_hbuffer_fixed) not aligned to 4"); + } +#elif (DUK_USE_ALIGN_BY == 8) + if ((sizeof(duk_hbuffer_fixed) % 8) != 0) { + DUK__FAILED("sizeof(duk_hbuffer_fixed) not aligned to 8"); + } +#elif (DUK_USE_ALIGN_BY == 1) + /* no check */ +#else +#error invalid DUK_USE_ALIGN_BY +#endif + return error_count; +} + +/* + * 64-bit arithmetic + * + * There are some platforms/compilers where 64-bit types are available + * but don't work correctly. Test for known cases. + */ + +DUK_LOCAL duk_uint_t duk__selftest_64bit_arithmetic(void) { + duk_uint_t error_count = 0; +#if defined(DUK_USE_64BIT_OPS) + volatile duk_int64_t i; + volatile duk_double_t d; + + /* Catch a double-to-int64 cast issue encountered in practice. */ + d = 2147483648.0; + i = (duk_int64_t) d; + if (i != DUK_I64_CONSTANT(0x80000000)) { + DUK__FAILED("casting 2147483648.0 to duk_int64_t failed"); + } +#else + /* nop */ +#endif + return error_count; +} + +/* + * Casting + */ + +DUK_LOCAL duk_uint_t duk__selftest_cast_double_to_small_uint(void) { + /* + * https://github.com/svaarala/duktape/issues/127#issuecomment-77863473 + */ + + duk_uint_t error_count = 0; + + duk_double_t d1, d2; + duk_small_uint_t u; + + duk_double_t d1v, d2v; + duk_small_uint_t uv; + + /* Test without volatiles */ + + d1 = 1.0; + u = (duk_small_uint_t) d1; + d2 = (duk_double_t) u; + + if (!(duk_double_equals(d1, 1.0) && u == 1 && duk_double_equals(d2, 1.0) && duk_double_equals(d1, d2))) { + DUK__FAILED("double to duk_small_uint_t cast failed"); + } + + /* Same test with volatiles */ + + d1v = 1.0; + uv = (duk_small_uint_t) d1v; + d2v = (duk_double_t) uv; + + if (!(duk_double_equals(d1v, 1.0) && uv == 1 && duk_double_equals(d2v, 1.0) && duk_double_equals(d1v, d2v))) { + DUK__FAILED("double to duk_small_uint_t cast failed"); + } + + return error_count; +} + +DUK_LOCAL duk_uint_t duk__selftest_cast_double_to_uint32(void) { + /* + * This test fails on an exotic ARM target; double-to-uint + * cast is incorrectly clamped to -signed- int highest value. + * + * https://github.com/svaarala/duktape/issues/336 + */ + + duk_uint_t error_count = 0; + duk_double_t dv; + duk_uint32_t uv; + + dv = 3735928559.0; /* 0xdeadbeef in decimal */ + uv = (duk_uint32_t) dv; + + if (uv != 0xdeadbeefUL) { + DUK__FAILED("double to duk_uint32_t cast failed"); + } + + return error_count; +} + +/* + * Minimal test of user supplied allocation functions + * + * - Basic alloc + realloc + free cycle + * + * - Realloc to significantly larger size to (hopefully) trigger a + * relocation and check that relocation copying works + */ + +DUK_LOCAL duk_uint_t duk__selftest_alloc_funcs(duk_alloc_function alloc_func, + duk_realloc_function realloc_func, + duk_free_function free_func, + void *udata) { + duk_uint_t error_count = 0; + void *ptr; + void *new_ptr; + duk_small_int_t i, j; + unsigned char x; + + if (alloc_func == NULL || realloc_func == NULL || free_func == NULL) { + return 0; + } + + for (i = 1; i <= 256; i++) { + ptr = alloc_func(udata, (duk_size_t) i); + if (ptr == NULL) { + DUK_D(DUK_DPRINT("alloc failed, ignore")); + continue; /* alloc failed, ignore */ + } + for (j = 0; j < i; j++) { + ((unsigned char *) ptr)[j] = (unsigned char) (0x80 + j); + } + new_ptr = realloc_func(udata, ptr, 1024); + if (new_ptr == NULL) { + DUK_D(DUK_DPRINT("realloc failed, ignore")); + free_func(udata, ptr); + continue; /* realloc failed, ignore */ + } + ptr = new_ptr; + for (j = 0; j < i; j++) { + x = ((unsigned char *) ptr)[j]; + if (x != (unsigned char) (0x80 + j)) { + DUK_D(DUK_DPRINT("byte at index %ld doesn't match after realloc: %02lx", + (long) j, + (unsigned long) x)); + DUK__FAILED("byte compare after realloc"); + break; + } + } + free_func(udata, ptr); + } + + return error_count; +} + +/* + * Self test main + */ + +DUK_INTERNAL duk_uint_t duk_selftest_run_tests(duk_alloc_function alloc_func, + duk_realloc_function realloc_func, + duk_free_function free_func, + void *udata) { + duk_uint_t error_count = 0; + + DUK_D(DUK_DPRINT("self test starting")); + + error_count += duk__selftest_types(); + error_count += duk__selftest_packed_tval(); + error_count += duk__selftest_twos_complement(); + error_count += duk__selftest_byte_order(); + error_count += duk__selftest_bswap_macros(); + error_count += duk__selftest_double_union_size(); + error_count += duk__selftest_double_aliasing(); + error_count += duk__selftest_double_zero_sign(); + error_count += duk__selftest_double_rounding(); + error_count += duk__selftest_fmod(); + error_count += duk__selftest_struct_align(); + error_count += duk__selftest_64bit_arithmetic(); + error_count += duk__selftest_cast_double_to_small_uint(); + error_count += duk__selftest_cast_double_to_uint32(); + error_count += duk__selftest_alloc_funcs(alloc_func, realloc_func, free_func, udata); + + DUK_D(DUK_DPRINT("self test complete, total error count: %ld", (long) error_count)); + + return error_count; +} + +#endif /* DUK_USE_SELF_TESTS */ + +/* automatic undefs */ +#undef DUK__DBLUNION_CMP_FALSE +#undef DUK__DBLUNION_CMP_TRUE +#undef DUK__DOUBLE_COMPARE +#undef DUK__DOUBLE_INIT +#undef DUK__FAILED +#undef DUK__U32_INIT +/* #include duk_internal.h -> already included */ +#line 2 "duk_tval.c" + +#if defined(DUK_USE_FASTINT) + +/* + * Manually optimized double-to-fastint downgrade check. + * + * This check has a large impact on performance, especially for fastint + * slow paths, so must be changed carefully. The code should probably be + * optimized for the case where the result does not fit into a fastint, + * to minimize the penalty for "slow path code" dealing with fractions etc. + * + * At least on one tested soft float ARM platform double-to-int64 coercion + * is very slow (and sometimes produces incorrect results, see self tests). + * This algorithm combines a fastint compatibility check and extracting the + * integer value from an IEEE double for setting the tagged fastint. For + * other platforms a more naive approach might be better. + * + * See doc/fastint.rst for details. + */ + +DUK_INTERNAL DUK_ALWAYS_INLINE void duk_tval_set_number_chkfast_fast(duk_tval *tv, duk_double_t x) { + duk_double_union du; + duk_int64_t i; + duk_small_int_t expt; + duk_small_int_t shift; + + /* XXX: optimize for packed duk_tval directly? */ + + du.d = x; + i = (duk_int64_t) DUK_DBLUNION_GET_INT64(&du); + expt = (duk_small_int_t) ((i >> 52) & 0x07ff); + shift = expt - 1023; + + if (shift >= 0 && shift <= 46) { /* exponents 1023 to 1069 */ + duk_int64_t t; + + if (((DUK_I64_CONSTANT(0x000fffffffffffff) >> shift) & i) == 0) { + t = i | DUK_I64_CONSTANT(0x0010000000000000); /* implicit leading one */ + t = t & DUK_I64_CONSTANT(0x001fffffffffffff); + t = t >> (52 - shift); + if (i < 0) { + t = -t; + } + DUK_TVAL_SET_FASTINT(tv, t); + return; + } + } else if (shift == -1023) { /* exponent 0 */ + if (i >= 0 && (i & DUK_I64_CONSTANT(0x000fffffffffffff)) == 0) { + /* Note: reject negative zero. */ + DUK_TVAL_SET_FASTINT(tv, (duk_int64_t) 0); + return; + } + } else if (shift == 47) { /* exponent 1070 */ + if (i < 0 && (i & DUK_I64_CONSTANT(0x000fffffffffffff)) == 0) { + DUK_TVAL_SET_FASTINT(tv, (duk_int64_t) DUK_FASTINT_MIN); + return; + } + } + + DUK_TVAL_SET_DOUBLE(tv, x); + return; +} + +DUK_INTERNAL DUK_NOINLINE void duk_tval_set_number_chkfast_slow(duk_tval *tv, duk_double_t x) { + duk_tval_set_number_chkfast_fast(tv, x); +} + +/* + * Manually optimized number-to-double conversion + */ + +#if defined(DUK_USE_FASTINT) && defined(DUK_USE_PACKED_TVAL) +DUK_INTERNAL DUK_ALWAYS_INLINE duk_double_t duk_tval_get_number_packed(duk_tval *tv) { + duk_double_union du; + duk_uint64_t t; + + t = (duk_uint64_t) DUK_DBLUNION_GET_UINT64(tv); + if ((t >> 48) != DUK_TAG_FASTINT) { + return tv->d; + } else if (t & DUK_U64_CONSTANT(0x0000800000000000)) { + t = (duk_uint64_t) (-((duk_int64_t) t)); /* avoid unary minus on unsigned */ + t = t & DUK_U64_CONSTANT(0x0000ffffffffffff); /* negative */ + t |= DUK_U64_CONSTANT(0xc330000000000000); + DUK_DBLUNION_SET_UINT64(&du, t); + return du.d + 4503599627370496.0; /* 1 << 52 */ + } else if (t != 0) { + t &= DUK_U64_CONSTANT(0x0000ffffffffffff); /* positive */ + t |= DUK_U64_CONSTANT(0x4330000000000000); + DUK_DBLUNION_SET_UINT64(&du, t); + return du.d - 4503599627370496.0; /* 1 << 52 */ + } else { + return 0.0; /* zero */ + } +} +#endif /* DUK_USE_FASTINT && DUK_USE_PACKED_TVAL */ + +#if 0 /* unused */ +#if defined(DUK_USE_FASTINT) && !defined(DUK_USE_PACKED_TVAL) +DUK_INTERNAL DUK_ALWAYS_INLINE duk_double_t duk_tval_get_number_unpacked(duk_tval *tv) { + duk_double_union du; + duk_uint64_t t; + + DUK_ASSERT(tv->t == DUK_TAG_NUMBER || tv->t == DUK_TAG_FASTINT); + + if (tv->t == DUK_TAG_FASTINT) { + if (tv->v.fi >= 0) { + t = DUK_U64_CONSTANT(0x4330000000000000) | (duk_uint64_t) tv->v.fi; + DUK_DBLUNION_SET_UINT64(&du, t); + return du.d - 4503599627370496.0; /* 1 << 52 */ + } else { + t = DUK_U64_CONSTANT(0xc330000000000000) | (duk_uint64_t) (-tv->v.fi); + DUK_DBLUNION_SET_UINT64(&du, t); + return du.d + 4503599627370496.0; /* 1 << 52 */ + } + } else { + return tv->v.d; + } +} +#endif /* DUK_USE_FASTINT && DUK_USE_PACKED_TVAL */ +#endif /* 0 */ + +#if defined(DUK_USE_FASTINT) && !defined(DUK_USE_PACKED_TVAL) +DUK_INTERNAL DUK_ALWAYS_INLINE duk_double_t duk_tval_get_number_unpacked_fastint(duk_tval *tv) { + duk_double_union du; + duk_uint64_t t; + + DUK_ASSERT(tv->t == DUK_TAG_FASTINT); + + if (tv->v.fi >= 0) { + t = DUK_U64_CONSTANT(0x4330000000000000) | (duk_uint64_t) tv->v.fi; + DUK_DBLUNION_SET_UINT64(&du, t); + return du.d - 4503599627370496.0; /* 1 << 52 */ + } else { + t = DUK_U64_CONSTANT(0xc330000000000000) | (duk_uint64_t) (-tv->v.fi); + DUK_DBLUNION_SET_UINT64(&du, t); + return du.d + 4503599627370496.0; /* 1 << 52 */ + } +} +#endif /* DUK_USE_FASTINT && DUK_USE_PACKED_TVAL */ + +#endif /* DUK_USE_FASTINT */ + +/* + * Assertion helpers. + */ + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL void duk_tval_assert_valid(duk_tval *tv) { + DUK_ASSERT(tv != NULL); +} +#endif +#line 1 "duk_unicode_tables.c" +/* + * Unicode support tables automatically generated during build. + */ + +/* #include duk_internal.h -> already included */ + +/* + * Unicode tables containing ranges of Unicode characters in a + * packed format. These tables are used to match non-ASCII + * characters of complex productions by resorting to a linear + * range-by-range comparison. This is very slow, but is expected + * to be very rare in practical ECMAScript source code, and thus + * compactness is most important. + * + * The tables are matched using uni_range_match() and the format + * is described in tools/extract_chars.py. + */ + +#if defined(DUK_USE_SOURCE_NONBMP) +/* IdentifierStart production with ASCII excluded */ +/* duk_unicode_ids_noa[] */ +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +const duk_uint8_t duk_unicode_ids_noa[1116] = { +249,176,176,80,111,7,47,15,47,254,11,197,191,0,72,2,15,115,66,19,50,7,2,34, +2,240,66,244,50,247,185,249,98,241,99,7,241,159,57,240,181,63,31,241,191, +21,18,245,50,15,1,24,27,35,15,2,2,240,239,15,244,156,15,10,241,26,21,6,240, +101,10,4,15,9,240,152,175,39,240,82,127,56,242,100,15,4,8,159,1,240,5,115, +19,240,98,98,4,52,15,2,14,18,47,0,27,9,85,19,240,98,98,18,18,31,17,50,15,5, +47,2,130,34,240,98,98,18,68,15,4,15,1,31,9,12,115,19,240,98,98,18,68,15,16, +18,47,1,15,3,2,84,34,52,18,2,20,20,36,191,8,15,38,114,34,240,114,240,4,15, +12,38,31,16,5,114,34,240,114,146,68,15,18,2,31,1,31,4,114,34,241,147,15,2, +6,41,47,10,86,240,36,240,130,130,3,111,44,242,2,29,111,44,18,2,66,240,130, +2,146,26,3,66,15,7,63,18,15,49,114,241,79,13,79,101,241,191,6,15,2,85,52,4, +24,37,205,15,3,241,98,6,3,241,178,255,224,63,35,54,32,35,63,25,35,63,17,35, +54,32,35,62,47,41,35,63,51,241,127,0,240,47,70,53,79,254,21,227,240,18,240, +166,243,180,168,194,63,0,240,47,0,240,47,0,194,47,1,242,79,21,5,15,53,244, +152,67,241,34,6,243,107,240,255,35,240,227,76,241,197,240,175,40,240,122, +242,95,68,15,79,241,255,3,111,41,240,238,27,241,207,12,241,79,27,43,241,67, +136,241,179,47,27,50,82,20,6,251,15,50,255,224,8,53,63,22,53,55,32,32,32, +47,15,63,37,38,32,66,38,67,53,92,98,38,246,96,224,240,44,245,112,80,57,32, +68,112,32,32,35,42,51,100,80,240,63,25,255,233,107,241,242,241,242,247,87, +52,29,241,98,6,3,242,136,15,2,240,122,98,98,98,98,98,98,98,111,66,15,254, +12,146,240,184,132,52,95,70,114,47,74,35,111,27,47,78,240,63,11,242,127,0, +255,224,244,255,240,0,138,143,60,255,240,4,14,47,2,255,227,127,243,95,30, +63,253,79,0,177,240,111,31,240,47,15,63,64,241,152,63,87,63,37,52,242,42, +34,35,47,7,240,255,36,240,15,34,243,5,64,33,207,12,191,7,240,191,13,143,31, +240,224,240,36,41,180,47,25,240,146,39,240,111,7,64,79,34,32,65,52,48,32, +240,162,58,130,213,53,53,166,38,47,27,43,159,99,240,255,255,0,26,150,223,7, +95,33,255,240,0,255,143,254,6,3,245,175,24,109,70,2,146,194,66,2,18,18,245, +207,19,255,224,93,240,79,48,63,38,241,171,246,100,47,119,241,111,10,127,10, +207,73,69,53,53,50,241,91,47,10,47,3,33,46,61,241,79,107,243,127,37,255, +223,13,79,33,242,31,16,239,14,111,22,191,14,63,20,87,36,241,207,142,240,79, +20,95,20,95,24,159,36,248,239,254,2,154,240,107,127,138,83,2,241,194,20,3, +240,123,240,122,240,255,51,240,50,27,240,107,240,175,56,242,135,31,50,15,1, +50,34,240,223,28,240,212,240,223,21,114,240,207,13,242,107,240,107,240,62, +240,47,96,243,159,41,242,62,242,62,241,79,254,13,15,13,176,159,6,248,207,7, +223,37,243,223,29,241,47,9,240,207,20,240,240,207,19,64,223,32,240,3,240, +112,32,241,95,2,47,9,244,102,32,35,46,41,143,31,241,135,49,63,6,38,33,36, +64,240,64,212,249,15,37,240,67,240,96,241,47,32,240,97,32,250,175,31,241, +179,241,111,32,240,96,242,223,27,224,243,159,11,253,127,28,246,111,48,241, +16,249,39,63,23,240,32,32,240,224,191,24,128,240,112,207,30,240,80,241,79, +41,255,152,47,21,240,48,242,63,14,246,38,33,47,22,240,112,240,181,33,47,16, +240,0,255,224,59,240,63,254,0,31,254,40,207,88,245,255,3,251,79,254,155,15, +254,50,31,254,236,95,254,19,159,255,0,16,173,255,225,43,143,15,246,63,14, +240,79,32,240,35,241,31,5,111,3,255,225,164,243,15,114,243,182,15,52,207, +50,18,15,14,255,240,0,110,169,255,225,229,255,240,1,64,31,254,1,31,35,47,3, +57,255,224,126,255,231,248,245,182,196,136,159,255,0,6,90,244,82,243,114, +19,3,19,50,178,2,98,243,18,51,114,98,240,194,50,66,4,98,255,224,70,63,9,47, +9,47,15,47,9,47,15,47,9,47,15,47,9,47,15,47,9,39,255,232,40,241,219,111,2, +15,254,6,95,28,255,228,8,251,95,45,243,72,15,254,58,131,47,11,33,32,48,41, +35,32,32,112,80,32,32,34,33,32,48,32,32,32,32,33,32,51,38,35,35,32,41,47,1, +98,36,47,1,255,240,0,3,143,255,0,149,201,241,191,254,242,124,252,227,255, +240,0,87,79,0,255,240,0,194,63,254,177,63,254,17,0, +}; +#else +/* IdentifierStart production with ASCII and non-BMP excluded */ +/* duk_unicode_ids_noabmp[] */ +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +const duk_uint8_t duk_unicode_ids_noabmp[625] = { +249,176,176,80,111,7,47,15,47,254,11,197,191,0,72,2,15,115,66,19,50,7,2,34, +2,240,66,244,50,247,185,249,98,241,99,7,241,159,57,240,181,63,31,241,191, +21,18,245,50,15,1,24,27,35,15,2,2,240,239,15,244,156,15,10,241,26,21,6,240, +101,10,4,15,9,240,152,175,39,240,82,127,56,242,100,15,4,8,159,1,240,5,115, +19,240,98,98,4,52,15,2,14,18,47,0,27,9,85,19,240,98,98,18,18,31,17,50,15,5, +47,2,130,34,240,98,98,18,68,15,4,15,1,31,9,12,115,19,240,98,98,18,68,15,16, +18,47,1,15,3,2,84,34,52,18,2,20,20,36,191,8,15,38,114,34,240,114,240,4,15, +12,38,31,16,5,114,34,240,114,146,68,15,18,2,31,1,31,4,114,34,241,147,15,2, +6,41,47,10,86,240,36,240,130,130,3,111,44,242,2,29,111,44,18,2,66,240,130, +2,146,26,3,66,15,7,63,18,15,49,114,241,79,13,79,101,241,191,6,15,2,85,52,4, +24,37,205,15,3,241,98,6,3,241,178,255,224,63,35,54,32,35,63,25,35,63,17,35, +54,32,35,62,47,41,35,63,51,241,127,0,240,47,70,53,79,254,21,227,240,18,240, +166,243,180,168,194,63,0,240,47,0,240,47,0,194,47,1,242,79,21,5,15,53,244, +152,67,241,34,6,243,107,240,255,35,240,227,76,241,197,240,175,40,240,122, +242,95,68,15,79,241,255,3,111,41,240,238,27,241,207,12,241,79,27,43,241,67, +136,241,179,47,27,50,82,20,6,251,15,50,255,224,8,53,63,22,53,55,32,32,32, +47,15,63,37,38,32,66,38,67,53,92,98,38,246,96,224,240,44,245,112,80,57,32, +68,112,32,32,35,42,51,100,80,240,63,25,255,233,107,241,242,241,242,247,87, +52,29,241,98,6,3,242,136,15,2,240,122,98,98,98,98,98,98,98,111,66,15,254, +12,146,240,184,132,52,95,70,114,47,74,35,111,27,47,78,240,63,11,242,127,0, +255,224,244,255,240,0,138,143,60,255,240,4,14,47,2,255,227,127,243,95,30, +63,253,79,0,177,240,111,31,240,47,15,63,64,241,152,63,87,63,37,52,242,42, +34,35,47,7,240,255,36,240,15,34,243,5,64,33,207,12,191,7,240,191,13,143,31, +240,224,240,36,41,180,47,25,240,146,39,240,111,7,64,79,34,32,65,52,48,32, +240,162,58,130,213,53,53,166,38,47,27,43,159,99,240,255,255,0,26,150,223,7, +95,33,255,240,0,255,143,254,6,3,245,175,24,109,70,2,146,194,66,2,18,18,245, +207,19,255,224,93,240,79,48,63,38,241,171,246,100,47,119,241,111,10,127,10, +207,73,69,53,53,50,0, +}; +#endif + +#if defined(DUK_USE_SOURCE_NONBMP) +/* IdentifierStart production with Letter and ASCII excluded */ +/* duk_unicode_ids_m_let_noa[] */ +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +const duk_uint8_t duk_unicode_ids_m_let_noa[42] = { +255,240,0,94,18,255,233,99,241,51,63,254,215,32,240,184,240,2,255,240,6,89, +249,255,240,4,148,79,37,255,224,192,9,15,120,79,255,0,15,30,245,240, +}; +#else +/* IdentifierStart production with Letter, ASCII, and non-BMP excluded */ +/* duk_unicode_ids_m_let_noabmp[] */ +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +const duk_uint8_t duk_unicode_ids_m_let_noabmp[24] = { +255,240,0,94,18,255,233,99,241,51,63,254,215,32,240,184,240,2,255,240,6,89, +249,0, +}; +#endif + +#if defined(DUK_USE_SOURCE_NONBMP) +/* IdentifierPart production with IdentifierStart and ASCII excluded */ +/* duk_unicode_idp_m_ids_noa[] */ +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +const duk_uint8_t duk_unicode_idp_m_ids_noa[576] = { +255,225,243,246,15,254,0,116,255,191,29,32,33,33,32,243,170,242,47,15,112, +245,118,53,49,35,57,240,144,241,15,11,244,218,240,25,241,56,160,240,163,40, +34,36,241,210,246,158,47,17,242,130,47,2,38,177,57,240,50,242,160,38,49,50, +160,177,57,240,0,50,242,160,36,81,50,64,240,107,64,194,242,160,39,34,34, +240,97,57,181,34,242,160,38,49,50,145,177,57,240,64,242,212,66,35,160,240, +9,240,36,242,182,34,35,129,193,57,240,50,242,160,38,34,35,129,193,57,240, +35,242,145,38,34,35,160,177,57,240,65,243,128,85,32,39,121,49,242,240,54, +215,41,244,144,56,197,57,243,1,121,192,32,32,81,242,63,4,33,106,47,20,160, +245,111,4,41,211,82,34,54,67,235,46,255,225,179,47,254,42,98,240,242,240, +241,241,1,243,47,16,160,57,241,50,57,245,209,241,64,246,139,91,185,247,41, +242,244,242,185,47,13,58,121,240,141,243,68,242,31,1,201,240,56,210,241,12, +57,241,237,242,47,4,153,121,246,130,47,5,80,112,50,251,143,42,36,255,225,0, +31,35,31,5,15,109,197,4,191,254,175,34,247,240,245,47,16,255,225,30,95,91, +31,255,0,100,121,159,55,5,159,18,31,66,31,254,0,64,64,80,240,148,244,161, +242,79,2,185,127,2,234,240,231,240,188,241,227,242,29,240,25,192,185,242, +29,208,145,57,241,50,242,64,34,49,97,32,241,180,97,253,231,33,57,255,240,3, +225,128,255,225,213,240,15,2,240,4,31,10,47,178,159,23,15,254,27,16,253,64, +248,116,255,224,25,159,254,68,178,33,99,241,162,80,249,113,255,225,49,57, +159,254,16,10,250,18,242,126,241,25,240,19,241,250,242,121,114,241,109,41, +97,241,224,210,242,45,147,73,244,75,112,249,43,105,115,242,145,38,49,50, +160,177,54,68,251,47,2,169,80,244,63,4,217,252,118,56,240,209,244,79,1,240, +25,244,60,153,244,94,89,254,78,249,121,253,150,54,64,240,233,241,166,35, +144,170,242,15,0,255,224,137,114,127,2,159,42,240,98,223,108,84,2,18,98,9, +159,34,66,18,73,159,254,3,211,255,240,3,165,217,247,132,242,214,240,185, +255,226,233,2,242,120,63,255,0,59,254,31,255,0,3,186,68,89,115,111,16,63, +134,47,254,71,223,34,255,224,244,242,117,242,41,15,0,15,8,66,239,254,68,70, +47,1,54,33,36,255,118,169,255,224,150,223,254,76,166,245,246,105,255,240, +192,105,175,224,0, +}; +#else +/* IdentifierPart production with IdentifierStart, ASCII, and non-BMP excluded */ +/* duk_unicode_idp_m_ids_noabmp[] */ +/* + * Automatically generated by extract_chars.py, do not edit! + */ + +const duk_uint8_t duk_unicode_idp_m_ids_noabmp[358] = { +255,225,243,246,15,254,0,116,255,191,29,32,33,33,32,243,170,242,47,15,112, +245,118,53,49,35,57,240,144,241,15,11,244,218,240,25,241,56,160,240,163,40, +34,36,241,210,246,158,47,17,242,130,47,2,38,177,57,240,50,242,160,38,49,50, +160,177,57,240,0,50,242,160,36,81,50,64,240,107,64,194,242,160,39,34,34, +240,97,57,181,34,242,160,38,49,50,145,177,57,240,64,242,212,66,35,160,240, +9,240,36,242,182,34,35,129,193,57,240,50,242,160,38,34,35,129,193,57,240, +35,242,145,38,34,35,160,177,57,240,65,243,128,85,32,39,121,49,242,240,54, +215,41,244,144,56,197,57,243,1,121,192,32,32,81,242,63,4,33,106,47,20,160, +245,111,4,41,211,82,34,54,67,235,46,255,225,179,47,254,42,98,240,242,240, +241,241,1,243,47,16,160,57,241,50,57,245,209,241,64,246,139,91,185,247,41, +242,244,242,185,47,13,58,121,240,141,243,68,242,31,1,201,240,56,210,241,12, +57,241,237,242,47,4,153,121,246,130,47,5,80,112,50,251,143,42,36,255,225,0, +31,35,31,5,15,109,197,4,191,254,175,34,247,240,245,47,16,255,225,30,95,91, +31,255,0,100,121,159,55,5,159,18,31,66,31,254,0,64,64,80,240,148,244,161, +242,79,2,185,127,2,234,240,231,240,188,241,227,242,29,240,25,192,185,242, +29,208,145,57,241,50,242,64,34,49,97,32,241,180,97,253,231,33,57,255,240,3, +225,128,255,225,213,240,15,2,240,4,31,10,47,178,159,23,0, +}; +#endif + +/* + * Case conversion tables generated using tools/extract_caseconv.py. + */ + +/* duk_unicode_caseconv_uc[] */ +/* duk_unicode_caseconv_lc[] */ + +/* + * Automatically generated by extract_caseconv.py, do not edit! + */ + +const duk_uint8_t duk_unicode_caseconv_uc[1411] = { +152,3,128,3,0,184,7,192,6,192,112,35,242,199,224,64,74,192,49,32,128,162, +128,108,65,1,189,129,254,131,3,173,3,136,6,7,98,7,34,68,15,12,14,140,72,30, +104,28,112,32,67,0,65,4,0,138,0,128,4,1,88,65,76,83,8,104,14,72,43,16,253, +28,189,6,39,240,39,224,24,114,12,16,132,16,248,0,248,64,129,241,1,241,128, +195,228,3,229,2,7,204,7,206,4,15,160,15,164,6,31,96,31,104,16,62,224,63, +116,8,125,200,127,32,32,251,176,254,208,33,247,129,255,128,67,239,67,253, +64,135,223,7,254,129,15,216,15,220,2,31,208,31,216,4,63,192,63,208,8,133, +192,133,128,129,38,129,37,177,162,195,2,192,5,229,160,2,20,9,170,220,4,232, +40,127,160,255,144,154,136,4,4,4,0,192,9,152,9,144,48,19,160,19,145,0,41, +96,41,69,192,94,128,94,65,128,193,128,193,2,1,161,1,160,6,3,104,3,102,8,7, +56,7,52,64,14,248,14,240,144,31,144,31,130,128,68,96,68,66,64,145,192,145, +130,129,184,129,184,2,3,217,3,216,24,8,194,8,192,68,18,44,18,40,216,38,16, +38,8,112,77,16,77,6,3,192,35,192,18,199,168,71,168,24,15,168,143,172,132, +44,104,44,103,6,89,2,89,0,200,179,176,179,172,21,50,13,50,1,122,104,26,104, +1,212,228,116,228,65,233,204,233,204,143,211,189,83,188,130,167,127,167, +126,11,79,35,79,32,10,158,94,158,88,85,61,173,61,160,97,192,107,64,107,1,0, +226,128,226,3,1,198,1,196,6,3,228,3,226,8,10,0,6,152,16,31,192,31,184,34, +199,50,199,32,65,128,196,0,195,130,1,185,1,184,4,4,205,79,84,8,0,192,143,0, +142,193,1,52,128,203,2,45,39,16,199,5,253,0,11,80,57,192,15,240,23,128,19, +16,4,144,23,240,5,48,24,0,36,48,25,32,25,16,25,80,31,96,25,144,25,128,25, +160,35,208,25,224,34,0,26,128,26,112,27,240,31,112,29,208,24,224,31,48,31, +16,37,2,198,240,37,18,198,208,37,34,199,0,37,48,24,16,37,64,24,96,37,144, +24,240,37,176,25,0,37,202,122,176,38,0,25,48,38,26,122,192,38,48,25,64,38, +90,120,208,38,128,25,112,38,178,198,32,38,202,122,208,39,18,198,224,39,32, +25,208,39,80,25,240,39,210,198,64,40,42,124,80,40,122,123,16,40,128,26,224, +40,144,36,64,40,192,36,80,41,32,27,112,41,218,123,32,41,234,123,0,52,80,57, +144,55,112,55,96,58,192,56,96,60,32,58,48,60,192,56,192,61,0,57,32,61,16, +57,128,61,80,58,96,61,96,58,0,61,112,60,240,63,0,57,160,63,16,58,16,63,32, +63,144,63,48,55,240,63,80,57,80,76,240,76,1,200,0,65,33,200,16,65,65,200, +32,65,225,200,80,66,33,200,96,66,161,200,112,70,33,200,138,100,161,215,154, +119,209,215,210,198,49,216,234,124,97,233,177,230,1,251,224,57,145,254,81, +254,194,20,226,19,34,24,66,24,50,198,18,198,2,198,80,35,162,198,96,35,226, +207,50,207,42,120,202,120,186,121,74,124,74,124,58,124,42,181,58,123,60, +192,27,240,2,152,2,152,10,76,5,120,0,156,3,225,0,37,1,134,1,200,96,115,32, +97,0,96,32,118,24,29,40,24,64,24,8,44,60,10,106,10,164,61,45,0,36,1,152, +143,75,192,10,128,97,3,211,16,2,184,24,80,244,204,0,178,6,20,61,53,0,32, +129,95,15,168,64,116,160,98,99,234,88,29,40,24,152,24,0,250,166,7,74,6,38, +6,2,62,173,129,210,129,137,129,161,15,192,67,225,0,115,35,240,48,248,72,28, +200,252,20,62,20,7,50,63,7,15,133,129,204,143,194,67,225,128,115,35,240, +176,248,104,28,200,252,52,62,28,7,50,63,15,15,135,129,204,143,196,67,225,0, +115,35,241,48,248,72,28,200,252,84,62,20,7,50,63,23,15,133,129,204,143,198, +67,225,128,115,35,241,176,248,104,28,200,252,116,62,28,7,50,63,31,15,135, +129,204,143,200,67,229,0,115,35,242,48,249,72,28,200,252,148,62,84,7,50,63, +39,15,149,129,204,143,202,67,229,128,115,35,242,176,249,104,28,200,252,180, +62,92,7,50,63,47,15,151,129,204,143,204,67,229,0,115,35,243,48,249,72,28, +200,252,212,62,84,7,50,63,55,15,149,129,204,143,206,67,229,128,115,35,243, +176,249,104,28,200,252,244,62,92,7,50,63,63,15,151,129,204,143,208,67,237, +0,115,35,244,48,251,72,28,200,253,20,62,212,7,50,63,71,15,181,129,204,143, +210,67,237,128,115,35,244,176,251,104,28,200,253,52,62,220,7,50,63,79,15, +183,129,204,143,212,67,237,0,115,35,245,48,251,72,28,200,253,84,62,212,7, +50,63,87,15,181,129,204,143,214,67,237,128,115,35,245,176,251,104,28,200, +253,116,62,220,7,50,63,95,15,183,129,204,143,217,67,247,64,115,35,246,112, +28,136,28,200,253,164,7,12,7,50,63,109,1,200,129,161,15,219,224,114,32,104, +64,115,35,247,144,28,136,28,200,254,20,63,148,7,50,63,135,1,203,129,204, +143,226,64,113,32,115,35,248,208,28,184,26,16,254,62,7,46,6,132,7,50,63, +153,1,203,129,204,143,233,96,115,32,97,0,96,3,250,120,28,200,24,64,24,8, +254,180,7,50,6,132,63,175,129,204,129,132,1,161,15,241,96,116,160,97,0,96, +3,252,120,29,40,24,64,24,8,255,36,7,66,6,38,63,205,1,210,129,161,15,243, +224,116,160,97,0,104,67,254,80,255,208,28,200,255,156,7,82,7,50,63,233,1, +199,129,204,143,251,64,117,32,104,67,254,248,29,72,26,16,28,200,255,228,7, +82,7,51,246,1,0,35,0,35,125,128,192,8,192,9,63,96,80,2,48,2,103,216,30,0, +140,0,140,0,147,246,9,128,35,0,35,0,38,125,130,192,10,96,10,159,96,208,2, +152,2,167,216,156,10,136,10,141,246,41,2,162,2,154,253,138,192,168,128,167, +127,98,208,42,112,42,55,216,188,10,136,10,122, +}; +const duk_uint8_t duk_unicode_caseconv_lc[706] = { +160,3,0,3,128,184,6,192,7,192,112,24,144,37,96,64,54,32,81,64,128,226,0, +235,65,129,199,1,230,130,3,145,3,177,34,7,70,7,134,36,15,244,13,236,24,32, +0,34,129,0,65,0,67,4,0,166,32,172,41,132,40,11,64,19,9,208,85,184,80,19, +240,19,248,12,57,32,33,160,172,114,244,67,244,24,248,64,248,0,129,241,129, +241,0,195,229,3,228,2,7,206,7,204,4,15,164,15,160,6,31,104,31,96,16,63,16, +63,0,32,126,96,126,64,64,253,64,253,0,129,251,129,251,0,67,247,67,238,0, +135,242,7,220,130,15,236,15,232,2,31,218,31,118,4,63,208,63,192,8,127,168, +125,232,16,255,192,251,192,33,255,161,247,192,68,44,4,46,4,9,45,137,52,13, +22,0,22,24,47,44,126,2,63,5,254,67,254,130,106,48,16,0,16,19,0,38,64,38,96, +192,78,64,78,132,0,165,0,165,151,1,121,1,122,6,3,4,3,6,8,6,128,6,132,24,13, +152,13,160,32,28,176,28,193,32,59,192,59,226,64,124,128,124,193,0,252,0, +252,148,2,34,2,35,18,4,140,4,142,20,13,192,13,196,16,30,192,30,200,192,70, +0,70,18,32,145,64,145,102,193,48,65,48,131,130,104,2,104,176,30,0,30,1,150, +61,64,61,66,192,125,100,125,68,33,99,57,99,64,50,200,2,200,22,69,157,101, +157,128,169,144,41,144,75,211,64,83,64,142,167,34,167,35,15,78,101,78,102, +126,157,230,157,232,21,59,245,59,248,90,121,10,121,16,84,242,212,242,226, +169,237,41,237,67,12,3,76,5,0,8,6,176,6,180,16,14,32,14,48,48,28,80,28,96, +64,126,224,127,0,139,28,139,28,193,6,3,14,3,16,8,6,224,6,228,21,61,80,19, +48,32,3,1,150,2,105,4,4,118,4,120,8,67,28,180,156,23,240,192,94,0,63,192, +96,64,148,192,97,128,149,0,99,128,119,64,99,192,150,64,100,0,150,192,100, +64,100,128,100,192,152,0,101,0,152,192,101,192,154,0,102,0,102,64,103,64, +156,128,103,192,157,64,105,192,106,0,107,128,162,0,109,192,164,128,124,64, +124,192,125,128,101,64,125,192,111,192,136,0,103,128,142,139,25,64,143,64, +102,128,143,139,25,128,144,192,96,0,145,0,162,64,145,64,163,0,221,128,221, +192,223,192,252,192,225,128,235,0,227,0,243,0,243,192,245,192,253,0,238,0, +254,64,252,129,48,1,51,199,167,128,55,199,239,7,236,199,243,7,240,199,251, +7,249,71,255,7,252,200,73,128,242,72,74,128,26,200,74,192,57,72,76,136,83, +136,96,200,97,11,24,11,24,75,24,128,154,203,24,199,95,75,25,0,159,75,27,64, +148,75,27,128,156,75,27,192,148,11,28,0,148,139,60,139,60,233,223,71,94, +105,226,233,227,41,227,64,153,105,234,192,151,41,235,0,152,105,235,64,155, +41,236,0,167,169,236,64,161,233,236,128,167,105,236,234,212,233,240,169, +240,233,241,41,229,41,241,64,160,169,241,135,99,128,128,152,64,13,32,96, +224, +}; + +#if defined(DUK_USE_REGEXP_CANON_WORKAROUND) +/* + * Automatically generated by extract_caseconv.py, do not edit! + */ + +const duk_uint16_t duk_unicode_re_canon_lookup[65536] = { +0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27, +28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52, +53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77, +78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,65,66,67,68,69,70, +71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,123,124,125, +126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143, +144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161, +162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179, +180,924,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197, +198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215, +216,217,218,219,220,221,222,223,192,193,194,195,196,197,198,199,200,201, +202,203,204,205,206,207,208,209,210,211,212,213,214,247,216,217,218,219, +220,221,222,376,256,256,258,258,260,260,262,262,264,264,266,266,268,268, +270,270,272,272,274,274,276,276,278,278,280,280,282,282,284,284,286,286, +288,288,290,290,292,292,294,294,296,296,298,298,300,300,302,302,304,305, +306,306,308,308,310,310,312,313,313,315,315,317,317,319,319,321,321,323, +323,325,325,327,327,329,330,330,332,332,334,334,336,336,338,338,340,340, +342,342,344,344,346,346,348,348,350,350,352,352,354,354,356,356,358,358, +360,360,362,362,364,364,366,366,368,368,370,370,372,372,374,374,376,377, +377,379,379,381,381,383,579,385,386,386,388,388,390,391,391,393,394,395, +395,397,398,399,400,401,401,403,404,502,406,407,408,408,573,411,412,413, +544,415,416,416,418,418,420,420,422,423,423,425,426,427,428,428,430,431, +431,433,434,435,435,437,437,439,440,440,442,443,444,444,446,503,448,449, +450,451,452,452,452,455,455,455,458,458,458,461,461,463,463,465,465,467, +467,469,469,471,471,473,473,475,475,398,478,478,480,480,482,482,484,484, +486,486,488,488,490,490,492,492,494,494,496,497,497,497,500,500,502,503, +504,504,506,506,508,508,510,510,512,512,514,514,516,516,518,518,520,520, +522,522,524,524,526,526,528,528,530,530,532,532,534,534,536,536,538,538, +540,540,542,542,544,545,546,546,548,548,550,550,552,552,554,554,556,556, +558,558,560,560,562,562,564,565,566,567,568,569,570,571,571,573,574,11390, +11391,577,577,579,580,581,582,582,584,584,586,586,588,588,590,590,11375, +11373,11376,385,390,597,393,394,600,399,602,400,42923L,605,606,607,403, +42924L,610,404,612,42893L,42922L,615,407,406,42926L,11362,42925L,621,622, +412,624,11374,413,627,628,415,630,631,632,633,634,635,636,11364,638,639, +422,641,42949L,425,644,645,646,42929L,430,580,433,434,581,653,654,655,656, +657,439,659,660,661,662,663,664,665,666,667,668,42930L,42928L,671,672,673, +674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691, +692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709, +710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727, +728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745, +746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763, +764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781, +782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799, +800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817, +818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835, +836,921,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853, +854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871, +872,873,874,875,876,877,878,879,880,880,882,882,884,885,886,886,888,889, +890,1021,1022,1023,894,895,896,897,898,899,900,901,902,903,904,905,906,907, +908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925, +926,927,928,929,930,931,932,933,934,935,936,937,938,939,902,904,905,906, +944,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929, +931,931,932,933,934,935,936,937,938,939,908,910,911,975,914,920,978,979, +980,934,928,975,984,984,986,986,988,988,990,990,992,992,994,994,996,996, +998,998,1000,1000,1002,1002,1004,1004,1006,1006,922,929,1017,895,1012,917, +1014,1015,1015,1017,1018,1018,1020,1021,1022,1023,1024,1025,1026,1027,1028, +1029,1030,1031,1032,1033,1034,1035,1036,1037,1038,1039,1040,1041,1042,1043, +1044,1045,1046,1047,1048,1049,1050,1051,1052,1053,1054,1055,1056,1057,1058, +1059,1060,1061,1062,1063,1064,1065,1066,1067,1068,1069,1070,1071,1040,1041, +1042,1043,1044,1045,1046,1047,1048,1049,1050,1051,1052,1053,1054,1055,1056, +1057,1058,1059,1060,1061,1062,1063,1064,1065,1066,1067,1068,1069,1070,1071, +1024,1025,1026,1027,1028,1029,1030,1031,1032,1033,1034,1035,1036,1037,1038, +1039,1120,1120,1122,1122,1124,1124,1126,1126,1128,1128,1130,1130,1132,1132, +1134,1134,1136,1136,1138,1138,1140,1140,1142,1142,1144,1144,1146,1146,1148, +1148,1150,1150,1152,1152,1154,1155,1156,1157,1158,1159,1160,1161,1162,1162, +1164,1164,1166,1166,1168,1168,1170,1170,1172,1172,1174,1174,1176,1176,1178, +1178,1180,1180,1182,1182,1184,1184,1186,1186,1188,1188,1190,1190,1192,1192, +1194,1194,1196,1196,1198,1198,1200,1200,1202,1202,1204,1204,1206,1206,1208, +1208,1210,1210,1212,1212,1214,1214,1216,1217,1217,1219,1219,1221,1221,1223, +1223,1225,1225,1227,1227,1229,1229,1216,1232,1232,1234,1234,1236,1236,1238, +1238,1240,1240,1242,1242,1244,1244,1246,1246,1248,1248,1250,1250,1252,1252, +1254,1254,1256,1256,1258,1258,1260,1260,1262,1262,1264,1264,1266,1266,1268, +1268,1270,1270,1272,1272,1274,1274,1276,1276,1278,1278,1280,1280,1282,1282, +1284,1284,1286,1286,1288,1288,1290,1290,1292,1292,1294,1294,1296,1296,1298, +1298,1300,1300,1302,1302,1304,1304,1306,1306,1308,1308,1310,1310,1312,1312, +1314,1314,1316,1316,1318,1318,1320,1320,1322,1322,1324,1324,1326,1326,1328, +1329,1330,1331,1332,1333,1334,1335,1336,1337,1338,1339,1340,1341,1342,1343, +1344,1345,1346,1347,1348,1349,1350,1351,1352,1353,1354,1355,1356,1357,1358, +1359,1360,1361,1362,1363,1364,1365,1366,1367,1368,1369,1370,1371,1372,1373, +1374,1375,1376,1329,1330,1331,1332,1333,1334,1335,1336,1337,1338,1339,1340, +1341,1342,1343,1344,1345,1346,1347,1348,1349,1350,1351,1352,1353,1354,1355, +1356,1357,1358,1359,1360,1361,1362,1363,1364,1365,1366,1415,1416,1417,1418, +1419,1420,1421,1422,1423,1424,1425,1426,1427,1428,1429,1430,1431,1432,1433, +1434,1435,1436,1437,1438,1439,1440,1441,1442,1443,1444,1445,1446,1447,1448, +1449,1450,1451,1452,1453,1454,1455,1456,1457,1458,1459,1460,1461,1462,1463, +1464,1465,1466,1467,1468,1469,1470,1471,1472,1473,1474,1475,1476,1477,1478, +1479,1480,1481,1482,1483,1484,1485,1486,1487,1488,1489,1490,1491,1492,1493, +1494,1495,1496,1497,1498,1499,1500,1501,1502,1503,1504,1505,1506,1507,1508, +1509,1510,1511,1512,1513,1514,1515,1516,1517,1518,1519,1520,1521,1522,1523, +1524,1525,1526,1527,1528,1529,1530,1531,1532,1533,1534,1535,1536,1537,1538, +1539,1540,1541,1542,1543,1544,1545,1546,1547,1548,1549,1550,1551,1552,1553, +1554,1555,1556,1557,1558,1559,1560,1561,1562,1563,1564,1565,1566,1567,1568, +1569,1570,1571,1572,1573,1574,1575,1576,1577,1578,1579,1580,1581,1582,1583, +1584,1585,1586,1587,1588,1589,1590,1591,1592,1593,1594,1595,1596,1597,1598, +1599,1600,1601,1602,1603,1604,1605,1606,1607,1608,1609,1610,1611,1612,1613, +1614,1615,1616,1617,1618,1619,1620,1621,1622,1623,1624,1625,1626,1627,1628, +1629,1630,1631,1632,1633,1634,1635,1636,1637,1638,1639,1640,1641,1642,1643, +1644,1645,1646,1647,1648,1649,1650,1651,1652,1653,1654,1655,1656,1657,1658, +1659,1660,1661,1662,1663,1664,1665,1666,1667,1668,1669,1670,1671,1672,1673, +1674,1675,1676,1677,1678,1679,1680,1681,1682,1683,1684,1685,1686,1687,1688, +1689,1690,1691,1692,1693,1694,1695,1696,1697,1698,1699,1700,1701,1702,1703, +1704,1705,1706,1707,1708,1709,1710,1711,1712,1713,1714,1715,1716,1717,1718, +1719,1720,1721,1722,1723,1724,1725,1726,1727,1728,1729,1730,1731,1732,1733, +1734,1735,1736,1737,1738,1739,1740,1741,1742,1743,1744,1745,1746,1747,1748, +1749,1750,1751,1752,1753,1754,1755,1756,1757,1758,1759,1760,1761,1762,1763, +1764,1765,1766,1767,1768,1769,1770,1771,1772,1773,1774,1775,1776,1777,1778, +1779,1780,1781,1782,1783,1784,1785,1786,1787,1788,1789,1790,1791,1792,1793, +1794,1795,1796,1797,1798,1799,1800,1801,1802,1803,1804,1805,1806,1807,1808, +1809,1810,1811,1812,1813,1814,1815,1816,1817,1818,1819,1820,1821,1822,1823, +1824,1825,1826,1827,1828,1829,1830,1831,1832,1833,1834,1835,1836,1837,1838, +1839,1840,1841,1842,1843,1844,1845,1846,1847,1848,1849,1850,1851,1852,1853, +1854,1855,1856,1857,1858,1859,1860,1861,1862,1863,1864,1865,1866,1867,1868, +1869,1870,1871,1872,1873,1874,1875,1876,1877,1878,1879,1880,1881,1882,1883, +1884,1885,1886,1887,1888,1889,1890,1891,1892,1893,1894,1895,1896,1897,1898, +1899,1900,1901,1902,1903,1904,1905,1906,1907,1908,1909,1910,1911,1912,1913, +1914,1915,1916,1917,1918,1919,1920,1921,1922,1923,1924,1925,1926,1927,1928, +1929,1930,1931,1932,1933,1934,1935,1936,1937,1938,1939,1940,1941,1942,1943, +1944,1945,1946,1947,1948,1949,1950,1951,1952,1953,1954,1955,1956,1957,1958, +1959,1960,1961,1962,1963,1964,1965,1966,1967,1968,1969,1970,1971,1972,1973, +1974,1975,1976,1977,1978,1979,1980,1981,1982,1983,1984,1985,1986,1987,1988, +1989,1990,1991,1992,1993,1994,1995,1996,1997,1998,1999,2000,2001,2002,2003, +2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014,2015,2016,2017,2018, +2019,2020,2021,2022,2023,2024,2025,2026,2027,2028,2029,2030,2031,2032,2033, +2034,2035,2036,2037,2038,2039,2040,2041,2042,2043,2044,2045,2046,2047,2048, +2049,2050,2051,2052,2053,2054,2055,2056,2057,2058,2059,2060,2061,2062,2063, +2064,2065,2066,2067,2068,2069,2070,2071,2072,2073,2074,2075,2076,2077,2078, +2079,2080,2081,2082,2083,2084,2085,2086,2087,2088,2089,2090,2091,2092,2093, +2094,2095,2096,2097,2098,2099,2100,2101,2102,2103,2104,2105,2106,2107,2108, +2109,2110,2111,2112,2113,2114,2115,2116,2117,2118,2119,2120,2121,2122,2123, +2124,2125,2126,2127,2128,2129,2130,2131,2132,2133,2134,2135,2136,2137,2138, +2139,2140,2141,2142,2143,2144,2145,2146,2147,2148,2149,2150,2151,2152,2153, +2154,2155,2156,2157,2158,2159,2160,2161,2162,2163,2164,2165,2166,2167,2168, +2169,2170,2171,2172,2173,2174,2175,2176,2177,2178,2179,2180,2181,2182,2183, +2184,2185,2186,2187,2188,2189,2190,2191,2192,2193,2194,2195,2196,2197,2198, +2199,2200,2201,2202,2203,2204,2205,2206,2207,2208,2209,2210,2211,2212,2213, +2214,2215,2216,2217,2218,2219,2220,2221,2222,2223,2224,2225,2226,2227,2228, +2229,2230,2231,2232,2233,2234,2235,2236,2237,2238,2239,2240,2241,2242,2243, +2244,2245,2246,2247,2248,2249,2250,2251,2252,2253,2254,2255,2256,2257,2258, +2259,2260,2261,2262,2263,2264,2265,2266,2267,2268,2269,2270,2271,2272,2273, +2274,2275,2276,2277,2278,2279,2280,2281,2282,2283,2284,2285,2286,2287,2288, +2289,2290,2291,2292,2293,2294,2295,2296,2297,2298,2299,2300,2301,2302,2303, +2304,2305,2306,2307,2308,2309,2310,2311,2312,2313,2314,2315,2316,2317,2318, +2319,2320,2321,2322,2323,2324,2325,2326,2327,2328,2329,2330,2331,2332,2333, +2334,2335,2336,2337,2338,2339,2340,2341,2342,2343,2344,2345,2346,2347,2348, +2349,2350,2351,2352,2353,2354,2355,2356,2357,2358,2359,2360,2361,2362,2363, +2364,2365,2366,2367,2368,2369,2370,2371,2372,2373,2374,2375,2376,2377,2378, +2379,2380,2381,2382,2383,2384,2385,2386,2387,2388,2389,2390,2391,2392,2393, +2394,2395,2396,2397,2398,2399,2400,2401,2402,2403,2404,2405,2406,2407,2408, +2409,2410,2411,2412,2413,2414,2415,2416,2417,2418,2419,2420,2421,2422,2423, +2424,2425,2426,2427,2428,2429,2430,2431,2432,2433,2434,2435,2436,2437,2438, +2439,2440,2441,2442,2443,2444,2445,2446,2447,2448,2449,2450,2451,2452,2453, +2454,2455,2456,2457,2458,2459,2460,2461,2462,2463,2464,2465,2466,2467,2468, +2469,2470,2471,2472,2473,2474,2475,2476,2477,2478,2479,2480,2481,2482,2483, +2484,2485,2486,2487,2488,2489,2490,2491,2492,2493,2494,2495,2496,2497,2498, +2499,2500,2501,2502,2503,2504,2505,2506,2507,2508,2509,2510,2511,2512,2513, +2514,2515,2516,2517,2518,2519,2520,2521,2522,2523,2524,2525,2526,2527,2528, +2529,2530,2531,2532,2533,2534,2535,2536,2537,2538,2539,2540,2541,2542,2543, +2544,2545,2546,2547,2548,2549,2550,2551,2552,2553,2554,2555,2556,2557,2558, +2559,2560,2561,2562,2563,2564,2565,2566,2567,2568,2569,2570,2571,2572,2573, +2574,2575,2576,2577,2578,2579,2580,2581,2582,2583,2584,2585,2586,2587,2588, +2589,2590,2591,2592,2593,2594,2595,2596,2597,2598,2599,2600,2601,2602,2603, +2604,2605,2606,2607,2608,2609,2610,2611,2612,2613,2614,2615,2616,2617,2618, +2619,2620,2621,2622,2623,2624,2625,2626,2627,2628,2629,2630,2631,2632,2633, +2634,2635,2636,2637,2638,2639,2640,2641,2642,2643,2644,2645,2646,2647,2648, +2649,2650,2651,2652,2653,2654,2655,2656,2657,2658,2659,2660,2661,2662,2663, +2664,2665,2666,2667,2668,2669,2670,2671,2672,2673,2674,2675,2676,2677,2678, +2679,2680,2681,2682,2683,2684,2685,2686,2687,2688,2689,2690,2691,2692,2693, +2694,2695,2696,2697,2698,2699,2700,2701,2702,2703,2704,2705,2706,2707,2708, +2709,2710,2711,2712,2713,2714,2715,2716,2717,2718,2719,2720,2721,2722,2723, +2724,2725,2726,2727,2728,2729,2730,2731,2732,2733,2734,2735,2736,2737,2738, +2739,2740,2741,2742,2743,2744,2745,2746,2747,2748,2749,2750,2751,2752,2753, +2754,2755,2756,2757,2758,2759,2760,2761,2762,2763,2764,2765,2766,2767,2768, +2769,2770,2771,2772,2773,2774,2775,2776,2777,2778,2779,2780,2781,2782,2783, +2784,2785,2786,2787,2788,2789,2790,2791,2792,2793,2794,2795,2796,2797,2798, +2799,2800,2801,2802,2803,2804,2805,2806,2807,2808,2809,2810,2811,2812,2813, +2814,2815,2816,2817,2818,2819,2820,2821,2822,2823,2824,2825,2826,2827,2828, +2829,2830,2831,2832,2833,2834,2835,2836,2837,2838,2839,2840,2841,2842,2843, +2844,2845,2846,2847,2848,2849,2850,2851,2852,2853,2854,2855,2856,2857,2858, +2859,2860,2861,2862,2863,2864,2865,2866,2867,2868,2869,2870,2871,2872,2873, +2874,2875,2876,2877,2878,2879,2880,2881,2882,2883,2884,2885,2886,2887,2888, +2889,2890,2891,2892,2893,2894,2895,2896,2897,2898,2899,2900,2901,2902,2903, +2904,2905,2906,2907,2908,2909,2910,2911,2912,2913,2914,2915,2916,2917,2918, +2919,2920,2921,2922,2923,2924,2925,2926,2927,2928,2929,2930,2931,2932,2933, +2934,2935,2936,2937,2938,2939,2940,2941,2942,2943,2944,2945,2946,2947,2948, +2949,2950,2951,2952,2953,2954,2955,2956,2957,2958,2959,2960,2961,2962,2963, +2964,2965,2966,2967,2968,2969,2970,2971,2972,2973,2974,2975,2976,2977,2978, +2979,2980,2981,2982,2983,2984,2985,2986,2987,2988,2989,2990,2991,2992,2993, +2994,2995,2996,2997,2998,2999,3000,3001,3002,3003,3004,3005,3006,3007,3008, +3009,3010,3011,3012,3013,3014,3015,3016,3017,3018,3019,3020,3021,3022,3023, +3024,3025,3026,3027,3028,3029,3030,3031,3032,3033,3034,3035,3036,3037,3038, +3039,3040,3041,3042,3043,3044,3045,3046,3047,3048,3049,3050,3051,3052,3053, +3054,3055,3056,3057,3058,3059,3060,3061,3062,3063,3064,3065,3066,3067,3068, +3069,3070,3071,3072,3073,3074,3075,3076,3077,3078,3079,3080,3081,3082,3083, +3084,3085,3086,3087,3088,3089,3090,3091,3092,3093,3094,3095,3096,3097,3098, +3099,3100,3101,3102,3103,3104,3105,3106,3107,3108,3109,3110,3111,3112,3113, +3114,3115,3116,3117,3118,3119,3120,3121,3122,3123,3124,3125,3126,3127,3128, +3129,3130,3131,3132,3133,3134,3135,3136,3137,3138,3139,3140,3141,3142,3143, +3144,3145,3146,3147,3148,3149,3150,3151,3152,3153,3154,3155,3156,3157,3158, +3159,3160,3161,3162,3163,3164,3165,3166,3167,3168,3169,3170,3171,3172,3173, +3174,3175,3176,3177,3178,3179,3180,3181,3182,3183,3184,3185,3186,3187,3188, +3189,3190,3191,3192,3193,3194,3195,3196,3197,3198,3199,3200,3201,3202,3203, +3204,3205,3206,3207,3208,3209,3210,3211,3212,3213,3214,3215,3216,3217,3218, +3219,3220,3221,3222,3223,3224,3225,3226,3227,3228,3229,3230,3231,3232,3233, +3234,3235,3236,3237,3238,3239,3240,3241,3242,3243,3244,3245,3246,3247,3248, +3249,3250,3251,3252,3253,3254,3255,3256,3257,3258,3259,3260,3261,3262,3263, +3264,3265,3266,3267,3268,3269,3270,3271,3272,3273,3274,3275,3276,3277,3278, +3279,3280,3281,3282,3283,3284,3285,3286,3287,3288,3289,3290,3291,3292,3293, +3294,3295,3296,3297,3298,3299,3300,3301,3302,3303,3304,3305,3306,3307,3308, +3309,3310,3311,3312,3313,3314,3315,3316,3317,3318,3319,3320,3321,3322,3323, +3324,3325,3326,3327,3328,3329,3330,3331,3332,3333,3334,3335,3336,3337,3338, +3339,3340,3341,3342,3343,3344,3345,3346,3347,3348,3349,3350,3351,3352,3353, +3354,3355,3356,3357,3358,3359,3360,3361,3362,3363,3364,3365,3366,3367,3368, +3369,3370,3371,3372,3373,3374,3375,3376,3377,3378,3379,3380,3381,3382,3383, +3384,3385,3386,3387,3388,3389,3390,3391,3392,3393,3394,3395,3396,3397,3398, +3399,3400,3401,3402,3403,3404,3405,3406,3407,3408,3409,3410,3411,3412,3413, +3414,3415,3416,3417,3418,3419,3420,3421,3422,3423,3424,3425,3426,3427,3428, +3429,3430,3431,3432,3433,3434,3435,3436,3437,3438,3439,3440,3441,3442,3443, +3444,3445,3446,3447,3448,3449,3450,3451,3452,3453,3454,3455,3456,3457,3458, +3459,3460,3461,3462,3463,3464,3465,3466,3467,3468,3469,3470,3471,3472,3473, +3474,3475,3476,3477,3478,3479,3480,3481,3482,3483,3484,3485,3486,3487,3488, +3489,3490,3491,3492,3493,3494,3495,3496,3497,3498,3499,3500,3501,3502,3503, +3504,3505,3506,3507,3508,3509,3510,3511,3512,3513,3514,3515,3516,3517,3518, +3519,3520,3521,3522,3523,3524,3525,3526,3527,3528,3529,3530,3531,3532,3533, +3534,3535,3536,3537,3538,3539,3540,3541,3542,3543,3544,3545,3546,3547,3548, +3549,3550,3551,3552,3553,3554,3555,3556,3557,3558,3559,3560,3561,3562,3563, +3564,3565,3566,3567,3568,3569,3570,3571,3572,3573,3574,3575,3576,3577,3578, +3579,3580,3581,3582,3583,3584,3585,3586,3587,3588,3589,3590,3591,3592,3593, +3594,3595,3596,3597,3598,3599,3600,3601,3602,3603,3604,3605,3606,3607,3608, +3609,3610,3611,3612,3613,3614,3615,3616,3617,3618,3619,3620,3621,3622,3623, +3624,3625,3626,3627,3628,3629,3630,3631,3632,3633,3634,3635,3636,3637,3638, +3639,3640,3641,3642,3643,3644,3645,3646,3647,3648,3649,3650,3651,3652,3653, +3654,3655,3656,3657,3658,3659,3660,3661,3662,3663,3664,3665,3666,3667,3668, +3669,3670,3671,3672,3673,3674,3675,3676,3677,3678,3679,3680,3681,3682,3683, +3684,3685,3686,3687,3688,3689,3690,3691,3692,3693,3694,3695,3696,3697,3698, +3699,3700,3701,3702,3703,3704,3705,3706,3707,3708,3709,3710,3711,3712,3713, +3714,3715,3716,3717,3718,3719,3720,3721,3722,3723,3724,3725,3726,3727,3728, +3729,3730,3731,3732,3733,3734,3735,3736,3737,3738,3739,3740,3741,3742,3743, +3744,3745,3746,3747,3748,3749,3750,3751,3752,3753,3754,3755,3756,3757,3758, +3759,3760,3761,3762,3763,3764,3765,3766,3767,3768,3769,3770,3771,3772,3773, +3774,3775,3776,3777,3778,3779,3780,3781,3782,3783,3784,3785,3786,3787,3788, +3789,3790,3791,3792,3793,3794,3795,3796,3797,3798,3799,3800,3801,3802,3803, +3804,3805,3806,3807,3808,3809,3810,3811,3812,3813,3814,3815,3816,3817,3818, +3819,3820,3821,3822,3823,3824,3825,3826,3827,3828,3829,3830,3831,3832,3833, +3834,3835,3836,3837,3838,3839,3840,3841,3842,3843,3844,3845,3846,3847,3848, +3849,3850,3851,3852,3853,3854,3855,3856,3857,3858,3859,3860,3861,3862,3863, +3864,3865,3866,3867,3868,3869,3870,3871,3872,3873,3874,3875,3876,3877,3878, +3879,3880,3881,3882,3883,3884,3885,3886,3887,3888,3889,3890,3891,3892,3893, +3894,3895,3896,3897,3898,3899,3900,3901,3902,3903,3904,3905,3906,3907,3908, +3909,3910,3911,3912,3913,3914,3915,3916,3917,3918,3919,3920,3921,3922,3923, +3924,3925,3926,3927,3928,3929,3930,3931,3932,3933,3934,3935,3936,3937,3938, +3939,3940,3941,3942,3943,3944,3945,3946,3947,3948,3949,3950,3951,3952,3953, +3954,3955,3956,3957,3958,3959,3960,3961,3962,3963,3964,3965,3966,3967,3968, +3969,3970,3971,3972,3973,3974,3975,3976,3977,3978,3979,3980,3981,3982,3983, +3984,3985,3986,3987,3988,3989,3990,3991,3992,3993,3994,3995,3996,3997,3998, +3999,4000,4001,4002,4003,4004,4005,4006,4007,4008,4009,4010,4011,4012,4013, +4014,4015,4016,4017,4018,4019,4020,4021,4022,4023,4024,4025,4026,4027,4028, +4029,4030,4031,4032,4033,4034,4035,4036,4037,4038,4039,4040,4041,4042,4043, +4044,4045,4046,4047,4048,4049,4050,4051,4052,4053,4054,4055,4056,4057,4058, +4059,4060,4061,4062,4063,4064,4065,4066,4067,4068,4069,4070,4071,4072,4073, +4074,4075,4076,4077,4078,4079,4080,4081,4082,4083,4084,4085,4086,4087,4088, +4089,4090,4091,4092,4093,4094,4095,4096,4097,4098,4099,4100,4101,4102,4103, +4104,4105,4106,4107,4108,4109,4110,4111,4112,4113,4114,4115,4116,4117,4118, +4119,4120,4121,4122,4123,4124,4125,4126,4127,4128,4129,4130,4131,4132,4133, +4134,4135,4136,4137,4138,4139,4140,4141,4142,4143,4144,4145,4146,4147,4148, +4149,4150,4151,4152,4153,4154,4155,4156,4157,4158,4159,4160,4161,4162,4163, +4164,4165,4166,4167,4168,4169,4170,4171,4172,4173,4174,4175,4176,4177,4178, +4179,4180,4181,4182,4183,4184,4185,4186,4187,4188,4189,4190,4191,4192,4193, +4194,4195,4196,4197,4198,4199,4200,4201,4202,4203,4204,4205,4206,4207,4208, +4209,4210,4211,4212,4213,4214,4215,4216,4217,4218,4219,4220,4221,4222,4223, +4224,4225,4226,4227,4228,4229,4230,4231,4232,4233,4234,4235,4236,4237,4238, +4239,4240,4241,4242,4243,4244,4245,4246,4247,4248,4249,4250,4251,4252,4253, +4254,4255,4256,4257,4258,4259,4260,4261,4262,4263,4264,4265,4266,4267,4268, +4269,4270,4271,4272,4273,4274,4275,4276,4277,4278,4279,4280,4281,4282,4283, +4284,4285,4286,4287,4288,4289,4290,4291,4292,4293,4294,4295,4296,4297,4298, +4299,4300,4301,4302,4303,7312,7313,7314,7315,7316,7317,7318,7319,7320,7321, +7322,7323,7324,7325,7326,7327,7328,7329,7330,7331,7332,7333,7334,7335,7336, +7337,7338,7339,7340,7341,7342,7343,7344,7345,7346,7347,7348,7349,7350,7351, +7352,7353,7354,4347,4348,7357,7358,7359,4352,4353,4354,4355,4356,4357,4358, +4359,4360,4361,4362,4363,4364,4365,4366,4367,4368,4369,4370,4371,4372,4373, +4374,4375,4376,4377,4378,4379,4380,4381,4382,4383,4384,4385,4386,4387,4388, +4389,4390,4391,4392,4393,4394,4395,4396,4397,4398,4399,4400,4401,4402,4403, +4404,4405,4406,4407,4408,4409,4410,4411,4412,4413,4414,4415,4416,4417,4418, +4419,4420,4421,4422,4423,4424,4425,4426,4427,4428,4429,4430,4431,4432,4433, +4434,4435,4436,4437,4438,4439,4440,4441,4442,4443,4444,4445,4446,4447,4448, +4449,4450,4451,4452,4453,4454,4455,4456,4457,4458,4459,4460,4461,4462,4463, +4464,4465,4466,4467,4468,4469,4470,4471,4472,4473,4474,4475,4476,4477,4478, +4479,4480,4481,4482,4483,4484,4485,4486,4487,4488,4489,4490,4491,4492,4493, +4494,4495,4496,4497,4498,4499,4500,4501,4502,4503,4504,4505,4506,4507,4508, +4509,4510,4511,4512,4513,4514,4515,4516,4517,4518,4519,4520,4521,4522,4523, +4524,4525,4526,4527,4528,4529,4530,4531,4532,4533,4534,4535,4536,4537,4538, +4539,4540,4541,4542,4543,4544,4545,4546,4547,4548,4549,4550,4551,4552,4553, +4554,4555,4556,4557,4558,4559,4560,4561,4562,4563,4564,4565,4566,4567,4568, +4569,4570,4571,4572,4573,4574,4575,4576,4577,4578,4579,4580,4581,4582,4583, +4584,4585,4586,4587,4588,4589,4590,4591,4592,4593,4594,4595,4596,4597,4598, +4599,4600,4601,4602,4603,4604,4605,4606,4607,4608,4609,4610,4611,4612,4613, +4614,4615,4616,4617,4618,4619,4620,4621,4622,4623,4624,4625,4626,4627,4628, +4629,4630,4631,4632,4633,4634,4635,4636,4637,4638,4639,4640,4641,4642,4643, +4644,4645,4646,4647,4648,4649,4650,4651,4652,4653,4654,4655,4656,4657,4658, +4659,4660,4661,4662,4663,4664,4665,4666,4667,4668,4669,4670,4671,4672,4673, +4674,4675,4676,4677,4678,4679,4680,4681,4682,4683,4684,4685,4686,4687,4688, +4689,4690,4691,4692,4693,4694,4695,4696,4697,4698,4699,4700,4701,4702,4703, +4704,4705,4706,4707,4708,4709,4710,4711,4712,4713,4714,4715,4716,4717,4718, +4719,4720,4721,4722,4723,4724,4725,4726,4727,4728,4729,4730,4731,4732,4733, +4734,4735,4736,4737,4738,4739,4740,4741,4742,4743,4744,4745,4746,4747,4748, +4749,4750,4751,4752,4753,4754,4755,4756,4757,4758,4759,4760,4761,4762,4763, +4764,4765,4766,4767,4768,4769,4770,4771,4772,4773,4774,4775,4776,4777,4778, +4779,4780,4781,4782,4783,4784,4785,4786,4787,4788,4789,4790,4791,4792,4793, +4794,4795,4796,4797,4798,4799,4800,4801,4802,4803,4804,4805,4806,4807,4808, +4809,4810,4811,4812,4813,4814,4815,4816,4817,4818,4819,4820,4821,4822,4823, +4824,4825,4826,4827,4828,4829,4830,4831,4832,4833,4834,4835,4836,4837,4838, +4839,4840,4841,4842,4843,4844,4845,4846,4847,4848,4849,4850,4851,4852,4853, +4854,4855,4856,4857,4858,4859,4860,4861,4862,4863,4864,4865,4866,4867,4868, +4869,4870,4871,4872,4873,4874,4875,4876,4877,4878,4879,4880,4881,4882,4883, +4884,4885,4886,4887,4888,4889,4890,4891,4892,4893,4894,4895,4896,4897,4898, +4899,4900,4901,4902,4903,4904,4905,4906,4907,4908,4909,4910,4911,4912,4913, +4914,4915,4916,4917,4918,4919,4920,4921,4922,4923,4924,4925,4926,4927,4928, +4929,4930,4931,4932,4933,4934,4935,4936,4937,4938,4939,4940,4941,4942,4943, +4944,4945,4946,4947,4948,4949,4950,4951,4952,4953,4954,4955,4956,4957,4958, +4959,4960,4961,4962,4963,4964,4965,4966,4967,4968,4969,4970,4971,4972,4973, +4974,4975,4976,4977,4978,4979,4980,4981,4982,4983,4984,4985,4986,4987,4988, +4989,4990,4991,4992,4993,4994,4995,4996,4997,4998,4999,5000,5001,5002,5003, +5004,5005,5006,5007,5008,5009,5010,5011,5012,5013,5014,5015,5016,5017,5018, +5019,5020,5021,5022,5023,5024,5025,5026,5027,5028,5029,5030,5031,5032,5033, +5034,5035,5036,5037,5038,5039,5040,5041,5042,5043,5044,5045,5046,5047,5048, +5049,5050,5051,5052,5053,5054,5055,5056,5057,5058,5059,5060,5061,5062,5063, +5064,5065,5066,5067,5068,5069,5070,5071,5072,5073,5074,5075,5076,5077,5078, +5079,5080,5081,5082,5083,5084,5085,5086,5087,5088,5089,5090,5091,5092,5093, +5094,5095,5096,5097,5098,5099,5100,5101,5102,5103,5104,5105,5106,5107,5108, +5109,5110,5111,5104,5105,5106,5107,5108,5109,5118,5119,5120,5121,5122,5123, +5124,5125,5126,5127,5128,5129,5130,5131,5132,5133,5134,5135,5136,5137,5138, +5139,5140,5141,5142,5143,5144,5145,5146,5147,5148,5149,5150,5151,5152,5153, +5154,5155,5156,5157,5158,5159,5160,5161,5162,5163,5164,5165,5166,5167,5168, +5169,5170,5171,5172,5173,5174,5175,5176,5177,5178,5179,5180,5181,5182,5183, +5184,5185,5186,5187,5188,5189,5190,5191,5192,5193,5194,5195,5196,5197,5198, +5199,5200,5201,5202,5203,5204,5205,5206,5207,5208,5209,5210,5211,5212,5213, +5214,5215,5216,5217,5218,5219,5220,5221,5222,5223,5224,5225,5226,5227,5228, +5229,5230,5231,5232,5233,5234,5235,5236,5237,5238,5239,5240,5241,5242,5243, +5244,5245,5246,5247,5248,5249,5250,5251,5252,5253,5254,5255,5256,5257,5258, +5259,5260,5261,5262,5263,5264,5265,5266,5267,5268,5269,5270,5271,5272,5273, +5274,5275,5276,5277,5278,5279,5280,5281,5282,5283,5284,5285,5286,5287,5288, +5289,5290,5291,5292,5293,5294,5295,5296,5297,5298,5299,5300,5301,5302,5303, +5304,5305,5306,5307,5308,5309,5310,5311,5312,5313,5314,5315,5316,5317,5318, +5319,5320,5321,5322,5323,5324,5325,5326,5327,5328,5329,5330,5331,5332,5333, +5334,5335,5336,5337,5338,5339,5340,5341,5342,5343,5344,5345,5346,5347,5348, +5349,5350,5351,5352,5353,5354,5355,5356,5357,5358,5359,5360,5361,5362,5363, +5364,5365,5366,5367,5368,5369,5370,5371,5372,5373,5374,5375,5376,5377,5378, +5379,5380,5381,5382,5383,5384,5385,5386,5387,5388,5389,5390,5391,5392,5393, +5394,5395,5396,5397,5398,5399,5400,5401,5402,5403,5404,5405,5406,5407,5408, +5409,5410,5411,5412,5413,5414,5415,5416,5417,5418,5419,5420,5421,5422,5423, +5424,5425,5426,5427,5428,5429,5430,5431,5432,5433,5434,5435,5436,5437,5438, +5439,5440,5441,5442,5443,5444,5445,5446,5447,5448,5449,5450,5451,5452,5453, +5454,5455,5456,5457,5458,5459,5460,5461,5462,5463,5464,5465,5466,5467,5468, +5469,5470,5471,5472,5473,5474,5475,5476,5477,5478,5479,5480,5481,5482,5483, +5484,5485,5486,5487,5488,5489,5490,5491,5492,5493,5494,5495,5496,5497,5498, +5499,5500,5501,5502,5503,5504,5505,5506,5507,5508,5509,5510,5511,5512,5513, +5514,5515,5516,5517,5518,5519,5520,5521,5522,5523,5524,5525,5526,5527,5528, +5529,5530,5531,5532,5533,5534,5535,5536,5537,5538,5539,5540,5541,5542,5543, +5544,5545,5546,5547,5548,5549,5550,5551,5552,5553,5554,5555,5556,5557,5558, +5559,5560,5561,5562,5563,5564,5565,5566,5567,5568,5569,5570,5571,5572,5573, +5574,5575,5576,5577,5578,5579,5580,5581,5582,5583,5584,5585,5586,5587,5588, +5589,5590,5591,5592,5593,5594,5595,5596,5597,5598,5599,5600,5601,5602,5603, +5604,5605,5606,5607,5608,5609,5610,5611,5612,5613,5614,5615,5616,5617,5618, +5619,5620,5621,5622,5623,5624,5625,5626,5627,5628,5629,5630,5631,5632,5633, +5634,5635,5636,5637,5638,5639,5640,5641,5642,5643,5644,5645,5646,5647,5648, +5649,5650,5651,5652,5653,5654,5655,5656,5657,5658,5659,5660,5661,5662,5663, +5664,5665,5666,5667,5668,5669,5670,5671,5672,5673,5674,5675,5676,5677,5678, +5679,5680,5681,5682,5683,5684,5685,5686,5687,5688,5689,5690,5691,5692,5693, +5694,5695,5696,5697,5698,5699,5700,5701,5702,5703,5704,5705,5706,5707,5708, +5709,5710,5711,5712,5713,5714,5715,5716,5717,5718,5719,5720,5721,5722,5723, +5724,5725,5726,5727,5728,5729,5730,5731,5732,5733,5734,5735,5736,5737,5738, +5739,5740,5741,5742,5743,5744,5745,5746,5747,5748,5749,5750,5751,5752,5753, +5754,5755,5756,5757,5758,5759,5760,5761,5762,5763,5764,5765,5766,5767,5768, +5769,5770,5771,5772,5773,5774,5775,5776,5777,5778,5779,5780,5781,5782,5783, +5784,5785,5786,5787,5788,5789,5790,5791,5792,5793,5794,5795,5796,5797,5798, +5799,5800,5801,5802,5803,5804,5805,5806,5807,5808,5809,5810,5811,5812,5813, +5814,5815,5816,5817,5818,5819,5820,5821,5822,5823,5824,5825,5826,5827,5828, +5829,5830,5831,5832,5833,5834,5835,5836,5837,5838,5839,5840,5841,5842,5843, +5844,5845,5846,5847,5848,5849,5850,5851,5852,5853,5854,5855,5856,5857,5858, +5859,5860,5861,5862,5863,5864,5865,5866,5867,5868,5869,5870,5871,5872,5873, +5874,5875,5876,5877,5878,5879,5880,5881,5882,5883,5884,5885,5886,5887,5888, +5889,5890,5891,5892,5893,5894,5895,5896,5897,5898,5899,5900,5901,5902,5903, +5904,5905,5906,5907,5908,5909,5910,5911,5912,5913,5914,5915,5916,5917,5918, +5919,5920,5921,5922,5923,5924,5925,5926,5927,5928,5929,5930,5931,5932,5933, +5934,5935,5936,5937,5938,5939,5940,5941,5942,5943,5944,5945,5946,5947,5948, +5949,5950,5951,5952,5953,5954,5955,5956,5957,5958,5959,5960,5961,5962,5963, +5964,5965,5966,5967,5968,5969,5970,5971,5972,5973,5974,5975,5976,5977,5978, +5979,5980,5981,5982,5983,5984,5985,5986,5987,5988,5989,5990,5991,5992,5993, +5994,5995,5996,5997,5998,5999,6000,6001,6002,6003,6004,6005,6006,6007,6008, +6009,6010,6011,6012,6013,6014,6015,6016,6017,6018,6019,6020,6021,6022,6023, +6024,6025,6026,6027,6028,6029,6030,6031,6032,6033,6034,6035,6036,6037,6038, +6039,6040,6041,6042,6043,6044,6045,6046,6047,6048,6049,6050,6051,6052,6053, +6054,6055,6056,6057,6058,6059,6060,6061,6062,6063,6064,6065,6066,6067,6068, +6069,6070,6071,6072,6073,6074,6075,6076,6077,6078,6079,6080,6081,6082,6083, +6084,6085,6086,6087,6088,6089,6090,6091,6092,6093,6094,6095,6096,6097,6098, +6099,6100,6101,6102,6103,6104,6105,6106,6107,6108,6109,6110,6111,6112,6113, +6114,6115,6116,6117,6118,6119,6120,6121,6122,6123,6124,6125,6126,6127,6128, +6129,6130,6131,6132,6133,6134,6135,6136,6137,6138,6139,6140,6141,6142,6143, +6144,6145,6146,6147,6148,6149,6150,6151,6152,6153,6154,6155,6156,6157,6158, +6159,6160,6161,6162,6163,6164,6165,6166,6167,6168,6169,6170,6171,6172,6173, +6174,6175,6176,6177,6178,6179,6180,6181,6182,6183,6184,6185,6186,6187,6188, +6189,6190,6191,6192,6193,6194,6195,6196,6197,6198,6199,6200,6201,6202,6203, +6204,6205,6206,6207,6208,6209,6210,6211,6212,6213,6214,6215,6216,6217,6218, +6219,6220,6221,6222,6223,6224,6225,6226,6227,6228,6229,6230,6231,6232,6233, +6234,6235,6236,6237,6238,6239,6240,6241,6242,6243,6244,6245,6246,6247,6248, +6249,6250,6251,6252,6253,6254,6255,6256,6257,6258,6259,6260,6261,6262,6263, +6264,6265,6266,6267,6268,6269,6270,6271,6272,6273,6274,6275,6276,6277,6278, +6279,6280,6281,6282,6283,6284,6285,6286,6287,6288,6289,6290,6291,6292,6293, +6294,6295,6296,6297,6298,6299,6300,6301,6302,6303,6304,6305,6306,6307,6308, +6309,6310,6311,6312,6313,6314,6315,6316,6317,6318,6319,6320,6321,6322,6323, +6324,6325,6326,6327,6328,6329,6330,6331,6332,6333,6334,6335,6336,6337,6338, +6339,6340,6341,6342,6343,6344,6345,6346,6347,6348,6349,6350,6351,6352,6353, +6354,6355,6356,6357,6358,6359,6360,6361,6362,6363,6364,6365,6366,6367,6368, +6369,6370,6371,6372,6373,6374,6375,6376,6377,6378,6379,6380,6381,6382,6383, +6384,6385,6386,6387,6388,6389,6390,6391,6392,6393,6394,6395,6396,6397,6398, +6399,6400,6401,6402,6403,6404,6405,6406,6407,6408,6409,6410,6411,6412,6413, +6414,6415,6416,6417,6418,6419,6420,6421,6422,6423,6424,6425,6426,6427,6428, +6429,6430,6431,6432,6433,6434,6435,6436,6437,6438,6439,6440,6441,6442,6443, +6444,6445,6446,6447,6448,6449,6450,6451,6452,6453,6454,6455,6456,6457,6458, +6459,6460,6461,6462,6463,6464,6465,6466,6467,6468,6469,6470,6471,6472,6473, +6474,6475,6476,6477,6478,6479,6480,6481,6482,6483,6484,6485,6486,6487,6488, +6489,6490,6491,6492,6493,6494,6495,6496,6497,6498,6499,6500,6501,6502,6503, +6504,6505,6506,6507,6508,6509,6510,6511,6512,6513,6514,6515,6516,6517,6518, +6519,6520,6521,6522,6523,6524,6525,6526,6527,6528,6529,6530,6531,6532,6533, +6534,6535,6536,6537,6538,6539,6540,6541,6542,6543,6544,6545,6546,6547,6548, +6549,6550,6551,6552,6553,6554,6555,6556,6557,6558,6559,6560,6561,6562,6563, +6564,6565,6566,6567,6568,6569,6570,6571,6572,6573,6574,6575,6576,6577,6578, +6579,6580,6581,6582,6583,6584,6585,6586,6587,6588,6589,6590,6591,6592,6593, +6594,6595,6596,6597,6598,6599,6600,6601,6602,6603,6604,6605,6606,6607,6608, +6609,6610,6611,6612,6613,6614,6615,6616,6617,6618,6619,6620,6621,6622,6623, +6624,6625,6626,6627,6628,6629,6630,6631,6632,6633,6634,6635,6636,6637,6638, +6639,6640,6641,6642,6643,6644,6645,6646,6647,6648,6649,6650,6651,6652,6653, +6654,6655,6656,6657,6658,6659,6660,6661,6662,6663,6664,6665,6666,6667,6668, +6669,6670,6671,6672,6673,6674,6675,6676,6677,6678,6679,6680,6681,6682,6683, +6684,6685,6686,6687,6688,6689,6690,6691,6692,6693,6694,6695,6696,6697,6698, +6699,6700,6701,6702,6703,6704,6705,6706,6707,6708,6709,6710,6711,6712,6713, +6714,6715,6716,6717,6718,6719,6720,6721,6722,6723,6724,6725,6726,6727,6728, +6729,6730,6731,6732,6733,6734,6735,6736,6737,6738,6739,6740,6741,6742,6743, +6744,6745,6746,6747,6748,6749,6750,6751,6752,6753,6754,6755,6756,6757,6758, +6759,6760,6761,6762,6763,6764,6765,6766,6767,6768,6769,6770,6771,6772,6773, +6774,6775,6776,6777,6778,6779,6780,6781,6782,6783,6784,6785,6786,6787,6788, +6789,6790,6791,6792,6793,6794,6795,6796,6797,6798,6799,6800,6801,6802,6803, +6804,6805,6806,6807,6808,6809,6810,6811,6812,6813,6814,6815,6816,6817,6818, +6819,6820,6821,6822,6823,6824,6825,6826,6827,6828,6829,6830,6831,6832,6833, +6834,6835,6836,6837,6838,6839,6840,6841,6842,6843,6844,6845,6846,6847,6848, +6849,6850,6851,6852,6853,6854,6855,6856,6857,6858,6859,6860,6861,6862,6863, +6864,6865,6866,6867,6868,6869,6870,6871,6872,6873,6874,6875,6876,6877,6878, +6879,6880,6881,6882,6883,6884,6885,6886,6887,6888,6889,6890,6891,6892,6893, +6894,6895,6896,6897,6898,6899,6900,6901,6902,6903,6904,6905,6906,6907,6908, +6909,6910,6911,6912,6913,6914,6915,6916,6917,6918,6919,6920,6921,6922,6923, +6924,6925,6926,6927,6928,6929,6930,6931,6932,6933,6934,6935,6936,6937,6938, +6939,6940,6941,6942,6943,6944,6945,6946,6947,6948,6949,6950,6951,6952,6953, +6954,6955,6956,6957,6958,6959,6960,6961,6962,6963,6964,6965,6966,6967,6968, +6969,6970,6971,6972,6973,6974,6975,6976,6977,6978,6979,6980,6981,6982,6983, +6984,6985,6986,6987,6988,6989,6990,6991,6992,6993,6994,6995,6996,6997,6998, +6999,7000,7001,7002,7003,7004,7005,7006,7007,7008,7009,7010,7011,7012,7013, +7014,7015,7016,7017,7018,7019,7020,7021,7022,7023,7024,7025,7026,7027,7028, +7029,7030,7031,7032,7033,7034,7035,7036,7037,7038,7039,7040,7041,7042,7043, +7044,7045,7046,7047,7048,7049,7050,7051,7052,7053,7054,7055,7056,7057,7058, +7059,7060,7061,7062,7063,7064,7065,7066,7067,7068,7069,7070,7071,7072,7073, +7074,7075,7076,7077,7078,7079,7080,7081,7082,7083,7084,7085,7086,7087,7088, +7089,7090,7091,7092,7093,7094,7095,7096,7097,7098,7099,7100,7101,7102,7103, +7104,7105,7106,7107,7108,7109,7110,7111,7112,7113,7114,7115,7116,7117,7118, +7119,7120,7121,7122,7123,7124,7125,7126,7127,7128,7129,7130,7131,7132,7133, +7134,7135,7136,7137,7138,7139,7140,7141,7142,7143,7144,7145,7146,7147,7148, +7149,7150,7151,7152,7153,7154,7155,7156,7157,7158,7159,7160,7161,7162,7163, +7164,7165,7166,7167,7168,7169,7170,7171,7172,7173,7174,7175,7176,7177,7178, +7179,7180,7181,7182,7183,7184,7185,7186,7187,7188,7189,7190,7191,7192,7193, +7194,7195,7196,7197,7198,7199,7200,7201,7202,7203,7204,7205,7206,7207,7208, +7209,7210,7211,7212,7213,7214,7215,7216,7217,7218,7219,7220,7221,7222,7223, +7224,7225,7226,7227,7228,7229,7230,7231,7232,7233,7234,7235,7236,7237,7238, +7239,7240,7241,7242,7243,7244,7245,7246,7247,7248,7249,7250,7251,7252,7253, +7254,7255,7256,7257,7258,7259,7260,7261,7262,7263,7264,7265,7266,7267,7268, +7269,7270,7271,7272,7273,7274,7275,7276,7277,7278,7279,7280,7281,7282,7283, +7284,7285,7286,7287,7288,7289,7290,7291,7292,7293,7294,7295,1042,1044,1054, +1057,1058,1058,1066,1122,42570L,7305,7306,7307,7308,7309,7310,7311,7312, +7313,7314,7315,7316,7317,7318,7319,7320,7321,7322,7323,7324,7325,7326,7327, +7328,7329,7330,7331,7332,7333,7334,7335,7336,7337,7338,7339,7340,7341,7342, +7343,7344,7345,7346,7347,7348,7349,7350,7351,7352,7353,7354,7355,7356,7357, +7358,7359,7360,7361,7362,7363,7364,7365,7366,7367,7368,7369,7370,7371,7372, +7373,7374,7375,7376,7377,7378,7379,7380,7381,7382,7383,7384,7385,7386,7387, +7388,7389,7390,7391,7392,7393,7394,7395,7396,7397,7398,7399,7400,7401,7402, +7403,7404,7405,7406,7407,7408,7409,7410,7411,7412,7413,7414,7415,7416,7417, +7418,7419,7420,7421,7422,7423,7424,7425,7426,7427,7428,7429,7430,7431,7432, +7433,7434,7435,7436,7437,7438,7439,7440,7441,7442,7443,7444,7445,7446,7447, +7448,7449,7450,7451,7452,7453,7454,7455,7456,7457,7458,7459,7460,7461,7462, +7463,7464,7465,7466,7467,7468,7469,7470,7471,7472,7473,7474,7475,7476,7477, +7478,7479,7480,7481,7482,7483,7484,7485,7486,7487,7488,7489,7490,7491,7492, +7493,7494,7495,7496,7497,7498,7499,7500,7501,7502,7503,7504,7505,7506,7507, +7508,7509,7510,7511,7512,7513,7514,7515,7516,7517,7518,7519,7520,7521,7522, +7523,7524,7525,7526,7527,7528,7529,7530,7531,7532,7533,7534,7535,7536,7537, +7538,7539,7540,7541,7542,7543,7544,42877L,7546,7547,7548,11363,7550,7551, +7552,7553,7554,7555,7556,7557,7558,7559,7560,7561,7562,7563,7564,7565, +42950L,7567,7568,7569,7570,7571,7572,7573,7574,7575,7576,7577,7578,7579, +7580,7581,7582,7583,7584,7585,7586,7587,7588,7589,7590,7591,7592,7593,7594, +7595,7596,7597,7598,7599,7600,7601,7602,7603,7604,7605,7606,7607,7608,7609, +7610,7611,7612,7613,7614,7615,7616,7617,7618,7619,7620,7621,7622,7623,7624, +7625,7626,7627,7628,7629,7630,7631,7632,7633,7634,7635,7636,7637,7638,7639, +7640,7641,7642,7643,7644,7645,7646,7647,7648,7649,7650,7651,7652,7653,7654, +7655,7656,7657,7658,7659,7660,7661,7662,7663,7664,7665,7666,7667,7668,7669, +7670,7671,7672,7673,7674,7675,7676,7677,7678,7679,7680,7680,7682,7682,7684, +7684,7686,7686,7688,7688,7690,7690,7692,7692,7694,7694,7696,7696,7698,7698, +7700,7700,7702,7702,7704,7704,7706,7706,7708,7708,7710,7710,7712,7712,7714, +7714,7716,7716,7718,7718,7720,7720,7722,7722,7724,7724,7726,7726,7728,7728, +7730,7730,7732,7732,7734,7734,7736,7736,7738,7738,7740,7740,7742,7742,7744, +7744,7746,7746,7748,7748,7750,7750,7752,7752,7754,7754,7756,7756,7758,7758, +7760,7760,7762,7762,7764,7764,7766,7766,7768,7768,7770,7770,7772,7772,7774, +7774,7776,7776,7778,7778,7780,7780,7782,7782,7784,7784,7786,7786,7788,7788, +7790,7790,7792,7792,7794,7794,7796,7796,7798,7798,7800,7800,7802,7802,7804, +7804,7806,7806,7808,7808,7810,7810,7812,7812,7814,7814,7816,7816,7818,7818, +7820,7820,7822,7822,7824,7824,7826,7826,7828,7828,7830,7831,7832,7833,7834, +7776,7836,7837,7838,7839,7840,7840,7842,7842,7844,7844,7846,7846,7848,7848, +7850,7850,7852,7852,7854,7854,7856,7856,7858,7858,7860,7860,7862,7862,7864, +7864,7866,7866,7868,7868,7870,7870,7872,7872,7874,7874,7876,7876,7878,7878, +7880,7880,7882,7882,7884,7884,7886,7886,7888,7888,7890,7890,7892,7892,7894, +7894,7896,7896,7898,7898,7900,7900,7902,7902,7904,7904,7906,7906,7908,7908, +7910,7910,7912,7912,7914,7914,7916,7916,7918,7918,7920,7920,7922,7922,7924, +7924,7926,7926,7928,7928,7930,7930,7932,7932,7934,7934,7944,7945,7946,7947, +7948,7949,7950,7951,7944,7945,7946,7947,7948,7949,7950,7951,7960,7961,7962, +7963,7964,7965,7958,7959,7960,7961,7962,7963,7964,7965,7966,7967,7976,7977, +7978,7979,7980,7981,7982,7983,7976,7977,7978,7979,7980,7981,7982,7983,7992, +7993,7994,7995,7996,7997,7998,7999,7992,7993,7994,7995,7996,7997,7998,7999, +8008,8009,8010,8011,8012,8013,8006,8007,8008,8009,8010,8011,8012,8013,8014, +8015,8016,8025,8018,8027,8020,8029,8022,8031,8024,8025,8026,8027,8028,8029, +8030,8031,8040,8041,8042,8043,8044,8045,8046,8047,8040,8041,8042,8043,8044, +8045,8046,8047,8122,8123,8136,8137,8138,8139,8154,8155,8184,8185,8170,8171, +8186,8187,8062,8063,8064,8065,8066,8067,8068,8069,8070,8071,8072,8073,8074, +8075,8076,8077,8078,8079,8080,8081,8082,8083,8084,8085,8086,8087,8088,8089, +8090,8091,8092,8093,8094,8095,8096,8097,8098,8099,8100,8101,8102,8103,8104, +8105,8106,8107,8108,8109,8110,8111,8120,8121,8114,8115,8116,8117,8118,8119, +8120,8121,8122,8123,8124,8125,921,8127,8128,8129,8130,8131,8132,8133,8134, +8135,8136,8137,8138,8139,8140,8141,8142,8143,8152,8153,8146,8147,8148,8149, +8150,8151,8152,8153,8154,8155,8156,8157,8158,8159,8168,8169,8162,8163,8164, +8172,8166,8167,8168,8169,8170,8171,8172,8173,8174,8175,8176,8177,8178,8179, +8180,8181,8182,8183,8184,8185,8186,8187,8188,8189,8190,8191,8192,8193,8194, +8195,8196,8197,8198,8199,8200,8201,8202,8203,8204,8205,8206,8207,8208,8209, +8210,8211,8212,8213,8214,8215,8216,8217,8218,8219,8220,8221,8222,8223,8224, +8225,8226,8227,8228,8229,8230,8231,8232,8233,8234,8235,8236,8237,8238,8239, +8240,8241,8242,8243,8244,8245,8246,8247,8248,8249,8250,8251,8252,8253,8254, +8255,8256,8257,8258,8259,8260,8261,8262,8263,8264,8265,8266,8267,8268,8269, +8270,8271,8272,8273,8274,8275,8276,8277,8278,8279,8280,8281,8282,8283,8284, +8285,8286,8287,8288,8289,8290,8291,8292,8293,8294,8295,8296,8297,8298,8299, +8300,8301,8302,8303,8304,8305,8306,8307,8308,8309,8310,8311,8312,8313,8314, +8315,8316,8317,8318,8319,8320,8321,8322,8323,8324,8325,8326,8327,8328,8329, +8330,8331,8332,8333,8334,8335,8336,8337,8338,8339,8340,8341,8342,8343,8344, +8345,8346,8347,8348,8349,8350,8351,8352,8353,8354,8355,8356,8357,8358,8359, +8360,8361,8362,8363,8364,8365,8366,8367,8368,8369,8370,8371,8372,8373,8374, +8375,8376,8377,8378,8379,8380,8381,8382,8383,8384,8385,8386,8387,8388,8389, +8390,8391,8392,8393,8394,8395,8396,8397,8398,8399,8400,8401,8402,8403,8404, +8405,8406,8407,8408,8409,8410,8411,8412,8413,8414,8415,8416,8417,8418,8419, +8420,8421,8422,8423,8424,8425,8426,8427,8428,8429,8430,8431,8432,8433,8434, +8435,8436,8437,8438,8439,8440,8441,8442,8443,8444,8445,8446,8447,8448,8449, +8450,8451,8452,8453,8454,8455,8456,8457,8458,8459,8460,8461,8462,8463,8464, +8465,8466,8467,8468,8469,8470,8471,8472,8473,8474,8475,8476,8477,8478,8479, +8480,8481,8482,8483,8484,8485,8486,8487,8488,8489,8490,8491,8492,8493,8494, +8495,8496,8497,8498,8499,8500,8501,8502,8503,8504,8505,8506,8507,8508,8509, +8510,8511,8512,8513,8514,8515,8516,8517,8518,8519,8520,8521,8522,8523,8524, +8525,8498,8527,8528,8529,8530,8531,8532,8533,8534,8535,8536,8537,8538,8539, +8540,8541,8542,8543,8544,8545,8546,8547,8548,8549,8550,8551,8552,8553,8554, +8555,8556,8557,8558,8559,8544,8545,8546,8547,8548,8549,8550,8551,8552,8553, +8554,8555,8556,8557,8558,8559,8576,8577,8578,8579,8579,8581,8582,8583,8584, +8585,8586,8587,8588,8589,8590,8591,8592,8593,8594,8595,8596,8597,8598,8599, +8600,8601,8602,8603,8604,8605,8606,8607,8608,8609,8610,8611,8612,8613,8614, +8615,8616,8617,8618,8619,8620,8621,8622,8623,8624,8625,8626,8627,8628,8629, +8630,8631,8632,8633,8634,8635,8636,8637,8638,8639,8640,8641,8642,8643,8644, +8645,8646,8647,8648,8649,8650,8651,8652,8653,8654,8655,8656,8657,8658,8659, +8660,8661,8662,8663,8664,8665,8666,8667,8668,8669,8670,8671,8672,8673,8674, +8675,8676,8677,8678,8679,8680,8681,8682,8683,8684,8685,8686,8687,8688,8689, +8690,8691,8692,8693,8694,8695,8696,8697,8698,8699,8700,8701,8702,8703,8704, +8705,8706,8707,8708,8709,8710,8711,8712,8713,8714,8715,8716,8717,8718,8719, +8720,8721,8722,8723,8724,8725,8726,8727,8728,8729,8730,8731,8732,8733,8734, +8735,8736,8737,8738,8739,8740,8741,8742,8743,8744,8745,8746,8747,8748,8749, +8750,8751,8752,8753,8754,8755,8756,8757,8758,8759,8760,8761,8762,8763,8764, +8765,8766,8767,8768,8769,8770,8771,8772,8773,8774,8775,8776,8777,8778,8779, +8780,8781,8782,8783,8784,8785,8786,8787,8788,8789,8790,8791,8792,8793,8794, +8795,8796,8797,8798,8799,8800,8801,8802,8803,8804,8805,8806,8807,8808,8809, +8810,8811,8812,8813,8814,8815,8816,8817,8818,8819,8820,8821,8822,8823,8824, +8825,8826,8827,8828,8829,8830,8831,8832,8833,8834,8835,8836,8837,8838,8839, +8840,8841,8842,8843,8844,8845,8846,8847,8848,8849,8850,8851,8852,8853,8854, +8855,8856,8857,8858,8859,8860,8861,8862,8863,8864,8865,8866,8867,8868,8869, +8870,8871,8872,8873,8874,8875,8876,8877,8878,8879,8880,8881,8882,8883,8884, +8885,8886,8887,8888,8889,8890,8891,8892,8893,8894,8895,8896,8897,8898,8899, +8900,8901,8902,8903,8904,8905,8906,8907,8908,8909,8910,8911,8912,8913,8914, +8915,8916,8917,8918,8919,8920,8921,8922,8923,8924,8925,8926,8927,8928,8929, +8930,8931,8932,8933,8934,8935,8936,8937,8938,8939,8940,8941,8942,8943,8944, +8945,8946,8947,8948,8949,8950,8951,8952,8953,8954,8955,8956,8957,8958,8959, +8960,8961,8962,8963,8964,8965,8966,8967,8968,8969,8970,8971,8972,8973,8974, +8975,8976,8977,8978,8979,8980,8981,8982,8983,8984,8985,8986,8987,8988,8989, +8990,8991,8992,8993,8994,8995,8996,8997,8998,8999,9000,9001,9002,9003,9004, +9005,9006,9007,9008,9009,9010,9011,9012,9013,9014,9015,9016,9017,9018,9019, +9020,9021,9022,9023,9024,9025,9026,9027,9028,9029,9030,9031,9032,9033,9034, +9035,9036,9037,9038,9039,9040,9041,9042,9043,9044,9045,9046,9047,9048,9049, +9050,9051,9052,9053,9054,9055,9056,9057,9058,9059,9060,9061,9062,9063,9064, +9065,9066,9067,9068,9069,9070,9071,9072,9073,9074,9075,9076,9077,9078,9079, +9080,9081,9082,9083,9084,9085,9086,9087,9088,9089,9090,9091,9092,9093,9094, +9095,9096,9097,9098,9099,9100,9101,9102,9103,9104,9105,9106,9107,9108,9109, +9110,9111,9112,9113,9114,9115,9116,9117,9118,9119,9120,9121,9122,9123,9124, +9125,9126,9127,9128,9129,9130,9131,9132,9133,9134,9135,9136,9137,9138,9139, +9140,9141,9142,9143,9144,9145,9146,9147,9148,9149,9150,9151,9152,9153,9154, +9155,9156,9157,9158,9159,9160,9161,9162,9163,9164,9165,9166,9167,9168,9169, +9170,9171,9172,9173,9174,9175,9176,9177,9178,9179,9180,9181,9182,9183,9184, +9185,9186,9187,9188,9189,9190,9191,9192,9193,9194,9195,9196,9197,9198,9199, +9200,9201,9202,9203,9204,9205,9206,9207,9208,9209,9210,9211,9212,9213,9214, +9215,9216,9217,9218,9219,9220,9221,9222,9223,9224,9225,9226,9227,9228,9229, +9230,9231,9232,9233,9234,9235,9236,9237,9238,9239,9240,9241,9242,9243,9244, +9245,9246,9247,9248,9249,9250,9251,9252,9253,9254,9255,9256,9257,9258,9259, +9260,9261,9262,9263,9264,9265,9266,9267,9268,9269,9270,9271,9272,9273,9274, +9275,9276,9277,9278,9279,9280,9281,9282,9283,9284,9285,9286,9287,9288,9289, +9290,9291,9292,9293,9294,9295,9296,9297,9298,9299,9300,9301,9302,9303,9304, +9305,9306,9307,9308,9309,9310,9311,9312,9313,9314,9315,9316,9317,9318,9319, +9320,9321,9322,9323,9324,9325,9326,9327,9328,9329,9330,9331,9332,9333,9334, +9335,9336,9337,9338,9339,9340,9341,9342,9343,9344,9345,9346,9347,9348,9349, +9350,9351,9352,9353,9354,9355,9356,9357,9358,9359,9360,9361,9362,9363,9364, +9365,9366,9367,9368,9369,9370,9371,9372,9373,9374,9375,9376,9377,9378,9379, +9380,9381,9382,9383,9384,9385,9386,9387,9388,9389,9390,9391,9392,9393,9394, +9395,9396,9397,9398,9399,9400,9401,9402,9403,9404,9405,9406,9407,9408,9409, +9410,9411,9412,9413,9414,9415,9416,9417,9418,9419,9420,9421,9422,9423,9398, +9399,9400,9401,9402,9403,9404,9405,9406,9407,9408,9409,9410,9411,9412,9413, +9414,9415,9416,9417,9418,9419,9420,9421,9422,9423,9450,9451,9452,9453,9454, +9455,9456,9457,9458,9459,9460,9461,9462,9463,9464,9465,9466,9467,9468,9469, +9470,9471,9472,9473,9474,9475,9476,9477,9478,9479,9480,9481,9482,9483,9484, +9485,9486,9487,9488,9489,9490,9491,9492,9493,9494,9495,9496,9497,9498,9499, +9500,9501,9502,9503,9504,9505,9506,9507,9508,9509,9510,9511,9512,9513,9514, +9515,9516,9517,9518,9519,9520,9521,9522,9523,9524,9525,9526,9527,9528,9529, +9530,9531,9532,9533,9534,9535,9536,9537,9538,9539,9540,9541,9542,9543,9544, +9545,9546,9547,9548,9549,9550,9551,9552,9553,9554,9555,9556,9557,9558,9559, +9560,9561,9562,9563,9564,9565,9566,9567,9568,9569,9570,9571,9572,9573,9574, +9575,9576,9577,9578,9579,9580,9581,9582,9583,9584,9585,9586,9587,9588,9589, +9590,9591,9592,9593,9594,9595,9596,9597,9598,9599,9600,9601,9602,9603,9604, +9605,9606,9607,9608,9609,9610,9611,9612,9613,9614,9615,9616,9617,9618,9619, +9620,9621,9622,9623,9624,9625,9626,9627,9628,9629,9630,9631,9632,9633,9634, +9635,9636,9637,9638,9639,9640,9641,9642,9643,9644,9645,9646,9647,9648,9649, +9650,9651,9652,9653,9654,9655,9656,9657,9658,9659,9660,9661,9662,9663,9664, +9665,9666,9667,9668,9669,9670,9671,9672,9673,9674,9675,9676,9677,9678,9679, +9680,9681,9682,9683,9684,9685,9686,9687,9688,9689,9690,9691,9692,9693,9694, +9695,9696,9697,9698,9699,9700,9701,9702,9703,9704,9705,9706,9707,9708,9709, +9710,9711,9712,9713,9714,9715,9716,9717,9718,9719,9720,9721,9722,9723,9724, +9725,9726,9727,9728,9729,9730,9731,9732,9733,9734,9735,9736,9737,9738,9739, +9740,9741,9742,9743,9744,9745,9746,9747,9748,9749,9750,9751,9752,9753,9754, +9755,9756,9757,9758,9759,9760,9761,9762,9763,9764,9765,9766,9767,9768,9769, +9770,9771,9772,9773,9774,9775,9776,9777,9778,9779,9780,9781,9782,9783,9784, +9785,9786,9787,9788,9789,9790,9791,9792,9793,9794,9795,9796,9797,9798,9799, +9800,9801,9802,9803,9804,9805,9806,9807,9808,9809,9810,9811,9812,9813,9814, +9815,9816,9817,9818,9819,9820,9821,9822,9823,9824,9825,9826,9827,9828,9829, +9830,9831,9832,9833,9834,9835,9836,9837,9838,9839,9840,9841,9842,9843,9844, +9845,9846,9847,9848,9849,9850,9851,9852,9853,9854,9855,9856,9857,9858,9859, +9860,9861,9862,9863,9864,9865,9866,9867,9868,9869,9870,9871,9872,9873,9874, +9875,9876,9877,9878,9879,9880,9881,9882,9883,9884,9885,9886,9887,9888,9889, +9890,9891,9892,9893,9894,9895,9896,9897,9898,9899,9900,9901,9902,9903,9904, +9905,9906,9907,9908,9909,9910,9911,9912,9913,9914,9915,9916,9917,9918,9919, +9920,9921,9922,9923,9924,9925,9926,9927,9928,9929,9930,9931,9932,9933,9934, +9935,9936,9937,9938,9939,9940,9941,9942,9943,9944,9945,9946,9947,9948,9949, +9950,9951,9952,9953,9954,9955,9956,9957,9958,9959,9960,9961,9962,9963,9964, +9965,9966,9967,9968,9969,9970,9971,9972,9973,9974,9975,9976,9977,9978,9979, +9980,9981,9982,9983,9984,9985,9986,9987,9988,9989,9990,9991,9992,9993,9994, +9995,9996,9997,9998,9999,10000,10001,10002,10003,10004,10005,10006,10007, +10008,10009,10010,10011,10012,10013,10014,10015,10016,10017,10018,10019, +10020,10021,10022,10023,10024,10025,10026,10027,10028,10029,10030,10031, +10032,10033,10034,10035,10036,10037,10038,10039,10040,10041,10042,10043, +10044,10045,10046,10047,10048,10049,10050,10051,10052,10053,10054,10055, +10056,10057,10058,10059,10060,10061,10062,10063,10064,10065,10066,10067, +10068,10069,10070,10071,10072,10073,10074,10075,10076,10077,10078,10079, +10080,10081,10082,10083,10084,10085,10086,10087,10088,10089,10090,10091, +10092,10093,10094,10095,10096,10097,10098,10099,10100,10101,10102,10103, +10104,10105,10106,10107,10108,10109,10110,10111,10112,10113,10114,10115, +10116,10117,10118,10119,10120,10121,10122,10123,10124,10125,10126,10127, +10128,10129,10130,10131,10132,10133,10134,10135,10136,10137,10138,10139, +10140,10141,10142,10143,10144,10145,10146,10147,10148,10149,10150,10151, +10152,10153,10154,10155,10156,10157,10158,10159,10160,10161,10162,10163, +10164,10165,10166,10167,10168,10169,10170,10171,10172,10173,10174,10175, +10176,10177,10178,10179,10180,10181,10182,10183,10184,10185,10186,10187, +10188,10189,10190,10191,10192,10193,10194,10195,10196,10197,10198,10199, +10200,10201,10202,10203,10204,10205,10206,10207,10208,10209,10210,10211, +10212,10213,10214,10215,10216,10217,10218,10219,10220,10221,10222,10223, +10224,10225,10226,10227,10228,10229,10230,10231,10232,10233,10234,10235, +10236,10237,10238,10239,10240,10241,10242,10243,10244,10245,10246,10247, +10248,10249,10250,10251,10252,10253,10254,10255,10256,10257,10258,10259, +10260,10261,10262,10263,10264,10265,10266,10267,10268,10269,10270,10271, +10272,10273,10274,10275,10276,10277,10278,10279,10280,10281,10282,10283, +10284,10285,10286,10287,10288,10289,10290,10291,10292,10293,10294,10295, +10296,10297,10298,10299,10300,10301,10302,10303,10304,10305,10306,10307, +10308,10309,10310,10311,10312,10313,10314,10315,10316,10317,10318,10319, +10320,10321,10322,10323,10324,10325,10326,10327,10328,10329,10330,10331, +10332,10333,10334,10335,10336,10337,10338,10339,10340,10341,10342,10343, +10344,10345,10346,10347,10348,10349,10350,10351,10352,10353,10354,10355, +10356,10357,10358,10359,10360,10361,10362,10363,10364,10365,10366,10367, +10368,10369,10370,10371,10372,10373,10374,10375,10376,10377,10378,10379, +10380,10381,10382,10383,10384,10385,10386,10387,10388,10389,10390,10391, +10392,10393,10394,10395,10396,10397,10398,10399,10400,10401,10402,10403, +10404,10405,10406,10407,10408,10409,10410,10411,10412,10413,10414,10415, +10416,10417,10418,10419,10420,10421,10422,10423,10424,10425,10426,10427, +10428,10429,10430,10431,10432,10433,10434,10435,10436,10437,10438,10439, +10440,10441,10442,10443,10444,10445,10446,10447,10448,10449,10450,10451, +10452,10453,10454,10455,10456,10457,10458,10459,10460,10461,10462,10463, +10464,10465,10466,10467,10468,10469,10470,10471,10472,10473,10474,10475, +10476,10477,10478,10479,10480,10481,10482,10483,10484,10485,10486,10487, +10488,10489,10490,10491,10492,10493,10494,10495,10496,10497,10498,10499, +10500,10501,10502,10503,10504,10505,10506,10507,10508,10509,10510,10511, +10512,10513,10514,10515,10516,10517,10518,10519,10520,10521,10522,10523, +10524,10525,10526,10527,10528,10529,10530,10531,10532,10533,10534,10535, +10536,10537,10538,10539,10540,10541,10542,10543,10544,10545,10546,10547, +10548,10549,10550,10551,10552,10553,10554,10555,10556,10557,10558,10559, +10560,10561,10562,10563,10564,10565,10566,10567,10568,10569,10570,10571, +10572,10573,10574,10575,10576,10577,10578,10579,10580,10581,10582,10583, +10584,10585,10586,10587,10588,10589,10590,10591,10592,10593,10594,10595, +10596,10597,10598,10599,10600,10601,10602,10603,10604,10605,10606,10607, +10608,10609,10610,10611,10612,10613,10614,10615,10616,10617,10618,10619, +10620,10621,10622,10623,10624,10625,10626,10627,10628,10629,10630,10631, +10632,10633,10634,10635,10636,10637,10638,10639,10640,10641,10642,10643, +10644,10645,10646,10647,10648,10649,10650,10651,10652,10653,10654,10655, +10656,10657,10658,10659,10660,10661,10662,10663,10664,10665,10666,10667, +10668,10669,10670,10671,10672,10673,10674,10675,10676,10677,10678,10679, +10680,10681,10682,10683,10684,10685,10686,10687,10688,10689,10690,10691, +10692,10693,10694,10695,10696,10697,10698,10699,10700,10701,10702,10703, +10704,10705,10706,10707,10708,10709,10710,10711,10712,10713,10714,10715, +10716,10717,10718,10719,10720,10721,10722,10723,10724,10725,10726,10727, +10728,10729,10730,10731,10732,10733,10734,10735,10736,10737,10738,10739, +10740,10741,10742,10743,10744,10745,10746,10747,10748,10749,10750,10751, +10752,10753,10754,10755,10756,10757,10758,10759,10760,10761,10762,10763, +10764,10765,10766,10767,10768,10769,10770,10771,10772,10773,10774,10775, +10776,10777,10778,10779,10780,10781,10782,10783,10784,10785,10786,10787, +10788,10789,10790,10791,10792,10793,10794,10795,10796,10797,10798,10799, +10800,10801,10802,10803,10804,10805,10806,10807,10808,10809,10810,10811, +10812,10813,10814,10815,10816,10817,10818,10819,10820,10821,10822,10823, +10824,10825,10826,10827,10828,10829,10830,10831,10832,10833,10834,10835, +10836,10837,10838,10839,10840,10841,10842,10843,10844,10845,10846,10847, +10848,10849,10850,10851,10852,10853,10854,10855,10856,10857,10858,10859, +10860,10861,10862,10863,10864,10865,10866,10867,10868,10869,10870,10871, +10872,10873,10874,10875,10876,10877,10878,10879,10880,10881,10882,10883, +10884,10885,10886,10887,10888,10889,10890,10891,10892,10893,10894,10895, +10896,10897,10898,10899,10900,10901,10902,10903,10904,10905,10906,10907, +10908,10909,10910,10911,10912,10913,10914,10915,10916,10917,10918,10919, +10920,10921,10922,10923,10924,10925,10926,10927,10928,10929,10930,10931, +10932,10933,10934,10935,10936,10937,10938,10939,10940,10941,10942,10943, +10944,10945,10946,10947,10948,10949,10950,10951,10952,10953,10954,10955, +10956,10957,10958,10959,10960,10961,10962,10963,10964,10965,10966,10967, +10968,10969,10970,10971,10972,10973,10974,10975,10976,10977,10978,10979, +10980,10981,10982,10983,10984,10985,10986,10987,10988,10989,10990,10991, +10992,10993,10994,10995,10996,10997,10998,10999,11000,11001,11002,11003, +11004,11005,11006,11007,11008,11009,11010,11011,11012,11013,11014,11015, +11016,11017,11018,11019,11020,11021,11022,11023,11024,11025,11026,11027, +11028,11029,11030,11031,11032,11033,11034,11035,11036,11037,11038,11039, +11040,11041,11042,11043,11044,11045,11046,11047,11048,11049,11050,11051, +11052,11053,11054,11055,11056,11057,11058,11059,11060,11061,11062,11063, +11064,11065,11066,11067,11068,11069,11070,11071,11072,11073,11074,11075, +11076,11077,11078,11079,11080,11081,11082,11083,11084,11085,11086,11087, +11088,11089,11090,11091,11092,11093,11094,11095,11096,11097,11098,11099, +11100,11101,11102,11103,11104,11105,11106,11107,11108,11109,11110,11111, +11112,11113,11114,11115,11116,11117,11118,11119,11120,11121,11122,11123, +11124,11125,11126,11127,11128,11129,11130,11131,11132,11133,11134,11135, +11136,11137,11138,11139,11140,11141,11142,11143,11144,11145,11146,11147, +11148,11149,11150,11151,11152,11153,11154,11155,11156,11157,11158,11159, +11160,11161,11162,11163,11164,11165,11166,11167,11168,11169,11170,11171, +11172,11173,11174,11175,11176,11177,11178,11179,11180,11181,11182,11183, +11184,11185,11186,11187,11188,11189,11190,11191,11192,11193,11194,11195, +11196,11197,11198,11199,11200,11201,11202,11203,11204,11205,11206,11207, +11208,11209,11210,11211,11212,11213,11214,11215,11216,11217,11218,11219, +11220,11221,11222,11223,11224,11225,11226,11227,11228,11229,11230,11231, +11232,11233,11234,11235,11236,11237,11238,11239,11240,11241,11242,11243, +11244,11245,11246,11247,11248,11249,11250,11251,11252,11253,11254,11255, +11256,11257,11258,11259,11260,11261,11262,11263,11264,11265,11266,11267, +11268,11269,11270,11271,11272,11273,11274,11275,11276,11277,11278,11279, +11280,11281,11282,11283,11284,11285,11286,11287,11288,11289,11290,11291, +11292,11293,11294,11295,11296,11297,11298,11299,11300,11301,11302,11303, +11304,11305,11306,11307,11308,11309,11310,11311,11264,11265,11266,11267, +11268,11269,11270,11271,11272,11273,11274,11275,11276,11277,11278,11279, +11280,11281,11282,11283,11284,11285,11286,11287,11288,11289,11290,11291, +11292,11293,11294,11295,11296,11297,11298,11299,11300,11301,11302,11303, +11304,11305,11306,11307,11308,11309,11310,11359,11360,11360,11362,11363, +11364,570,574,11367,11367,11369,11369,11371,11371,11373,11374,11375,11376, +11377,11378,11378,11380,11381,11381,11383,11384,11385,11386,11387,11388, +11389,11390,11391,11392,11392,11394,11394,11396,11396,11398,11398,11400, +11400,11402,11402,11404,11404,11406,11406,11408,11408,11410,11410,11412, +11412,11414,11414,11416,11416,11418,11418,11420,11420,11422,11422,11424, +11424,11426,11426,11428,11428,11430,11430,11432,11432,11434,11434,11436, +11436,11438,11438,11440,11440,11442,11442,11444,11444,11446,11446,11448, +11448,11450,11450,11452,11452,11454,11454,11456,11456,11458,11458,11460, +11460,11462,11462,11464,11464,11466,11466,11468,11468,11470,11470,11472, +11472,11474,11474,11476,11476,11478,11478,11480,11480,11482,11482,11484, +11484,11486,11486,11488,11488,11490,11490,11492,11493,11494,11495,11496, +11497,11498,11499,11499,11501,11501,11503,11504,11505,11506,11506,11508, +11509,11510,11511,11512,11513,11514,11515,11516,11517,11518,11519,4256, +4257,4258,4259,4260,4261,4262,4263,4264,4265,4266,4267,4268,4269,4270,4271, +4272,4273,4274,4275,4276,4277,4278,4279,4280,4281,4282,4283,4284,4285,4286, +4287,4288,4289,4290,4291,4292,4293,11558,4295,11560,11561,11562,11563, +11564,4301,11566,11567,11568,11569,11570,11571,11572,11573,11574,11575, +11576,11577,11578,11579,11580,11581,11582,11583,11584,11585,11586,11587, +11588,11589,11590,11591,11592,11593,11594,11595,11596,11597,11598,11599, +11600,11601,11602,11603,11604,11605,11606,11607,11608,11609,11610,11611, +11612,11613,11614,11615,11616,11617,11618,11619,11620,11621,11622,11623, +11624,11625,11626,11627,11628,11629,11630,11631,11632,11633,11634,11635, +11636,11637,11638,11639,11640,11641,11642,11643,11644,11645,11646,11647, +11648,11649,11650,11651,11652,11653,11654,11655,11656,11657,11658,11659, +11660,11661,11662,11663,11664,11665,11666,11667,11668,11669,11670,11671, +11672,11673,11674,11675,11676,11677,11678,11679,11680,11681,11682,11683, +11684,11685,11686,11687,11688,11689,11690,11691,11692,11693,11694,11695, +11696,11697,11698,11699,11700,11701,11702,11703,11704,11705,11706,11707, +11708,11709,11710,11711,11712,11713,11714,11715,11716,11717,11718,11719, +11720,11721,11722,11723,11724,11725,11726,11727,11728,11729,11730,11731, +11732,11733,11734,11735,11736,11737,11738,11739,11740,11741,11742,11743, +11744,11745,11746,11747,11748,11749,11750,11751,11752,11753,11754,11755, +11756,11757,11758,11759,11760,11761,11762,11763,11764,11765,11766,11767, +11768,11769,11770,11771,11772,11773,11774,11775,11776,11777,11778,11779, +11780,11781,11782,11783,11784,11785,11786,11787,11788,11789,11790,11791, +11792,11793,11794,11795,11796,11797,11798,11799,11800,11801,11802,11803, +11804,11805,11806,11807,11808,11809,11810,11811,11812,11813,11814,11815, +11816,11817,11818,11819,11820,11821,11822,11823,11824,11825,11826,11827, +11828,11829,11830,11831,11832,11833,11834,11835,11836,11837,11838,11839, +11840,11841,11842,11843,11844,11845,11846,11847,11848,11849,11850,11851, +11852,11853,11854,11855,11856,11857,11858,11859,11860,11861,11862,11863, +11864,11865,11866,11867,11868,11869,11870,11871,11872,11873,11874,11875, +11876,11877,11878,11879,11880,11881,11882,11883,11884,11885,11886,11887, +11888,11889,11890,11891,11892,11893,11894,11895,11896,11897,11898,11899, +11900,11901,11902,11903,11904,11905,11906,11907,11908,11909,11910,11911, +11912,11913,11914,11915,11916,11917,11918,11919,11920,11921,11922,11923, +11924,11925,11926,11927,11928,11929,11930,11931,11932,11933,11934,11935, +11936,11937,11938,11939,11940,11941,11942,11943,11944,11945,11946,11947, +11948,11949,11950,11951,11952,11953,11954,11955,11956,11957,11958,11959, +11960,11961,11962,11963,11964,11965,11966,11967,11968,11969,11970,11971, +11972,11973,11974,11975,11976,11977,11978,11979,11980,11981,11982,11983, +11984,11985,11986,11987,11988,11989,11990,11991,11992,11993,11994,11995, +11996,11997,11998,11999,12000,12001,12002,12003,12004,12005,12006,12007, +12008,12009,12010,12011,12012,12013,12014,12015,12016,12017,12018,12019, +12020,12021,12022,12023,12024,12025,12026,12027,12028,12029,12030,12031, +12032,12033,12034,12035,12036,12037,12038,12039,12040,12041,12042,12043, +12044,12045,12046,12047,12048,12049,12050,12051,12052,12053,12054,12055, +12056,12057,12058,12059,12060,12061,12062,12063,12064,12065,12066,12067, +12068,12069,12070,12071,12072,12073,12074,12075,12076,12077,12078,12079, +12080,12081,12082,12083,12084,12085,12086,12087,12088,12089,12090,12091, +12092,12093,12094,12095,12096,12097,12098,12099,12100,12101,12102,12103, +12104,12105,12106,12107,12108,12109,12110,12111,12112,12113,12114,12115, +12116,12117,12118,12119,12120,12121,12122,12123,12124,12125,12126,12127, +12128,12129,12130,12131,12132,12133,12134,12135,12136,12137,12138,12139, +12140,12141,12142,12143,12144,12145,12146,12147,12148,12149,12150,12151, +12152,12153,12154,12155,12156,12157,12158,12159,12160,12161,12162,12163, +12164,12165,12166,12167,12168,12169,12170,12171,12172,12173,12174,12175, +12176,12177,12178,12179,12180,12181,12182,12183,12184,12185,12186,12187, +12188,12189,12190,12191,12192,12193,12194,12195,12196,12197,12198,12199, +12200,12201,12202,12203,12204,12205,12206,12207,12208,12209,12210,12211, +12212,12213,12214,12215,12216,12217,12218,12219,12220,12221,12222,12223, +12224,12225,12226,12227,12228,12229,12230,12231,12232,12233,12234,12235, +12236,12237,12238,12239,12240,12241,12242,12243,12244,12245,12246,12247, +12248,12249,12250,12251,12252,12253,12254,12255,12256,12257,12258,12259, +12260,12261,12262,12263,12264,12265,12266,12267,12268,12269,12270,12271, +12272,12273,12274,12275,12276,12277,12278,12279,12280,12281,12282,12283, +12284,12285,12286,12287,12288,12289,12290,12291,12292,12293,12294,12295, +12296,12297,12298,12299,12300,12301,12302,12303,12304,12305,12306,12307, +12308,12309,12310,12311,12312,12313,12314,12315,12316,12317,12318,12319, +12320,12321,12322,12323,12324,12325,12326,12327,12328,12329,12330,12331, +12332,12333,12334,12335,12336,12337,12338,12339,12340,12341,12342,12343, +12344,12345,12346,12347,12348,12349,12350,12351,12352,12353,12354,12355, +12356,12357,12358,12359,12360,12361,12362,12363,12364,12365,12366,12367, +12368,12369,12370,12371,12372,12373,12374,12375,12376,12377,12378,12379, +12380,12381,12382,12383,12384,12385,12386,12387,12388,12389,12390,12391, +12392,12393,12394,12395,12396,12397,12398,12399,12400,12401,12402,12403, +12404,12405,12406,12407,12408,12409,12410,12411,12412,12413,12414,12415, +12416,12417,12418,12419,12420,12421,12422,12423,12424,12425,12426,12427, +12428,12429,12430,12431,12432,12433,12434,12435,12436,12437,12438,12439, +12440,12441,12442,12443,12444,12445,12446,12447,12448,12449,12450,12451, +12452,12453,12454,12455,12456,12457,12458,12459,12460,12461,12462,12463, +12464,12465,12466,12467,12468,12469,12470,12471,12472,12473,12474,12475, +12476,12477,12478,12479,12480,12481,12482,12483,12484,12485,12486,12487, +12488,12489,12490,12491,12492,12493,12494,12495,12496,12497,12498,12499, +12500,12501,12502,12503,12504,12505,12506,12507,12508,12509,12510,12511, +12512,12513,12514,12515,12516,12517,12518,12519,12520,12521,12522,12523, +12524,12525,12526,12527,12528,12529,12530,12531,12532,12533,12534,12535, +12536,12537,12538,12539,12540,12541,12542,12543,12544,12545,12546,12547, +12548,12549,12550,12551,12552,12553,12554,12555,12556,12557,12558,12559, +12560,12561,12562,12563,12564,12565,12566,12567,12568,12569,12570,12571, +12572,12573,12574,12575,12576,12577,12578,12579,12580,12581,12582,12583, +12584,12585,12586,12587,12588,12589,12590,12591,12592,12593,12594,12595, +12596,12597,12598,12599,12600,12601,12602,12603,12604,12605,12606,12607, +12608,12609,12610,12611,12612,12613,12614,12615,12616,12617,12618,12619, +12620,12621,12622,12623,12624,12625,12626,12627,12628,12629,12630,12631, +12632,12633,12634,12635,12636,12637,12638,12639,12640,12641,12642,12643, +12644,12645,12646,12647,12648,12649,12650,12651,12652,12653,12654,12655, +12656,12657,12658,12659,12660,12661,12662,12663,12664,12665,12666,12667, +12668,12669,12670,12671,12672,12673,12674,12675,12676,12677,12678,12679, +12680,12681,12682,12683,12684,12685,12686,12687,12688,12689,12690,12691, +12692,12693,12694,12695,12696,12697,12698,12699,12700,12701,12702,12703, +12704,12705,12706,12707,12708,12709,12710,12711,12712,12713,12714,12715, +12716,12717,12718,12719,12720,12721,12722,12723,12724,12725,12726,12727, +12728,12729,12730,12731,12732,12733,12734,12735,12736,12737,12738,12739, +12740,12741,12742,12743,12744,12745,12746,12747,12748,12749,12750,12751, +12752,12753,12754,12755,12756,12757,12758,12759,12760,12761,12762,12763, +12764,12765,12766,12767,12768,12769,12770,12771,12772,12773,12774,12775, +12776,12777,12778,12779,12780,12781,12782,12783,12784,12785,12786,12787, +12788,12789,12790,12791,12792,12793,12794,12795,12796,12797,12798,12799, +12800,12801,12802,12803,12804,12805,12806,12807,12808,12809,12810,12811, +12812,12813,12814,12815,12816,12817,12818,12819,12820,12821,12822,12823, +12824,12825,12826,12827,12828,12829,12830,12831,12832,12833,12834,12835, +12836,12837,12838,12839,12840,12841,12842,12843,12844,12845,12846,12847, +12848,12849,12850,12851,12852,12853,12854,12855,12856,12857,12858,12859, +12860,12861,12862,12863,12864,12865,12866,12867,12868,12869,12870,12871, +12872,12873,12874,12875,12876,12877,12878,12879,12880,12881,12882,12883, +12884,12885,12886,12887,12888,12889,12890,12891,12892,12893,12894,12895, +12896,12897,12898,12899,12900,12901,12902,12903,12904,12905,12906,12907, +12908,12909,12910,12911,12912,12913,12914,12915,12916,12917,12918,12919, +12920,12921,12922,12923,12924,12925,12926,12927,12928,12929,12930,12931, +12932,12933,12934,12935,12936,12937,12938,12939,12940,12941,12942,12943, +12944,12945,12946,12947,12948,12949,12950,12951,12952,12953,12954,12955, +12956,12957,12958,12959,12960,12961,12962,12963,12964,12965,12966,12967, +12968,12969,12970,12971,12972,12973,12974,12975,12976,12977,12978,12979, +12980,12981,12982,12983,12984,12985,12986,12987,12988,12989,12990,12991, +12992,12993,12994,12995,12996,12997,12998,12999,13000,13001,13002,13003, +13004,13005,13006,13007,13008,13009,13010,13011,13012,13013,13014,13015, +13016,13017,13018,13019,13020,13021,13022,13023,13024,13025,13026,13027, +13028,13029,13030,13031,13032,13033,13034,13035,13036,13037,13038,13039, +13040,13041,13042,13043,13044,13045,13046,13047,13048,13049,13050,13051, +13052,13053,13054,13055,13056,13057,13058,13059,13060,13061,13062,13063, +13064,13065,13066,13067,13068,13069,13070,13071,13072,13073,13074,13075, +13076,13077,13078,13079,13080,13081,13082,13083,13084,13085,13086,13087, +13088,13089,13090,13091,13092,13093,13094,13095,13096,13097,13098,13099, +13100,13101,13102,13103,13104,13105,13106,13107,13108,13109,13110,13111, +13112,13113,13114,13115,13116,13117,13118,13119,13120,13121,13122,13123, +13124,13125,13126,13127,13128,13129,13130,13131,13132,13133,13134,13135, +13136,13137,13138,13139,13140,13141,13142,13143,13144,13145,13146,13147, +13148,13149,13150,13151,13152,13153,13154,13155,13156,13157,13158,13159, +13160,13161,13162,13163,13164,13165,13166,13167,13168,13169,13170,13171, +13172,13173,13174,13175,13176,13177,13178,13179,13180,13181,13182,13183, +13184,13185,13186,13187,13188,13189,13190,13191,13192,13193,13194,13195, +13196,13197,13198,13199,13200,13201,13202,13203,13204,13205,13206,13207, +13208,13209,13210,13211,13212,13213,13214,13215,13216,13217,13218,13219, +13220,13221,13222,13223,13224,13225,13226,13227,13228,13229,13230,13231, +13232,13233,13234,13235,13236,13237,13238,13239,13240,13241,13242,13243, +13244,13245,13246,13247,13248,13249,13250,13251,13252,13253,13254,13255, +13256,13257,13258,13259,13260,13261,13262,13263,13264,13265,13266,13267, +13268,13269,13270,13271,13272,13273,13274,13275,13276,13277,13278,13279, +13280,13281,13282,13283,13284,13285,13286,13287,13288,13289,13290,13291, +13292,13293,13294,13295,13296,13297,13298,13299,13300,13301,13302,13303, +13304,13305,13306,13307,13308,13309,13310,13311,13312,13313,13314,13315, +13316,13317,13318,13319,13320,13321,13322,13323,13324,13325,13326,13327, +13328,13329,13330,13331,13332,13333,13334,13335,13336,13337,13338,13339, +13340,13341,13342,13343,13344,13345,13346,13347,13348,13349,13350,13351, +13352,13353,13354,13355,13356,13357,13358,13359,13360,13361,13362,13363, +13364,13365,13366,13367,13368,13369,13370,13371,13372,13373,13374,13375, +13376,13377,13378,13379,13380,13381,13382,13383,13384,13385,13386,13387, +13388,13389,13390,13391,13392,13393,13394,13395,13396,13397,13398,13399, +13400,13401,13402,13403,13404,13405,13406,13407,13408,13409,13410,13411, +13412,13413,13414,13415,13416,13417,13418,13419,13420,13421,13422,13423, +13424,13425,13426,13427,13428,13429,13430,13431,13432,13433,13434,13435, +13436,13437,13438,13439,13440,13441,13442,13443,13444,13445,13446,13447, +13448,13449,13450,13451,13452,13453,13454,13455,13456,13457,13458,13459, +13460,13461,13462,13463,13464,13465,13466,13467,13468,13469,13470,13471, +13472,13473,13474,13475,13476,13477,13478,13479,13480,13481,13482,13483, +13484,13485,13486,13487,13488,13489,13490,13491,13492,13493,13494,13495, +13496,13497,13498,13499,13500,13501,13502,13503,13504,13505,13506,13507, +13508,13509,13510,13511,13512,13513,13514,13515,13516,13517,13518,13519, +13520,13521,13522,13523,13524,13525,13526,13527,13528,13529,13530,13531, +13532,13533,13534,13535,13536,13537,13538,13539,13540,13541,13542,13543, +13544,13545,13546,13547,13548,13549,13550,13551,13552,13553,13554,13555, +13556,13557,13558,13559,13560,13561,13562,13563,13564,13565,13566,13567, +13568,13569,13570,13571,13572,13573,13574,13575,13576,13577,13578,13579, +13580,13581,13582,13583,13584,13585,13586,13587,13588,13589,13590,13591, +13592,13593,13594,13595,13596,13597,13598,13599,13600,13601,13602,13603, +13604,13605,13606,13607,13608,13609,13610,13611,13612,13613,13614,13615, +13616,13617,13618,13619,13620,13621,13622,13623,13624,13625,13626,13627, +13628,13629,13630,13631,13632,13633,13634,13635,13636,13637,13638,13639, +13640,13641,13642,13643,13644,13645,13646,13647,13648,13649,13650,13651, +13652,13653,13654,13655,13656,13657,13658,13659,13660,13661,13662,13663, +13664,13665,13666,13667,13668,13669,13670,13671,13672,13673,13674,13675, +13676,13677,13678,13679,13680,13681,13682,13683,13684,13685,13686,13687, +13688,13689,13690,13691,13692,13693,13694,13695,13696,13697,13698,13699, +13700,13701,13702,13703,13704,13705,13706,13707,13708,13709,13710,13711, +13712,13713,13714,13715,13716,13717,13718,13719,13720,13721,13722,13723, +13724,13725,13726,13727,13728,13729,13730,13731,13732,13733,13734,13735, +13736,13737,13738,13739,13740,13741,13742,13743,13744,13745,13746,13747, +13748,13749,13750,13751,13752,13753,13754,13755,13756,13757,13758,13759, +13760,13761,13762,13763,13764,13765,13766,13767,13768,13769,13770,13771, +13772,13773,13774,13775,13776,13777,13778,13779,13780,13781,13782,13783, +13784,13785,13786,13787,13788,13789,13790,13791,13792,13793,13794,13795, +13796,13797,13798,13799,13800,13801,13802,13803,13804,13805,13806,13807, +13808,13809,13810,13811,13812,13813,13814,13815,13816,13817,13818,13819, +13820,13821,13822,13823,13824,13825,13826,13827,13828,13829,13830,13831, +13832,13833,13834,13835,13836,13837,13838,13839,13840,13841,13842,13843, +13844,13845,13846,13847,13848,13849,13850,13851,13852,13853,13854,13855, +13856,13857,13858,13859,13860,13861,13862,13863,13864,13865,13866,13867, +13868,13869,13870,13871,13872,13873,13874,13875,13876,13877,13878,13879, +13880,13881,13882,13883,13884,13885,13886,13887,13888,13889,13890,13891, +13892,13893,13894,13895,13896,13897,13898,13899,13900,13901,13902,13903, +13904,13905,13906,13907,13908,13909,13910,13911,13912,13913,13914,13915, +13916,13917,13918,13919,13920,13921,13922,13923,13924,13925,13926,13927, +13928,13929,13930,13931,13932,13933,13934,13935,13936,13937,13938,13939, +13940,13941,13942,13943,13944,13945,13946,13947,13948,13949,13950,13951, +13952,13953,13954,13955,13956,13957,13958,13959,13960,13961,13962,13963, +13964,13965,13966,13967,13968,13969,13970,13971,13972,13973,13974,13975, +13976,13977,13978,13979,13980,13981,13982,13983,13984,13985,13986,13987, +13988,13989,13990,13991,13992,13993,13994,13995,13996,13997,13998,13999, +14000,14001,14002,14003,14004,14005,14006,14007,14008,14009,14010,14011, +14012,14013,14014,14015,14016,14017,14018,14019,14020,14021,14022,14023, +14024,14025,14026,14027,14028,14029,14030,14031,14032,14033,14034,14035, +14036,14037,14038,14039,14040,14041,14042,14043,14044,14045,14046,14047, +14048,14049,14050,14051,14052,14053,14054,14055,14056,14057,14058,14059, +14060,14061,14062,14063,14064,14065,14066,14067,14068,14069,14070,14071, +14072,14073,14074,14075,14076,14077,14078,14079,14080,14081,14082,14083, +14084,14085,14086,14087,14088,14089,14090,14091,14092,14093,14094,14095, +14096,14097,14098,14099,14100,14101,14102,14103,14104,14105,14106,14107, +14108,14109,14110,14111,14112,14113,14114,14115,14116,14117,14118,14119, +14120,14121,14122,14123,14124,14125,14126,14127,14128,14129,14130,14131, +14132,14133,14134,14135,14136,14137,14138,14139,14140,14141,14142,14143, +14144,14145,14146,14147,14148,14149,14150,14151,14152,14153,14154,14155, +14156,14157,14158,14159,14160,14161,14162,14163,14164,14165,14166,14167, +14168,14169,14170,14171,14172,14173,14174,14175,14176,14177,14178,14179, +14180,14181,14182,14183,14184,14185,14186,14187,14188,14189,14190,14191, +14192,14193,14194,14195,14196,14197,14198,14199,14200,14201,14202,14203, +14204,14205,14206,14207,14208,14209,14210,14211,14212,14213,14214,14215, +14216,14217,14218,14219,14220,14221,14222,14223,14224,14225,14226,14227, +14228,14229,14230,14231,14232,14233,14234,14235,14236,14237,14238,14239, +14240,14241,14242,14243,14244,14245,14246,14247,14248,14249,14250,14251, +14252,14253,14254,14255,14256,14257,14258,14259,14260,14261,14262,14263, +14264,14265,14266,14267,14268,14269,14270,14271,14272,14273,14274,14275, +14276,14277,14278,14279,14280,14281,14282,14283,14284,14285,14286,14287, +14288,14289,14290,14291,14292,14293,14294,14295,14296,14297,14298,14299, +14300,14301,14302,14303,14304,14305,14306,14307,14308,14309,14310,14311, +14312,14313,14314,14315,14316,14317,14318,14319,14320,14321,14322,14323, +14324,14325,14326,14327,14328,14329,14330,14331,14332,14333,14334,14335, +14336,14337,14338,14339,14340,14341,14342,14343,14344,14345,14346,14347, +14348,14349,14350,14351,14352,14353,14354,14355,14356,14357,14358,14359, +14360,14361,14362,14363,14364,14365,14366,14367,14368,14369,14370,14371, +14372,14373,14374,14375,14376,14377,14378,14379,14380,14381,14382,14383, +14384,14385,14386,14387,14388,14389,14390,14391,14392,14393,14394,14395, +14396,14397,14398,14399,14400,14401,14402,14403,14404,14405,14406,14407, +14408,14409,14410,14411,14412,14413,14414,14415,14416,14417,14418,14419, +14420,14421,14422,14423,14424,14425,14426,14427,14428,14429,14430,14431, +14432,14433,14434,14435,14436,14437,14438,14439,14440,14441,14442,14443, +14444,14445,14446,14447,14448,14449,14450,14451,14452,14453,14454,14455, +14456,14457,14458,14459,14460,14461,14462,14463,14464,14465,14466,14467, +14468,14469,14470,14471,14472,14473,14474,14475,14476,14477,14478,14479, +14480,14481,14482,14483,14484,14485,14486,14487,14488,14489,14490,14491, +14492,14493,14494,14495,14496,14497,14498,14499,14500,14501,14502,14503, +14504,14505,14506,14507,14508,14509,14510,14511,14512,14513,14514,14515, +14516,14517,14518,14519,14520,14521,14522,14523,14524,14525,14526,14527, +14528,14529,14530,14531,14532,14533,14534,14535,14536,14537,14538,14539, +14540,14541,14542,14543,14544,14545,14546,14547,14548,14549,14550,14551, +14552,14553,14554,14555,14556,14557,14558,14559,14560,14561,14562,14563, +14564,14565,14566,14567,14568,14569,14570,14571,14572,14573,14574,14575, +14576,14577,14578,14579,14580,14581,14582,14583,14584,14585,14586,14587, +14588,14589,14590,14591,14592,14593,14594,14595,14596,14597,14598,14599, +14600,14601,14602,14603,14604,14605,14606,14607,14608,14609,14610,14611, +14612,14613,14614,14615,14616,14617,14618,14619,14620,14621,14622,14623, +14624,14625,14626,14627,14628,14629,14630,14631,14632,14633,14634,14635, +14636,14637,14638,14639,14640,14641,14642,14643,14644,14645,14646,14647, +14648,14649,14650,14651,14652,14653,14654,14655,14656,14657,14658,14659, +14660,14661,14662,14663,14664,14665,14666,14667,14668,14669,14670,14671, +14672,14673,14674,14675,14676,14677,14678,14679,14680,14681,14682,14683, +14684,14685,14686,14687,14688,14689,14690,14691,14692,14693,14694,14695, +14696,14697,14698,14699,14700,14701,14702,14703,14704,14705,14706,14707, +14708,14709,14710,14711,14712,14713,14714,14715,14716,14717,14718,14719, +14720,14721,14722,14723,14724,14725,14726,14727,14728,14729,14730,14731, +14732,14733,14734,14735,14736,14737,14738,14739,14740,14741,14742,14743, +14744,14745,14746,14747,14748,14749,14750,14751,14752,14753,14754,14755, +14756,14757,14758,14759,14760,14761,14762,14763,14764,14765,14766,14767, +14768,14769,14770,14771,14772,14773,14774,14775,14776,14777,14778,14779, +14780,14781,14782,14783,14784,14785,14786,14787,14788,14789,14790,14791, +14792,14793,14794,14795,14796,14797,14798,14799,14800,14801,14802,14803, +14804,14805,14806,14807,14808,14809,14810,14811,14812,14813,14814,14815, +14816,14817,14818,14819,14820,14821,14822,14823,14824,14825,14826,14827, +14828,14829,14830,14831,14832,14833,14834,14835,14836,14837,14838,14839, +14840,14841,14842,14843,14844,14845,14846,14847,14848,14849,14850,14851, +14852,14853,14854,14855,14856,14857,14858,14859,14860,14861,14862,14863, +14864,14865,14866,14867,14868,14869,14870,14871,14872,14873,14874,14875, +14876,14877,14878,14879,14880,14881,14882,14883,14884,14885,14886,14887, +14888,14889,14890,14891,14892,14893,14894,14895,14896,14897,14898,14899, +14900,14901,14902,14903,14904,14905,14906,14907,14908,14909,14910,14911, +14912,14913,14914,14915,14916,14917,14918,14919,14920,14921,14922,14923, +14924,14925,14926,14927,14928,14929,14930,14931,14932,14933,14934,14935, +14936,14937,14938,14939,14940,14941,14942,14943,14944,14945,14946,14947, +14948,14949,14950,14951,14952,14953,14954,14955,14956,14957,14958,14959, +14960,14961,14962,14963,14964,14965,14966,14967,14968,14969,14970,14971, +14972,14973,14974,14975,14976,14977,14978,14979,14980,14981,14982,14983, +14984,14985,14986,14987,14988,14989,14990,14991,14992,14993,14994,14995, +14996,14997,14998,14999,15000,15001,15002,15003,15004,15005,15006,15007, +15008,15009,15010,15011,15012,15013,15014,15015,15016,15017,15018,15019, +15020,15021,15022,15023,15024,15025,15026,15027,15028,15029,15030,15031, +15032,15033,15034,15035,15036,15037,15038,15039,15040,15041,15042,15043, +15044,15045,15046,15047,15048,15049,15050,15051,15052,15053,15054,15055, +15056,15057,15058,15059,15060,15061,15062,15063,15064,15065,15066,15067, +15068,15069,15070,15071,15072,15073,15074,15075,15076,15077,15078,15079, +15080,15081,15082,15083,15084,15085,15086,15087,15088,15089,15090,15091, +15092,15093,15094,15095,15096,15097,15098,15099,15100,15101,15102,15103, +15104,15105,15106,15107,15108,15109,15110,15111,15112,15113,15114,15115, +15116,15117,15118,15119,15120,15121,15122,15123,15124,15125,15126,15127, +15128,15129,15130,15131,15132,15133,15134,15135,15136,15137,15138,15139, +15140,15141,15142,15143,15144,15145,15146,15147,15148,15149,15150,15151, +15152,15153,15154,15155,15156,15157,15158,15159,15160,15161,15162,15163, +15164,15165,15166,15167,15168,15169,15170,15171,15172,15173,15174,15175, +15176,15177,15178,15179,15180,15181,15182,15183,15184,15185,15186,15187, +15188,15189,15190,15191,15192,15193,15194,15195,15196,15197,15198,15199, +15200,15201,15202,15203,15204,15205,15206,15207,15208,15209,15210,15211, +15212,15213,15214,15215,15216,15217,15218,15219,15220,15221,15222,15223, +15224,15225,15226,15227,15228,15229,15230,15231,15232,15233,15234,15235, +15236,15237,15238,15239,15240,15241,15242,15243,15244,15245,15246,15247, +15248,15249,15250,15251,15252,15253,15254,15255,15256,15257,15258,15259, +15260,15261,15262,15263,15264,15265,15266,15267,15268,15269,15270,15271, +15272,15273,15274,15275,15276,15277,15278,15279,15280,15281,15282,15283, +15284,15285,15286,15287,15288,15289,15290,15291,15292,15293,15294,15295, +15296,15297,15298,15299,15300,15301,15302,15303,15304,15305,15306,15307, +15308,15309,15310,15311,15312,15313,15314,15315,15316,15317,15318,15319, +15320,15321,15322,15323,15324,15325,15326,15327,15328,15329,15330,15331, +15332,15333,15334,15335,15336,15337,15338,15339,15340,15341,15342,15343, +15344,15345,15346,15347,15348,15349,15350,15351,15352,15353,15354,15355, +15356,15357,15358,15359,15360,15361,15362,15363,15364,15365,15366,15367, +15368,15369,15370,15371,15372,15373,15374,15375,15376,15377,15378,15379, +15380,15381,15382,15383,15384,15385,15386,15387,15388,15389,15390,15391, +15392,15393,15394,15395,15396,15397,15398,15399,15400,15401,15402,15403, +15404,15405,15406,15407,15408,15409,15410,15411,15412,15413,15414,15415, +15416,15417,15418,15419,15420,15421,15422,15423,15424,15425,15426,15427, +15428,15429,15430,15431,15432,15433,15434,15435,15436,15437,15438,15439, +15440,15441,15442,15443,15444,15445,15446,15447,15448,15449,15450,15451, +15452,15453,15454,15455,15456,15457,15458,15459,15460,15461,15462,15463, +15464,15465,15466,15467,15468,15469,15470,15471,15472,15473,15474,15475, +15476,15477,15478,15479,15480,15481,15482,15483,15484,15485,15486,15487, +15488,15489,15490,15491,15492,15493,15494,15495,15496,15497,15498,15499, +15500,15501,15502,15503,15504,15505,15506,15507,15508,15509,15510,15511, +15512,15513,15514,15515,15516,15517,15518,15519,15520,15521,15522,15523, +15524,15525,15526,15527,15528,15529,15530,15531,15532,15533,15534,15535, +15536,15537,15538,15539,15540,15541,15542,15543,15544,15545,15546,15547, +15548,15549,15550,15551,15552,15553,15554,15555,15556,15557,15558,15559, +15560,15561,15562,15563,15564,15565,15566,15567,15568,15569,15570,15571, +15572,15573,15574,15575,15576,15577,15578,15579,15580,15581,15582,15583, +15584,15585,15586,15587,15588,15589,15590,15591,15592,15593,15594,15595, +15596,15597,15598,15599,15600,15601,15602,15603,15604,15605,15606,15607, +15608,15609,15610,15611,15612,15613,15614,15615,15616,15617,15618,15619, +15620,15621,15622,15623,15624,15625,15626,15627,15628,15629,15630,15631, +15632,15633,15634,15635,15636,15637,15638,15639,15640,15641,15642,15643, +15644,15645,15646,15647,15648,15649,15650,15651,15652,15653,15654,15655, +15656,15657,15658,15659,15660,15661,15662,15663,15664,15665,15666,15667, +15668,15669,15670,15671,15672,15673,15674,15675,15676,15677,15678,15679, +15680,15681,15682,15683,15684,15685,15686,15687,15688,15689,15690,15691, +15692,15693,15694,15695,15696,15697,15698,15699,15700,15701,15702,15703, +15704,15705,15706,15707,15708,15709,15710,15711,15712,15713,15714,15715, +15716,15717,15718,15719,15720,15721,15722,15723,15724,15725,15726,15727, +15728,15729,15730,15731,15732,15733,15734,15735,15736,15737,15738,15739, +15740,15741,15742,15743,15744,15745,15746,15747,15748,15749,15750,15751, +15752,15753,15754,15755,15756,15757,15758,15759,15760,15761,15762,15763, +15764,15765,15766,15767,15768,15769,15770,15771,15772,15773,15774,15775, +15776,15777,15778,15779,15780,15781,15782,15783,15784,15785,15786,15787, +15788,15789,15790,15791,15792,15793,15794,15795,15796,15797,15798,15799, +15800,15801,15802,15803,15804,15805,15806,15807,15808,15809,15810,15811, +15812,15813,15814,15815,15816,15817,15818,15819,15820,15821,15822,15823, +15824,15825,15826,15827,15828,15829,15830,15831,15832,15833,15834,15835, +15836,15837,15838,15839,15840,15841,15842,15843,15844,15845,15846,15847, +15848,15849,15850,15851,15852,15853,15854,15855,15856,15857,15858,15859, +15860,15861,15862,15863,15864,15865,15866,15867,15868,15869,15870,15871, +15872,15873,15874,15875,15876,15877,15878,15879,15880,15881,15882,15883, +15884,15885,15886,15887,15888,15889,15890,15891,15892,15893,15894,15895, +15896,15897,15898,15899,15900,15901,15902,15903,15904,15905,15906,15907, +15908,15909,15910,15911,15912,15913,15914,15915,15916,15917,15918,15919, +15920,15921,15922,15923,15924,15925,15926,15927,15928,15929,15930,15931, +15932,15933,15934,15935,15936,15937,15938,15939,15940,15941,15942,15943, +15944,15945,15946,15947,15948,15949,15950,15951,15952,15953,15954,15955, +15956,15957,15958,15959,15960,15961,15962,15963,15964,15965,15966,15967, +15968,15969,15970,15971,15972,15973,15974,15975,15976,15977,15978,15979, +15980,15981,15982,15983,15984,15985,15986,15987,15988,15989,15990,15991, +15992,15993,15994,15995,15996,15997,15998,15999,16000,16001,16002,16003, +16004,16005,16006,16007,16008,16009,16010,16011,16012,16013,16014,16015, +16016,16017,16018,16019,16020,16021,16022,16023,16024,16025,16026,16027, +16028,16029,16030,16031,16032,16033,16034,16035,16036,16037,16038,16039, +16040,16041,16042,16043,16044,16045,16046,16047,16048,16049,16050,16051, +16052,16053,16054,16055,16056,16057,16058,16059,16060,16061,16062,16063, +16064,16065,16066,16067,16068,16069,16070,16071,16072,16073,16074,16075, +16076,16077,16078,16079,16080,16081,16082,16083,16084,16085,16086,16087, +16088,16089,16090,16091,16092,16093,16094,16095,16096,16097,16098,16099, +16100,16101,16102,16103,16104,16105,16106,16107,16108,16109,16110,16111, +16112,16113,16114,16115,16116,16117,16118,16119,16120,16121,16122,16123, +16124,16125,16126,16127,16128,16129,16130,16131,16132,16133,16134,16135, +16136,16137,16138,16139,16140,16141,16142,16143,16144,16145,16146,16147, +16148,16149,16150,16151,16152,16153,16154,16155,16156,16157,16158,16159, +16160,16161,16162,16163,16164,16165,16166,16167,16168,16169,16170,16171, +16172,16173,16174,16175,16176,16177,16178,16179,16180,16181,16182,16183, +16184,16185,16186,16187,16188,16189,16190,16191,16192,16193,16194,16195, +16196,16197,16198,16199,16200,16201,16202,16203,16204,16205,16206,16207, +16208,16209,16210,16211,16212,16213,16214,16215,16216,16217,16218,16219, +16220,16221,16222,16223,16224,16225,16226,16227,16228,16229,16230,16231, +16232,16233,16234,16235,16236,16237,16238,16239,16240,16241,16242,16243, +16244,16245,16246,16247,16248,16249,16250,16251,16252,16253,16254,16255, +16256,16257,16258,16259,16260,16261,16262,16263,16264,16265,16266,16267, +16268,16269,16270,16271,16272,16273,16274,16275,16276,16277,16278,16279, +16280,16281,16282,16283,16284,16285,16286,16287,16288,16289,16290,16291, +16292,16293,16294,16295,16296,16297,16298,16299,16300,16301,16302,16303, +16304,16305,16306,16307,16308,16309,16310,16311,16312,16313,16314,16315, +16316,16317,16318,16319,16320,16321,16322,16323,16324,16325,16326,16327, +16328,16329,16330,16331,16332,16333,16334,16335,16336,16337,16338,16339, +16340,16341,16342,16343,16344,16345,16346,16347,16348,16349,16350,16351, +16352,16353,16354,16355,16356,16357,16358,16359,16360,16361,16362,16363, +16364,16365,16366,16367,16368,16369,16370,16371,16372,16373,16374,16375, +16376,16377,16378,16379,16380,16381,16382,16383,16384,16385,16386,16387, +16388,16389,16390,16391,16392,16393,16394,16395,16396,16397,16398,16399, +16400,16401,16402,16403,16404,16405,16406,16407,16408,16409,16410,16411, +16412,16413,16414,16415,16416,16417,16418,16419,16420,16421,16422,16423, +16424,16425,16426,16427,16428,16429,16430,16431,16432,16433,16434,16435, +16436,16437,16438,16439,16440,16441,16442,16443,16444,16445,16446,16447, +16448,16449,16450,16451,16452,16453,16454,16455,16456,16457,16458,16459, +16460,16461,16462,16463,16464,16465,16466,16467,16468,16469,16470,16471, +16472,16473,16474,16475,16476,16477,16478,16479,16480,16481,16482,16483, +16484,16485,16486,16487,16488,16489,16490,16491,16492,16493,16494,16495, +16496,16497,16498,16499,16500,16501,16502,16503,16504,16505,16506,16507, +16508,16509,16510,16511,16512,16513,16514,16515,16516,16517,16518,16519, +16520,16521,16522,16523,16524,16525,16526,16527,16528,16529,16530,16531, +16532,16533,16534,16535,16536,16537,16538,16539,16540,16541,16542,16543, +16544,16545,16546,16547,16548,16549,16550,16551,16552,16553,16554,16555, +16556,16557,16558,16559,16560,16561,16562,16563,16564,16565,16566,16567, +16568,16569,16570,16571,16572,16573,16574,16575,16576,16577,16578,16579, +16580,16581,16582,16583,16584,16585,16586,16587,16588,16589,16590,16591, +16592,16593,16594,16595,16596,16597,16598,16599,16600,16601,16602,16603, +16604,16605,16606,16607,16608,16609,16610,16611,16612,16613,16614,16615, +16616,16617,16618,16619,16620,16621,16622,16623,16624,16625,16626,16627, +16628,16629,16630,16631,16632,16633,16634,16635,16636,16637,16638,16639, +16640,16641,16642,16643,16644,16645,16646,16647,16648,16649,16650,16651, +16652,16653,16654,16655,16656,16657,16658,16659,16660,16661,16662,16663, +16664,16665,16666,16667,16668,16669,16670,16671,16672,16673,16674,16675, +16676,16677,16678,16679,16680,16681,16682,16683,16684,16685,16686,16687, +16688,16689,16690,16691,16692,16693,16694,16695,16696,16697,16698,16699, +16700,16701,16702,16703,16704,16705,16706,16707,16708,16709,16710,16711, +16712,16713,16714,16715,16716,16717,16718,16719,16720,16721,16722,16723, +16724,16725,16726,16727,16728,16729,16730,16731,16732,16733,16734,16735, +16736,16737,16738,16739,16740,16741,16742,16743,16744,16745,16746,16747, +16748,16749,16750,16751,16752,16753,16754,16755,16756,16757,16758,16759, +16760,16761,16762,16763,16764,16765,16766,16767,16768,16769,16770,16771, +16772,16773,16774,16775,16776,16777,16778,16779,16780,16781,16782,16783, +16784,16785,16786,16787,16788,16789,16790,16791,16792,16793,16794,16795, +16796,16797,16798,16799,16800,16801,16802,16803,16804,16805,16806,16807, +16808,16809,16810,16811,16812,16813,16814,16815,16816,16817,16818,16819, +16820,16821,16822,16823,16824,16825,16826,16827,16828,16829,16830,16831, +16832,16833,16834,16835,16836,16837,16838,16839,16840,16841,16842,16843, +16844,16845,16846,16847,16848,16849,16850,16851,16852,16853,16854,16855, +16856,16857,16858,16859,16860,16861,16862,16863,16864,16865,16866,16867, +16868,16869,16870,16871,16872,16873,16874,16875,16876,16877,16878,16879, +16880,16881,16882,16883,16884,16885,16886,16887,16888,16889,16890,16891, +16892,16893,16894,16895,16896,16897,16898,16899,16900,16901,16902,16903, +16904,16905,16906,16907,16908,16909,16910,16911,16912,16913,16914,16915, +16916,16917,16918,16919,16920,16921,16922,16923,16924,16925,16926,16927, +16928,16929,16930,16931,16932,16933,16934,16935,16936,16937,16938,16939, +16940,16941,16942,16943,16944,16945,16946,16947,16948,16949,16950,16951, +16952,16953,16954,16955,16956,16957,16958,16959,16960,16961,16962,16963, +16964,16965,16966,16967,16968,16969,16970,16971,16972,16973,16974,16975, +16976,16977,16978,16979,16980,16981,16982,16983,16984,16985,16986,16987, +16988,16989,16990,16991,16992,16993,16994,16995,16996,16997,16998,16999, +17000,17001,17002,17003,17004,17005,17006,17007,17008,17009,17010,17011, +17012,17013,17014,17015,17016,17017,17018,17019,17020,17021,17022,17023, +17024,17025,17026,17027,17028,17029,17030,17031,17032,17033,17034,17035, +17036,17037,17038,17039,17040,17041,17042,17043,17044,17045,17046,17047, +17048,17049,17050,17051,17052,17053,17054,17055,17056,17057,17058,17059, +17060,17061,17062,17063,17064,17065,17066,17067,17068,17069,17070,17071, +17072,17073,17074,17075,17076,17077,17078,17079,17080,17081,17082,17083, +17084,17085,17086,17087,17088,17089,17090,17091,17092,17093,17094,17095, +17096,17097,17098,17099,17100,17101,17102,17103,17104,17105,17106,17107, +17108,17109,17110,17111,17112,17113,17114,17115,17116,17117,17118,17119, +17120,17121,17122,17123,17124,17125,17126,17127,17128,17129,17130,17131, +17132,17133,17134,17135,17136,17137,17138,17139,17140,17141,17142,17143, +17144,17145,17146,17147,17148,17149,17150,17151,17152,17153,17154,17155, +17156,17157,17158,17159,17160,17161,17162,17163,17164,17165,17166,17167, +17168,17169,17170,17171,17172,17173,17174,17175,17176,17177,17178,17179, +17180,17181,17182,17183,17184,17185,17186,17187,17188,17189,17190,17191, +17192,17193,17194,17195,17196,17197,17198,17199,17200,17201,17202,17203, +17204,17205,17206,17207,17208,17209,17210,17211,17212,17213,17214,17215, +17216,17217,17218,17219,17220,17221,17222,17223,17224,17225,17226,17227, +17228,17229,17230,17231,17232,17233,17234,17235,17236,17237,17238,17239, +17240,17241,17242,17243,17244,17245,17246,17247,17248,17249,17250,17251, +17252,17253,17254,17255,17256,17257,17258,17259,17260,17261,17262,17263, +17264,17265,17266,17267,17268,17269,17270,17271,17272,17273,17274,17275, +17276,17277,17278,17279,17280,17281,17282,17283,17284,17285,17286,17287, +17288,17289,17290,17291,17292,17293,17294,17295,17296,17297,17298,17299, +17300,17301,17302,17303,17304,17305,17306,17307,17308,17309,17310,17311, +17312,17313,17314,17315,17316,17317,17318,17319,17320,17321,17322,17323, +17324,17325,17326,17327,17328,17329,17330,17331,17332,17333,17334,17335, +17336,17337,17338,17339,17340,17341,17342,17343,17344,17345,17346,17347, +17348,17349,17350,17351,17352,17353,17354,17355,17356,17357,17358,17359, +17360,17361,17362,17363,17364,17365,17366,17367,17368,17369,17370,17371, +17372,17373,17374,17375,17376,17377,17378,17379,17380,17381,17382,17383, +17384,17385,17386,17387,17388,17389,17390,17391,17392,17393,17394,17395, +17396,17397,17398,17399,17400,17401,17402,17403,17404,17405,17406,17407, +17408,17409,17410,17411,17412,17413,17414,17415,17416,17417,17418,17419, +17420,17421,17422,17423,17424,17425,17426,17427,17428,17429,17430,17431, +17432,17433,17434,17435,17436,17437,17438,17439,17440,17441,17442,17443, +17444,17445,17446,17447,17448,17449,17450,17451,17452,17453,17454,17455, +17456,17457,17458,17459,17460,17461,17462,17463,17464,17465,17466,17467, +17468,17469,17470,17471,17472,17473,17474,17475,17476,17477,17478,17479, +17480,17481,17482,17483,17484,17485,17486,17487,17488,17489,17490,17491, +17492,17493,17494,17495,17496,17497,17498,17499,17500,17501,17502,17503, +17504,17505,17506,17507,17508,17509,17510,17511,17512,17513,17514,17515, +17516,17517,17518,17519,17520,17521,17522,17523,17524,17525,17526,17527, +17528,17529,17530,17531,17532,17533,17534,17535,17536,17537,17538,17539, +17540,17541,17542,17543,17544,17545,17546,17547,17548,17549,17550,17551, +17552,17553,17554,17555,17556,17557,17558,17559,17560,17561,17562,17563, +17564,17565,17566,17567,17568,17569,17570,17571,17572,17573,17574,17575, +17576,17577,17578,17579,17580,17581,17582,17583,17584,17585,17586,17587, +17588,17589,17590,17591,17592,17593,17594,17595,17596,17597,17598,17599, +17600,17601,17602,17603,17604,17605,17606,17607,17608,17609,17610,17611, +17612,17613,17614,17615,17616,17617,17618,17619,17620,17621,17622,17623, +17624,17625,17626,17627,17628,17629,17630,17631,17632,17633,17634,17635, +17636,17637,17638,17639,17640,17641,17642,17643,17644,17645,17646,17647, +17648,17649,17650,17651,17652,17653,17654,17655,17656,17657,17658,17659, +17660,17661,17662,17663,17664,17665,17666,17667,17668,17669,17670,17671, +17672,17673,17674,17675,17676,17677,17678,17679,17680,17681,17682,17683, +17684,17685,17686,17687,17688,17689,17690,17691,17692,17693,17694,17695, +17696,17697,17698,17699,17700,17701,17702,17703,17704,17705,17706,17707, +17708,17709,17710,17711,17712,17713,17714,17715,17716,17717,17718,17719, +17720,17721,17722,17723,17724,17725,17726,17727,17728,17729,17730,17731, +17732,17733,17734,17735,17736,17737,17738,17739,17740,17741,17742,17743, +17744,17745,17746,17747,17748,17749,17750,17751,17752,17753,17754,17755, +17756,17757,17758,17759,17760,17761,17762,17763,17764,17765,17766,17767, +17768,17769,17770,17771,17772,17773,17774,17775,17776,17777,17778,17779, +17780,17781,17782,17783,17784,17785,17786,17787,17788,17789,17790,17791, +17792,17793,17794,17795,17796,17797,17798,17799,17800,17801,17802,17803, +17804,17805,17806,17807,17808,17809,17810,17811,17812,17813,17814,17815, +17816,17817,17818,17819,17820,17821,17822,17823,17824,17825,17826,17827, +17828,17829,17830,17831,17832,17833,17834,17835,17836,17837,17838,17839, +17840,17841,17842,17843,17844,17845,17846,17847,17848,17849,17850,17851, +17852,17853,17854,17855,17856,17857,17858,17859,17860,17861,17862,17863, +17864,17865,17866,17867,17868,17869,17870,17871,17872,17873,17874,17875, +17876,17877,17878,17879,17880,17881,17882,17883,17884,17885,17886,17887, +17888,17889,17890,17891,17892,17893,17894,17895,17896,17897,17898,17899, +17900,17901,17902,17903,17904,17905,17906,17907,17908,17909,17910,17911, +17912,17913,17914,17915,17916,17917,17918,17919,17920,17921,17922,17923, +17924,17925,17926,17927,17928,17929,17930,17931,17932,17933,17934,17935, +17936,17937,17938,17939,17940,17941,17942,17943,17944,17945,17946,17947, +17948,17949,17950,17951,17952,17953,17954,17955,17956,17957,17958,17959, +17960,17961,17962,17963,17964,17965,17966,17967,17968,17969,17970,17971, +17972,17973,17974,17975,17976,17977,17978,17979,17980,17981,17982,17983, +17984,17985,17986,17987,17988,17989,17990,17991,17992,17993,17994,17995, +17996,17997,17998,17999,18000,18001,18002,18003,18004,18005,18006,18007, +18008,18009,18010,18011,18012,18013,18014,18015,18016,18017,18018,18019, +18020,18021,18022,18023,18024,18025,18026,18027,18028,18029,18030,18031, +18032,18033,18034,18035,18036,18037,18038,18039,18040,18041,18042,18043, +18044,18045,18046,18047,18048,18049,18050,18051,18052,18053,18054,18055, +18056,18057,18058,18059,18060,18061,18062,18063,18064,18065,18066,18067, +18068,18069,18070,18071,18072,18073,18074,18075,18076,18077,18078,18079, +18080,18081,18082,18083,18084,18085,18086,18087,18088,18089,18090,18091, +18092,18093,18094,18095,18096,18097,18098,18099,18100,18101,18102,18103, +18104,18105,18106,18107,18108,18109,18110,18111,18112,18113,18114,18115, +18116,18117,18118,18119,18120,18121,18122,18123,18124,18125,18126,18127, +18128,18129,18130,18131,18132,18133,18134,18135,18136,18137,18138,18139, +18140,18141,18142,18143,18144,18145,18146,18147,18148,18149,18150,18151, +18152,18153,18154,18155,18156,18157,18158,18159,18160,18161,18162,18163, +18164,18165,18166,18167,18168,18169,18170,18171,18172,18173,18174,18175, +18176,18177,18178,18179,18180,18181,18182,18183,18184,18185,18186,18187, +18188,18189,18190,18191,18192,18193,18194,18195,18196,18197,18198,18199, +18200,18201,18202,18203,18204,18205,18206,18207,18208,18209,18210,18211, +18212,18213,18214,18215,18216,18217,18218,18219,18220,18221,18222,18223, +18224,18225,18226,18227,18228,18229,18230,18231,18232,18233,18234,18235, +18236,18237,18238,18239,18240,18241,18242,18243,18244,18245,18246,18247, +18248,18249,18250,18251,18252,18253,18254,18255,18256,18257,18258,18259, +18260,18261,18262,18263,18264,18265,18266,18267,18268,18269,18270,18271, +18272,18273,18274,18275,18276,18277,18278,18279,18280,18281,18282,18283, +18284,18285,18286,18287,18288,18289,18290,18291,18292,18293,18294,18295, +18296,18297,18298,18299,18300,18301,18302,18303,18304,18305,18306,18307, +18308,18309,18310,18311,18312,18313,18314,18315,18316,18317,18318,18319, +18320,18321,18322,18323,18324,18325,18326,18327,18328,18329,18330,18331, +18332,18333,18334,18335,18336,18337,18338,18339,18340,18341,18342,18343, +18344,18345,18346,18347,18348,18349,18350,18351,18352,18353,18354,18355, +18356,18357,18358,18359,18360,18361,18362,18363,18364,18365,18366,18367, +18368,18369,18370,18371,18372,18373,18374,18375,18376,18377,18378,18379, +18380,18381,18382,18383,18384,18385,18386,18387,18388,18389,18390,18391, +18392,18393,18394,18395,18396,18397,18398,18399,18400,18401,18402,18403, +18404,18405,18406,18407,18408,18409,18410,18411,18412,18413,18414,18415, +18416,18417,18418,18419,18420,18421,18422,18423,18424,18425,18426,18427, +18428,18429,18430,18431,18432,18433,18434,18435,18436,18437,18438,18439, +18440,18441,18442,18443,18444,18445,18446,18447,18448,18449,18450,18451, +18452,18453,18454,18455,18456,18457,18458,18459,18460,18461,18462,18463, +18464,18465,18466,18467,18468,18469,18470,18471,18472,18473,18474,18475, +18476,18477,18478,18479,18480,18481,18482,18483,18484,18485,18486,18487, +18488,18489,18490,18491,18492,18493,18494,18495,18496,18497,18498,18499, +18500,18501,18502,18503,18504,18505,18506,18507,18508,18509,18510,18511, +18512,18513,18514,18515,18516,18517,18518,18519,18520,18521,18522,18523, +18524,18525,18526,18527,18528,18529,18530,18531,18532,18533,18534,18535, +18536,18537,18538,18539,18540,18541,18542,18543,18544,18545,18546,18547, +18548,18549,18550,18551,18552,18553,18554,18555,18556,18557,18558,18559, +18560,18561,18562,18563,18564,18565,18566,18567,18568,18569,18570,18571, +18572,18573,18574,18575,18576,18577,18578,18579,18580,18581,18582,18583, +18584,18585,18586,18587,18588,18589,18590,18591,18592,18593,18594,18595, +18596,18597,18598,18599,18600,18601,18602,18603,18604,18605,18606,18607, +18608,18609,18610,18611,18612,18613,18614,18615,18616,18617,18618,18619, +18620,18621,18622,18623,18624,18625,18626,18627,18628,18629,18630,18631, +18632,18633,18634,18635,18636,18637,18638,18639,18640,18641,18642,18643, +18644,18645,18646,18647,18648,18649,18650,18651,18652,18653,18654,18655, +18656,18657,18658,18659,18660,18661,18662,18663,18664,18665,18666,18667, +18668,18669,18670,18671,18672,18673,18674,18675,18676,18677,18678,18679, +18680,18681,18682,18683,18684,18685,18686,18687,18688,18689,18690,18691, +18692,18693,18694,18695,18696,18697,18698,18699,18700,18701,18702,18703, +18704,18705,18706,18707,18708,18709,18710,18711,18712,18713,18714,18715, +18716,18717,18718,18719,18720,18721,18722,18723,18724,18725,18726,18727, +18728,18729,18730,18731,18732,18733,18734,18735,18736,18737,18738,18739, +18740,18741,18742,18743,18744,18745,18746,18747,18748,18749,18750,18751, +18752,18753,18754,18755,18756,18757,18758,18759,18760,18761,18762,18763, +18764,18765,18766,18767,18768,18769,18770,18771,18772,18773,18774,18775, +18776,18777,18778,18779,18780,18781,18782,18783,18784,18785,18786,18787, +18788,18789,18790,18791,18792,18793,18794,18795,18796,18797,18798,18799, +18800,18801,18802,18803,18804,18805,18806,18807,18808,18809,18810,18811, +18812,18813,18814,18815,18816,18817,18818,18819,18820,18821,18822,18823, +18824,18825,18826,18827,18828,18829,18830,18831,18832,18833,18834,18835, +18836,18837,18838,18839,18840,18841,18842,18843,18844,18845,18846,18847, +18848,18849,18850,18851,18852,18853,18854,18855,18856,18857,18858,18859, +18860,18861,18862,18863,18864,18865,18866,18867,18868,18869,18870,18871, +18872,18873,18874,18875,18876,18877,18878,18879,18880,18881,18882,18883, +18884,18885,18886,18887,18888,18889,18890,18891,18892,18893,18894,18895, +18896,18897,18898,18899,18900,18901,18902,18903,18904,18905,18906,18907, +18908,18909,18910,18911,18912,18913,18914,18915,18916,18917,18918,18919, +18920,18921,18922,18923,18924,18925,18926,18927,18928,18929,18930,18931, +18932,18933,18934,18935,18936,18937,18938,18939,18940,18941,18942,18943, +18944,18945,18946,18947,18948,18949,18950,18951,18952,18953,18954,18955, +18956,18957,18958,18959,18960,18961,18962,18963,18964,18965,18966,18967, +18968,18969,18970,18971,18972,18973,18974,18975,18976,18977,18978,18979, +18980,18981,18982,18983,18984,18985,18986,18987,18988,18989,18990,18991, +18992,18993,18994,18995,18996,18997,18998,18999,19000,19001,19002,19003, +19004,19005,19006,19007,19008,19009,19010,19011,19012,19013,19014,19015, +19016,19017,19018,19019,19020,19021,19022,19023,19024,19025,19026,19027, +19028,19029,19030,19031,19032,19033,19034,19035,19036,19037,19038,19039, +19040,19041,19042,19043,19044,19045,19046,19047,19048,19049,19050,19051, +19052,19053,19054,19055,19056,19057,19058,19059,19060,19061,19062,19063, +19064,19065,19066,19067,19068,19069,19070,19071,19072,19073,19074,19075, +19076,19077,19078,19079,19080,19081,19082,19083,19084,19085,19086,19087, +19088,19089,19090,19091,19092,19093,19094,19095,19096,19097,19098,19099, +19100,19101,19102,19103,19104,19105,19106,19107,19108,19109,19110,19111, +19112,19113,19114,19115,19116,19117,19118,19119,19120,19121,19122,19123, +19124,19125,19126,19127,19128,19129,19130,19131,19132,19133,19134,19135, +19136,19137,19138,19139,19140,19141,19142,19143,19144,19145,19146,19147, +19148,19149,19150,19151,19152,19153,19154,19155,19156,19157,19158,19159, +19160,19161,19162,19163,19164,19165,19166,19167,19168,19169,19170,19171, +19172,19173,19174,19175,19176,19177,19178,19179,19180,19181,19182,19183, +19184,19185,19186,19187,19188,19189,19190,19191,19192,19193,19194,19195, +19196,19197,19198,19199,19200,19201,19202,19203,19204,19205,19206,19207, +19208,19209,19210,19211,19212,19213,19214,19215,19216,19217,19218,19219, +19220,19221,19222,19223,19224,19225,19226,19227,19228,19229,19230,19231, +19232,19233,19234,19235,19236,19237,19238,19239,19240,19241,19242,19243, +19244,19245,19246,19247,19248,19249,19250,19251,19252,19253,19254,19255, +19256,19257,19258,19259,19260,19261,19262,19263,19264,19265,19266,19267, +19268,19269,19270,19271,19272,19273,19274,19275,19276,19277,19278,19279, +19280,19281,19282,19283,19284,19285,19286,19287,19288,19289,19290,19291, +19292,19293,19294,19295,19296,19297,19298,19299,19300,19301,19302,19303, +19304,19305,19306,19307,19308,19309,19310,19311,19312,19313,19314,19315, +19316,19317,19318,19319,19320,19321,19322,19323,19324,19325,19326,19327, +19328,19329,19330,19331,19332,19333,19334,19335,19336,19337,19338,19339, +19340,19341,19342,19343,19344,19345,19346,19347,19348,19349,19350,19351, +19352,19353,19354,19355,19356,19357,19358,19359,19360,19361,19362,19363, +19364,19365,19366,19367,19368,19369,19370,19371,19372,19373,19374,19375, +19376,19377,19378,19379,19380,19381,19382,19383,19384,19385,19386,19387, +19388,19389,19390,19391,19392,19393,19394,19395,19396,19397,19398,19399, +19400,19401,19402,19403,19404,19405,19406,19407,19408,19409,19410,19411, +19412,19413,19414,19415,19416,19417,19418,19419,19420,19421,19422,19423, +19424,19425,19426,19427,19428,19429,19430,19431,19432,19433,19434,19435, +19436,19437,19438,19439,19440,19441,19442,19443,19444,19445,19446,19447, +19448,19449,19450,19451,19452,19453,19454,19455,19456,19457,19458,19459, +19460,19461,19462,19463,19464,19465,19466,19467,19468,19469,19470,19471, +19472,19473,19474,19475,19476,19477,19478,19479,19480,19481,19482,19483, +19484,19485,19486,19487,19488,19489,19490,19491,19492,19493,19494,19495, +19496,19497,19498,19499,19500,19501,19502,19503,19504,19505,19506,19507, +19508,19509,19510,19511,19512,19513,19514,19515,19516,19517,19518,19519, +19520,19521,19522,19523,19524,19525,19526,19527,19528,19529,19530,19531, +19532,19533,19534,19535,19536,19537,19538,19539,19540,19541,19542,19543, +19544,19545,19546,19547,19548,19549,19550,19551,19552,19553,19554,19555, +19556,19557,19558,19559,19560,19561,19562,19563,19564,19565,19566,19567, +19568,19569,19570,19571,19572,19573,19574,19575,19576,19577,19578,19579, +19580,19581,19582,19583,19584,19585,19586,19587,19588,19589,19590,19591, +19592,19593,19594,19595,19596,19597,19598,19599,19600,19601,19602,19603, +19604,19605,19606,19607,19608,19609,19610,19611,19612,19613,19614,19615, +19616,19617,19618,19619,19620,19621,19622,19623,19624,19625,19626,19627, +19628,19629,19630,19631,19632,19633,19634,19635,19636,19637,19638,19639, +19640,19641,19642,19643,19644,19645,19646,19647,19648,19649,19650,19651, +19652,19653,19654,19655,19656,19657,19658,19659,19660,19661,19662,19663, +19664,19665,19666,19667,19668,19669,19670,19671,19672,19673,19674,19675, +19676,19677,19678,19679,19680,19681,19682,19683,19684,19685,19686,19687, +19688,19689,19690,19691,19692,19693,19694,19695,19696,19697,19698,19699, +19700,19701,19702,19703,19704,19705,19706,19707,19708,19709,19710,19711, +19712,19713,19714,19715,19716,19717,19718,19719,19720,19721,19722,19723, +19724,19725,19726,19727,19728,19729,19730,19731,19732,19733,19734,19735, +19736,19737,19738,19739,19740,19741,19742,19743,19744,19745,19746,19747, +19748,19749,19750,19751,19752,19753,19754,19755,19756,19757,19758,19759, +19760,19761,19762,19763,19764,19765,19766,19767,19768,19769,19770,19771, +19772,19773,19774,19775,19776,19777,19778,19779,19780,19781,19782,19783, +19784,19785,19786,19787,19788,19789,19790,19791,19792,19793,19794,19795, +19796,19797,19798,19799,19800,19801,19802,19803,19804,19805,19806,19807, +19808,19809,19810,19811,19812,19813,19814,19815,19816,19817,19818,19819, +19820,19821,19822,19823,19824,19825,19826,19827,19828,19829,19830,19831, +19832,19833,19834,19835,19836,19837,19838,19839,19840,19841,19842,19843, +19844,19845,19846,19847,19848,19849,19850,19851,19852,19853,19854,19855, +19856,19857,19858,19859,19860,19861,19862,19863,19864,19865,19866,19867, +19868,19869,19870,19871,19872,19873,19874,19875,19876,19877,19878,19879, +19880,19881,19882,19883,19884,19885,19886,19887,19888,19889,19890,19891, +19892,19893,19894,19895,19896,19897,19898,19899,19900,19901,19902,19903, +19904,19905,19906,19907,19908,19909,19910,19911,19912,19913,19914,19915, +19916,19917,19918,19919,19920,19921,19922,19923,19924,19925,19926,19927, +19928,19929,19930,19931,19932,19933,19934,19935,19936,19937,19938,19939, +19940,19941,19942,19943,19944,19945,19946,19947,19948,19949,19950,19951, +19952,19953,19954,19955,19956,19957,19958,19959,19960,19961,19962,19963, +19964,19965,19966,19967,19968,19969,19970,19971,19972,19973,19974,19975, +19976,19977,19978,19979,19980,19981,19982,19983,19984,19985,19986,19987, +19988,19989,19990,19991,19992,19993,19994,19995,19996,19997,19998,19999, +20000,20001,20002,20003,20004,20005,20006,20007,20008,20009,20010,20011, +20012,20013,20014,20015,20016,20017,20018,20019,20020,20021,20022,20023, +20024,20025,20026,20027,20028,20029,20030,20031,20032,20033,20034,20035, +20036,20037,20038,20039,20040,20041,20042,20043,20044,20045,20046,20047, +20048,20049,20050,20051,20052,20053,20054,20055,20056,20057,20058,20059, +20060,20061,20062,20063,20064,20065,20066,20067,20068,20069,20070,20071, +20072,20073,20074,20075,20076,20077,20078,20079,20080,20081,20082,20083, +20084,20085,20086,20087,20088,20089,20090,20091,20092,20093,20094,20095, +20096,20097,20098,20099,20100,20101,20102,20103,20104,20105,20106,20107, +20108,20109,20110,20111,20112,20113,20114,20115,20116,20117,20118,20119, +20120,20121,20122,20123,20124,20125,20126,20127,20128,20129,20130,20131, +20132,20133,20134,20135,20136,20137,20138,20139,20140,20141,20142,20143, +20144,20145,20146,20147,20148,20149,20150,20151,20152,20153,20154,20155, +20156,20157,20158,20159,20160,20161,20162,20163,20164,20165,20166,20167, +20168,20169,20170,20171,20172,20173,20174,20175,20176,20177,20178,20179, +20180,20181,20182,20183,20184,20185,20186,20187,20188,20189,20190,20191, +20192,20193,20194,20195,20196,20197,20198,20199,20200,20201,20202,20203, +20204,20205,20206,20207,20208,20209,20210,20211,20212,20213,20214,20215, +20216,20217,20218,20219,20220,20221,20222,20223,20224,20225,20226,20227, +20228,20229,20230,20231,20232,20233,20234,20235,20236,20237,20238,20239, +20240,20241,20242,20243,20244,20245,20246,20247,20248,20249,20250,20251, +20252,20253,20254,20255,20256,20257,20258,20259,20260,20261,20262,20263, +20264,20265,20266,20267,20268,20269,20270,20271,20272,20273,20274,20275, +20276,20277,20278,20279,20280,20281,20282,20283,20284,20285,20286,20287, +20288,20289,20290,20291,20292,20293,20294,20295,20296,20297,20298,20299, +20300,20301,20302,20303,20304,20305,20306,20307,20308,20309,20310,20311, +20312,20313,20314,20315,20316,20317,20318,20319,20320,20321,20322,20323, +20324,20325,20326,20327,20328,20329,20330,20331,20332,20333,20334,20335, +20336,20337,20338,20339,20340,20341,20342,20343,20344,20345,20346,20347, +20348,20349,20350,20351,20352,20353,20354,20355,20356,20357,20358,20359, +20360,20361,20362,20363,20364,20365,20366,20367,20368,20369,20370,20371, +20372,20373,20374,20375,20376,20377,20378,20379,20380,20381,20382,20383, +20384,20385,20386,20387,20388,20389,20390,20391,20392,20393,20394,20395, +20396,20397,20398,20399,20400,20401,20402,20403,20404,20405,20406,20407, +20408,20409,20410,20411,20412,20413,20414,20415,20416,20417,20418,20419, +20420,20421,20422,20423,20424,20425,20426,20427,20428,20429,20430,20431, +20432,20433,20434,20435,20436,20437,20438,20439,20440,20441,20442,20443, +20444,20445,20446,20447,20448,20449,20450,20451,20452,20453,20454,20455, +20456,20457,20458,20459,20460,20461,20462,20463,20464,20465,20466,20467, +20468,20469,20470,20471,20472,20473,20474,20475,20476,20477,20478,20479, +20480,20481,20482,20483,20484,20485,20486,20487,20488,20489,20490,20491, +20492,20493,20494,20495,20496,20497,20498,20499,20500,20501,20502,20503, +20504,20505,20506,20507,20508,20509,20510,20511,20512,20513,20514,20515, +20516,20517,20518,20519,20520,20521,20522,20523,20524,20525,20526,20527, +20528,20529,20530,20531,20532,20533,20534,20535,20536,20537,20538,20539, +20540,20541,20542,20543,20544,20545,20546,20547,20548,20549,20550,20551, +20552,20553,20554,20555,20556,20557,20558,20559,20560,20561,20562,20563, +20564,20565,20566,20567,20568,20569,20570,20571,20572,20573,20574,20575, +20576,20577,20578,20579,20580,20581,20582,20583,20584,20585,20586,20587, +20588,20589,20590,20591,20592,20593,20594,20595,20596,20597,20598,20599, +20600,20601,20602,20603,20604,20605,20606,20607,20608,20609,20610,20611, +20612,20613,20614,20615,20616,20617,20618,20619,20620,20621,20622,20623, +20624,20625,20626,20627,20628,20629,20630,20631,20632,20633,20634,20635, +20636,20637,20638,20639,20640,20641,20642,20643,20644,20645,20646,20647, +20648,20649,20650,20651,20652,20653,20654,20655,20656,20657,20658,20659, +20660,20661,20662,20663,20664,20665,20666,20667,20668,20669,20670,20671, +20672,20673,20674,20675,20676,20677,20678,20679,20680,20681,20682,20683, +20684,20685,20686,20687,20688,20689,20690,20691,20692,20693,20694,20695, +20696,20697,20698,20699,20700,20701,20702,20703,20704,20705,20706,20707, +20708,20709,20710,20711,20712,20713,20714,20715,20716,20717,20718,20719, +20720,20721,20722,20723,20724,20725,20726,20727,20728,20729,20730,20731, +20732,20733,20734,20735,20736,20737,20738,20739,20740,20741,20742,20743, +20744,20745,20746,20747,20748,20749,20750,20751,20752,20753,20754,20755, +20756,20757,20758,20759,20760,20761,20762,20763,20764,20765,20766,20767, +20768,20769,20770,20771,20772,20773,20774,20775,20776,20777,20778,20779, +20780,20781,20782,20783,20784,20785,20786,20787,20788,20789,20790,20791, +20792,20793,20794,20795,20796,20797,20798,20799,20800,20801,20802,20803, +20804,20805,20806,20807,20808,20809,20810,20811,20812,20813,20814,20815, +20816,20817,20818,20819,20820,20821,20822,20823,20824,20825,20826,20827, +20828,20829,20830,20831,20832,20833,20834,20835,20836,20837,20838,20839, +20840,20841,20842,20843,20844,20845,20846,20847,20848,20849,20850,20851, +20852,20853,20854,20855,20856,20857,20858,20859,20860,20861,20862,20863, +20864,20865,20866,20867,20868,20869,20870,20871,20872,20873,20874,20875, +20876,20877,20878,20879,20880,20881,20882,20883,20884,20885,20886,20887, +20888,20889,20890,20891,20892,20893,20894,20895,20896,20897,20898,20899, +20900,20901,20902,20903,20904,20905,20906,20907,20908,20909,20910,20911, +20912,20913,20914,20915,20916,20917,20918,20919,20920,20921,20922,20923, +20924,20925,20926,20927,20928,20929,20930,20931,20932,20933,20934,20935, +20936,20937,20938,20939,20940,20941,20942,20943,20944,20945,20946,20947, +20948,20949,20950,20951,20952,20953,20954,20955,20956,20957,20958,20959, +20960,20961,20962,20963,20964,20965,20966,20967,20968,20969,20970,20971, +20972,20973,20974,20975,20976,20977,20978,20979,20980,20981,20982,20983, +20984,20985,20986,20987,20988,20989,20990,20991,20992,20993,20994,20995, +20996,20997,20998,20999,21000,21001,21002,21003,21004,21005,21006,21007, +21008,21009,21010,21011,21012,21013,21014,21015,21016,21017,21018,21019, +21020,21021,21022,21023,21024,21025,21026,21027,21028,21029,21030,21031, +21032,21033,21034,21035,21036,21037,21038,21039,21040,21041,21042,21043, +21044,21045,21046,21047,21048,21049,21050,21051,21052,21053,21054,21055, +21056,21057,21058,21059,21060,21061,21062,21063,21064,21065,21066,21067, +21068,21069,21070,21071,21072,21073,21074,21075,21076,21077,21078,21079, +21080,21081,21082,21083,21084,21085,21086,21087,21088,21089,21090,21091, +21092,21093,21094,21095,21096,21097,21098,21099,21100,21101,21102,21103, +21104,21105,21106,21107,21108,21109,21110,21111,21112,21113,21114,21115, +21116,21117,21118,21119,21120,21121,21122,21123,21124,21125,21126,21127, +21128,21129,21130,21131,21132,21133,21134,21135,21136,21137,21138,21139, +21140,21141,21142,21143,21144,21145,21146,21147,21148,21149,21150,21151, +21152,21153,21154,21155,21156,21157,21158,21159,21160,21161,21162,21163, +21164,21165,21166,21167,21168,21169,21170,21171,21172,21173,21174,21175, +21176,21177,21178,21179,21180,21181,21182,21183,21184,21185,21186,21187, +21188,21189,21190,21191,21192,21193,21194,21195,21196,21197,21198,21199, +21200,21201,21202,21203,21204,21205,21206,21207,21208,21209,21210,21211, +21212,21213,21214,21215,21216,21217,21218,21219,21220,21221,21222,21223, +21224,21225,21226,21227,21228,21229,21230,21231,21232,21233,21234,21235, +21236,21237,21238,21239,21240,21241,21242,21243,21244,21245,21246,21247, +21248,21249,21250,21251,21252,21253,21254,21255,21256,21257,21258,21259, +21260,21261,21262,21263,21264,21265,21266,21267,21268,21269,21270,21271, +21272,21273,21274,21275,21276,21277,21278,21279,21280,21281,21282,21283, +21284,21285,21286,21287,21288,21289,21290,21291,21292,21293,21294,21295, +21296,21297,21298,21299,21300,21301,21302,21303,21304,21305,21306,21307, +21308,21309,21310,21311,21312,21313,21314,21315,21316,21317,21318,21319, +21320,21321,21322,21323,21324,21325,21326,21327,21328,21329,21330,21331, +21332,21333,21334,21335,21336,21337,21338,21339,21340,21341,21342,21343, +21344,21345,21346,21347,21348,21349,21350,21351,21352,21353,21354,21355, +21356,21357,21358,21359,21360,21361,21362,21363,21364,21365,21366,21367, +21368,21369,21370,21371,21372,21373,21374,21375,21376,21377,21378,21379, +21380,21381,21382,21383,21384,21385,21386,21387,21388,21389,21390,21391, +21392,21393,21394,21395,21396,21397,21398,21399,21400,21401,21402,21403, +21404,21405,21406,21407,21408,21409,21410,21411,21412,21413,21414,21415, +21416,21417,21418,21419,21420,21421,21422,21423,21424,21425,21426,21427, +21428,21429,21430,21431,21432,21433,21434,21435,21436,21437,21438,21439, +21440,21441,21442,21443,21444,21445,21446,21447,21448,21449,21450,21451, +21452,21453,21454,21455,21456,21457,21458,21459,21460,21461,21462,21463, +21464,21465,21466,21467,21468,21469,21470,21471,21472,21473,21474,21475, +21476,21477,21478,21479,21480,21481,21482,21483,21484,21485,21486,21487, +21488,21489,21490,21491,21492,21493,21494,21495,21496,21497,21498,21499, +21500,21501,21502,21503,21504,21505,21506,21507,21508,21509,21510,21511, +21512,21513,21514,21515,21516,21517,21518,21519,21520,21521,21522,21523, +21524,21525,21526,21527,21528,21529,21530,21531,21532,21533,21534,21535, +21536,21537,21538,21539,21540,21541,21542,21543,21544,21545,21546,21547, +21548,21549,21550,21551,21552,21553,21554,21555,21556,21557,21558,21559, +21560,21561,21562,21563,21564,21565,21566,21567,21568,21569,21570,21571, +21572,21573,21574,21575,21576,21577,21578,21579,21580,21581,21582,21583, +21584,21585,21586,21587,21588,21589,21590,21591,21592,21593,21594,21595, +21596,21597,21598,21599,21600,21601,21602,21603,21604,21605,21606,21607, +21608,21609,21610,21611,21612,21613,21614,21615,21616,21617,21618,21619, +21620,21621,21622,21623,21624,21625,21626,21627,21628,21629,21630,21631, +21632,21633,21634,21635,21636,21637,21638,21639,21640,21641,21642,21643, +21644,21645,21646,21647,21648,21649,21650,21651,21652,21653,21654,21655, +21656,21657,21658,21659,21660,21661,21662,21663,21664,21665,21666,21667, +21668,21669,21670,21671,21672,21673,21674,21675,21676,21677,21678,21679, +21680,21681,21682,21683,21684,21685,21686,21687,21688,21689,21690,21691, +21692,21693,21694,21695,21696,21697,21698,21699,21700,21701,21702,21703, +21704,21705,21706,21707,21708,21709,21710,21711,21712,21713,21714,21715, +21716,21717,21718,21719,21720,21721,21722,21723,21724,21725,21726,21727, +21728,21729,21730,21731,21732,21733,21734,21735,21736,21737,21738,21739, +21740,21741,21742,21743,21744,21745,21746,21747,21748,21749,21750,21751, +21752,21753,21754,21755,21756,21757,21758,21759,21760,21761,21762,21763, +21764,21765,21766,21767,21768,21769,21770,21771,21772,21773,21774,21775, +21776,21777,21778,21779,21780,21781,21782,21783,21784,21785,21786,21787, +21788,21789,21790,21791,21792,21793,21794,21795,21796,21797,21798,21799, +21800,21801,21802,21803,21804,21805,21806,21807,21808,21809,21810,21811, +21812,21813,21814,21815,21816,21817,21818,21819,21820,21821,21822,21823, +21824,21825,21826,21827,21828,21829,21830,21831,21832,21833,21834,21835, +21836,21837,21838,21839,21840,21841,21842,21843,21844,21845,21846,21847, +21848,21849,21850,21851,21852,21853,21854,21855,21856,21857,21858,21859, +21860,21861,21862,21863,21864,21865,21866,21867,21868,21869,21870,21871, +21872,21873,21874,21875,21876,21877,21878,21879,21880,21881,21882,21883, +21884,21885,21886,21887,21888,21889,21890,21891,21892,21893,21894,21895, +21896,21897,21898,21899,21900,21901,21902,21903,21904,21905,21906,21907, +21908,21909,21910,21911,21912,21913,21914,21915,21916,21917,21918,21919, +21920,21921,21922,21923,21924,21925,21926,21927,21928,21929,21930,21931, +21932,21933,21934,21935,21936,21937,21938,21939,21940,21941,21942,21943, +21944,21945,21946,21947,21948,21949,21950,21951,21952,21953,21954,21955, +21956,21957,21958,21959,21960,21961,21962,21963,21964,21965,21966,21967, +21968,21969,21970,21971,21972,21973,21974,21975,21976,21977,21978,21979, +21980,21981,21982,21983,21984,21985,21986,21987,21988,21989,21990,21991, +21992,21993,21994,21995,21996,21997,21998,21999,22000,22001,22002,22003, +22004,22005,22006,22007,22008,22009,22010,22011,22012,22013,22014,22015, +22016,22017,22018,22019,22020,22021,22022,22023,22024,22025,22026,22027, +22028,22029,22030,22031,22032,22033,22034,22035,22036,22037,22038,22039, +22040,22041,22042,22043,22044,22045,22046,22047,22048,22049,22050,22051, +22052,22053,22054,22055,22056,22057,22058,22059,22060,22061,22062,22063, +22064,22065,22066,22067,22068,22069,22070,22071,22072,22073,22074,22075, +22076,22077,22078,22079,22080,22081,22082,22083,22084,22085,22086,22087, +22088,22089,22090,22091,22092,22093,22094,22095,22096,22097,22098,22099, +22100,22101,22102,22103,22104,22105,22106,22107,22108,22109,22110,22111, +22112,22113,22114,22115,22116,22117,22118,22119,22120,22121,22122,22123, +22124,22125,22126,22127,22128,22129,22130,22131,22132,22133,22134,22135, +22136,22137,22138,22139,22140,22141,22142,22143,22144,22145,22146,22147, +22148,22149,22150,22151,22152,22153,22154,22155,22156,22157,22158,22159, +22160,22161,22162,22163,22164,22165,22166,22167,22168,22169,22170,22171, +22172,22173,22174,22175,22176,22177,22178,22179,22180,22181,22182,22183, +22184,22185,22186,22187,22188,22189,22190,22191,22192,22193,22194,22195, +22196,22197,22198,22199,22200,22201,22202,22203,22204,22205,22206,22207, +22208,22209,22210,22211,22212,22213,22214,22215,22216,22217,22218,22219, +22220,22221,22222,22223,22224,22225,22226,22227,22228,22229,22230,22231, +22232,22233,22234,22235,22236,22237,22238,22239,22240,22241,22242,22243, +22244,22245,22246,22247,22248,22249,22250,22251,22252,22253,22254,22255, +22256,22257,22258,22259,22260,22261,22262,22263,22264,22265,22266,22267, +22268,22269,22270,22271,22272,22273,22274,22275,22276,22277,22278,22279, +22280,22281,22282,22283,22284,22285,22286,22287,22288,22289,22290,22291, +22292,22293,22294,22295,22296,22297,22298,22299,22300,22301,22302,22303, +22304,22305,22306,22307,22308,22309,22310,22311,22312,22313,22314,22315, +22316,22317,22318,22319,22320,22321,22322,22323,22324,22325,22326,22327, +22328,22329,22330,22331,22332,22333,22334,22335,22336,22337,22338,22339, +22340,22341,22342,22343,22344,22345,22346,22347,22348,22349,22350,22351, +22352,22353,22354,22355,22356,22357,22358,22359,22360,22361,22362,22363, +22364,22365,22366,22367,22368,22369,22370,22371,22372,22373,22374,22375, +22376,22377,22378,22379,22380,22381,22382,22383,22384,22385,22386,22387, +22388,22389,22390,22391,22392,22393,22394,22395,22396,22397,22398,22399, +22400,22401,22402,22403,22404,22405,22406,22407,22408,22409,22410,22411, +22412,22413,22414,22415,22416,22417,22418,22419,22420,22421,22422,22423, +22424,22425,22426,22427,22428,22429,22430,22431,22432,22433,22434,22435, +22436,22437,22438,22439,22440,22441,22442,22443,22444,22445,22446,22447, +22448,22449,22450,22451,22452,22453,22454,22455,22456,22457,22458,22459, +22460,22461,22462,22463,22464,22465,22466,22467,22468,22469,22470,22471, +22472,22473,22474,22475,22476,22477,22478,22479,22480,22481,22482,22483, +22484,22485,22486,22487,22488,22489,22490,22491,22492,22493,22494,22495, +22496,22497,22498,22499,22500,22501,22502,22503,22504,22505,22506,22507, +22508,22509,22510,22511,22512,22513,22514,22515,22516,22517,22518,22519, +22520,22521,22522,22523,22524,22525,22526,22527,22528,22529,22530,22531, +22532,22533,22534,22535,22536,22537,22538,22539,22540,22541,22542,22543, +22544,22545,22546,22547,22548,22549,22550,22551,22552,22553,22554,22555, +22556,22557,22558,22559,22560,22561,22562,22563,22564,22565,22566,22567, +22568,22569,22570,22571,22572,22573,22574,22575,22576,22577,22578,22579, +22580,22581,22582,22583,22584,22585,22586,22587,22588,22589,22590,22591, +22592,22593,22594,22595,22596,22597,22598,22599,22600,22601,22602,22603, +22604,22605,22606,22607,22608,22609,22610,22611,22612,22613,22614,22615, +22616,22617,22618,22619,22620,22621,22622,22623,22624,22625,22626,22627, +22628,22629,22630,22631,22632,22633,22634,22635,22636,22637,22638,22639, +22640,22641,22642,22643,22644,22645,22646,22647,22648,22649,22650,22651, +22652,22653,22654,22655,22656,22657,22658,22659,22660,22661,22662,22663, +22664,22665,22666,22667,22668,22669,22670,22671,22672,22673,22674,22675, +22676,22677,22678,22679,22680,22681,22682,22683,22684,22685,22686,22687, +22688,22689,22690,22691,22692,22693,22694,22695,22696,22697,22698,22699, +22700,22701,22702,22703,22704,22705,22706,22707,22708,22709,22710,22711, +22712,22713,22714,22715,22716,22717,22718,22719,22720,22721,22722,22723, +22724,22725,22726,22727,22728,22729,22730,22731,22732,22733,22734,22735, +22736,22737,22738,22739,22740,22741,22742,22743,22744,22745,22746,22747, +22748,22749,22750,22751,22752,22753,22754,22755,22756,22757,22758,22759, +22760,22761,22762,22763,22764,22765,22766,22767,22768,22769,22770,22771, +22772,22773,22774,22775,22776,22777,22778,22779,22780,22781,22782,22783, +22784,22785,22786,22787,22788,22789,22790,22791,22792,22793,22794,22795, +22796,22797,22798,22799,22800,22801,22802,22803,22804,22805,22806,22807, +22808,22809,22810,22811,22812,22813,22814,22815,22816,22817,22818,22819, +22820,22821,22822,22823,22824,22825,22826,22827,22828,22829,22830,22831, +22832,22833,22834,22835,22836,22837,22838,22839,22840,22841,22842,22843, +22844,22845,22846,22847,22848,22849,22850,22851,22852,22853,22854,22855, +22856,22857,22858,22859,22860,22861,22862,22863,22864,22865,22866,22867, +22868,22869,22870,22871,22872,22873,22874,22875,22876,22877,22878,22879, +22880,22881,22882,22883,22884,22885,22886,22887,22888,22889,22890,22891, +22892,22893,22894,22895,22896,22897,22898,22899,22900,22901,22902,22903, +22904,22905,22906,22907,22908,22909,22910,22911,22912,22913,22914,22915, +22916,22917,22918,22919,22920,22921,22922,22923,22924,22925,22926,22927, +22928,22929,22930,22931,22932,22933,22934,22935,22936,22937,22938,22939, +22940,22941,22942,22943,22944,22945,22946,22947,22948,22949,22950,22951, +22952,22953,22954,22955,22956,22957,22958,22959,22960,22961,22962,22963, +22964,22965,22966,22967,22968,22969,22970,22971,22972,22973,22974,22975, +22976,22977,22978,22979,22980,22981,22982,22983,22984,22985,22986,22987, +22988,22989,22990,22991,22992,22993,22994,22995,22996,22997,22998,22999, +23000,23001,23002,23003,23004,23005,23006,23007,23008,23009,23010,23011, +23012,23013,23014,23015,23016,23017,23018,23019,23020,23021,23022,23023, +23024,23025,23026,23027,23028,23029,23030,23031,23032,23033,23034,23035, +23036,23037,23038,23039,23040,23041,23042,23043,23044,23045,23046,23047, +23048,23049,23050,23051,23052,23053,23054,23055,23056,23057,23058,23059, +23060,23061,23062,23063,23064,23065,23066,23067,23068,23069,23070,23071, +23072,23073,23074,23075,23076,23077,23078,23079,23080,23081,23082,23083, +23084,23085,23086,23087,23088,23089,23090,23091,23092,23093,23094,23095, +23096,23097,23098,23099,23100,23101,23102,23103,23104,23105,23106,23107, +23108,23109,23110,23111,23112,23113,23114,23115,23116,23117,23118,23119, +23120,23121,23122,23123,23124,23125,23126,23127,23128,23129,23130,23131, +23132,23133,23134,23135,23136,23137,23138,23139,23140,23141,23142,23143, +23144,23145,23146,23147,23148,23149,23150,23151,23152,23153,23154,23155, +23156,23157,23158,23159,23160,23161,23162,23163,23164,23165,23166,23167, +23168,23169,23170,23171,23172,23173,23174,23175,23176,23177,23178,23179, +23180,23181,23182,23183,23184,23185,23186,23187,23188,23189,23190,23191, +23192,23193,23194,23195,23196,23197,23198,23199,23200,23201,23202,23203, +23204,23205,23206,23207,23208,23209,23210,23211,23212,23213,23214,23215, +23216,23217,23218,23219,23220,23221,23222,23223,23224,23225,23226,23227, +23228,23229,23230,23231,23232,23233,23234,23235,23236,23237,23238,23239, +23240,23241,23242,23243,23244,23245,23246,23247,23248,23249,23250,23251, +23252,23253,23254,23255,23256,23257,23258,23259,23260,23261,23262,23263, +23264,23265,23266,23267,23268,23269,23270,23271,23272,23273,23274,23275, +23276,23277,23278,23279,23280,23281,23282,23283,23284,23285,23286,23287, +23288,23289,23290,23291,23292,23293,23294,23295,23296,23297,23298,23299, +23300,23301,23302,23303,23304,23305,23306,23307,23308,23309,23310,23311, +23312,23313,23314,23315,23316,23317,23318,23319,23320,23321,23322,23323, +23324,23325,23326,23327,23328,23329,23330,23331,23332,23333,23334,23335, +23336,23337,23338,23339,23340,23341,23342,23343,23344,23345,23346,23347, +23348,23349,23350,23351,23352,23353,23354,23355,23356,23357,23358,23359, +23360,23361,23362,23363,23364,23365,23366,23367,23368,23369,23370,23371, +23372,23373,23374,23375,23376,23377,23378,23379,23380,23381,23382,23383, +23384,23385,23386,23387,23388,23389,23390,23391,23392,23393,23394,23395, +23396,23397,23398,23399,23400,23401,23402,23403,23404,23405,23406,23407, +23408,23409,23410,23411,23412,23413,23414,23415,23416,23417,23418,23419, +23420,23421,23422,23423,23424,23425,23426,23427,23428,23429,23430,23431, +23432,23433,23434,23435,23436,23437,23438,23439,23440,23441,23442,23443, +23444,23445,23446,23447,23448,23449,23450,23451,23452,23453,23454,23455, +23456,23457,23458,23459,23460,23461,23462,23463,23464,23465,23466,23467, +23468,23469,23470,23471,23472,23473,23474,23475,23476,23477,23478,23479, +23480,23481,23482,23483,23484,23485,23486,23487,23488,23489,23490,23491, +23492,23493,23494,23495,23496,23497,23498,23499,23500,23501,23502,23503, +23504,23505,23506,23507,23508,23509,23510,23511,23512,23513,23514,23515, +23516,23517,23518,23519,23520,23521,23522,23523,23524,23525,23526,23527, +23528,23529,23530,23531,23532,23533,23534,23535,23536,23537,23538,23539, +23540,23541,23542,23543,23544,23545,23546,23547,23548,23549,23550,23551, +23552,23553,23554,23555,23556,23557,23558,23559,23560,23561,23562,23563, +23564,23565,23566,23567,23568,23569,23570,23571,23572,23573,23574,23575, +23576,23577,23578,23579,23580,23581,23582,23583,23584,23585,23586,23587, +23588,23589,23590,23591,23592,23593,23594,23595,23596,23597,23598,23599, +23600,23601,23602,23603,23604,23605,23606,23607,23608,23609,23610,23611, +23612,23613,23614,23615,23616,23617,23618,23619,23620,23621,23622,23623, +23624,23625,23626,23627,23628,23629,23630,23631,23632,23633,23634,23635, +23636,23637,23638,23639,23640,23641,23642,23643,23644,23645,23646,23647, +23648,23649,23650,23651,23652,23653,23654,23655,23656,23657,23658,23659, +23660,23661,23662,23663,23664,23665,23666,23667,23668,23669,23670,23671, +23672,23673,23674,23675,23676,23677,23678,23679,23680,23681,23682,23683, +23684,23685,23686,23687,23688,23689,23690,23691,23692,23693,23694,23695, +23696,23697,23698,23699,23700,23701,23702,23703,23704,23705,23706,23707, +23708,23709,23710,23711,23712,23713,23714,23715,23716,23717,23718,23719, +23720,23721,23722,23723,23724,23725,23726,23727,23728,23729,23730,23731, +23732,23733,23734,23735,23736,23737,23738,23739,23740,23741,23742,23743, +23744,23745,23746,23747,23748,23749,23750,23751,23752,23753,23754,23755, +23756,23757,23758,23759,23760,23761,23762,23763,23764,23765,23766,23767, +23768,23769,23770,23771,23772,23773,23774,23775,23776,23777,23778,23779, +23780,23781,23782,23783,23784,23785,23786,23787,23788,23789,23790,23791, +23792,23793,23794,23795,23796,23797,23798,23799,23800,23801,23802,23803, +23804,23805,23806,23807,23808,23809,23810,23811,23812,23813,23814,23815, +23816,23817,23818,23819,23820,23821,23822,23823,23824,23825,23826,23827, +23828,23829,23830,23831,23832,23833,23834,23835,23836,23837,23838,23839, +23840,23841,23842,23843,23844,23845,23846,23847,23848,23849,23850,23851, +23852,23853,23854,23855,23856,23857,23858,23859,23860,23861,23862,23863, +23864,23865,23866,23867,23868,23869,23870,23871,23872,23873,23874,23875, +23876,23877,23878,23879,23880,23881,23882,23883,23884,23885,23886,23887, +23888,23889,23890,23891,23892,23893,23894,23895,23896,23897,23898,23899, +23900,23901,23902,23903,23904,23905,23906,23907,23908,23909,23910,23911, +23912,23913,23914,23915,23916,23917,23918,23919,23920,23921,23922,23923, +23924,23925,23926,23927,23928,23929,23930,23931,23932,23933,23934,23935, +23936,23937,23938,23939,23940,23941,23942,23943,23944,23945,23946,23947, +23948,23949,23950,23951,23952,23953,23954,23955,23956,23957,23958,23959, +23960,23961,23962,23963,23964,23965,23966,23967,23968,23969,23970,23971, +23972,23973,23974,23975,23976,23977,23978,23979,23980,23981,23982,23983, +23984,23985,23986,23987,23988,23989,23990,23991,23992,23993,23994,23995, +23996,23997,23998,23999,24000,24001,24002,24003,24004,24005,24006,24007, +24008,24009,24010,24011,24012,24013,24014,24015,24016,24017,24018,24019, +24020,24021,24022,24023,24024,24025,24026,24027,24028,24029,24030,24031, +24032,24033,24034,24035,24036,24037,24038,24039,24040,24041,24042,24043, +24044,24045,24046,24047,24048,24049,24050,24051,24052,24053,24054,24055, +24056,24057,24058,24059,24060,24061,24062,24063,24064,24065,24066,24067, +24068,24069,24070,24071,24072,24073,24074,24075,24076,24077,24078,24079, +24080,24081,24082,24083,24084,24085,24086,24087,24088,24089,24090,24091, +24092,24093,24094,24095,24096,24097,24098,24099,24100,24101,24102,24103, +24104,24105,24106,24107,24108,24109,24110,24111,24112,24113,24114,24115, +24116,24117,24118,24119,24120,24121,24122,24123,24124,24125,24126,24127, +24128,24129,24130,24131,24132,24133,24134,24135,24136,24137,24138,24139, +24140,24141,24142,24143,24144,24145,24146,24147,24148,24149,24150,24151, +24152,24153,24154,24155,24156,24157,24158,24159,24160,24161,24162,24163, +24164,24165,24166,24167,24168,24169,24170,24171,24172,24173,24174,24175, +24176,24177,24178,24179,24180,24181,24182,24183,24184,24185,24186,24187, +24188,24189,24190,24191,24192,24193,24194,24195,24196,24197,24198,24199, +24200,24201,24202,24203,24204,24205,24206,24207,24208,24209,24210,24211, +24212,24213,24214,24215,24216,24217,24218,24219,24220,24221,24222,24223, +24224,24225,24226,24227,24228,24229,24230,24231,24232,24233,24234,24235, +24236,24237,24238,24239,24240,24241,24242,24243,24244,24245,24246,24247, +24248,24249,24250,24251,24252,24253,24254,24255,24256,24257,24258,24259, +24260,24261,24262,24263,24264,24265,24266,24267,24268,24269,24270,24271, +24272,24273,24274,24275,24276,24277,24278,24279,24280,24281,24282,24283, +24284,24285,24286,24287,24288,24289,24290,24291,24292,24293,24294,24295, +24296,24297,24298,24299,24300,24301,24302,24303,24304,24305,24306,24307, +24308,24309,24310,24311,24312,24313,24314,24315,24316,24317,24318,24319, +24320,24321,24322,24323,24324,24325,24326,24327,24328,24329,24330,24331, +24332,24333,24334,24335,24336,24337,24338,24339,24340,24341,24342,24343, +24344,24345,24346,24347,24348,24349,24350,24351,24352,24353,24354,24355, +24356,24357,24358,24359,24360,24361,24362,24363,24364,24365,24366,24367, +24368,24369,24370,24371,24372,24373,24374,24375,24376,24377,24378,24379, +24380,24381,24382,24383,24384,24385,24386,24387,24388,24389,24390,24391, +24392,24393,24394,24395,24396,24397,24398,24399,24400,24401,24402,24403, +24404,24405,24406,24407,24408,24409,24410,24411,24412,24413,24414,24415, +24416,24417,24418,24419,24420,24421,24422,24423,24424,24425,24426,24427, +24428,24429,24430,24431,24432,24433,24434,24435,24436,24437,24438,24439, +24440,24441,24442,24443,24444,24445,24446,24447,24448,24449,24450,24451, +24452,24453,24454,24455,24456,24457,24458,24459,24460,24461,24462,24463, +24464,24465,24466,24467,24468,24469,24470,24471,24472,24473,24474,24475, +24476,24477,24478,24479,24480,24481,24482,24483,24484,24485,24486,24487, +24488,24489,24490,24491,24492,24493,24494,24495,24496,24497,24498,24499, +24500,24501,24502,24503,24504,24505,24506,24507,24508,24509,24510,24511, +24512,24513,24514,24515,24516,24517,24518,24519,24520,24521,24522,24523, +24524,24525,24526,24527,24528,24529,24530,24531,24532,24533,24534,24535, +24536,24537,24538,24539,24540,24541,24542,24543,24544,24545,24546,24547, +24548,24549,24550,24551,24552,24553,24554,24555,24556,24557,24558,24559, +24560,24561,24562,24563,24564,24565,24566,24567,24568,24569,24570,24571, +24572,24573,24574,24575,24576,24577,24578,24579,24580,24581,24582,24583, +24584,24585,24586,24587,24588,24589,24590,24591,24592,24593,24594,24595, +24596,24597,24598,24599,24600,24601,24602,24603,24604,24605,24606,24607, +24608,24609,24610,24611,24612,24613,24614,24615,24616,24617,24618,24619, +24620,24621,24622,24623,24624,24625,24626,24627,24628,24629,24630,24631, +24632,24633,24634,24635,24636,24637,24638,24639,24640,24641,24642,24643, +24644,24645,24646,24647,24648,24649,24650,24651,24652,24653,24654,24655, +24656,24657,24658,24659,24660,24661,24662,24663,24664,24665,24666,24667, +24668,24669,24670,24671,24672,24673,24674,24675,24676,24677,24678,24679, +24680,24681,24682,24683,24684,24685,24686,24687,24688,24689,24690,24691, +24692,24693,24694,24695,24696,24697,24698,24699,24700,24701,24702,24703, +24704,24705,24706,24707,24708,24709,24710,24711,24712,24713,24714,24715, +24716,24717,24718,24719,24720,24721,24722,24723,24724,24725,24726,24727, +24728,24729,24730,24731,24732,24733,24734,24735,24736,24737,24738,24739, +24740,24741,24742,24743,24744,24745,24746,24747,24748,24749,24750,24751, +24752,24753,24754,24755,24756,24757,24758,24759,24760,24761,24762,24763, +24764,24765,24766,24767,24768,24769,24770,24771,24772,24773,24774,24775, +24776,24777,24778,24779,24780,24781,24782,24783,24784,24785,24786,24787, +24788,24789,24790,24791,24792,24793,24794,24795,24796,24797,24798,24799, +24800,24801,24802,24803,24804,24805,24806,24807,24808,24809,24810,24811, +24812,24813,24814,24815,24816,24817,24818,24819,24820,24821,24822,24823, +24824,24825,24826,24827,24828,24829,24830,24831,24832,24833,24834,24835, +24836,24837,24838,24839,24840,24841,24842,24843,24844,24845,24846,24847, +24848,24849,24850,24851,24852,24853,24854,24855,24856,24857,24858,24859, +24860,24861,24862,24863,24864,24865,24866,24867,24868,24869,24870,24871, +24872,24873,24874,24875,24876,24877,24878,24879,24880,24881,24882,24883, +24884,24885,24886,24887,24888,24889,24890,24891,24892,24893,24894,24895, +24896,24897,24898,24899,24900,24901,24902,24903,24904,24905,24906,24907, +24908,24909,24910,24911,24912,24913,24914,24915,24916,24917,24918,24919, +24920,24921,24922,24923,24924,24925,24926,24927,24928,24929,24930,24931, +24932,24933,24934,24935,24936,24937,24938,24939,24940,24941,24942,24943, +24944,24945,24946,24947,24948,24949,24950,24951,24952,24953,24954,24955, +24956,24957,24958,24959,24960,24961,24962,24963,24964,24965,24966,24967, +24968,24969,24970,24971,24972,24973,24974,24975,24976,24977,24978,24979, +24980,24981,24982,24983,24984,24985,24986,24987,24988,24989,24990,24991, +24992,24993,24994,24995,24996,24997,24998,24999,25000,25001,25002,25003, +25004,25005,25006,25007,25008,25009,25010,25011,25012,25013,25014,25015, +25016,25017,25018,25019,25020,25021,25022,25023,25024,25025,25026,25027, +25028,25029,25030,25031,25032,25033,25034,25035,25036,25037,25038,25039, +25040,25041,25042,25043,25044,25045,25046,25047,25048,25049,25050,25051, +25052,25053,25054,25055,25056,25057,25058,25059,25060,25061,25062,25063, +25064,25065,25066,25067,25068,25069,25070,25071,25072,25073,25074,25075, +25076,25077,25078,25079,25080,25081,25082,25083,25084,25085,25086,25087, +25088,25089,25090,25091,25092,25093,25094,25095,25096,25097,25098,25099, +25100,25101,25102,25103,25104,25105,25106,25107,25108,25109,25110,25111, +25112,25113,25114,25115,25116,25117,25118,25119,25120,25121,25122,25123, +25124,25125,25126,25127,25128,25129,25130,25131,25132,25133,25134,25135, +25136,25137,25138,25139,25140,25141,25142,25143,25144,25145,25146,25147, +25148,25149,25150,25151,25152,25153,25154,25155,25156,25157,25158,25159, +25160,25161,25162,25163,25164,25165,25166,25167,25168,25169,25170,25171, +25172,25173,25174,25175,25176,25177,25178,25179,25180,25181,25182,25183, +25184,25185,25186,25187,25188,25189,25190,25191,25192,25193,25194,25195, +25196,25197,25198,25199,25200,25201,25202,25203,25204,25205,25206,25207, +25208,25209,25210,25211,25212,25213,25214,25215,25216,25217,25218,25219, +25220,25221,25222,25223,25224,25225,25226,25227,25228,25229,25230,25231, +25232,25233,25234,25235,25236,25237,25238,25239,25240,25241,25242,25243, +25244,25245,25246,25247,25248,25249,25250,25251,25252,25253,25254,25255, +25256,25257,25258,25259,25260,25261,25262,25263,25264,25265,25266,25267, +25268,25269,25270,25271,25272,25273,25274,25275,25276,25277,25278,25279, +25280,25281,25282,25283,25284,25285,25286,25287,25288,25289,25290,25291, +25292,25293,25294,25295,25296,25297,25298,25299,25300,25301,25302,25303, +25304,25305,25306,25307,25308,25309,25310,25311,25312,25313,25314,25315, +25316,25317,25318,25319,25320,25321,25322,25323,25324,25325,25326,25327, +25328,25329,25330,25331,25332,25333,25334,25335,25336,25337,25338,25339, +25340,25341,25342,25343,25344,25345,25346,25347,25348,25349,25350,25351, +25352,25353,25354,25355,25356,25357,25358,25359,25360,25361,25362,25363, +25364,25365,25366,25367,25368,25369,25370,25371,25372,25373,25374,25375, +25376,25377,25378,25379,25380,25381,25382,25383,25384,25385,25386,25387, +25388,25389,25390,25391,25392,25393,25394,25395,25396,25397,25398,25399, +25400,25401,25402,25403,25404,25405,25406,25407,25408,25409,25410,25411, +25412,25413,25414,25415,25416,25417,25418,25419,25420,25421,25422,25423, +25424,25425,25426,25427,25428,25429,25430,25431,25432,25433,25434,25435, +25436,25437,25438,25439,25440,25441,25442,25443,25444,25445,25446,25447, +25448,25449,25450,25451,25452,25453,25454,25455,25456,25457,25458,25459, +25460,25461,25462,25463,25464,25465,25466,25467,25468,25469,25470,25471, +25472,25473,25474,25475,25476,25477,25478,25479,25480,25481,25482,25483, +25484,25485,25486,25487,25488,25489,25490,25491,25492,25493,25494,25495, +25496,25497,25498,25499,25500,25501,25502,25503,25504,25505,25506,25507, +25508,25509,25510,25511,25512,25513,25514,25515,25516,25517,25518,25519, +25520,25521,25522,25523,25524,25525,25526,25527,25528,25529,25530,25531, +25532,25533,25534,25535,25536,25537,25538,25539,25540,25541,25542,25543, +25544,25545,25546,25547,25548,25549,25550,25551,25552,25553,25554,25555, +25556,25557,25558,25559,25560,25561,25562,25563,25564,25565,25566,25567, +25568,25569,25570,25571,25572,25573,25574,25575,25576,25577,25578,25579, +25580,25581,25582,25583,25584,25585,25586,25587,25588,25589,25590,25591, +25592,25593,25594,25595,25596,25597,25598,25599,25600,25601,25602,25603, +25604,25605,25606,25607,25608,25609,25610,25611,25612,25613,25614,25615, +25616,25617,25618,25619,25620,25621,25622,25623,25624,25625,25626,25627, +25628,25629,25630,25631,25632,25633,25634,25635,25636,25637,25638,25639, +25640,25641,25642,25643,25644,25645,25646,25647,25648,25649,25650,25651, +25652,25653,25654,25655,25656,25657,25658,25659,25660,25661,25662,25663, +25664,25665,25666,25667,25668,25669,25670,25671,25672,25673,25674,25675, +25676,25677,25678,25679,25680,25681,25682,25683,25684,25685,25686,25687, +25688,25689,25690,25691,25692,25693,25694,25695,25696,25697,25698,25699, +25700,25701,25702,25703,25704,25705,25706,25707,25708,25709,25710,25711, +25712,25713,25714,25715,25716,25717,25718,25719,25720,25721,25722,25723, +25724,25725,25726,25727,25728,25729,25730,25731,25732,25733,25734,25735, +25736,25737,25738,25739,25740,25741,25742,25743,25744,25745,25746,25747, +25748,25749,25750,25751,25752,25753,25754,25755,25756,25757,25758,25759, +25760,25761,25762,25763,25764,25765,25766,25767,25768,25769,25770,25771, +25772,25773,25774,25775,25776,25777,25778,25779,25780,25781,25782,25783, +25784,25785,25786,25787,25788,25789,25790,25791,25792,25793,25794,25795, +25796,25797,25798,25799,25800,25801,25802,25803,25804,25805,25806,25807, +25808,25809,25810,25811,25812,25813,25814,25815,25816,25817,25818,25819, +25820,25821,25822,25823,25824,25825,25826,25827,25828,25829,25830,25831, +25832,25833,25834,25835,25836,25837,25838,25839,25840,25841,25842,25843, +25844,25845,25846,25847,25848,25849,25850,25851,25852,25853,25854,25855, +25856,25857,25858,25859,25860,25861,25862,25863,25864,25865,25866,25867, +25868,25869,25870,25871,25872,25873,25874,25875,25876,25877,25878,25879, +25880,25881,25882,25883,25884,25885,25886,25887,25888,25889,25890,25891, +25892,25893,25894,25895,25896,25897,25898,25899,25900,25901,25902,25903, +25904,25905,25906,25907,25908,25909,25910,25911,25912,25913,25914,25915, +25916,25917,25918,25919,25920,25921,25922,25923,25924,25925,25926,25927, +25928,25929,25930,25931,25932,25933,25934,25935,25936,25937,25938,25939, +25940,25941,25942,25943,25944,25945,25946,25947,25948,25949,25950,25951, +25952,25953,25954,25955,25956,25957,25958,25959,25960,25961,25962,25963, +25964,25965,25966,25967,25968,25969,25970,25971,25972,25973,25974,25975, +25976,25977,25978,25979,25980,25981,25982,25983,25984,25985,25986,25987, +25988,25989,25990,25991,25992,25993,25994,25995,25996,25997,25998,25999, +26000,26001,26002,26003,26004,26005,26006,26007,26008,26009,26010,26011, +26012,26013,26014,26015,26016,26017,26018,26019,26020,26021,26022,26023, +26024,26025,26026,26027,26028,26029,26030,26031,26032,26033,26034,26035, +26036,26037,26038,26039,26040,26041,26042,26043,26044,26045,26046,26047, +26048,26049,26050,26051,26052,26053,26054,26055,26056,26057,26058,26059, +26060,26061,26062,26063,26064,26065,26066,26067,26068,26069,26070,26071, +26072,26073,26074,26075,26076,26077,26078,26079,26080,26081,26082,26083, +26084,26085,26086,26087,26088,26089,26090,26091,26092,26093,26094,26095, +26096,26097,26098,26099,26100,26101,26102,26103,26104,26105,26106,26107, +26108,26109,26110,26111,26112,26113,26114,26115,26116,26117,26118,26119, +26120,26121,26122,26123,26124,26125,26126,26127,26128,26129,26130,26131, +26132,26133,26134,26135,26136,26137,26138,26139,26140,26141,26142,26143, +26144,26145,26146,26147,26148,26149,26150,26151,26152,26153,26154,26155, +26156,26157,26158,26159,26160,26161,26162,26163,26164,26165,26166,26167, +26168,26169,26170,26171,26172,26173,26174,26175,26176,26177,26178,26179, +26180,26181,26182,26183,26184,26185,26186,26187,26188,26189,26190,26191, +26192,26193,26194,26195,26196,26197,26198,26199,26200,26201,26202,26203, +26204,26205,26206,26207,26208,26209,26210,26211,26212,26213,26214,26215, +26216,26217,26218,26219,26220,26221,26222,26223,26224,26225,26226,26227, +26228,26229,26230,26231,26232,26233,26234,26235,26236,26237,26238,26239, +26240,26241,26242,26243,26244,26245,26246,26247,26248,26249,26250,26251, +26252,26253,26254,26255,26256,26257,26258,26259,26260,26261,26262,26263, +26264,26265,26266,26267,26268,26269,26270,26271,26272,26273,26274,26275, +26276,26277,26278,26279,26280,26281,26282,26283,26284,26285,26286,26287, +26288,26289,26290,26291,26292,26293,26294,26295,26296,26297,26298,26299, +26300,26301,26302,26303,26304,26305,26306,26307,26308,26309,26310,26311, +26312,26313,26314,26315,26316,26317,26318,26319,26320,26321,26322,26323, +26324,26325,26326,26327,26328,26329,26330,26331,26332,26333,26334,26335, +26336,26337,26338,26339,26340,26341,26342,26343,26344,26345,26346,26347, +26348,26349,26350,26351,26352,26353,26354,26355,26356,26357,26358,26359, +26360,26361,26362,26363,26364,26365,26366,26367,26368,26369,26370,26371, +26372,26373,26374,26375,26376,26377,26378,26379,26380,26381,26382,26383, +26384,26385,26386,26387,26388,26389,26390,26391,26392,26393,26394,26395, +26396,26397,26398,26399,26400,26401,26402,26403,26404,26405,26406,26407, +26408,26409,26410,26411,26412,26413,26414,26415,26416,26417,26418,26419, +26420,26421,26422,26423,26424,26425,26426,26427,26428,26429,26430,26431, +26432,26433,26434,26435,26436,26437,26438,26439,26440,26441,26442,26443, +26444,26445,26446,26447,26448,26449,26450,26451,26452,26453,26454,26455, +26456,26457,26458,26459,26460,26461,26462,26463,26464,26465,26466,26467, +26468,26469,26470,26471,26472,26473,26474,26475,26476,26477,26478,26479, +26480,26481,26482,26483,26484,26485,26486,26487,26488,26489,26490,26491, +26492,26493,26494,26495,26496,26497,26498,26499,26500,26501,26502,26503, +26504,26505,26506,26507,26508,26509,26510,26511,26512,26513,26514,26515, +26516,26517,26518,26519,26520,26521,26522,26523,26524,26525,26526,26527, +26528,26529,26530,26531,26532,26533,26534,26535,26536,26537,26538,26539, +26540,26541,26542,26543,26544,26545,26546,26547,26548,26549,26550,26551, +26552,26553,26554,26555,26556,26557,26558,26559,26560,26561,26562,26563, +26564,26565,26566,26567,26568,26569,26570,26571,26572,26573,26574,26575, +26576,26577,26578,26579,26580,26581,26582,26583,26584,26585,26586,26587, +26588,26589,26590,26591,26592,26593,26594,26595,26596,26597,26598,26599, +26600,26601,26602,26603,26604,26605,26606,26607,26608,26609,26610,26611, +26612,26613,26614,26615,26616,26617,26618,26619,26620,26621,26622,26623, +26624,26625,26626,26627,26628,26629,26630,26631,26632,26633,26634,26635, +26636,26637,26638,26639,26640,26641,26642,26643,26644,26645,26646,26647, +26648,26649,26650,26651,26652,26653,26654,26655,26656,26657,26658,26659, +26660,26661,26662,26663,26664,26665,26666,26667,26668,26669,26670,26671, +26672,26673,26674,26675,26676,26677,26678,26679,26680,26681,26682,26683, +26684,26685,26686,26687,26688,26689,26690,26691,26692,26693,26694,26695, +26696,26697,26698,26699,26700,26701,26702,26703,26704,26705,26706,26707, +26708,26709,26710,26711,26712,26713,26714,26715,26716,26717,26718,26719, +26720,26721,26722,26723,26724,26725,26726,26727,26728,26729,26730,26731, +26732,26733,26734,26735,26736,26737,26738,26739,26740,26741,26742,26743, +26744,26745,26746,26747,26748,26749,26750,26751,26752,26753,26754,26755, +26756,26757,26758,26759,26760,26761,26762,26763,26764,26765,26766,26767, +26768,26769,26770,26771,26772,26773,26774,26775,26776,26777,26778,26779, +26780,26781,26782,26783,26784,26785,26786,26787,26788,26789,26790,26791, +26792,26793,26794,26795,26796,26797,26798,26799,26800,26801,26802,26803, +26804,26805,26806,26807,26808,26809,26810,26811,26812,26813,26814,26815, +26816,26817,26818,26819,26820,26821,26822,26823,26824,26825,26826,26827, +26828,26829,26830,26831,26832,26833,26834,26835,26836,26837,26838,26839, +26840,26841,26842,26843,26844,26845,26846,26847,26848,26849,26850,26851, +26852,26853,26854,26855,26856,26857,26858,26859,26860,26861,26862,26863, +26864,26865,26866,26867,26868,26869,26870,26871,26872,26873,26874,26875, +26876,26877,26878,26879,26880,26881,26882,26883,26884,26885,26886,26887, +26888,26889,26890,26891,26892,26893,26894,26895,26896,26897,26898,26899, +26900,26901,26902,26903,26904,26905,26906,26907,26908,26909,26910,26911, +26912,26913,26914,26915,26916,26917,26918,26919,26920,26921,26922,26923, +26924,26925,26926,26927,26928,26929,26930,26931,26932,26933,26934,26935, +26936,26937,26938,26939,26940,26941,26942,26943,26944,26945,26946,26947, +26948,26949,26950,26951,26952,26953,26954,26955,26956,26957,26958,26959, +26960,26961,26962,26963,26964,26965,26966,26967,26968,26969,26970,26971, +26972,26973,26974,26975,26976,26977,26978,26979,26980,26981,26982,26983, +26984,26985,26986,26987,26988,26989,26990,26991,26992,26993,26994,26995, +26996,26997,26998,26999,27000,27001,27002,27003,27004,27005,27006,27007, +27008,27009,27010,27011,27012,27013,27014,27015,27016,27017,27018,27019, +27020,27021,27022,27023,27024,27025,27026,27027,27028,27029,27030,27031, +27032,27033,27034,27035,27036,27037,27038,27039,27040,27041,27042,27043, +27044,27045,27046,27047,27048,27049,27050,27051,27052,27053,27054,27055, +27056,27057,27058,27059,27060,27061,27062,27063,27064,27065,27066,27067, +27068,27069,27070,27071,27072,27073,27074,27075,27076,27077,27078,27079, +27080,27081,27082,27083,27084,27085,27086,27087,27088,27089,27090,27091, +27092,27093,27094,27095,27096,27097,27098,27099,27100,27101,27102,27103, +27104,27105,27106,27107,27108,27109,27110,27111,27112,27113,27114,27115, +27116,27117,27118,27119,27120,27121,27122,27123,27124,27125,27126,27127, +27128,27129,27130,27131,27132,27133,27134,27135,27136,27137,27138,27139, +27140,27141,27142,27143,27144,27145,27146,27147,27148,27149,27150,27151, +27152,27153,27154,27155,27156,27157,27158,27159,27160,27161,27162,27163, +27164,27165,27166,27167,27168,27169,27170,27171,27172,27173,27174,27175, +27176,27177,27178,27179,27180,27181,27182,27183,27184,27185,27186,27187, +27188,27189,27190,27191,27192,27193,27194,27195,27196,27197,27198,27199, +27200,27201,27202,27203,27204,27205,27206,27207,27208,27209,27210,27211, +27212,27213,27214,27215,27216,27217,27218,27219,27220,27221,27222,27223, +27224,27225,27226,27227,27228,27229,27230,27231,27232,27233,27234,27235, +27236,27237,27238,27239,27240,27241,27242,27243,27244,27245,27246,27247, +27248,27249,27250,27251,27252,27253,27254,27255,27256,27257,27258,27259, +27260,27261,27262,27263,27264,27265,27266,27267,27268,27269,27270,27271, +27272,27273,27274,27275,27276,27277,27278,27279,27280,27281,27282,27283, +27284,27285,27286,27287,27288,27289,27290,27291,27292,27293,27294,27295, +27296,27297,27298,27299,27300,27301,27302,27303,27304,27305,27306,27307, +27308,27309,27310,27311,27312,27313,27314,27315,27316,27317,27318,27319, +27320,27321,27322,27323,27324,27325,27326,27327,27328,27329,27330,27331, +27332,27333,27334,27335,27336,27337,27338,27339,27340,27341,27342,27343, +27344,27345,27346,27347,27348,27349,27350,27351,27352,27353,27354,27355, +27356,27357,27358,27359,27360,27361,27362,27363,27364,27365,27366,27367, +27368,27369,27370,27371,27372,27373,27374,27375,27376,27377,27378,27379, +27380,27381,27382,27383,27384,27385,27386,27387,27388,27389,27390,27391, +27392,27393,27394,27395,27396,27397,27398,27399,27400,27401,27402,27403, +27404,27405,27406,27407,27408,27409,27410,27411,27412,27413,27414,27415, +27416,27417,27418,27419,27420,27421,27422,27423,27424,27425,27426,27427, +27428,27429,27430,27431,27432,27433,27434,27435,27436,27437,27438,27439, +27440,27441,27442,27443,27444,27445,27446,27447,27448,27449,27450,27451, +27452,27453,27454,27455,27456,27457,27458,27459,27460,27461,27462,27463, +27464,27465,27466,27467,27468,27469,27470,27471,27472,27473,27474,27475, +27476,27477,27478,27479,27480,27481,27482,27483,27484,27485,27486,27487, +27488,27489,27490,27491,27492,27493,27494,27495,27496,27497,27498,27499, +27500,27501,27502,27503,27504,27505,27506,27507,27508,27509,27510,27511, +27512,27513,27514,27515,27516,27517,27518,27519,27520,27521,27522,27523, +27524,27525,27526,27527,27528,27529,27530,27531,27532,27533,27534,27535, +27536,27537,27538,27539,27540,27541,27542,27543,27544,27545,27546,27547, +27548,27549,27550,27551,27552,27553,27554,27555,27556,27557,27558,27559, +27560,27561,27562,27563,27564,27565,27566,27567,27568,27569,27570,27571, +27572,27573,27574,27575,27576,27577,27578,27579,27580,27581,27582,27583, +27584,27585,27586,27587,27588,27589,27590,27591,27592,27593,27594,27595, +27596,27597,27598,27599,27600,27601,27602,27603,27604,27605,27606,27607, +27608,27609,27610,27611,27612,27613,27614,27615,27616,27617,27618,27619, +27620,27621,27622,27623,27624,27625,27626,27627,27628,27629,27630,27631, +27632,27633,27634,27635,27636,27637,27638,27639,27640,27641,27642,27643, +27644,27645,27646,27647,27648,27649,27650,27651,27652,27653,27654,27655, +27656,27657,27658,27659,27660,27661,27662,27663,27664,27665,27666,27667, +27668,27669,27670,27671,27672,27673,27674,27675,27676,27677,27678,27679, +27680,27681,27682,27683,27684,27685,27686,27687,27688,27689,27690,27691, +27692,27693,27694,27695,27696,27697,27698,27699,27700,27701,27702,27703, +27704,27705,27706,27707,27708,27709,27710,27711,27712,27713,27714,27715, +27716,27717,27718,27719,27720,27721,27722,27723,27724,27725,27726,27727, +27728,27729,27730,27731,27732,27733,27734,27735,27736,27737,27738,27739, +27740,27741,27742,27743,27744,27745,27746,27747,27748,27749,27750,27751, +27752,27753,27754,27755,27756,27757,27758,27759,27760,27761,27762,27763, +27764,27765,27766,27767,27768,27769,27770,27771,27772,27773,27774,27775, +27776,27777,27778,27779,27780,27781,27782,27783,27784,27785,27786,27787, +27788,27789,27790,27791,27792,27793,27794,27795,27796,27797,27798,27799, +27800,27801,27802,27803,27804,27805,27806,27807,27808,27809,27810,27811, +27812,27813,27814,27815,27816,27817,27818,27819,27820,27821,27822,27823, +27824,27825,27826,27827,27828,27829,27830,27831,27832,27833,27834,27835, +27836,27837,27838,27839,27840,27841,27842,27843,27844,27845,27846,27847, +27848,27849,27850,27851,27852,27853,27854,27855,27856,27857,27858,27859, +27860,27861,27862,27863,27864,27865,27866,27867,27868,27869,27870,27871, +27872,27873,27874,27875,27876,27877,27878,27879,27880,27881,27882,27883, +27884,27885,27886,27887,27888,27889,27890,27891,27892,27893,27894,27895, +27896,27897,27898,27899,27900,27901,27902,27903,27904,27905,27906,27907, +27908,27909,27910,27911,27912,27913,27914,27915,27916,27917,27918,27919, +27920,27921,27922,27923,27924,27925,27926,27927,27928,27929,27930,27931, +27932,27933,27934,27935,27936,27937,27938,27939,27940,27941,27942,27943, +27944,27945,27946,27947,27948,27949,27950,27951,27952,27953,27954,27955, +27956,27957,27958,27959,27960,27961,27962,27963,27964,27965,27966,27967, +27968,27969,27970,27971,27972,27973,27974,27975,27976,27977,27978,27979, +27980,27981,27982,27983,27984,27985,27986,27987,27988,27989,27990,27991, +27992,27993,27994,27995,27996,27997,27998,27999,28000,28001,28002,28003, +28004,28005,28006,28007,28008,28009,28010,28011,28012,28013,28014,28015, +28016,28017,28018,28019,28020,28021,28022,28023,28024,28025,28026,28027, +28028,28029,28030,28031,28032,28033,28034,28035,28036,28037,28038,28039, +28040,28041,28042,28043,28044,28045,28046,28047,28048,28049,28050,28051, +28052,28053,28054,28055,28056,28057,28058,28059,28060,28061,28062,28063, +28064,28065,28066,28067,28068,28069,28070,28071,28072,28073,28074,28075, +28076,28077,28078,28079,28080,28081,28082,28083,28084,28085,28086,28087, +28088,28089,28090,28091,28092,28093,28094,28095,28096,28097,28098,28099, +28100,28101,28102,28103,28104,28105,28106,28107,28108,28109,28110,28111, +28112,28113,28114,28115,28116,28117,28118,28119,28120,28121,28122,28123, +28124,28125,28126,28127,28128,28129,28130,28131,28132,28133,28134,28135, +28136,28137,28138,28139,28140,28141,28142,28143,28144,28145,28146,28147, +28148,28149,28150,28151,28152,28153,28154,28155,28156,28157,28158,28159, +28160,28161,28162,28163,28164,28165,28166,28167,28168,28169,28170,28171, +28172,28173,28174,28175,28176,28177,28178,28179,28180,28181,28182,28183, +28184,28185,28186,28187,28188,28189,28190,28191,28192,28193,28194,28195, +28196,28197,28198,28199,28200,28201,28202,28203,28204,28205,28206,28207, +28208,28209,28210,28211,28212,28213,28214,28215,28216,28217,28218,28219, +28220,28221,28222,28223,28224,28225,28226,28227,28228,28229,28230,28231, +28232,28233,28234,28235,28236,28237,28238,28239,28240,28241,28242,28243, +28244,28245,28246,28247,28248,28249,28250,28251,28252,28253,28254,28255, +28256,28257,28258,28259,28260,28261,28262,28263,28264,28265,28266,28267, +28268,28269,28270,28271,28272,28273,28274,28275,28276,28277,28278,28279, +28280,28281,28282,28283,28284,28285,28286,28287,28288,28289,28290,28291, +28292,28293,28294,28295,28296,28297,28298,28299,28300,28301,28302,28303, +28304,28305,28306,28307,28308,28309,28310,28311,28312,28313,28314,28315, +28316,28317,28318,28319,28320,28321,28322,28323,28324,28325,28326,28327, +28328,28329,28330,28331,28332,28333,28334,28335,28336,28337,28338,28339, +28340,28341,28342,28343,28344,28345,28346,28347,28348,28349,28350,28351, +28352,28353,28354,28355,28356,28357,28358,28359,28360,28361,28362,28363, +28364,28365,28366,28367,28368,28369,28370,28371,28372,28373,28374,28375, +28376,28377,28378,28379,28380,28381,28382,28383,28384,28385,28386,28387, +28388,28389,28390,28391,28392,28393,28394,28395,28396,28397,28398,28399, +28400,28401,28402,28403,28404,28405,28406,28407,28408,28409,28410,28411, +28412,28413,28414,28415,28416,28417,28418,28419,28420,28421,28422,28423, +28424,28425,28426,28427,28428,28429,28430,28431,28432,28433,28434,28435, +28436,28437,28438,28439,28440,28441,28442,28443,28444,28445,28446,28447, +28448,28449,28450,28451,28452,28453,28454,28455,28456,28457,28458,28459, +28460,28461,28462,28463,28464,28465,28466,28467,28468,28469,28470,28471, +28472,28473,28474,28475,28476,28477,28478,28479,28480,28481,28482,28483, +28484,28485,28486,28487,28488,28489,28490,28491,28492,28493,28494,28495, +28496,28497,28498,28499,28500,28501,28502,28503,28504,28505,28506,28507, +28508,28509,28510,28511,28512,28513,28514,28515,28516,28517,28518,28519, +28520,28521,28522,28523,28524,28525,28526,28527,28528,28529,28530,28531, +28532,28533,28534,28535,28536,28537,28538,28539,28540,28541,28542,28543, +28544,28545,28546,28547,28548,28549,28550,28551,28552,28553,28554,28555, +28556,28557,28558,28559,28560,28561,28562,28563,28564,28565,28566,28567, +28568,28569,28570,28571,28572,28573,28574,28575,28576,28577,28578,28579, +28580,28581,28582,28583,28584,28585,28586,28587,28588,28589,28590,28591, +28592,28593,28594,28595,28596,28597,28598,28599,28600,28601,28602,28603, +28604,28605,28606,28607,28608,28609,28610,28611,28612,28613,28614,28615, +28616,28617,28618,28619,28620,28621,28622,28623,28624,28625,28626,28627, +28628,28629,28630,28631,28632,28633,28634,28635,28636,28637,28638,28639, +28640,28641,28642,28643,28644,28645,28646,28647,28648,28649,28650,28651, +28652,28653,28654,28655,28656,28657,28658,28659,28660,28661,28662,28663, +28664,28665,28666,28667,28668,28669,28670,28671,28672,28673,28674,28675, +28676,28677,28678,28679,28680,28681,28682,28683,28684,28685,28686,28687, +28688,28689,28690,28691,28692,28693,28694,28695,28696,28697,28698,28699, +28700,28701,28702,28703,28704,28705,28706,28707,28708,28709,28710,28711, +28712,28713,28714,28715,28716,28717,28718,28719,28720,28721,28722,28723, +28724,28725,28726,28727,28728,28729,28730,28731,28732,28733,28734,28735, +28736,28737,28738,28739,28740,28741,28742,28743,28744,28745,28746,28747, +28748,28749,28750,28751,28752,28753,28754,28755,28756,28757,28758,28759, +28760,28761,28762,28763,28764,28765,28766,28767,28768,28769,28770,28771, +28772,28773,28774,28775,28776,28777,28778,28779,28780,28781,28782,28783, +28784,28785,28786,28787,28788,28789,28790,28791,28792,28793,28794,28795, +28796,28797,28798,28799,28800,28801,28802,28803,28804,28805,28806,28807, +28808,28809,28810,28811,28812,28813,28814,28815,28816,28817,28818,28819, +28820,28821,28822,28823,28824,28825,28826,28827,28828,28829,28830,28831, +28832,28833,28834,28835,28836,28837,28838,28839,28840,28841,28842,28843, +28844,28845,28846,28847,28848,28849,28850,28851,28852,28853,28854,28855, +28856,28857,28858,28859,28860,28861,28862,28863,28864,28865,28866,28867, +28868,28869,28870,28871,28872,28873,28874,28875,28876,28877,28878,28879, +28880,28881,28882,28883,28884,28885,28886,28887,28888,28889,28890,28891, +28892,28893,28894,28895,28896,28897,28898,28899,28900,28901,28902,28903, +28904,28905,28906,28907,28908,28909,28910,28911,28912,28913,28914,28915, +28916,28917,28918,28919,28920,28921,28922,28923,28924,28925,28926,28927, +28928,28929,28930,28931,28932,28933,28934,28935,28936,28937,28938,28939, +28940,28941,28942,28943,28944,28945,28946,28947,28948,28949,28950,28951, +28952,28953,28954,28955,28956,28957,28958,28959,28960,28961,28962,28963, +28964,28965,28966,28967,28968,28969,28970,28971,28972,28973,28974,28975, +28976,28977,28978,28979,28980,28981,28982,28983,28984,28985,28986,28987, +28988,28989,28990,28991,28992,28993,28994,28995,28996,28997,28998,28999, +29000,29001,29002,29003,29004,29005,29006,29007,29008,29009,29010,29011, +29012,29013,29014,29015,29016,29017,29018,29019,29020,29021,29022,29023, +29024,29025,29026,29027,29028,29029,29030,29031,29032,29033,29034,29035, +29036,29037,29038,29039,29040,29041,29042,29043,29044,29045,29046,29047, +29048,29049,29050,29051,29052,29053,29054,29055,29056,29057,29058,29059, +29060,29061,29062,29063,29064,29065,29066,29067,29068,29069,29070,29071, +29072,29073,29074,29075,29076,29077,29078,29079,29080,29081,29082,29083, +29084,29085,29086,29087,29088,29089,29090,29091,29092,29093,29094,29095, +29096,29097,29098,29099,29100,29101,29102,29103,29104,29105,29106,29107, +29108,29109,29110,29111,29112,29113,29114,29115,29116,29117,29118,29119, +29120,29121,29122,29123,29124,29125,29126,29127,29128,29129,29130,29131, +29132,29133,29134,29135,29136,29137,29138,29139,29140,29141,29142,29143, +29144,29145,29146,29147,29148,29149,29150,29151,29152,29153,29154,29155, +29156,29157,29158,29159,29160,29161,29162,29163,29164,29165,29166,29167, +29168,29169,29170,29171,29172,29173,29174,29175,29176,29177,29178,29179, +29180,29181,29182,29183,29184,29185,29186,29187,29188,29189,29190,29191, +29192,29193,29194,29195,29196,29197,29198,29199,29200,29201,29202,29203, +29204,29205,29206,29207,29208,29209,29210,29211,29212,29213,29214,29215, +29216,29217,29218,29219,29220,29221,29222,29223,29224,29225,29226,29227, +29228,29229,29230,29231,29232,29233,29234,29235,29236,29237,29238,29239, +29240,29241,29242,29243,29244,29245,29246,29247,29248,29249,29250,29251, +29252,29253,29254,29255,29256,29257,29258,29259,29260,29261,29262,29263, +29264,29265,29266,29267,29268,29269,29270,29271,29272,29273,29274,29275, +29276,29277,29278,29279,29280,29281,29282,29283,29284,29285,29286,29287, +29288,29289,29290,29291,29292,29293,29294,29295,29296,29297,29298,29299, +29300,29301,29302,29303,29304,29305,29306,29307,29308,29309,29310,29311, +29312,29313,29314,29315,29316,29317,29318,29319,29320,29321,29322,29323, +29324,29325,29326,29327,29328,29329,29330,29331,29332,29333,29334,29335, +29336,29337,29338,29339,29340,29341,29342,29343,29344,29345,29346,29347, +29348,29349,29350,29351,29352,29353,29354,29355,29356,29357,29358,29359, +29360,29361,29362,29363,29364,29365,29366,29367,29368,29369,29370,29371, +29372,29373,29374,29375,29376,29377,29378,29379,29380,29381,29382,29383, +29384,29385,29386,29387,29388,29389,29390,29391,29392,29393,29394,29395, +29396,29397,29398,29399,29400,29401,29402,29403,29404,29405,29406,29407, +29408,29409,29410,29411,29412,29413,29414,29415,29416,29417,29418,29419, +29420,29421,29422,29423,29424,29425,29426,29427,29428,29429,29430,29431, +29432,29433,29434,29435,29436,29437,29438,29439,29440,29441,29442,29443, +29444,29445,29446,29447,29448,29449,29450,29451,29452,29453,29454,29455, +29456,29457,29458,29459,29460,29461,29462,29463,29464,29465,29466,29467, +29468,29469,29470,29471,29472,29473,29474,29475,29476,29477,29478,29479, +29480,29481,29482,29483,29484,29485,29486,29487,29488,29489,29490,29491, +29492,29493,29494,29495,29496,29497,29498,29499,29500,29501,29502,29503, +29504,29505,29506,29507,29508,29509,29510,29511,29512,29513,29514,29515, +29516,29517,29518,29519,29520,29521,29522,29523,29524,29525,29526,29527, +29528,29529,29530,29531,29532,29533,29534,29535,29536,29537,29538,29539, +29540,29541,29542,29543,29544,29545,29546,29547,29548,29549,29550,29551, +29552,29553,29554,29555,29556,29557,29558,29559,29560,29561,29562,29563, +29564,29565,29566,29567,29568,29569,29570,29571,29572,29573,29574,29575, +29576,29577,29578,29579,29580,29581,29582,29583,29584,29585,29586,29587, +29588,29589,29590,29591,29592,29593,29594,29595,29596,29597,29598,29599, +29600,29601,29602,29603,29604,29605,29606,29607,29608,29609,29610,29611, +29612,29613,29614,29615,29616,29617,29618,29619,29620,29621,29622,29623, +29624,29625,29626,29627,29628,29629,29630,29631,29632,29633,29634,29635, +29636,29637,29638,29639,29640,29641,29642,29643,29644,29645,29646,29647, +29648,29649,29650,29651,29652,29653,29654,29655,29656,29657,29658,29659, +29660,29661,29662,29663,29664,29665,29666,29667,29668,29669,29670,29671, +29672,29673,29674,29675,29676,29677,29678,29679,29680,29681,29682,29683, +29684,29685,29686,29687,29688,29689,29690,29691,29692,29693,29694,29695, +29696,29697,29698,29699,29700,29701,29702,29703,29704,29705,29706,29707, +29708,29709,29710,29711,29712,29713,29714,29715,29716,29717,29718,29719, +29720,29721,29722,29723,29724,29725,29726,29727,29728,29729,29730,29731, +29732,29733,29734,29735,29736,29737,29738,29739,29740,29741,29742,29743, +29744,29745,29746,29747,29748,29749,29750,29751,29752,29753,29754,29755, +29756,29757,29758,29759,29760,29761,29762,29763,29764,29765,29766,29767, +29768,29769,29770,29771,29772,29773,29774,29775,29776,29777,29778,29779, +29780,29781,29782,29783,29784,29785,29786,29787,29788,29789,29790,29791, +29792,29793,29794,29795,29796,29797,29798,29799,29800,29801,29802,29803, +29804,29805,29806,29807,29808,29809,29810,29811,29812,29813,29814,29815, +29816,29817,29818,29819,29820,29821,29822,29823,29824,29825,29826,29827, +29828,29829,29830,29831,29832,29833,29834,29835,29836,29837,29838,29839, +29840,29841,29842,29843,29844,29845,29846,29847,29848,29849,29850,29851, +29852,29853,29854,29855,29856,29857,29858,29859,29860,29861,29862,29863, +29864,29865,29866,29867,29868,29869,29870,29871,29872,29873,29874,29875, +29876,29877,29878,29879,29880,29881,29882,29883,29884,29885,29886,29887, +29888,29889,29890,29891,29892,29893,29894,29895,29896,29897,29898,29899, +29900,29901,29902,29903,29904,29905,29906,29907,29908,29909,29910,29911, +29912,29913,29914,29915,29916,29917,29918,29919,29920,29921,29922,29923, +29924,29925,29926,29927,29928,29929,29930,29931,29932,29933,29934,29935, +29936,29937,29938,29939,29940,29941,29942,29943,29944,29945,29946,29947, +29948,29949,29950,29951,29952,29953,29954,29955,29956,29957,29958,29959, +29960,29961,29962,29963,29964,29965,29966,29967,29968,29969,29970,29971, +29972,29973,29974,29975,29976,29977,29978,29979,29980,29981,29982,29983, +29984,29985,29986,29987,29988,29989,29990,29991,29992,29993,29994,29995, +29996,29997,29998,29999,30000,30001,30002,30003,30004,30005,30006,30007, +30008,30009,30010,30011,30012,30013,30014,30015,30016,30017,30018,30019, +30020,30021,30022,30023,30024,30025,30026,30027,30028,30029,30030,30031, +30032,30033,30034,30035,30036,30037,30038,30039,30040,30041,30042,30043, +30044,30045,30046,30047,30048,30049,30050,30051,30052,30053,30054,30055, +30056,30057,30058,30059,30060,30061,30062,30063,30064,30065,30066,30067, +30068,30069,30070,30071,30072,30073,30074,30075,30076,30077,30078,30079, +30080,30081,30082,30083,30084,30085,30086,30087,30088,30089,30090,30091, +30092,30093,30094,30095,30096,30097,30098,30099,30100,30101,30102,30103, +30104,30105,30106,30107,30108,30109,30110,30111,30112,30113,30114,30115, +30116,30117,30118,30119,30120,30121,30122,30123,30124,30125,30126,30127, +30128,30129,30130,30131,30132,30133,30134,30135,30136,30137,30138,30139, +30140,30141,30142,30143,30144,30145,30146,30147,30148,30149,30150,30151, +30152,30153,30154,30155,30156,30157,30158,30159,30160,30161,30162,30163, +30164,30165,30166,30167,30168,30169,30170,30171,30172,30173,30174,30175, +30176,30177,30178,30179,30180,30181,30182,30183,30184,30185,30186,30187, +30188,30189,30190,30191,30192,30193,30194,30195,30196,30197,30198,30199, +30200,30201,30202,30203,30204,30205,30206,30207,30208,30209,30210,30211, +30212,30213,30214,30215,30216,30217,30218,30219,30220,30221,30222,30223, +30224,30225,30226,30227,30228,30229,30230,30231,30232,30233,30234,30235, +30236,30237,30238,30239,30240,30241,30242,30243,30244,30245,30246,30247, +30248,30249,30250,30251,30252,30253,30254,30255,30256,30257,30258,30259, +30260,30261,30262,30263,30264,30265,30266,30267,30268,30269,30270,30271, +30272,30273,30274,30275,30276,30277,30278,30279,30280,30281,30282,30283, +30284,30285,30286,30287,30288,30289,30290,30291,30292,30293,30294,30295, +30296,30297,30298,30299,30300,30301,30302,30303,30304,30305,30306,30307, +30308,30309,30310,30311,30312,30313,30314,30315,30316,30317,30318,30319, +30320,30321,30322,30323,30324,30325,30326,30327,30328,30329,30330,30331, +30332,30333,30334,30335,30336,30337,30338,30339,30340,30341,30342,30343, +30344,30345,30346,30347,30348,30349,30350,30351,30352,30353,30354,30355, +30356,30357,30358,30359,30360,30361,30362,30363,30364,30365,30366,30367, +30368,30369,30370,30371,30372,30373,30374,30375,30376,30377,30378,30379, +30380,30381,30382,30383,30384,30385,30386,30387,30388,30389,30390,30391, +30392,30393,30394,30395,30396,30397,30398,30399,30400,30401,30402,30403, +30404,30405,30406,30407,30408,30409,30410,30411,30412,30413,30414,30415, +30416,30417,30418,30419,30420,30421,30422,30423,30424,30425,30426,30427, +30428,30429,30430,30431,30432,30433,30434,30435,30436,30437,30438,30439, +30440,30441,30442,30443,30444,30445,30446,30447,30448,30449,30450,30451, +30452,30453,30454,30455,30456,30457,30458,30459,30460,30461,30462,30463, +30464,30465,30466,30467,30468,30469,30470,30471,30472,30473,30474,30475, +30476,30477,30478,30479,30480,30481,30482,30483,30484,30485,30486,30487, +30488,30489,30490,30491,30492,30493,30494,30495,30496,30497,30498,30499, +30500,30501,30502,30503,30504,30505,30506,30507,30508,30509,30510,30511, +30512,30513,30514,30515,30516,30517,30518,30519,30520,30521,30522,30523, +30524,30525,30526,30527,30528,30529,30530,30531,30532,30533,30534,30535, +30536,30537,30538,30539,30540,30541,30542,30543,30544,30545,30546,30547, +30548,30549,30550,30551,30552,30553,30554,30555,30556,30557,30558,30559, +30560,30561,30562,30563,30564,30565,30566,30567,30568,30569,30570,30571, +30572,30573,30574,30575,30576,30577,30578,30579,30580,30581,30582,30583, +30584,30585,30586,30587,30588,30589,30590,30591,30592,30593,30594,30595, +30596,30597,30598,30599,30600,30601,30602,30603,30604,30605,30606,30607, +30608,30609,30610,30611,30612,30613,30614,30615,30616,30617,30618,30619, +30620,30621,30622,30623,30624,30625,30626,30627,30628,30629,30630,30631, +30632,30633,30634,30635,30636,30637,30638,30639,30640,30641,30642,30643, +30644,30645,30646,30647,30648,30649,30650,30651,30652,30653,30654,30655, +30656,30657,30658,30659,30660,30661,30662,30663,30664,30665,30666,30667, +30668,30669,30670,30671,30672,30673,30674,30675,30676,30677,30678,30679, +30680,30681,30682,30683,30684,30685,30686,30687,30688,30689,30690,30691, +30692,30693,30694,30695,30696,30697,30698,30699,30700,30701,30702,30703, +30704,30705,30706,30707,30708,30709,30710,30711,30712,30713,30714,30715, +30716,30717,30718,30719,30720,30721,30722,30723,30724,30725,30726,30727, +30728,30729,30730,30731,30732,30733,30734,30735,30736,30737,30738,30739, +30740,30741,30742,30743,30744,30745,30746,30747,30748,30749,30750,30751, +30752,30753,30754,30755,30756,30757,30758,30759,30760,30761,30762,30763, +30764,30765,30766,30767,30768,30769,30770,30771,30772,30773,30774,30775, +30776,30777,30778,30779,30780,30781,30782,30783,30784,30785,30786,30787, +30788,30789,30790,30791,30792,30793,30794,30795,30796,30797,30798,30799, +30800,30801,30802,30803,30804,30805,30806,30807,30808,30809,30810,30811, +30812,30813,30814,30815,30816,30817,30818,30819,30820,30821,30822,30823, +30824,30825,30826,30827,30828,30829,30830,30831,30832,30833,30834,30835, +30836,30837,30838,30839,30840,30841,30842,30843,30844,30845,30846,30847, +30848,30849,30850,30851,30852,30853,30854,30855,30856,30857,30858,30859, +30860,30861,30862,30863,30864,30865,30866,30867,30868,30869,30870,30871, +30872,30873,30874,30875,30876,30877,30878,30879,30880,30881,30882,30883, +30884,30885,30886,30887,30888,30889,30890,30891,30892,30893,30894,30895, +30896,30897,30898,30899,30900,30901,30902,30903,30904,30905,30906,30907, +30908,30909,30910,30911,30912,30913,30914,30915,30916,30917,30918,30919, +30920,30921,30922,30923,30924,30925,30926,30927,30928,30929,30930,30931, +30932,30933,30934,30935,30936,30937,30938,30939,30940,30941,30942,30943, +30944,30945,30946,30947,30948,30949,30950,30951,30952,30953,30954,30955, +30956,30957,30958,30959,30960,30961,30962,30963,30964,30965,30966,30967, +30968,30969,30970,30971,30972,30973,30974,30975,30976,30977,30978,30979, +30980,30981,30982,30983,30984,30985,30986,30987,30988,30989,30990,30991, +30992,30993,30994,30995,30996,30997,30998,30999,31000,31001,31002,31003, +31004,31005,31006,31007,31008,31009,31010,31011,31012,31013,31014,31015, +31016,31017,31018,31019,31020,31021,31022,31023,31024,31025,31026,31027, +31028,31029,31030,31031,31032,31033,31034,31035,31036,31037,31038,31039, +31040,31041,31042,31043,31044,31045,31046,31047,31048,31049,31050,31051, +31052,31053,31054,31055,31056,31057,31058,31059,31060,31061,31062,31063, +31064,31065,31066,31067,31068,31069,31070,31071,31072,31073,31074,31075, +31076,31077,31078,31079,31080,31081,31082,31083,31084,31085,31086,31087, +31088,31089,31090,31091,31092,31093,31094,31095,31096,31097,31098,31099, +31100,31101,31102,31103,31104,31105,31106,31107,31108,31109,31110,31111, +31112,31113,31114,31115,31116,31117,31118,31119,31120,31121,31122,31123, +31124,31125,31126,31127,31128,31129,31130,31131,31132,31133,31134,31135, +31136,31137,31138,31139,31140,31141,31142,31143,31144,31145,31146,31147, +31148,31149,31150,31151,31152,31153,31154,31155,31156,31157,31158,31159, +31160,31161,31162,31163,31164,31165,31166,31167,31168,31169,31170,31171, +31172,31173,31174,31175,31176,31177,31178,31179,31180,31181,31182,31183, +31184,31185,31186,31187,31188,31189,31190,31191,31192,31193,31194,31195, +31196,31197,31198,31199,31200,31201,31202,31203,31204,31205,31206,31207, +31208,31209,31210,31211,31212,31213,31214,31215,31216,31217,31218,31219, +31220,31221,31222,31223,31224,31225,31226,31227,31228,31229,31230,31231, +31232,31233,31234,31235,31236,31237,31238,31239,31240,31241,31242,31243, +31244,31245,31246,31247,31248,31249,31250,31251,31252,31253,31254,31255, +31256,31257,31258,31259,31260,31261,31262,31263,31264,31265,31266,31267, +31268,31269,31270,31271,31272,31273,31274,31275,31276,31277,31278,31279, +31280,31281,31282,31283,31284,31285,31286,31287,31288,31289,31290,31291, +31292,31293,31294,31295,31296,31297,31298,31299,31300,31301,31302,31303, +31304,31305,31306,31307,31308,31309,31310,31311,31312,31313,31314,31315, +31316,31317,31318,31319,31320,31321,31322,31323,31324,31325,31326,31327, +31328,31329,31330,31331,31332,31333,31334,31335,31336,31337,31338,31339, +31340,31341,31342,31343,31344,31345,31346,31347,31348,31349,31350,31351, +31352,31353,31354,31355,31356,31357,31358,31359,31360,31361,31362,31363, +31364,31365,31366,31367,31368,31369,31370,31371,31372,31373,31374,31375, +31376,31377,31378,31379,31380,31381,31382,31383,31384,31385,31386,31387, +31388,31389,31390,31391,31392,31393,31394,31395,31396,31397,31398,31399, +31400,31401,31402,31403,31404,31405,31406,31407,31408,31409,31410,31411, +31412,31413,31414,31415,31416,31417,31418,31419,31420,31421,31422,31423, +31424,31425,31426,31427,31428,31429,31430,31431,31432,31433,31434,31435, +31436,31437,31438,31439,31440,31441,31442,31443,31444,31445,31446,31447, +31448,31449,31450,31451,31452,31453,31454,31455,31456,31457,31458,31459, +31460,31461,31462,31463,31464,31465,31466,31467,31468,31469,31470,31471, +31472,31473,31474,31475,31476,31477,31478,31479,31480,31481,31482,31483, +31484,31485,31486,31487,31488,31489,31490,31491,31492,31493,31494,31495, +31496,31497,31498,31499,31500,31501,31502,31503,31504,31505,31506,31507, +31508,31509,31510,31511,31512,31513,31514,31515,31516,31517,31518,31519, +31520,31521,31522,31523,31524,31525,31526,31527,31528,31529,31530,31531, +31532,31533,31534,31535,31536,31537,31538,31539,31540,31541,31542,31543, +31544,31545,31546,31547,31548,31549,31550,31551,31552,31553,31554,31555, +31556,31557,31558,31559,31560,31561,31562,31563,31564,31565,31566,31567, +31568,31569,31570,31571,31572,31573,31574,31575,31576,31577,31578,31579, +31580,31581,31582,31583,31584,31585,31586,31587,31588,31589,31590,31591, +31592,31593,31594,31595,31596,31597,31598,31599,31600,31601,31602,31603, +31604,31605,31606,31607,31608,31609,31610,31611,31612,31613,31614,31615, +31616,31617,31618,31619,31620,31621,31622,31623,31624,31625,31626,31627, +31628,31629,31630,31631,31632,31633,31634,31635,31636,31637,31638,31639, +31640,31641,31642,31643,31644,31645,31646,31647,31648,31649,31650,31651, +31652,31653,31654,31655,31656,31657,31658,31659,31660,31661,31662,31663, +31664,31665,31666,31667,31668,31669,31670,31671,31672,31673,31674,31675, +31676,31677,31678,31679,31680,31681,31682,31683,31684,31685,31686,31687, +31688,31689,31690,31691,31692,31693,31694,31695,31696,31697,31698,31699, +31700,31701,31702,31703,31704,31705,31706,31707,31708,31709,31710,31711, +31712,31713,31714,31715,31716,31717,31718,31719,31720,31721,31722,31723, +31724,31725,31726,31727,31728,31729,31730,31731,31732,31733,31734,31735, +31736,31737,31738,31739,31740,31741,31742,31743,31744,31745,31746,31747, +31748,31749,31750,31751,31752,31753,31754,31755,31756,31757,31758,31759, +31760,31761,31762,31763,31764,31765,31766,31767,31768,31769,31770,31771, +31772,31773,31774,31775,31776,31777,31778,31779,31780,31781,31782,31783, +31784,31785,31786,31787,31788,31789,31790,31791,31792,31793,31794,31795, +31796,31797,31798,31799,31800,31801,31802,31803,31804,31805,31806,31807, +31808,31809,31810,31811,31812,31813,31814,31815,31816,31817,31818,31819, +31820,31821,31822,31823,31824,31825,31826,31827,31828,31829,31830,31831, +31832,31833,31834,31835,31836,31837,31838,31839,31840,31841,31842,31843, +31844,31845,31846,31847,31848,31849,31850,31851,31852,31853,31854,31855, +31856,31857,31858,31859,31860,31861,31862,31863,31864,31865,31866,31867, +31868,31869,31870,31871,31872,31873,31874,31875,31876,31877,31878,31879, +31880,31881,31882,31883,31884,31885,31886,31887,31888,31889,31890,31891, +31892,31893,31894,31895,31896,31897,31898,31899,31900,31901,31902,31903, +31904,31905,31906,31907,31908,31909,31910,31911,31912,31913,31914,31915, +31916,31917,31918,31919,31920,31921,31922,31923,31924,31925,31926,31927, +31928,31929,31930,31931,31932,31933,31934,31935,31936,31937,31938,31939, +31940,31941,31942,31943,31944,31945,31946,31947,31948,31949,31950,31951, +31952,31953,31954,31955,31956,31957,31958,31959,31960,31961,31962,31963, +31964,31965,31966,31967,31968,31969,31970,31971,31972,31973,31974,31975, +31976,31977,31978,31979,31980,31981,31982,31983,31984,31985,31986,31987, +31988,31989,31990,31991,31992,31993,31994,31995,31996,31997,31998,31999, +32000,32001,32002,32003,32004,32005,32006,32007,32008,32009,32010,32011, +32012,32013,32014,32015,32016,32017,32018,32019,32020,32021,32022,32023, +32024,32025,32026,32027,32028,32029,32030,32031,32032,32033,32034,32035, +32036,32037,32038,32039,32040,32041,32042,32043,32044,32045,32046,32047, +32048,32049,32050,32051,32052,32053,32054,32055,32056,32057,32058,32059, +32060,32061,32062,32063,32064,32065,32066,32067,32068,32069,32070,32071, +32072,32073,32074,32075,32076,32077,32078,32079,32080,32081,32082,32083, +32084,32085,32086,32087,32088,32089,32090,32091,32092,32093,32094,32095, +32096,32097,32098,32099,32100,32101,32102,32103,32104,32105,32106,32107, +32108,32109,32110,32111,32112,32113,32114,32115,32116,32117,32118,32119, +32120,32121,32122,32123,32124,32125,32126,32127,32128,32129,32130,32131, +32132,32133,32134,32135,32136,32137,32138,32139,32140,32141,32142,32143, +32144,32145,32146,32147,32148,32149,32150,32151,32152,32153,32154,32155, +32156,32157,32158,32159,32160,32161,32162,32163,32164,32165,32166,32167, +32168,32169,32170,32171,32172,32173,32174,32175,32176,32177,32178,32179, +32180,32181,32182,32183,32184,32185,32186,32187,32188,32189,32190,32191, +32192,32193,32194,32195,32196,32197,32198,32199,32200,32201,32202,32203, +32204,32205,32206,32207,32208,32209,32210,32211,32212,32213,32214,32215, +32216,32217,32218,32219,32220,32221,32222,32223,32224,32225,32226,32227, +32228,32229,32230,32231,32232,32233,32234,32235,32236,32237,32238,32239, +32240,32241,32242,32243,32244,32245,32246,32247,32248,32249,32250,32251, +32252,32253,32254,32255,32256,32257,32258,32259,32260,32261,32262,32263, +32264,32265,32266,32267,32268,32269,32270,32271,32272,32273,32274,32275, +32276,32277,32278,32279,32280,32281,32282,32283,32284,32285,32286,32287, +32288,32289,32290,32291,32292,32293,32294,32295,32296,32297,32298,32299, +32300,32301,32302,32303,32304,32305,32306,32307,32308,32309,32310,32311, +32312,32313,32314,32315,32316,32317,32318,32319,32320,32321,32322,32323, +32324,32325,32326,32327,32328,32329,32330,32331,32332,32333,32334,32335, +32336,32337,32338,32339,32340,32341,32342,32343,32344,32345,32346,32347, +32348,32349,32350,32351,32352,32353,32354,32355,32356,32357,32358,32359, +32360,32361,32362,32363,32364,32365,32366,32367,32368,32369,32370,32371, +32372,32373,32374,32375,32376,32377,32378,32379,32380,32381,32382,32383, +32384,32385,32386,32387,32388,32389,32390,32391,32392,32393,32394,32395, +32396,32397,32398,32399,32400,32401,32402,32403,32404,32405,32406,32407, +32408,32409,32410,32411,32412,32413,32414,32415,32416,32417,32418,32419, +32420,32421,32422,32423,32424,32425,32426,32427,32428,32429,32430,32431, +32432,32433,32434,32435,32436,32437,32438,32439,32440,32441,32442,32443, +32444,32445,32446,32447,32448,32449,32450,32451,32452,32453,32454,32455, +32456,32457,32458,32459,32460,32461,32462,32463,32464,32465,32466,32467, +32468,32469,32470,32471,32472,32473,32474,32475,32476,32477,32478,32479, +32480,32481,32482,32483,32484,32485,32486,32487,32488,32489,32490,32491, +32492,32493,32494,32495,32496,32497,32498,32499,32500,32501,32502,32503, +32504,32505,32506,32507,32508,32509,32510,32511,32512,32513,32514,32515, +32516,32517,32518,32519,32520,32521,32522,32523,32524,32525,32526,32527, +32528,32529,32530,32531,32532,32533,32534,32535,32536,32537,32538,32539, +32540,32541,32542,32543,32544,32545,32546,32547,32548,32549,32550,32551, +32552,32553,32554,32555,32556,32557,32558,32559,32560,32561,32562,32563, +32564,32565,32566,32567,32568,32569,32570,32571,32572,32573,32574,32575, +32576,32577,32578,32579,32580,32581,32582,32583,32584,32585,32586,32587, +32588,32589,32590,32591,32592,32593,32594,32595,32596,32597,32598,32599, +32600,32601,32602,32603,32604,32605,32606,32607,32608,32609,32610,32611, +32612,32613,32614,32615,32616,32617,32618,32619,32620,32621,32622,32623, +32624,32625,32626,32627,32628,32629,32630,32631,32632,32633,32634,32635, +32636,32637,32638,32639,32640,32641,32642,32643,32644,32645,32646,32647, +32648,32649,32650,32651,32652,32653,32654,32655,32656,32657,32658,32659, +32660,32661,32662,32663,32664,32665,32666,32667,32668,32669,32670,32671, +32672,32673,32674,32675,32676,32677,32678,32679,32680,32681,32682,32683, +32684,32685,32686,32687,32688,32689,32690,32691,32692,32693,32694,32695, +32696,32697,32698,32699,32700,32701,32702,32703,32704,32705,32706,32707, +32708,32709,32710,32711,32712,32713,32714,32715,32716,32717,32718,32719, +32720,32721,32722,32723,32724,32725,32726,32727,32728,32729,32730,32731, +32732,32733,32734,32735,32736,32737,32738,32739,32740,32741,32742,32743, +32744,32745,32746,32747,32748,32749,32750,32751,32752,32753,32754,32755, +32756,32757,32758,32759,32760,32761,32762,32763,32764,32765,32766,32767, +32768L,32769L,32770L,32771L,32772L,32773L,32774L,32775L,32776L,32777L, +32778L,32779L,32780L,32781L,32782L,32783L,32784L,32785L,32786L,32787L, +32788L,32789L,32790L,32791L,32792L,32793L,32794L,32795L,32796L,32797L, +32798L,32799L,32800L,32801L,32802L,32803L,32804L,32805L,32806L,32807L, +32808L,32809L,32810L,32811L,32812L,32813L,32814L,32815L,32816L,32817L, +32818L,32819L,32820L,32821L,32822L,32823L,32824L,32825L,32826L,32827L, +32828L,32829L,32830L,32831L,32832L,32833L,32834L,32835L,32836L,32837L, +32838L,32839L,32840L,32841L,32842L,32843L,32844L,32845L,32846L,32847L, +32848L,32849L,32850L,32851L,32852L,32853L,32854L,32855L,32856L,32857L, +32858L,32859L,32860L,32861L,32862L,32863L,32864L,32865L,32866L,32867L, +32868L,32869L,32870L,32871L,32872L,32873L,32874L,32875L,32876L,32877L, +32878L,32879L,32880L,32881L,32882L,32883L,32884L,32885L,32886L,32887L, +32888L,32889L,32890L,32891L,32892L,32893L,32894L,32895L,32896L,32897L, +32898L,32899L,32900L,32901L,32902L,32903L,32904L,32905L,32906L,32907L, +32908L,32909L,32910L,32911L,32912L,32913L,32914L,32915L,32916L,32917L, +32918L,32919L,32920L,32921L,32922L,32923L,32924L,32925L,32926L,32927L, +32928L,32929L,32930L,32931L,32932L,32933L,32934L,32935L,32936L,32937L, +32938L,32939L,32940L,32941L,32942L,32943L,32944L,32945L,32946L,32947L, +32948L,32949L,32950L,32951L,32952L,32953L,32954L,32955L,32956L,32957L, +32958L,32959L,32960L,32961L,32962L,32963L,32964L,32965L,32966L,32967L, +32968L,32969L,32970L,32971L,32972L,32973L,32974L,32975L,32976L,32977L, +32978L,32979L,32980L,32981L,32982L,32983L,32984L,32985L,32986L,32987L, +32988L,32989L,32990L,32991L,32992L,32993L,32994L,32995L,32996L,32997L, +32998L,32999L,33000L,33001L,33002L,33003L,33004L,33005L,33006L,33007L, +33008L,33009L,33010L,33011L,33012L,33013L,33014L,33015L,33016L,33017L, +33018L,33019L,33020L,33021L,33022L,33023L,33024L,33025L,33026L,33027L, +33028L,33029L,33030L,33031L,33032L,33033L,33034L,33035L,33036L,33037L, +33038L,33039L,33040L,33041L,33042L,33043L,33044L,33045L,33046L,33047L, +33048L,33049L,33050L,33051L,33052L,33053L,33054L,33055L,33056L,33057L, +33058L,33059L,33060L,33061L,33062L,33063L,33064L,33065L,33066L,33067L, +33068L,33069L,33070L,33071L,33072L,33073L,33074L,33075L,33076L,33077L, +33078L,33079L,33080L,33081L,33082L,33083L,33084L,33085L,33086L,33087L, +33088L,33089L,33090L,33091L,33092L,33093L,33094L,33095L,33096L,33097L, +33098L,33099L,33100L,33101L,33102L,33103L,33104L,33105L,33106L,33107L, +33108L,33109L,33110L,33111L,33112L,33113L,33114L,33115L,33116L,33117L, +33118L,33119L,33120L,33121L,33122L,33123L,33124L,33125L,33126L,33127L, +33128L,33129L,33130L,33131L,33132L,33133L,33134L,33135L,33136L,33137L, +33138L,33139L,33140L,33141L,33142L,33143L,33144L,33145L,33146L,33147L, +33148L,33149L,33150L,33151L,33152L,33153L,33154L,33155L,33156L,33157L, +33158L,33159L,33160L,33161L,33162L,33163L,33164L,33165L,33166L,33167L, +33168L,33169L,33170L,33171L,33172L,33173L,33174L,33175L,33176L,33177L, +33178L,33179L,33180L,33181L,33182L,33183L,33184L,33185L,33186L,33187L, +33188L,33189L,33190L,33191L,33192L,33193L,33194L,33195L,33196L,33197L, +33198L,33199L,33200L,33201L,33202L,33203L,33204L,33205L,33206L,33207L, +33208L,33209L,33210L,33211L,33212L,33213L,33214L,33215L,33216L,33217L, +33218L,33219L,33220L,33221L,33222L,33223L,33224L,33225L,33226L,33227L, +33228L,33229L,33230L,33231L,33232L,33233L,33234L,33235L,33236L,33237L, +33238L,33239L,33240L,33241L,33242L,33243L,33244L,33245L,33246L,33247L, +33248L,33249L,33250L,33251L,33252L,33253L,33254L,33255L,33256L,33257L, +33258L,33259L,33260L,33261L,33262L,33263L,33264L,33265L,33266L,33267L, +33268L,33269L,33270L,33271L,33272L,33273L,33274L,33275L,33276L,33277L, +33278L,33279L,33280L,33281L,33282L,33283L,33284L,33285L,33286L,33287L, +33288L,33289L,33290L,33291L,33292L,33293L,33294L,33295L,33296L,33297L, +33298L,33299L,33300L,33301L,33302L,33303L,33304L,33305L,33306L,33307L, +33308L,33309L,33310L,33311L,33312L,33313L,33314L,33315L,33316L,33317L, +33318L,33319L,33320L,33321L,33322L,33323L,33324L,33325L,33326L,33327L, +33328L,33329L,33330L,33331L,33332L,33333L,33334L,33335L,33336L,33337L, +33338L,33339L,33340L,33341L,33342L,33343L,33344L,33345L,33346L,33347L, +33348L,33349L,33350L,33351L,33352L,33353L,33354L,33355L,33356L,33357L, +33358L,33359L,33360L,33361L,33362L,33363L,33364L,33365L,33366L,33367L, +33368L,33369L,33370L,33371L,33372L,33373L,33374L,33375L,33376L,33377L, +33378L,33379L,33380L,33381L,33382L,33383L,33384L,33385L,33386L,33387L, +33388L,33389L,33390L,33391L,33392L,33393L,33394L,33395L,33396L,33397L, +33398L,33399L,33400L,33401L,33402L,33403L,33404L,33405L,33406L,33407L, +33408L,33409L,33410L,33411L,33412L,33413L,33414L,33415L,33416L,33417L, +33418L,33419L,33420L,33421L,33422L,33423L,33424L,33425L,33426L,33427L, +33428L,33429L,33430L,33431L,33432L,33433L,33434L,33435L,33436L,33437L, +33438L,33439L,33440L,33441L,33442L,33443L,33444L,33445L,33446L,33447L, +33448L,33449L,33450L,33451L,33452L,33453L,33454L,33455L,33456L,33457L, +33458L,33459L,33460L,33461L,33462L,33463L,33464L,33465L,33466L,33467L, +33468L,33469L,33470L,33471L,33472L,33473L,33474L,33475L,33476L,33477L, +33478L,33479L,33480L,33481L,33482L,33483L,33484L,33485L,33486L,33487L, +33488L,33489L,33490L,33491L,33492L,33493L,33494L,33495L,33496L,33497L, +33498L,33499L,33500L,33501L,33502L,33503L,33504L,33505L,33506L,33507L, +33508L,33509L,33510L,33511L,33512L,33513L,33514L,33515L,33516L,33517L, +33518L,33519L,33520L,33521L,33522L,33523L,33524L,33525L,33526L,33527L, +33528L,33529L,33530L,33531L,33532L,33533L,33534L,33535L,33536L,33537L, +33538L,33539L,33540L,33541L,33542L,33543L,33544L,33545L,33546L,33547L, +33548L,33549L,33550L,33551L,33552L,33553L,33554L,33555L,33556L,33557L, +33558L,33559L,33560L,33561L,33562L,33563L,33564L,33565L,33566L,33567L, +33568L,33569L,33570L,33571L,33572L,33573L,33574L,33575L,33576L,33577L, +33578L,33579L,33580L,33581L,33582L,33583L,33584L,33585L,33586L,33587L, +33588L,33589L,33590L,33591L,33592L,33593L,33594L,33595L,33596L,33597L, +33598L,33599L,33600L,33601L,33602L,33603L,33604L,33605L,33606L,33607L, +33608L,33609L,33610L,33611L,33612L,33613L,33614L,33615L,33616L,33617L, +33618L,33619L,33620L,33621L,33622L,33623L,33624L,33625L,33626L,33627L, +33628L,33629L,33630L,33631L,33632L,33633L,33634L,33635L,33636L,33637L, +33638L,33639L,33640L,33641L,33642L,33643L,33644L,33645L,33646L,33647L, +33648L,33649L,33650L,33651L,33652L,33653L,33654L,33655L,33656L,33657L, +33658L,33659L,33660L,33661L,33662L,33663L,33664L,33665L,33666L,33667L, +33668L,33669L,33670L,33671L,33672L,33673L,33674L,33675L,33676L,33677L, +33678L,33679L,33680L,33681L,33682L,33683L,33684L,33685L,33686L,33687L, +33688L,33689L,33690L,33691L,33692L,33693L,33694L,33695L,33696L,33697L, +33698L,33699L,33700L,33701L,33702L,33703L,33704L,33705L,33706L,33707L, +33708L,33709L,33710L,33711L,33712L,33713L,33714L,33715L,33716L,33717L, +33718L,33719L,33720L,33721L,33722L,33723L,33724L,33725L,33726L,33727L, +33728L,33729L,33730L,33731L,33732L,33733L,33734L,33735L,33736L,33737L, +33738L,33739L,33740L,33741L,33742L,33743L,33744L,33745L,33746L,33747L, +33748L,33749L,33750L,33751L,33752L,33753L,33754L,33755L,33756L,33757L, +33758L,33759L,33760L,33761L,33762L,33763L,33764L,33765L,33766L,33767L, +33768L,33769L,33770L,33771L,33772L,33773L,33774L,33775L,33776L,33777L, +33778L,33779L,33780L,33781L,33782L,33783L,33784L,33785L,33786L,33787L, +33788L,33789L,33790L,33791L,33792L,33793L,33794L,33795L,33796L,33797L, +33798L,33799L,33800L,33801L,33802L,33803L,33804L,33805L,33806L,33807L, +33808L,33809L,33810L,33811L,33812L,33813L,33814L,33815L,33816L,33817L, +33818L,33819L,33820L,33821L,33822L,33823L,33824L,33825L,33826L,33827L, +33828L,33829L,33830L,33831L,33832L,33833L,33834L,33835L,33836L,33837L, +33838L,33839L,33840L,33841L,33842L,33843L,33844L,33845L,33846L,33847L, +33848L,33849L,33850L,33851L,33852L,33853L,33854L,33855L,33856L,33857L, +33858L,33859L,33860L,33861L,33862L,33863L,33864L,33865L,33866L,33867L, +33868L,33869L,33870L,33871L,33872L,33873L,33874L,33875L,33876L,33877L, +33878L,33879L,33880L,33881L,33882L,33883L,33884L,33885L,33886L,33887L, +33888L,33889L,33890L,33891L,33892L,33893L,33894L,33895L,33896L,33897L, +33898L,33899L,33900L,33901L,33902L,33903L,33904L,33905L,33906L,33907L, +33908L,33909L,33910L,33911L,33912L,33913L,33914L,33915L,33916L,33917L, +33918L,33919L,33920L,33921L,33922L,33923L,33924L,33925L,33926L,33927L, +33928L,33929L,33930L,33931L,33932L,33933L,33934L,33935L,33936L,33937L, +33938L,33939L,33940L,33941L,33942L,33943L,33944L,33945L,33946L,33947L, +33948L,33949L,33950L,33951L,33952L,33953L,33954L,33955L,33956L,33957L, +33958L,33959L,33960L,33961L,33962L,33963L,33964L,33965L,33966L,33967L, +33968L,33969L,33970L,33971L,33972L,33973L,33974L,33975L,33976L,33977L, +33978L,33979L,33980L,33981L,33982L,33983L,33984L,33985L,33986L,33987L, +33988L,33989L,33990L,33991L,33992L,33993L,33994L,33995L,33996L,33997L, +33998L,33999L,34000L,34001L,34002L,34003L,34004L,34005L,34006L,34007L, +34008L,34009L,34010L,34011L,34012L,34013L,34014L,34015L,34016L,34017L, +34018L,34019L,34020L,34021L,34022L,34023L,34024L,34025L,34026L,34027L, +34028L,34029L,34030L,34031L,34032L,34033L,34034L,34035L,34036L,34037L, +34038L,34039L,34040L,34041L,34042L,34043L,34044L,34045L,34046L,34047L, +34048L,34049L,34050L,34051L,34052L,34053L,34054L,34055L,34056L,34057L, +34058L,34059L,34060L,34061L,34062L,34063L,34064L,34065L,34066L,34067L, +34068L,34069L,34070L,34071L,34072L,34073L,34074L,34075L,34076L,34077L, +34078L,34079L,34080L,34081L,34082L,34083L,34084L,34085L,34086L,34087L, +34088L,34089L,34090L,34091L,34092L,34093L,34094L,34095L,34096L,34097L, +34098L,34099L,34100L,34101L,34102L,34103L,34104L,34105L,34106L,34107L, +34108L,34109L,34110L,34111L,34112L,34113L,34114L,34115L,34116L,34117L, +34118L,34119L,34120L,34121L,34122L,34123L,34124L,34125L,34126L,34127L, +34128L,34129L,34130L,34131L,34132L,34133L,34134L,34135L,34136L,34137L, +34138L,34139L,34140L,34141L,34142L,34143L,34144L,34145L,34146L,34147L, +34148L,34149L,34150L,34151L,34152L,34153L,34154L,34155L,34156L,34157L, +34158L,34159L,34160L,34161L,34162L,34163L,34164L,34165L,34166L,34167L, +34168L,34169L,34170L,34171L,34172L,34173L,34174L,34175L,34176L,34177L, +34178L,34179L,34180L,34181L,34182L,34183L,34184L,34185L,34186L,34187L, +34188L,34189L,34190L,34191L,34192L,34193L,34194L,34195L,34196L,34197L, +34198L,34199L,34200L,34201L,34202L,34203L,34204L,34205L,34206L,34207L, +34208L,34209L,34210L,34211L,34212L,34213L,34214L,34215L,34216L,34217L, +34218L,34219L,34220L,34221L,34222L,34223L,34224L,34225L,34226L,34227L, +34228L,34229L,34230L,34231L,34232L,34233L,34234L,34235L,34236L,34237L, +34238L,34239L,34240L,34241L,34242L,34243L,34244L,34245L,34246L,34247L, +34248L,34249L,34250L,34251L,34252L,34253L,34254L,34255L,34256L,34257L, +34258L,34259L,34260L,34261L,34262L,34263L,34264L,34265L,34266L,34267L, +34268L,34269L,34270L,34271L,34272L,34273L,34274L,34275L,34276L,34277L, +34278L,34279L,34280L,34281L,34282L,34283L,34284L,34285L,34286L,34287L, +34288L,34289L,34290L,34291L,34292L,34293L,34294L,34295L,34296L,34297L, +34298L,34299L,34300L,34301L,34302L,34303L,34304L,34305L,34306L,34307L, +34308L,34309L,34310L,34311L,34312L,34313L,34314L,34315L,34316L,34317L, +34318L,34319L,34320L,34321L,34322L,34323L,34324L,34325L,34326L,34327L, +34328L,34329L,34330L,34331L,34332L,34333L,34334L,34335L,34336L,34337L, +34338L,34339L,34340L,34341L,34342L,34343L,34344L,34345L,34346L,34347L, +34348L,34349L,34350L,34351L,34352L,34353L,34354L,34355L,34356L,34357L, +34358L,34359L,34360L,34361L,34362L,34363L,34364L,34365L,34366L,34367L, +34368L,34369L,34370L,34371L,34372L,34373L,34374L,34375L,34376L,34377L, +34378L,34379L,34380L,34381L,34382L,34383L,34384L,34385L,34386L,34387L, +34388L,34389L,34390L,34391L,34392L,34393L,34394L,34395L,34396L,34397L, +34398L,34399L,34400L,34401L,34402L,34403L,34404L,34405L,34406L,34407L, +34408L,34409L,34410L,34411L,34412L,34413L,34414L,34415L,34416L,34417L, +34418L,34419L,34420L,34421L,34422L,34423L,34424L,34425L,34426L,34427L, +34428L,34429L,34430L,34431L,34432L,34433L,34434L,34435L,34436L,34437L, +34438L,34439L,34440L,34441L,34442L,34443L,34444L,34445L,34446L,34447L, +34448L,34449L,34450L,34451L,34452L,34453L,34454L,34455L,34456L,34457L, +34458L,34459L,34460L,34461L,34462L,34463L,34464L,34465L,34466L,34467L, +34468L,34469L,34470L,34471L,34472L,34473L,34474L,34475L,34476L,34477L, +34478L,34479L,34480L,34481L,34482L,34483L,34484L,34485L,34486L,34487L, +34488L,34489L,34490L,34491L,34492L,34493L,34494L,34495L,34496L,34497L, +34498L,34499L,34500L,34501L,34502L,34503L,34504L,34505L,34506L,34507L, +34508L,34509L,34510L,34511L,34512L,34513L,34514L,34515L,34516L,34517L, +34518L,34519L,34520L,34521L,34522L,34523L,34524L,34525L,34526L,34527L, +34528L,34529L,34530L,34531L,34532L,34533L,34534L,34535L,34536L,34537L, +34538L,34539L,34540L,34541L,34542L,34543L,34544L,34545L,34546L,34547L, +34548L,34549L,34550L,34551L,34552L,34553L,34554L,34555L,34556L,34557L, +34558L,34559L,34560L,34561L,34562L,34563L,34564L,34565L,34566L,34567L, +34568L,34569L,34570L,34571L,34572L,34573L,34574L,34575L,34576L,34577L, +34578L,34579L,34580L,34581L,34582L,34583L,34584L,34585L,34586L,34587L, +34588L,34589L,34590L,34591L,34592L,34593L,34594L,34595L,34596L,34597L, +34598L,34599L,34600L,34601L,34602L,34603L,34604L,34605L,34606L,34607L, +34608L,34609L,34610L,34611L,34612L,34613L,34614L,34615L,34616L,34617L, +34618L,34619L,34620L,34621L,34622L,34623L,34624L,34625L,34626L,34627L, +34628L,34629L,34630L,34631L,34632L,34633L,34634L,34635L,34636L,34637L, +34638L,34639L,34640L,34641L,34642L,34643L,34644L,34645L,34646L,34647L, +34648L,34649L,34650L,34651L,34652L,34653L,34654L,34655L,34656L,34657L, +34658L,34659L,34660L,34661L,34662L,34663L,34664L,34665L,34666L,34667L, +34668L,34669L,34670L,34671L,34672L,34673L,34674L,34675L,34676L,34677L, +34678L,34679L,34680L,34681L,34682L,34683L,34684L,34685L,34686L,34687L, +34688L,34689L,34690L,34691L,34692L,34693L,34694L,34695L,34696L,34697L, +34698L,34699L,34700L,34701L,34702L,34703L,34704L,34705L,34706L,34707L, +34708L,34709L,34710L,34711L,34712L,34713L,34714L,34715L,34716L,34717L, +34718L,34719L,34720L,34721L,34722L,34723L,34724L,34725L,34726L,34727L, +34728L,34729L,34730L,34731L,34732L,34733L,34734L,34735L,34736L,34737L, +34738L,34739L,34740L,34741L,34742L,34743L,34744L,34745L,34746L,34747L, +34748L,34749L,34750L,34751L,34752L,34753L,34754L,34755L,34756L,34757L, +34758L,34759L,34760L,34761L,34762L,34763L,34764L,34765L,34766L,34767L, +34768L,34769L,34770L,34771L,34772L,34773L,34774L,34775L,34776L,34777L, +34778L,34779L,34780L,34781L,34782L,34783L,34784L,34785L,34786L,34787L, +34788L,34789L,34790L,34791L,34792L,34793L,34794L,34795L,34796L,34797L, +34798L,34799L,34800L,34801L,34802L,34803L,34804L,34805L,34806L,34807L, +34808L,34809L,34810L,34811L,34812L,34813L,34814L,34815L,34816L,34817L, +34818L,34819L,34820L,34821L,34822L,34823L,34824L,34825L,34826L,34827L, +34828L,34829L,34830L,34831L,34832L,34833L,34834L,34835L,34836L,34837L, +34838L,34839L,34840L,34841L,34842L,34843L,34844L,34845L,34846L,34847L, +34848L,34849L,34850L,34851L,34852L,34853L,34854L,34855L,34856L,34857L, +34858L,34859L,34860L,34861L,34862L,34863L,34864L,34865L,34866L,34867L, +34868L,34869L,34870L,34871L,34872L,34873L,34874L,34875L,34876L,34877L, +34878L,34879L,34880L,34881L,34882L,34883L,34884L,34885L,34886L,34887L, +34888L,34889L,34890L,34891L,34892L,34893L,34894L,34895L,34896L,34897L, +34898L,34899L,34900L,34901L,34902L,34903L,34904L,34905L,34906L,34907L, +34908L,34909L,34910L,34911L,34912L,34913L,34914L,34915L,34916L,34917L, +34918L,34919L,34920L,34921L,34922L,34923L,34924L,34925L,34926L,34927L, +34928L,34929L,34930L,34931L,34932L,34933L,34934L,34935L,34936L,34937L, +34938L,34939L,34940L,34941L,34942L,34943L,34944L,34945L,34946L,34947L, +34948L,34949L,34950L,34951L,34952L,34953L,34954L,34955L,34956L,34957L, +34958L,34959L,34960L,34961L,34962L,34963L,34964L,34965L,34966L,34967L, +34968L,34969L,34970L,34971L,34972L,34973L,34974L,34975L,34976L,34977L, +34978L,34979L,34980L,34981L,34982L,34983L,34984L,34985L,34986L,34987L, +34988L,34989L,34990L,34991L,34992L,34993L,34994L,34995L,34996L,34997L, +34998L,34999L,35000L,35001L,35002L,35003L,35004L,35005L,35006L,35007L, +35008L,35009L,35010L,35011L,35012L,35013L,35014L,35015L,35016L,35017L, +35018L,35019L,35020L,35021L,35022L,35023L,35024L,35025L,35026L,35027L, +35028L,35029L,35030L,35031L,35032L,35033L,35034L,35035L,35036L,35037L, +35038L,35039L,35040L,35041L,35042L,35043L,35044L,35045L,35046L,35047L, +35048L,35049L,35050L,35051L,35052L,35053L,35054L,35055L,35056L,35057L, +35058L,35059L,35060L,35061L,35062L,35063L,35064L,35065L,35066L,35067L, +35068L,35069L,35070L,35071L,35072L,35073L,35074L,35075L,35076L,35077L, +35078L,35079L,35080L,35081L,35082L,35083L,35084L,35085L,35086L,35087L, +35088L,35089L,35090L,35091L,35092L,35093L,35094L,35095L,35096L,35097L, +35098L,35099L,35100L,35101L,35102L,35103L,35104L,35105L,35106L,35107L, +35108L,35109L,35110L,35111L,35112L,35113L,35114L,35115L,35116L,35117L, +35118L,35119L,35120L,35121L,35122L,35123L,35124L,35125L,35126L,35127L, +35128L,35129L,35130L,35131L,35132L,35133L,35134L,35135L,35136L,35137L, +35138L,35139L,35140L,35141L,35142L,35143L,35144L,35145L,35146L,35147L, +35148L,35149L,35150L,35151L,35152L,35153L,35154L,35155L,35156L,35157L, +35158L,35159L,35160L,35161L,35162L,35163L,35164L,35165L,35166L,35167L, +35168L,35169L,35170L,35171L,35172L,35173L,35174L,35175L,35176L,35177L, +35178L,35179L,35180L,35181L,35182L,35183L,35184L,35185L,35186L,35187L, +35188L,35189L,35190L,35191L,35192L,35193L,35194L,35195L,35196L,35197L, +35198L,35199L,35200L,35201L,35202L,35203L,35204L,35205L,35206L,35207L, +35208L,35209L,35210L,35211L,35212L,35213L,35214L,35215L,35216L,35217L, +35218L,35219L,35220L,35221L,35222L,35223L,35224L,35225L,35226L,35227L, +35228L,35229L,35230L,35231L,35232L,35233L,35234L,35235L,35236L,35237L, +35238L,35239L,35240L,35241L,35242L,35243L,35244L,35245L,35246L,35247L, +35248L,35249L,35250L,35251L,35252L,35253L,35254L,35255L,35256L,35257L, +35258L,35259L,35260L,35261L,35262L,35263L,35264L,35265L,35266L,35267L, +35268L,35269L,35270L,35271L,35272L,35273L,35274L,35275L,35276L,35277L, +35278L,35279L,35280L,35281L,35282L,35283L,35284L,35285L,35286L,35287L, +35288L,35289L,35290L,35291L,35292L,35293L,35294L,35295L,35296L,35297L, +35298L,35299L,35300L,35301L,35302L,35303L,35304L,35305L,35306L,35307L, +35308L,35309L,35310L,35311L,35312L,35313L,35314L,35315L,35316L,35317L, +35318L,35319L,35320L,35321L,35322L,35323L,35324L,35325L,35326L,35327L, +35328L,35329L,35330L,35331L,35332L,35333L,35334L,35335L,35336L,35337L, +35338L,35339L,35340L,35341L,35342L,35343L,35344L,35345L,35346L,35347L, +35348L,35349L,35350L,35351L,35352L,35353L,35354L,35355L,35356L,35357L, +35358L,35359L,35360L,35361L,35362L,35363L,35364L,35365L,35366L,35367L, +35368L,35369L,35370L,35371L,35372L,35373L,35374L,35375L,35376L,35377L, +35378L,35379L,35380L,35381L,35382L,35383L,35384L,35385L,35386L,35387L, +35388L,35389L,35390L,35391L,35392L,35393L,35394L,35395L,35396L,35397L, +35398L,35399L,35400L,35401L,35402L,35403L,35404L,35405L,35406L,35407L, +35408L,35409L,35410L,35411L,35412L,35413L,35414L,35415L,35416L,35417L, +35418L,35419L,35420L,35421L,35422L,35423L,35424L,35425L,35426L,35427L, +35428L,35429L,35430L,35431L,35432L,35433L,35434L,35435L,35436L,35437L, +35438L,35439L,35440L,35441L,35442L,35443L,35444L,35445L,35446L,35447L, +35448L,35449L,35450L,35451L,35452L,35453L,35454L,35455L,35456L,35457L, +35458L,35459L,35460L,35461L,35462L,35463L,35464L,35465L,35466L,35467L, +35468L,35469L,35470L,35471L,35472L,35473L,35474L,35475L,35476L,35477L, +35478L,35479L,35480L,35481L,35482L,35483L,35484L,35485L,35486L,35487L, +35488L,35489L,35490L,35491L,35492L,35493L,35494L,35495L,35496L,35497L, +35498L,35499L,35500L,35501L,35502L,35503L,35504L,35505L,35506L,35507L, +35508L,35509L,35510L,35511L,35512L,35513L,35514L,35515L,35516L,35517L, +35518L,35519L,35520L,35521L,35522L,35523L,35524L,35525L,35526L,35527L, +35528L,35529L,35530L,35531L,35532L,35533L,35534L,35535L,35536L,35537L, +35538L,35539L,35540L,35541L,35542L,35543L,35544L,35545L,35546L,35547L, +35548L,35549L,35550L,35551L,35552L,35553L,35554L,35555L,35556L,35557L, +35558L,35559L,35560L,35561L,35562L,35563L,35564L,35565L,35566L,35567L, +35568L,35569L,35570L,35571L,35572L,35573L,35574L,35575L,35576L,35577L, +35578L,35579L,35580L,35581L,35582L,35583L,35584L,35585L,35586L,35587L, +35588L,35589L,35590L,35591L,35592L,35593L,35594L,35595L,35596L,35597L, +35598L,35599L,35600L,35601L,35602L,35603L,35604L,35605L,35606L,35607L, +35608L,35609L,35610L,35611L,35612L,35613L,35614L,35615L,35616L,35617L, +35618L,35619L,35620L,35621L,35622L,35623L,35624L,35625L,35626L,35627L, +35628L,35629L,35630L,35631L,35632L,35633L,35634L,35635L,35636L,35637L, +35638L,35639L,35640L,35641L,35642L,35643L,35644L,35645L,35646L,35647L, +35648L,35649L,35650L,35651L,35652L,35653L,35654L,35655L,35656L,35657L, +35658L,35659L,35660L,35661L,35662L,35663L,35664L,35665L,35666L,35667L, +35668L,35669L,35670L,35671L,35672L,35673L,35674L,35675L,35676L,35677L, +35678L,35679L,35680L,35681L,35682L,35683L,35684L,35685L,35686L,35687L, +35688L,35689L,35690L,35691L,35692L,35693L,35694L,35695L,35696L,35697L, +35698L,35699L,35700L,35701L,35702L,35703L,35704L,35705L,35706L,35707L, +35708L,35709L,35710L,35711L,35712L,35713L,35714L,35715L,35716L,35717L, +35718L,35719L,35720L,35721L,35722L,35723L,35724L,35725L,35726L,35727L, +35728L,35729L,35730L,35731L,35732L,35733L,35734L,35735L,35736L,35737L, +35738L,35739L,35740L,35741L,35742L,35743L,35744L,35745L,35746L,35747L, +35748L,35749L,35750L,35751L,35752L,35753L,35754L,35755L,35756L,35757L, +35758L,35759L,35760L,35761L,35762L,35763L,35764L,35765L,35766L,35767L, +35768L,35769L,35770L,35771L,35772L,35773L,35774L,35775L,35776L,35777L, +35778L,35779L,35780L,35781L,35782L,35783L,35784L,35785L,35786L,35787L, +35788L,35789L,35790L,35791L,35792L,35793L,35794L,35795L,35796L,35797L, +35798L,35799L,35800L,35801L,35802L,35803L,35804L,35805L,35806L,35807L, +35808L,35809L,35810L,35811L,35812L,35813L,35814L,35815L,35816L,35817L, +35818L,35819L,35820L,35821L,35822L,35823L,35824L,35825L,35826L,35827L, +35828L,35829L,35830L,35831L,35832L,35833L,35834L,35835L,35836L,35837L, +35838L,35839L,35840L,35841L,35842L,35843L,35844L,35845L,35846L,35847L, +35848L,35849L,35850L,35851L,35852L,35853L,35854L,35855L,35856L,35857L, +35858L,35859L,35860L,35861L,35862L,35863L,35864L,35865L,35866L,35867L, +35868L,35869L,35870L,35871L,35872L,35873L,35874L,35875L,35876L,35877L, +35878L,35879L,35880L,35881L,35882L,35883L,35884L,35885L,35886L,35887L, +35888L,35889L,35890L,35891L,35892L,35893L,35894L,35895L,35896L,35897L, +35898L,35899L,35900L,35901L,35902L,35903L,35904L,35905L,35906L,35907L, +35908L,35909L,35910L,35911L,35912L,35913L,35914L,35915L,35916L,35917L, +35918L,35919L,35920L,35921L,35922L,35923L,35924L,35925L,35926L,35927L, +35928L,35929L,35930L,35931L,35932L,35933L,35934L,35935L,35936L,35937L, +35938L,35939L,35940L,35941L,35942L,35943L,35944L,35945L,35946L,35947L, +35948L,35949L,35950L,35951L,35952L,35953L,35954L,35955L,35956L,35957L, +35958L,35959L,35960L,35961L,35962L,35963L,35964L,35965L,35966L,35967L, +35968L,35969L,35970L,35971L,35972L,35973L,35974L,35975L,35976L,35977L, +35978L,35979L,35980L,35981L,35982L,35983L,35984L,35985L,35986L,35987L, +35988L,35989L,35990L,35991L,35992L,35993L,35994L,35995L,35996L,35997L, +35998L,35999L,36000L,36001L,36002L,36003L,36004L,36005L,36006L,36007L, +36008L,36009L,36010L,36011L,36012L,36013L,36014L,36015L,36016L,36017L, +36018L,36019L,36020L,36021L,36022L,36023L,36024L,36025L,36026L,36027L, +36028L,36029L,36030L,36031L,36032L,36033L,36034L,36035L,36036L,36037L, +36038L,36039L,36040L,36041L,36042L,36043L,36044L,36045L,36046L,36047L, +36048L,36049L,36050L,36051L,36052L,36053L,36054L,36055L,36056L,36057L, +36058L,36059L,36060L,36061L,36062L,36063L,36064L,36065L,36066L,36067L, +36068L,36069L,36070L,36071L,36072L,36073L,36074L,36075L,36076L,36077L, +36078L,36079L,36080L,36081L,36082L,36083L,36084L,36085L,36086L,36087L, +36088L,36089L,36090L,36091L,36092L,36093L,36094L,36095L,36096L,36097L, +36098L,36099L,36100L,36101L,36102L,36103L,36104L,36105L,36106L,36107L, +36108L,36109L,36110L,36111L,36112L,36113L,36114L,36115L,36116L,36117L, +36118L,36119L,36120L,36121L,36122L,36123L,36124L,36125L,36126L,36127L, +36128L,36129L,36130L,36131L,36132L,36133L,36134L,36135L,36136L,36137L, +36138L,36139L,36140L,36141L,36142L,36143L,36144L,36145L,36146L,36147L, +36148L,36149L,36150L,36151L,36152L,36153L,36154L,36155L,36156L,36157L, +36158L,36159L,36160L,36161L,36162L,36163L,36164L,36165L,36166L,36167L, +36168L,36169L,36170L,36171L,36172L,36173L,36174L,36175L,36176L,36177L, +36178L,36179L,36180L,36181L,36182L,36183L,36184L,36185L,36186L,36187L, +36188L,36189L,36190L,36191L,36192L,36193L,36194L,36195L,36196L,36197L, +36198L,36199L,36200L,36201L,36202L,36203L,36204L,36205L,36206L,36207L, +36208L,36209L,36210L,36211L,36212L,36213L,36214L,36215L,36216L,36217L, +36218L,36219L,36220L,36221L,36222L,36223L,36224L,36225L,36226L,36227L, +36228L,36229L,36230L,36231L,36232L,36233L,36234L,36235L,36236L,36237L, +36238L,36239L,36240L,36241L,36242L,36243L,36244L,36245L,36246L,36247L, +36248L,36249L,36250L,36251L,36252L,36253L,36254L,36255L,36256L,36257L, +36258L,36259L,36260L,36261L,36262L,36263L,36264L,36265L,36266L,36267L, +36268L,36269L,36270L,36271L,36272L,36273L,36274L,36275L,36276L,36277L, +36278L,36279L,36280L,36281L,36282L,36283L,36284L,36285L,36286L,36287L, +36288L,36289L,36290L,36291L,36292L,36293L,36294L,36295L,36296L,36297L, +36298L,36299L,36300L,36301L,36302L,36303L,36304L,36305L,36306L,36307L, +36308L,36309L,36310L,36311L,36312L,36313L,36314L,36315L,36316L,36317L, +36318L,36319L,36320L,36321L,36322L,36323L,36324L,36325L,36326L,36327L, +36328L,36329L,36330L,36331L,36332L,36333L,36334L,36335L,36336L,36337L, +36338L,36339L,36340L,36341L,36342L,36343L,36344L,36345L,36346L,36347L, +36348L,36349L,36350L,36351L,36352L,36353L,36354L,36355L,36356L,36357L, +36358L,36359L,36360L,36361L,36362L,36363L,36364L,36365L,36366L,36367L, +36368L,36369L,36370L,36371L,36372L,36373L,36374L,36375L,36376L,36377L, +36378L,36379L,36380L,36381L,36382L,36383L,36384L,36385L,36386L,36387L, +36388L,36389L,36390L,36391L,36392L,36393L,36394L,36395L,36396L,36397L, +36398L,36399L,36400L,36401L,36402L,36403L,36404L,36405L,36406L,36407L, +36408L,36409L,36410L,36411L,36412L,36413L,36414L,36415L,36416L,36417L, +36418L,36419L,36420L,36421L,36422L,36423L,36424L,36425L,36426L,36427L, +36428L,36429L,36430L,36431L,36432L,36433L,36434L,36435L,36436L,36437L, +36438L,36439L,36440L,36441L,36442L,36443L,36444L,36445L,36446L,36447L, +36448L,36449L,36450L,36451L,36452L,36453L,36454L,36455L,36456L,36457L, +36458L,36459L,36460L,36461L,36462L,36463L,36464L,36465L,36466L,36467L, +36468L,36469L,36470L,36471L,36472L,36473L,36474L,36475L,36476L,36477L, +36478L,36479L,36480L,36481L,36482L,36483L,36484L,36485L,36486L,36487L, +36488L,36489L,36490L,36491L,36492L,36493L,36494L,36495L,36496L,36497L, +36498L,36499L,36500L,36501L,36502L,36503L,36504L,36505L,36506L,36507L, +36508L,36509L,36510L,36511L,36512L,36513L,36514L,36515L,36516L,36517L, +36518L,36519L,36520L,36521L,36522L,36523L,36524L,36525L,36526L,36527L, +36528L,36529L,36530L,36531L,36532L,36533L,36534L,36535L,36536L,36537L, +36538L,36539L,36540L,36541L,36542L,36543L,36544L,36545L,36546L,36547L, +36548L,36549L,36550L,36551L,36552L,36553L,36554L,36555L,36556L,36557L, +36558L,36559L,36560L,36561L,36562L,36563L,36564L,36565L,36566L,36567L, +36568L,36569L,36570L,36571L,36572L,36573L,36574L,36575L,36576L,36577L, +36578L,36579L,36580L,36581L,36582L,36583L,36584L,36585L,36586L,36587L, +36588L,36589L,36590L,36591L,36592L,36593L,36594L,36595L,36596L,36597L, +36598L,36599L,36600L,36601L,36602L,36603L,36604L,36605L,36606L,36607L, +36608L,36609L,36610L,36611L,36612L,36613L,36614L,36615L,36616L,36617L, +36618L,36619L,36620L,36621L,36622L,36623L,36624L,36625L,36626L,36627L, +36628L,36629L,36630L,36631L,36632L,36633L,36634L,36635L,36636L,36637L, +36638L,36639L,36640L,36641L,36642L,36643L,36644L,36645L,36646L,36647L, +36648L,36649L,36650L,36651L,36652L,36653L,36654L,36655L,36656L,36657L, +36658L,36659L,36660L,36661L,36662L,36663L,36664L,36665L,36666L,36667L, +36668L,36669L,36670L,36671L,36672L,36673L,36674L,36675L,36676L,36677L, +36678L,36679L,36680L,36681L,36682L,36683L,36684L,36685L,36686L,36687L, +36688L,36689L,36690L,36691L,36692L,36693L,36694L,36695L,36696L,36697L, +36698L,36699L,36700L,36701L,36702L,36703L,36704L,36705L,36706L,36707L, +36708L,36709L,36710L,36711L,36712L,36713L,36714L,36715L,36716L,36717L, +36718L,36719L,36720L,36721L,36722L,36723L,36724L,36725L,36726L,36727L, +36728L,36729L,36730L,36731L,36732L,36733L,36734L,36735L,36736L,36737L, +36738L,36739L,36740L,36741L,36742L,36743L,36744L,36745L,36746L,36747L, +36748L,36749L,36750L,36751L,36752L,36753L,36754L,36755L,36756L,36757L, +36758L,36759L,36760L,36761L,36762L,36763L,36764L,36765L,36766L,36767L, +36768L,36769L,36770L,36771L,36772L,36773L,36774L,36775L,36776L,36777L, +36778L,36779L,36780L,36781L,36782L,36783L,36784L,36785L,36786L,36787L, +36788L,36789L,36790L,36791L,36792L,36793L,36794L,36795L,36796L,36797L, +36798L,36799L,36800L,36801L,36802L,36803L,36804L,36805L,36806L,36807L, +36808L,36809L,36810L,36811L,36812L,36813L,36814L,36815L,36816L,36817L, +36818L,36819L,36820L,36821L,36822L,36823L,36824L,36825L,36826L,36827L, +36828L,36829L,36830L,36831L,36832L,36833L,36834L,36835L,36836L,36837L, +36838L,36839L,36840L,36841L,36842L,36843L,36844L,36845L,36846L,36847L, +36848L,36849L,36850L,36851L,36852L,36853L,36854L,36855L,36856L,36857L, +36858L,36859L,36860L,36861L,36862L,36863L,36864L,36865L,36866L,36867L, +36868L,36869L,36870L,36871L,36872L,36873L,36874L,36875L,36876L,36877L, +36878L,36879L,36880L,36881L,36882L,36883L,36884L,36885L,36886L,36887L, +36888L,36889L,36890L,36891L,36892L,36893L,36894L,36895L,36896L,36897L, +36898L,36899L,36900L,36901L,36902L,36903L,36904L,36905L,36906L,36907L, +36908L,36909L,36910L,36911L,36912L,36913L,36914L,36915L,36916L,36917L, +36918L,36919L,36920L,36921L,36922L,36923L,36924L,36925L,36926L,36927L, +36928L,36929L,36930L,36931L,36932L,36933L,36934L,36935L,36936L,36937L, +36938L,36939L,36940L,36941L,36942L,36943L,36944L,36945L,36946L,36947L, +36948L,36949L,36950L,36951L,36952L,36953L,36954L,36955L,36956L,36957L, +36958L,36959L,36960L,36961L,36962L,36963L,36964L,36965L,36966L,36967L, +36968L,36969L,36970L,36971L,36972L,36973L,36974L,36975L,36976L,36977L, +36978L,36979L,36980L,36981L,36982L,36983L,36984L,36985L,36986L,36987L, +36988L,36989L,36990L,36991L,36992L,36993L,36994L,36995L,36996L,36997L, +36998L,36999L,37000L,37001L,37002L,37003L,37004L,37005L,37006L,37007L, +37008L,37009L,37010L,37011L,37012L,37013L,37014L,37015L,37016L,37017L, +37018L,37019L,37020L,37021L,37022L,37023L,37024L,37025L,37026L,37027L, +37028L,37029L,37030L,37031L,37032L,37033L,37034L,37035L,37036L,37037L, +37038L,37039L,37040L,37041L,37042L,37043L,37044L,37045L,37046L,37047L, +37048L,37049L,37050L,37051L,37052L,37053L,37054L,37055L,37056L,37057L, +37058L,37059L,37060L,37061L,37062L,37063L,37064L,37065L,37066L,37067L, +37068L,37069L,37070L,37071L,37072L,37073L,37074L,37075L,37076L,37077L, +37078L,37079L,37080L,37081L,37082L,37083L,37084L,37085L,37086L,37087L, +37088L,37089L,37090L,37091L,37092L,37093L,37094L,37095L,37096L,37097L, +37098L,37099L,37100L,37101L,37102L,37103L,37104L,37105L,37106L,37107L, +37108L,37109L,37110L,37111L,37112L,37113L,37114L,37115L,37116L,37117L, +37118L,37119L,37120L,37121L,37122L,37123L,37124L,37125L,37126L,37127L, +37128L,37129L,37130L,37131L,37132L,37133L,37134L,37135L,37136L,37137L, +37138L,37139L,37140L,37141L,37142L,37143L,37144L,37145L,37146L,37147L, +37148L,37149L,37150L,37151L,37152L,37153L,37154L,37155L,37156L,37157L, +37158L,37159L,37160L,37161L,37162L,37163L,37164L,37165L,37166L,37167L, +37168L,37169L,37170L,37171L,37172L,37173L,37174L,37175L,37176L,37177L, +37178L,37179L,37180L,37181L,37182L,37183L,37184L,37185L,37186L,37187L, +37188L,37189L,37190L,37191L,37192L,37193L,37194L,37195L,37196L,37197L, +37198L,37199L,37200L,37201L,37202L,37203L,37204L,37205L,37206L,37207L, +37208L,37209L,37210L,37211L,37212L,37213L,37214L,37215L,37216L,37217L, +37218L,37219L,37220L,37221L,37222L,37223L,37224L,37225L,37226L,37227L, +37228L,37229L,37230L,37231L,37232L,37233L,37234L,37235L,37236L,37237L, +37238L,37239L,37240L,37241L,37242L,37243L,37244L,37245L,37246L,37247L, +37248L,37249L,37250L,37251L,37252L,37253L,37254L,37255L,37256L,37257L, +37258L,37259L,37260L,37261L,37262L,37263L,37264L,37265L,37266L,37267L, +37268L,37269L,37270L,37271L,37272L,37273L,37274L,37275L,37276L,37277L, +37278L,37279L,37280L,37281L,37282L,37283L,37284L,37285L,37286L,37287L, +37288L,37289L,37290L,37291L,37292L,37293L,37294L,37295L,37296L,37297L, +37298L,37299L,37300L,37301L,37302L,37303L,37304L,37305L,37306L,37307L, +37308L,37309L,37310L,37311L,37312L,37313L,37314L,37315L,37316L,37317L, +37318L,37319L,37320L,37321L,37322L,37323L,37324L,37325L,37326L,37327L, +37328L,37329L,37330L,37331L,37332L,37333L,37334L,37335L,37336L,37337L, +37338L,37339L,37340L,37341L,37342L,37343L,37344L,37345L,37346L,37347L, +37348L,37349L,37350L,37351L,37352L,37353L,37354L,37355L,37356L,37357L, +37358L,37359L,37360L,37361L,37362L,37363L,37364L,37365L,37366L,37367L, +37368L,37369L,37370L,37371L,37372L,37373L,37374L,37375L,37376L,37377L, +37378L,37379L,37380L,37381L,37382L,37383L,37384L,37385L,37386L,37387L, +37388L,37389L,37390L,37391L,37392L,37393L,37394L,37395L,37396L,37397L, +37398L,37399L,37400L,37401L,37402L,37403L,37404L,37405L,37406L,37407L, +37408L,37409L,37410L,37411L,37412L,37413L,37414L,37415L,37416L,37417L, +37418L,37419L,37420L,37421L,37422L,37423L,37424L,37425L,37426L,37427L, +37428L,37429L,37430L,37431L,37432L,37433L,37434L,37435L,37436L,37437L, +37438L,37439L,37440L,37441L,37442L,37443L,37444L,37445L,37446L,37447L, +37448L,37449L,37450L,37451L,37452L,37453L,37454L,37455L,37456L,37457L, +37458L,37459L,37460L,37461L,37462L,37463L,37464L,37465L,37466L,37467L, +37468L,37469L,37470L,37471L,37472L,37473L,37474L,37475L,37476L,37477L, +37478L,37479L,37480L,37481L,37482L,37483L,37484L,37485L,37486L,37487L, +37488L,37489L,37490L,37491L,37492L,37493L,37494L,37495L,37496L,37497L, +37498L,37499L,37500L,37501L,37502L,37503L,37504L,37505L,37506L,37507L, +37508L,37509L,37510L,37511L,37512L,37513L,37514L,37515L,37516L,37517L, +37518L,37519L,37520L,37521L,37522L,37523L,37524L,37525L,37526L,37527L, +37528L,37529L,37530L,37531L,37532L,37533L,37534L,37535L,37536L,37537L, +37538L,37539L,37540L,37541L,37542L,37543L,37544L,37545L,37546L,37547L, +37548L,37549L,37550L,37551L,37552L,37553L,37554L,37555L,37556L,37557L, +37558L,37559L,37560L,37561L,37562L,37563L,37564L,37565L,37566L,37567L, +37568L,37569L,37570L,37571L,37572L,37573L,37574L,37575L,37576L,37577L, +37578L,37579L,37580L,37581L,37582L,37583L,37584L,37585L,37586L,37587L, +37588L,37589L,37590L,37591L,37592L,37593L,37594L,37595L,37596L,37597L, +37598L,37599L,37600L,37601L,37602L,37603L,37604L,37605L,37606L,37607L, +37608L,37609L,37610L,37611L,37612L,37613L,37614L,37615L,37616L,37617L, +37618L,37619L,37620L,37621L,37622L,37623L,37624L,37625L,37626L,37627L, +37628L,37629L,37630L,37631L,37632L,37633L,37634L,37635L,37636L,37637L, +37638L,37639L,37640L,37641L,37642L,37643L,37644L,37645L,37646L,37647L, +37648L,37649L,37650L,37651L,37652L,37653L,37654L,37655L,37656L,37657L, +37658L,37659L,37660L,37661L,37662L,37663L,37664L,37665L,37666L,37667L, +37668L,37669L,37670L,37671L,37672L,37673L,37674L,37675L,37676L,37677L, +37678L,37679L,37680L,37681L,37682L,37683L,37684L,37685L,37686L,37687L, +37688L,37689L,37690L,37691L,37692L,37693L,37694L,37695L,37696L,37697L, +37698L,37699L,37700L,37701L,37702L,37703L,37704L,37705L,37706L,37707L, +37708L,37709L,37710L,37711L,37712L,37713L,37714L,37715L,37716L,37717L, +37718L,37719L,37720L,37721L,37722L,37723L,37724L,37725L,37726L,37727L, +37728L,37729L,37730L,37731L,37732L,37733L,37734L,37735L,37736L,37737L, +37738L,37739L,37740L,37741L,37742L,37743L,37744L,37745L,37746L,37747L, +37748L,37749L,37750L,37751L,37752L,37753L,37754L,37755L,37756L,37757L, +37758L,37759L,37760L,37761L,37762L,37763L,37764L,37765L,37766L,37767L, +37768L,37769L,37770L,37771L,37772L,37773L,37774L,37775L,37776L,37777L, +37778L,37779L,37780L,37781L,37782L,37783L,37784L,37785L,37786L,37787L, +37788L,37789L,37790L,37791L,37792L,37793L,37794L,37795L,37796L,37797L, +37798L,37799L,37800L,37801L,37802L,37803L,37804L,37805L,37806L,37807L, +37808L,37809L,37810L,37811L,37812L,37813L,37814L,37815L,37816L,37817L, +37818L,37819L,37820L,37821L,37822L,37823L,37824L,37825L,37826L,37827L, +37828L,37829L,37830L,37831L,37832L,37833L,37834L,37835L,37836L,37837L, +37838L,37839L,37840L,37841L,37842L,37843L,37844L,37845L,37846L,37847L, +37848L,37849L,37850L,37851L,37852L,37853L,37854L,37855L,37856L,37857L, +37858L,37859L,37860L,37861L,37862L,37863L,37864L,37865L,37866L,37867L, +37868L,37869L,37870L,37871L,37872L,37873L,37874L,37875L,37876L,37877L, +37878L,37879L,37880L,37881L,37882L,37883L,37884L,37885L,37886L,37887L, +37888L,37889L,37890L,37891L,37892L,37893L,37894L,37895L,37896L,37897L, +37898L,37899L,37900L,37901L,37902L,37903L,37904L,37905L,37906L,37907L, +37908L,37909L,37910L,37911L,37912L,37913L,37914L,37915L,37916L,37917L, +37918L,37919L,37920L,37921L,37922L,37923L,37924L,37925L,37926L,37927L, +37928L,37929L,37930L,37931L,37932L,37933L,37934L,37935L,37936L,37937L, +37938L,37939L,37940L,37941L,37942L,37943L,37944L,37945L,37946L,37947L, +37948L,37949L,37950L,37951L,37952L,37953L,37954L,37955L,37956L,37957L, +37958L,37959L,37960L,37961L,37962L,37963L,37964L,37965L,37966L,37967L, +37968L,37969L,37970L,37971L,37972L,37973L,37974L,37975L,37976L,37977L, +37978L,37979L,37980L,37981L,37982L,37983L,37984L,37985L,37986L,37987L, +37988L,37989L,37990L,37991L,37992L,37993L,37994L,37995L,37996L,37997L, +37998L,37999L,38000L,38001L,38002L,38003L,38004L,38005L,38006L,38007L, +38008L,38009L,38010L,38011L,38012L,38013L,38014L,38015L,38016L,38017L, +38018L,38019L,38020L,38021L,38022L,38023L,38024L,38025L,38026L,38027L, +38028L,38029L,38030L,38031L,38032L,38033L,38034L,38035L,38036L,38037L, +38038L,38039L,38040L,38041L,38042L,38043L,38044L,38045L,38046L,38047L, +38048L,38049L,38050L,38051L,38052L,38053L,38054L,38055L,38056L,38057L, +38058L,38059L,38060L,38061L,38062L,38063L,38064L,38065L,38066L,38067L, +38068L,38069L,38070L,38071L,38072L,38073L,38074L,38075L,38076L,38077L, +38078L,38079L,38080L,38081L,38082L,38083L,38084L,38085L,38086L,38087L, +38088L,38089L,38090L,38091L,38092L,38093L,38094L,38095L,38096L,38097L, +38098L,38099L,38100L,38101L,38102L,38103L,38104L,38105L,38106L,38107L, +38108L,38109L,38110L,38111L,38112L,38113L,38114L,38115L,38116L,38117L, +38118L,38119L,38120L,38121L,38122L,38123L,38124L,38125L,38126L,38127L, +38128L,38129L,38130L,38131L,38132L,38133L,38134L,38135L,38136L,38137L, +38138L,38139L,38140L,38141L,38142L,38143L,38144L,38145L,38146L,38147L, +38148L,38149L,38150L,38151L,38152L,38153L,38154L,38155L,38156L,38157L, +38158L,38159L,38160L,38161L,38162L,38163L,38164L,38165L,38166L,38167L, +38168L,38169L,38170L,38171L,38172L,38173L,38174L,38175L,38176L,38177L, +38178L,38179L,38180L,38181L,38182L,38183L,38184L,38185L,38186L,38187L, +38188L,38189L,38190L,38191L,38192L,38193L,38194L,38195L,38196L,38197L, +38198L,38199L,38200L,38201L,38202L,38203L,38204L,38205L,38206L,38207L, +38208L,38209L,38210L,38211L,38212L,38213L,38214L,38215L,38216L,38217L, +38218L,38219L,38220L,38221L,38222L,38223L,38224L,38225L,38226L,38227L, +38228L,38229L,38230L,38231L,38232L,38233L,38234L,38235L,38236L,38237L, +38238L,38239L,38240L,38241L,38242L,38243L,38244L,38245L,38246L,38247L, +38248L,38249L,38250L,38251L,38252L,38253L,38254L,38255L,38256L,38257L, +38258L,38259L,38260L,38261L,38262L,38263L,38264L,38265L,38266L,38267L, +38268L,38269L,38270L,38271L,38272L,38273L,38274L,38275L,38276L,38277L, +38278L,38279L,38280L,38281L,38282L,38283L,38284L,38285L,38286L,38287L, +38288L,38289L,38290L,38291L,38292L,38293L,38294L,38295L,38296L,38297L, +38298L,38299L,38300L,38301L,38302L,38303L,38304L,38305L,38306L,38307L, +38308L,38309L,38310L,38311L,38312L,38313L,38314L,38315L,38316L,38317L, +38318L,38319L,38320L,38321L,38322L,38323L,38324L,38325L,38326L,38327L, +38328L,38329L,38330L,38331L,38332L,38333L,38334L,38335L,38336L,38337L, +38338L,38339L,38340L,38341L,38342L,38343L,38344L,38345L,38346L,38347L, +38348L,38349L,38350L,38351L,38352L,38353L,38354L,38355L,38356L,38357L, +38358L,38359L,38360L,38361L,38362L,38363L,38364L,38365L,38366L,38367L, +38368L,38369L,38370L,38371L,38372L,38373L,38374L,38375L,38376L,38377L, +38378L,38379L,38380L,38381L,38382L,38383L,38384L,38385L,38386L,38387L, +38388L,38389L,38390L,38391L,38392L,38393L,38394L,38395L,38396L,38397L, +38398L,38399L,38400L,38401L,38402L,38403L,38404L,38405L,38406L,38407L, +38408L,38409L,38410L,38411L,38412L,38413L,38414L,38415L,38416L,38417L, +38418L,38419L,38420L,38421L,38422L,38423L,38424L,38425L,38426L,38427L, +38428L,38429L,38430L,38431L,38432L,38433L,38434L,38435L,38436L,38437L, +38438L,38439L,38440L,38441L,38442L,38443L,38444L,38445L,38446L,38447L, +38448L,38449L,38450L,38451L,38452L,38453L,38454L,38455L,38456L,38457L, +38458L,38459L,38460L,38461L,38462L,38463L,38464L,38465L,38466L,38467L, +38468L,38469L,38470L,38471L,38472L,38473L,38474L,38475L,38476L,38477L, +38478L,38479L,38480L,38481L,38482L,38483L,38484L,38485L,38486L,38487L, +38488L,38489L,38490L,38491L,38492L,38493L,38494L,38495L,38496L,38497L, +38498L,38499L,38500L,38501L,38502L,38503L,38504L,38505L,38506L,38507L, +38508L,38509L,38510L,38511L,38512L,38513L,38514L,38515L,38516L,38517L, +38518L,38519L,38520L,38521L,38522L,38523L,38524L,38525L,38526L,38527L, +38528L,38529L,38530L,38531L,38532L,38533L,38534L,38535L,38536L,38537L, +38538L,38539L,38540L,38541L,38542L,38543L,38544L,38545L,38546L,38547L, +38548L,38549L,38550L,38551L,38552L,38553L,38554L,38555L,38556L,38557L, +38558L,38559L,38560L,38561L,38562L,38563L,38564L,38565L,38566L,38567L, +38568L,38569L,38570L,38571L,38572L,38573L,38574L,38575L,38576L,38577L, +38578L,38579L,38580L,38581L,38582L,38583L,38584L,38585L,38586L,38587L, +38588L,38589L,38590L,38591L,38592L,38593L,38594L,38595L,38596L,38597L, +38598L,38599L,38600L,38601L,38602L,38603L,38604L,38605L,38606L,38607L, +38608L,38609L,38610L,38611L,38612L,38613L,38614L,38615L,38616L,38617L, +38618L,38619L,38620L,38621L,38622L,38623L,38624L,38625L,38626L,38627L, +38628L,38629L,38630L,38631L,38632L,38633L,38634L,38635L,38636L,38637L, +38638L,38639L,38640L,38641L,38642L,38643L,38644L,38645L,38646L,38647L, +38648L,38649L,38650L,38651L,38652L,38653L,38654L,38655L,38656L,38657L, +38658L,38659L,38660L,38661L,38662L,38663L,38664L,38665L,38666L,38667L, +38668L,38669L,38670L,38671L,38672L,38673L,38674L,38675L,38676L,38677L, +38678L,38679L,38680L,38681L,38682L,38683L,38684L,38685L,38686L,38687L, +38688L,38689L,38690L,38691L,38692L,38693L,38694L,38695L,38696L,38697L, +38698L,38699L,38700L,38701L,38702L,38703L,38704L,38705L,38706L,38707L, +38708L,38709L,38710L,38711L,38712L,38713L,38714L,38715L,38716L,38717L, +38718L,38719L,38720L,38721L,38722L,38723L,38724L,38725L,38726L,38727L, +38728L,38729L,38730L,38731L,38732L,38733L,38734L,38735L,38736L,38737L, +38738L,38739L,38740L,38741L,38742L,38743L,38744L,38745L,38746L,38747L, +38748L,38749L,38750L,38751L,38752L,38753L,38754L,38755L,38756L,38757L, +38758L,38759L,38760L,38761L,38762L,38763L,38764L,38765L,38766L,38767L, +38768L,38769L,38770L,38771L,38772L,38773L,38774L,38775L,38776L,38777L, +38778L,38779L,38780L,38781L,38782L,38783L,38784L,38785L,38786L,38787L, +38788L,38789L,38790L,38791L,38792L,38793L,38794L,38795L,38796L,38797L, +38798L,38799L,38800L,38801L,38802L,38803L,38804L,38805L,38806L,38807L, +38808L,38809L,38810L,38811L,38812L,38813L,38814L,38815L,38816L,38817L, +38818L,38819L,38820L,38821L,38822L,38823L,38824L,38825L,38826L,38827L, +38828L,38829L,38830L,38831L,38832L,38833L,38834L,38835L,38836L,38837L, +38838L,38839L,38840L,38841L,38842L,38843L,38844L,38845L,38846L,38847L, +38848L,38849L,38850L,38851L,38852L,38853L,38854L,38855L,38856L,38857L, +38858L,38859L,38860L,38861L,38862L,38863L,38864L,38865L,38866L,38867L, +38868L,38869L,38870L,38871L,38872L,38873L,38874L,38875L,38876L,38877L, +38878L,38879L,38880L,38881L,38882L,38883L,38884L,38885L,38886L,38887L, +38888L,38889L,38890L,38891L,38892L,38893L,38894L,38895L,38896L,38897L, +38898L,38899L,38900L,38901L,38902L,38903L,38904L,38905L,38906L,38907L, +38908L,38909L,38910L,38911L,38912L,38913L,38914L,38915L,38916L,38917L, +38918L,38919L,38920L,38921L,38922L,38923L,38924L,38925L,38926L,38927L, +38928L,38929L,38930L,38931L,38932L,38933L,38934L,38935L,38936L,38937L, +38938L,38939L,38940L,38941L,38942L,38943L,38944L,38945L,38946L,38947L, +38948L,38949L,38950L,38951L,38952L,38953L,38954L,38955L,38956L,38957L, +38958L,38959L,38960L,38961L,38962L,38963L,38964L,38965L,38966L,38967L, +38968L,38969L,38970L,38971L,38972L,38973L,38974L,38975L,38976L,38977L, +38978L,38979L,38980L,38981L,38982L,38983L,38984L,38985L,38986L,38987L, +38988L,38989L,38990L,38991L,38992L,38993L,38994L,38995L,38996L,38997L, +38998L,38999L,39000L,39001L,39002L,39003L,39004L,39005L,39006L,39007L, +39008L,39009L,39010L,39011L,39012L,39013L,39014L,39015L,39016L,39017L, +39018L,39019L,39020L,39021L,39022L,39023L,39024L,39025L,39026L,39027L, +39028L,39029L,39030L,39031L,39032L,39033L,39034L,39035L,39036L,39037L, +39038L,39039L,39040L,39041L,39042L,39043L,39044L,39045L,39046L,39047L, +39048L,39049L,39050L,39051L,39052L,39053L,39054L,39055L,39056L,39057L, +39058L,39059L,39060L,39061L,39062L,39063L,39064L,39065L,39066L,39067L, +39068L,39069L,39070L,39071L,39072L,39073L,39074L,39075L,39076L,39077L, +39078L,39079L,39080L,39081L,39082L,39083L,39084L,39085L,39086L,39087L, +39088L,39089L,39090L,39091L,39092L,39093L,39094L,39095L,39096L,39097L, +39098L,39099L,39100L,39101L,39102L,39103L,39104L,39105L,39106L,39107L, +39108L,39109L,39110L,39111L,39112L,39113L,39114L,39115L,39116L,39117L, +39118L,39119L,39120L,39121L,39122L,39123L,39124L,39125L,39126L,39127L, +39128L,39129L,39130L,39131L,39132L,39133L,39134L,39135L,39136L,39137L, +39138L,39139L,39140L,39141L,39142L,39143L,39144L,39145L,39146L,39147L, +39148L,39149L,39150L,39151L,39152L,39153L,39154L,39155L,39156L,39157L, +39158L,39159L,39160L,39161L,39162L,39163L,39164L,39165L,39166L,39167L, +39168L,39169L,39170L,39171L,39172L,39173L,39174L,39175L,39176L,39177L, +39178L,39179L,39180L,39181L,39182L,39183L,39184L,39185L,39186L,39187L, +39188L,39189L,39190L,39191L,39192L,39193L,39194L,39195L,39196L,39197L, +39198L,39199L,39200L,39201L,39202L,39203L,39204L,39205L,39206L,39207L, +39208L,39209L,39210L,39211L,39212L,39213L,39214L,39215L,39216L,39217L, +39218L,39219L,39220L,39221L,39222L,39223L,39224L,39225L,39226L,39227L, +39228L,39229L,39230L,39231L,39232L,39233L,39234L,39235L,39236L,39237L, +39238L,39239L,39240L,39241L,39242L,39243L,39244L,39245L,39246L,39247L, +39248L,39249L,39250L,39251L,39252L,39253L,39254L,39255L,39256L,39257L, +39258L,39259L,39260L,39261L,39262L,39263L,39264L,39265L,39266L,39267L, +39268L,39269L,39270L,39271L,39272L,39273L,39274L,39275L,39276L,39277L, +39278L,39279L,39280L,39281L,39282L,39283L,39284L,39285L,39286L,39287L, +39288L,39289L,39290L,39291L,39292L,39293L,39294L,39295L,39296L,39297L, +39298L,39299L,39300L,39301L,39302L,39303L,39304L,39305L,39306L,39307L, +39308L,39309L,39310L,39311L,39312L,39313L,39314L,39315L,39316L,39317L, +39318L,39319L,39320L,39321L,39322L,39323L,39324L,39325L,39326L,39327L, +39328L,39329L,39330L,39331L,39332L,39333L,39334L,39335L,39336L,39337L, +39338L,39339L,39340L,39341L,39342L,39343L,39344L,39345L,39346L,39347L, +39348L,39349L,39350L,39351L,39352L,39353L,39354L,39355L,39356L,39357L, +39358L,39359L,39360L,39361L,39362L,39363L,39364L,39365L,39366L,39367L, +39368L,39369L,39370L,39371L,39372L,39373L,39374L,39375L,39376L,39377L, +39378L,39379L,39380L,39381L,39382L,39383L,39384L,39385L,39386L,39387L, +39388L,39389L,39390L,39391L,39392L,39393L,39394L,39395L,39396L,39397L, +39398L,39399L,39400L,39401L,39402L,39403L,39404L,39405L,39406L,39407L, +39408L,39409L,39410L,39411L,39412L,39413L,39414L,39415L,39416L,39417L, +39418L,39419L,39420L,39421L,39422L,39423L,39424L,39425L,39426L,39427L, +39428L,39429L,39430L,39431L,39432L,39433L,39434L,39435L,39436L,39437L, +39438L,39439L,39440L,39441L,39442L,39443L,39444L,39445L,39446L,39447L, +39448L,39449L,39450L,39451L,39452L,39453L,39454L,39455L,39456L,39457L, +39458L,39459L,39460L,39461L,39462L,39463L,39464L,39465L,39466L,39467L, +39468L,39469L,39470L,39471L,39472L,39473L,39474L,39475L,39476L,39477L, +39478L,39479L,39480L,39481L,39482L,39483L,39484L,39485L,39486L,39487L, +39488L,39489L,39490L,39491L,39492L,39493L,39494L,39495L,39496L,39497L, +39498L,39499L,39500L,39501L,39502L,39503L,39504L,39505L,39506L,39507L, +39508L,39509L,39510L,39511L,39512L,39513L,39514L,39515L,39516L,39517L, +39518L,39519L,39520L,39521L,39522L,39523L,39524L,39525L,39526L,39527L, +39528L,39529L,39530L,39531L,39532L,39533L,39534L,39535L,39536L,39537L, +39538L,39539L,39540L,39541L,39542L,39543L,39544L,39545L,39546L,39547L, +39548L,39549L,39550L,39551L,39552L,39553L,39554L,39555L,39556L,39557L, +39558L,39559L,39560L,39561L,39562L,39563L,39564L,39565L,39566L,39567L, +39568L,39569L,39570L,39571L,39572L,39573L,39574L,39575L,39576L,39577L, +39578L,39579L,39580L,39581L,39582L,39583L,39584L,39585L,39586L,39587L, +39588L,39589L,39590L,39591L,39592L,39593L,39594L,39595L,39596L,39597L, +39598L,39599L,39600L,39601L,39602L,39603L,39604L,39605L,39606L,39607L, +39608L,39609L,39610L,39611L,39612L,39613L,39614L,39615L,39616L,39617L, +39618L,39619L,39620L,39621L,39622L,39623L,39624L,39625L,39626L,39627L, +39628L,39629L,39630L,39631L,39632L,39633L,39634L,39635L,39636L,39637L, +39638L,39639L,39640L,39641L,39642L,39643L,39644L,39645L,39646L,39647L, +39648L,39649L,39650L,39651L,39652L,39653L,39654L,39655L,39656L,39657L, +39658L,39659L,39660L,39661L,39662L,39663L,39664L,39665L,39666L,39667L, +39668L,39669L,39670L,39671L,39672L,39673L,39674L,39675L,39676L,39677L, +39678L,39679L,39680L,39681L,39682L,39683L,39684L,39685L,39686L,39687L, +39688L,39689L,39690L,39691L,39692L,39693L,39694L,39695L,39696L,39697L, +39698L,39699L,39700L,39701L,39702L,39703L,39704L,39705L,39706L,39707L, +39708L,39709L,39710L,39711L,39712L,39713L,39714L,39715L,39716L,39717L, +39718L,39719L,39720L,39721L,39722L,39723L,39724L,39725L,39726L,39727L, +39728L,39729L,39730L,39731L,39732L,39733L,39734L,39735L,39736L,39737L, +39738L,39739L,39740L,39741L,39742L,39743L,39744L,39745L,39746L,39747L, +39748L,39749L,39750L,39751L,39752L,39753L,39754L,39755L,39756L,39757L, +39758L,39759L,39760L,39761L,39762L,39763L,39764L,39765L,39766L,39767L, +39768L,39769L,39770L,39771L,39772L,39773L,39774L,39775L,39776L,39777L, +39778L,39779L,39780L,39781L,39782L,39783L,39784L,39785L,39786L,39787L, +39788L,39789L,39790L,39791L,39792L,39793L,39794L,39795L,39796L,39797L, +39798L,39799L,39800L,39801L,39802L,39803L,39804L,39805L,39806L,39807L, +39808L,39809L,39810L,39811L,39812L,39813L,39814L,39815L,39816L,39817L, +39818L,39819L,39820L,39821L,39822L,39823L,39824L,39825L,39826L,39827L, +39828L,39829L,39830L,39831L,39832L,39833L,39834L,39835L,39836L,39837L, +39838L,39839L,39840L,39841L,39842L,39843L,39844L,39845L,39846L,39847L, +39848L,39849L,39850L,39851L,39852L,39853L,39854L,39855L,39856L,39857L, +39858L,39859L,39860L,39861L,39862L,39863L,39864L,39865L,39866L,39867L, +39868L,39869L,39870L,39871L,39872L,39873L,39874L,39875L,39876L,39877L, +39878L,39879L,39880L,39881L,39882L,39883L,39884L,39885L,39886L,39887L, +39888L,39889L,39890L,39891L,39892L,39893L,39894L,39895L,39896L,39897L, +39898L,39899L,39900L,39901L,39902L,39903L,39904L,39905L,39906L,39907L, +39908L,39909L,39910L,39911L,39912L,39913L,39914L,39915L,39916L,39917L, +39918L,39919L,39920L,39921L,39922L,39923L,39924L,39925L,39926L,39927L, +39928L,39929L,39930L,39931L,39932L,39933L,39934L,39935L,39936L,39937L, +39938L,39939L,39940L,39941L,39942L,39943L,39944L,39945L,39946L,39947L, +39948L,39949L,39950L,39951L,39952L,39953L,39954L,39955L,39956L,39957L, +39958L,39959L,39960L,39961L,39962L,39963L,39964L,39965L,39966L,39967L, +39968L,39969L,39970L,39971L,39972L,39973L,39974L,39975L,39976L,39977L, +39978L,39979L,39980L,39981L,39982L,39983L,39984L,39985L,39986L,39987L, +39988L,39989L,39990L,39991L,39992L,39993L,39994L,39995L,39996L,39997L, +39998L,39999L,40000L,40001L,40002L,40003L,40004L,40005L,40006L,40007L, +40008L,40009L,40010L,40011L,40012L,40013L,40014L,40015L,40016L,40017L, +40018L,40019L,40020L,40021L,40022L,40023L,40024L,40025L,40026L,40027L, +40028L,40029L,40030L,40031L,40032L,40033L,40034L,40035L,40036L,40037L, +40038L,40039L,40040L,40041L,40042L,40043L,40044L,40045L,40046L,40047L, +40048L,40049L,40050L,40051L,40052L,40053L,40054L,40055L,40056L,40057L, +40058L,40059L,40060L,40061L,40062L,40063L,40064L,40065L,40066L,40067L, +40068L,40069L,40070L,40071L,40072L,40073L,40074L,40075L,40076L,40077L, +40078L,40079L,40080L,40081L,40082L,40083L,40084L,40085L,40086L,40087L, +40088L,40089L,40090L,40091L,40092L,40093L,40094L,40095L,40096L,40097L, +40098L,40099L,40100L,40101L,40102L,40103L,40104L,40105L,40106L,40107L, +40108L,40109L,40110L,40111L,40112L,40113L,40114L,40115L,40116L,40117L, +40118L,40119L,40120L,40121L,40122L,40123L,40124L,40125L,40126L,40127L, +40128L,40129L,40130L,40131L,40132L,40133L,40134L,40135L,40136L,40137L, +40138L,40139L,40140L,40141L,40142L,40143L,40144L,40145L,40146L,40147L, +40148L,40149L,40150L,40151L,40152L,40153L,40154L,40155L,40156L,40157L, +40158L,40159L,40160L,40161L,40162L,40163L,40164L,40165L,40166L,40167L, +40168L,40169L,40170L,40171L,40172L,40173L,40174L,40175L,40176L,40177L, +40178L,40179L,40180L,40181L,40182L,40183L,40184L,40185L,40186L,40187L, +40188L,40189L,40190L,40191L,40192L,40193L,40194L,40195L,40196L,40197L, +40198L,40199L,40200L,40201L,40202L,40203L,40204L,40205L,40206L,40207L, +40208L,40209L,40210L,40211L,40212L,40213L,40214L,40215L,40216L,40217L, +40218L,40219L,40220L,40221L,40222L,40223L,40224L,40225L,40226L,40227L, +40228L,40229L,40230L,40231L,40232L,40233L,40234L,40235L,40236L,40237L, +40238L,40239L,40240L,40241L,40242L,40243L,40244L,40245L,40246L,40247L, +40248L,40249L,40250L,40251L,40252L,40253L,40254L,40255L,40256L,40257L, +40258L,40259L,40260L,40261L,40262L,40263L,40264L,40265L,40266L,40267L, +40268L,40269L,40270L,40271L,40272L,40273L,40274L,40275L,40276L,40277L, +40278L,40279L,40280L,40281L,40282L,40283L,40284L,40285L,40286L,40287L, +40288L,40289L,40290L,40291L,40292L,40293L,40294L,40295L,40296L,40297L, +40298L,40299L,40300L,40301L,40302L,40303L,40304L,40305L,40306L,40307L, +40308L,40309L,40310L,40311L,40312L,40313L,40314L,40315L,40316L,40317L, +40318L,40319L,40320L,40321L,40322L,40323L,40324L,40325L,40326L,40327L, +40328L,40329L,40330L,40331L,40332L,40333L,40334L,40335L,40336L,40337L, +40338L,40339L,40340L,40341L,40342L,40343L,40344L,40345L,40346L,40347L, +40348L,40349L,40350L,40351L,40352L,40353L,40354L,40355L,40356L,40357L, +40358L,40359L,40360L,40361L,40362L,40363L,40364L,40365L,40366L,40367L, +40368L,40369L,40370L,40371L,40372L,40373L,40374L,40375L,40376L,40377L, +40378L,40379L,40380L,40381L,40382L,40383L,40384L,40385L,40386L,40387L, +40388L,40389L,40390L,40391L,40392L,40393L,40394L,40395L,40396L,40397L, +40398L,40399L,40400L,40401L,40402L,40403L,40404L,40405L,40406L,40407L, +40408L,40409L,40410L,40411L,40412L,40413L,40414L,40415L,40416L,40417L, +40418L,40419L,40420L,40421L,40422L,40423L,40424L,40425L,40426L,40427L, +40428L,40429L,40430L,40431L,40432L,40433L,40434L,40435L,40436L,40437L, +40438L,40439L,40440L,40441L,40442L,40443L,40444L,40445L,40446L,40447L, +40448L,40449L,40450L,40451L,40452L,40453L,40454L,40455L,40456L,40457L, +40458L,40459L,40460L,40461L,40462L,40463L,40464L,40465L,40466L,40467L, +40468L,40469L,40470L,40471L,40472L,40473L,40474L,40475L,40476L,40477L, +40478L,40479L,40480L,40481L,40482L,40483L,40484L,40485L,40486L,40487L, +40488L,40489L,40490L,40491L,40492L,40493L,40494L,40495L,40496L,40497L, +40498L,40499L,40500L,40501L,40502L,40503L,40504L,40505L,40506L,40507L, +40508L,40509L,40510L,40511L,40512L,40513L,40514L,40515L,40516L,40517L, +40518L,40519L,40520L,40521L,40522L,40523L,40524L,40525L,40526L,40527L, +40528L,40529L,40530L,40531L,40532L,40533L,40534L,40535L,40536L,40537L, +40538L,40539L,40540L,40541L,40542L,40543L,40544L,40545L,40546L,40547L, +40548L,40549L,40550L,40551L,40552L,40553L,40554L,40555L,40556L,40557L, +40558L,40559L,40560L,40561L,40562L,40563L,40564L,40565L,40566L,40567L, +40568L,40569L,40570L,40571L,40572L,40573L,40574L,40575L,40576L,40577L, +40578L,40579L,40580L,40581L,40582L,40583L,40584L,40585L,40586L,40587L, +40588L,40589L,40590L,40591L,40592L,40593L,40594L,40595L,40596L,40597L, +40598L,40599L,40600L,40601L,40602L,40603L,40604L,40605L,40606L,40607L, +40608L,40609L,40610L,40611L,40612L,40613L,40614L,40615L,40616L,40617L, +40618L,40619L,40620L,40621L,40622L,40623L,40624L,40625L,40626L,40627L, +40628L,40629L,40630L,40631L,40632L,40633L,40634L,40635L,40636L,40637L, +40638L,40639L,40640L,40641L,40642L,40643L,40644L,40645L,40646L,40647L, +40648L,40649L,40650L,40651L,40652L,40653L,40654L,40655L,40656L,40657L, +40658L,40659L,40660L,40661L,40662L,40663L,40664L,40665L,40666L,40667L, +40668L,40669L,40670L,40671L,40672L,40673L,40674L,40675L,40676L,40677L, +40678L,40679L,40680L,40681L,40682L,40683L,40684L,40685L,40686L,40687L, +40688L,40689L,40690L,40691L,40692L,40693L,40694L,40695L,40696L,40697L, +40698L,40699L,40700L,40701L,40702L,40703L,40704L,40705L,40706L,40707L, +40708L,40709L,40710L,40711L,40712L,40713L,40714L,40715L,40716L,40717L, +40718L,40719L,40720L,40721L,40722L,40723L,40724L,40725L,40726L,40727L, +40728L,40729L,40730L,40731L,40732L,40733L,40734L,40735L,40736L,40737L, +40738L,40739L,40740L,40741L,40742L,40743L,40744L,40745L,40746L,40747L, +40748L,40749L,40750L,40751L,40752L,40753L,40754L,40755L,40756L,40757L, +40758L,40759L,40760L,40761L,40762L,40763L,40764L,40765L,40766L,40767L, +40768L,40769L,40770L,40771L,40772L,40773L,40774L,40775L,40776L,40777L, +40778L,40779L,40780L,40781L,40782L,40783L,40784L,40785L,40786L,40787L, +40788L,40789L,40790L,40791L,40792L,40793L,40794L,40795L,40796L,40797L, +40798L,40799L,40800L,40801L,40802L,40803L,40804L,40805L,40806L,40807L, +40808L,40809L,40810L,40811L,40812L,40813L,40814L,40815L,40816L,40817L, +40818L,40819L,40820L,40821L,40822L,40823L,40824L,40825L,40826L,40827L, +40828L,40829L,40830L,40831L,40832L,40833L,40834L,40835L,40836L,40837L, +40838L,40839L,40840L,40841L,40842L,40843L,40844L,40845L,40846L,40847L, +40848L,40849L,40850L,40851L,40852L,40853L,40854L,40855L,40856L,40857L, +40858L,40859L,40860L,40861L,40862L,40863L,40864L,40865L,40866L,40867L, +40868L,40869L,40870L,40871L,40872L,40873L,40874L,40875L,40876L,40877L, +40878L,40879L,40880L,40881L,40882L,40883L,40884L,40885L,40886L,40887L, +40888L,40889L,40890L,40891L,40892L,40893L,40894L,40895L,40896L,40897L, +40898L,40899L,40900L,40901L,40902L,40903L,40904L,40905L,40906L,40907L, +40908L,40909L,40910L,40911L,40912L,40913L,40914L,40915L,40916L,40917L, +40918L,40919L,40920L,40921L,40922L,40923L,40924L,40925L,40926L,40927L, +40928L,40929L,40930L,40931L,40932L,40933L,40934L,40935L,40936L,40937L, +40938L,40939L,40940L,40941L,40942L,40943L,40944L,40945L,40946L,40947L, +40948L,40949L,40950L,40951L,40952L,40953L,40954L,40955L,40956L,40957L, +40958L,40959L,40960L,40961L,40962L,40963L,40964L,40965L,40966L,40967L, +40968L,40969L,40970L,40971L,40972L,40973L,40974L,40975L,40976L,40977L, +40978L,40979L,40980L,40981L,40982L,40983L,40984L,40985L,40986L,40987L, +40988L,40989L,40990L,40991L,40992L,40993L,40994L,40995L,40996L,40997L, +40998L,40999L,41000L,41001L,41002L,41003L,41004L,41005L,41006L,41007L, +41008L,41009L,41010L,41011L,41012L,41013L,41014L,41015L,41016L,41017L, +41018L,41019L,41020L,41021L,41022L,41023L,41024L,41025L,41026L,41027L, +41028L,41029L,41030L,41031L,41032L,41033L,41034L,41035L,41036L,41037L, +41038L,41039L,41040L,41041L,41042L,41043L,41044L,41045L,41046L,41047L, +41048L,41049L,41050L,41051L,41052L,41053L,41054L,41055L,41056L,41057L, +41058L,41059L,41060L,41061L,41062L,41063L,41064L,41065L,41066L,41067L, +41068L,41069L,41070L,41071L,41072L,41073L,41074L,41075L,41076L,41077L, +41078L,41079L,41080L,41081L,41082L,41083L,41084L,41085L,41086L,41087L, +41088L,41089L,41090L,41091L,41092L,41093L,41094L,41095L,41096L,41097L, +41098L,41099L,41100L,41101L,41102L,41103L,41104L,41105L,41106L,41107L, +41108L,41109L,41110L,41111L,41112L,41113L,41114L,41115L,41116L,41117L, +41118L,41119L,41120L,41121L,41122L,41123L,41124L,41125L,41126L,41127L, +41128L,41129L,41130L,41131L,41132L,41133L,41134L,41135L,41136L,41137L, +41138L,41139L,41140L,41141L,41142L,41143L,41144L,41145L,41146L,41147L, +41148L,41149L,41150L,41151L,41152L,41153L,41154L,41155L,41156L,41157L, +41158L,41159L,41160L,41161L,41162L,41163L,41164L,41165L,41166L,41167L, +41168L,41169L,41170L,41171L,41172L,41173L,41174L,41175L,41176L,41177L, +41178L,41179L,41180L,41181L,41182L,41183L,41184L,41185L,41186L,41187L, +41188L,41189L,41190L,41191L,41192L,41193L,41194L,41195L,41196L,41197L, +41198L,41199L,41200L,41201L,41202L,41203L,41204L,41205L,41206L,41207L, +41208L,41209L,41210L,41211L,41212L,41213L,41214L,41215L,41216L,41217L, +41218L,41219L,41220L,41221L,41222L,41223L,41224L,41225L,41226L,41227L, +41228L,41229L,41230L,41231L,41232L,41233L,41234L,41235L,41236L,41237L, +41238L,41239L,41240L,41241L,41242L,41243L,41244L,41245L,41246L,41247L, +41248L,41249L,41250L,41251L,41252L,41253L,41254L,41255L,41256L,41257L, +41258L,41259L,41260L,41261L,41262L,41263L,41264L,41265L,41266L,41267L, +41268L,41269L,41270L,41271L,41272L,41273L,41274L,41275L,41276L,41277L, +41278L,41279L,41280L,41281L,41282L,41283L,41284L,41285L,41286L,41287L, +41288L,41289L,41290L,41291L,41292L,41293L,41294L,41295L,41296L,41297L, +41298L,41299L,41300L,41301L,41302L,41303L,41304L,41305L,41306L,41307L, +41308L,41309L,41310L,41311L,41312L,41313L,41314L,41315L,41316L,41317L, +41318L,41319L,41320L,41321L,41322L,41323L,41324L,41325L,41326L,41327L, +41328L,41329L,41330L,41331L,41332L,41333L,41334L,41335L,41336L,41337L, +41338L,41339L,41340L,41341L,41342L,41343L,41344L,41345L,41346L,41347L, +41348L,41349L,41350L,41351L,41352L,41353L,41354L,41355L,41356L,41357L, +41358L,41359L,41360L,41361L,41362L,41363L,41364L,41365L,41366L,41367L, +41368L,41369L,41370L,41371L,41372L,41373L,41374L,41375L,41376L,41377L, +41378L,41379L,41380L,41381L,41382L,41383L,41384L,41385L,41386L,41387L, +41388L,41389L,41390L,41391L,41392L,41393L,41394L,41395L,41396L,41397L, +41398L,41399L,41400L,41401L,41402L,41403L,41404L,41405L,41406L,41407L, +41408L,41409L,41410L,41411L,41412L,41413L,41414L,41415L,41416L,41417L, +41418L,41419L,41420L,41421L,41422L,41423L,41424L,41425L,41426L,41427L, +41428L,41429L,41430L,41431L,41432L,41433L,41434L,41435L,41436L,41437L, +41438L,41439L,41440L,41441L,41442L,41443L,41444L,41445L,41446L,41447L, +41448L,41449L,41450L,41451L,41452L,41453L,41454L,41455L,41456L,41457L, +41458L,41459L,41460L,41461L,41462L,41463L,41464L,41465L,41466L,41467L, +41468L,41469L,41470L,41471L,41472L,41473L,41474L,41475L,41476L,41477L, +41478L,41479L,41480L,41481L,41482L,41483L,41484L,41485L,41486L,41487L, +41488L,41489L,41490L,41491L,41492L,41493L,41494L,41495L,41496L,41497L, +41498L,41499L,41500L,41501L,41502L,41503L,41504L,41505L,41506L,41507L, +41508L,41509L,41510L,41511L,41512L,41513L,41514L,41515L,41516L,41517L, +41518L,41519L,41520L,41521L,41522L,41523L,41524L,41525L,41526L,41527L, +41528L,41529L,41530L,41531L,41532L,41533L,41534L,41535L,41536L,41537L, +41538L,41539L,41540L,41541L,41542L,41543L,41544L,41545L,41546L,41547L, +41548L,41549L,41550L,41551L,41552L,41553L,41554L,41555L,41556L,41557L, +41558L,41559L,41560L,41561L,41562L,41563L,41564L,41565L,41566L,41567L, +41568L,41569L,41570L,41571L,41572L,41573L,41574L,41575L,41576L,41577L, +41578L,41579L,41580L,41581L,41582L,41583L,41584L,41585L,41586L,41587L, +41588L,41589L,41590L,41591L,41592L,41593L,41594L,41595L,41596L,41597L, +41598L,41599L,41600L,41601L,41602L,41603L,41604L,41605L,41606L,41607L, +41608L,41609L,41610L,41611L,41612L,41613L,41614L,41615L,41616L,41617L, +41618L,41619L,41620L,41621L,41622L,41623L,41624L,41625L,41626L,41627L, +41628L,41629L,41630L,41631L,41632L,41633L,41634L,41635L,41636L,41637L, +41638L,41639L,41640L,41641L,41642L,41643L,41644L,41645L,41646L,41647L, +41648L,41649L,41650L,41651L,41652L,41653L,41654L,41655L,41656L,41657L, +41658L,41659L,41660L,41661L,41662L,41663L,41664L,41665L,41666L,41667L, +41668L,41669L,41670L,41671L,41672L,41673L,41674L,41675L,41676L,41677L, +41678L,41679L,41680L,41681L,41682L,41683L,41684L,41685L,41686L,41687L, +41688L,41689L,41690L,41691L,41692L,41693L,41694L,41695L,41696L,41697L, +41698L,41699L,41700L,41701L,41702L,41703L,41704L,41705L,41706L,41707L, +41708L,41709L,41710L,41711L,41712L,41713L,41714L,41715L,41716L,41717L, +41718L,41719L,41720L,41721L,41722L,41723L,41724L,41725L,41726L,41727L, +41728L,41729L,41730L,41731L,41732L,41733L,41734L,41735L,41736L,41737L, +41738L,41739L,41740L,41741L,41742L,41743L,41744L,41745L,41746L,41747L, +41748L,41749L,41750L,41751L,41752L,41753L,41754L,41755L,41756L,41757L, +41758L,41759L,41760L,41761L,41762L,41763L,41764L,41765L,41766L,41767L, +41768L,41769L,41770L,41771L,41772L,41773L,41774L,41775L,41776L,41777L, +41778L,41779L,41780L,41781L,41782L,41783L,41784L,41785L,41786L,41787L, +41788L,41789L,41790L,41791L,41792L,41793L,41794L,41795L,41796L,41797L, +41798L,41799L,41800L,41801L,41802L,41803L,41804L,41805L,41806L,41807L, +41808L,41809L,41810L,41811L,41812L,41813L,41814L,41815L,41816L,41817L, +41818L,41819L,41820L,41821L,41822L,41823L,41824L,41825L,41826L,41827L, +41828L,41829L,41830L,41831L,41832L,41833L,41834L,41835L,41836L,41837L, +41838L,41839L,41840L,41841L,41842L,41843L,41844L,41845L,41846L,41847L, +41848L,41849L,41850L,41851L,41852L,41853L,41854L,41855L,41856L,41857L, +41858L,41859L,41860L,41861L,41862L,41863L,41864L,41865L,41866L,41867L, +41868L,41869L,41870L,41871L,41872L,41873L,41874L,41875L,41876L,41877L, +41878L,41879L,41880L,41881L,41882L,41883L,41884L,41885L,41886L,41887L, +41888L,41889L,41890L,41891L,41892L,41893L,41894L,41895L,41896L,41897L, +41898L,41899L,41900L,41901L,41902L,41903L,41904L,41905L,41906L,41907L, +41908L,41909L,41910L,41911L,41912L,41913L,41914L,41915L,41916L,41917L, +41918L,41919L,41920L,41921L,41922L,41923L,41924L,41925L,41926L,41927L, +41928L,41929L,41930L,41931L,41932L,41933L,41934L,41935L,41936L,41937L, +41938L,41939L,41940L,41941L,41942L,41943L,41944L,41945L,41946L,41947L, +41948L,41949L,41950L,41951L,41952L,41953L,41954L,41955L,41956L,41957L, +41958L,41959L,41960L,41961L,41962L,41963L,41964L,41965L,41966L,41967L, +41968L,41969L,41970L,41971L,41972L,41973L,41974L,41975L,41976L,41977L, +41978L,41979L,41980L,41981L,41982L,41983L,41984L,41985L,41986L,41987L, +41988L,41989L,41990L,41991L,41992L,41993L,41994L,41995L,41996L,41997L, +41998L,41999L,42000L,42001L,42002L,42003L,42004L,42005L,42006L,42007L, +42008L,42009L,42010L,42011L,42012L,42013L,42014L,42015L,42016L,42017L, +42018L,42019L,42020L,42021L,42022L,42023L,42024L,42025L,42026L,42027L, +42028L,42029L,42030L,42031L,42032L,42033L,42034L,42035L,42036L,42037L, +42038L,42039L,42040L,42041L,42042L,42043L,42044L,42045L,42046L,42047L, +42048L,42049L,42050L,42051L,42052L,42053L,42054L,42055L,42056L,42057L, +42058L,42059L,42060L,42061L,42062L,42063L,42064L,42065L,42066L,42067L, +42068L,42069L,42070L,42071L,42072L,42073L,42074L,42075L,42076L,42077L, +42078L,42079L,42080L,42081L,42082L,42083L,42084L,42085L,42086L,42087L, +42088L,42089L,42090L,42091L,42092L,42093L,42094L,42095L,42096L,42097L, +42098L,42099L,42100L,42101L,42102L,42103L,42104L,42105L,42106L,42107L, +42108L,42109L,42110L,42111L,42112L,42113L,42114L,42115L,42116L,42117L, +42118L,42119L,42120L,42121L,42122L,42123L,42124L,42125L,42126L,42127L, +42128L,42129L,42130L,42131L,42132L,42133L,42134L,42135L,42136L,42137L, +42138L,42139L,42140L,42141L,42142L,42143L,42144L,42145L,42146L,42147L, +42148L,42149L,42150L,42151L,42152L,42153L,42154L,42155L,42156L,42157L, +42158L,42159L,42160L,42161L,42162L,42163L,42164L,42165L,42166L,42167L, +42168L,42169L,42170L,42171L,42172L,42173L,42174L,42175L,42176L,42177L, +42178L,42179L,42180L,42181L,42182L,42183L,42184L,42185L,42186L,42187L, +42188L,42189L,42190L,42191L,42192L,42193L,42194L,42195L,42196L,42197L, +42198L,42199L,42200L,42201L,42202L,42203L,42204L,42205L,42206L,42207L, +42208L,42209L,42210L,42211L,42212L,42213L,42214L,42215L,42216L,42217L, +42218L,42219L,42220L,42221L,42222L,42223L,42224L,42225L,42226L,42227L, +42228L,42229L,42230L,42231L,42232L,42233L,42234L,42235L,42236L,42237L, +42238L,42239L,42240L,42241L,42242L,42243L,42244L,42245L,42246L,42247L, +42248L,42249L,42250L,42251L,42252L,42253L,42254L,42255L,42256L,42257L, +42258L,42259L,42260L,42261L,42262L,42263L,42264L,42265L,42266L,42267L, +42268L,42269L,42270L,42271L,42272L,42273L,42274L,42275L,42276L,42277L, +42278L,42279L,42280L,42281L,42282L,42283L,42284L,42285L,42286L,42287L, +42288L,42289L,42290L,42291L,42292L,42293L,42294L,42295L,42296L,42297L, +42298L,42299L,42300L,42301L,42302L,42303L,42304L,42305L,42306L,42307L, +42308L,42309L,42310L,42311L,42312L,42313L,42314L,42315L,42316L,42317L, +42318L,42319L,42320L,42321L,42322L,42323L,42324L,42325L,42326L,42327L, +42328L,42329L,42330L,42331L,42332L,42333L,42334L,42335L,42336L,42337L, +42338L,42339L,42340L,42341L,42342L,42343L,42344L,42345L,42346L,42347L, +42348L,42349L,42350L,42351L,42352L,42353L,42354L,42355L,42356L,42357L, +42358L,42359L,42360L,42361L,42362L,42363L,42364L,42365L,42366L,42367L, +42368L,42369L,42370L,42371L,42372L,42373L,42374L,42375L,42376L,42377L, +42378L,42379L,42380L,42381L,42382L,42383L,42384L,42385L,42386L,42387L, +42388L,42389L,42390L,42391L,42392L,42393L,42394L,42395L,42396L,42397L, +42398L,42399L,42400L,42401L,42402L,42403L,42404L,42405L,42406L,42407L, +42408L,42409L,42410L,42411L,42412L,42413L,42414L,42415L,42416L,42417L, +42418L,42419L,42420L,42421L,42422L,42423L,42424L,42425L,42426L,42427L, +42428L,42429L,42430L,42431L,42432L,42433L,42434L,42435L,42436L,42437L, +42438L,42439L,42440L,42441L,42442L,42443L,42444L,42445L,42446L,42447L, +42448L,42449L,42450L,42451L,42452L,42453L,42454L,42455L,42456L,42457L, +42458L,42459L,42460L,42461L,42462L,42463L,42464L,42465L,42466L,42467L, +42468L,42469L,42470L,42471L,42472L,42473L,42474L,42475L,42476L,42477L, +42478L,42479L,42480L,42481L,42482L,42483L,42484L,42485L,42486L,42487L, +42488L,42489L,42490L,42491L,42492L,42493L,42494L,42495L,42496L,42497L, +42498L,42499L,42500L,42501L,42502L,42503L,42504L,42505L,42506L,42507L, +42508L,42509L,42510L,42511L,42512L,42513L,42514L,42515L,42516L,42517L, +42518L,42519L,42520L,42521L,42522L,42523L,42524L,42525L,42526L,42527L, +42528L,42529L,42530L,42531L,42532L,42533L,42534L,42535L,42536L,42537L, +42538L,42539L,42540L,42541L,42542L,42543L,42544L,42545L,42546L,42547L, +42548L,42549L,42550L,42551L,42552L,42553L,42554L,42555L,42556L,42557L, +42558L,42559L,42560L,42560L,42562L,42562L,42564L,42564L,42566L,42566L, +42568L,42568L,42570L,42570L,42572L,42572L,42574L,42574L,42576L,42576L, +42578L,42578L,42580L,42580L,42582L,42582L,42584L,42584L,42586L,42586L, +42588L,42588L,42590L,42590L,42592L,42592L,42594L,42594L,42596L,42596L, +42598L,42598L,42600L,42600L,42602L,42602L,42604L,42604L,42606L,42607L, +42608L,42609L,42610L,42611L,42612L,42613L,42614L,42615L,42616L,42617L, +42618L,42619L,42620L,42621L,42622L,42623L,42624L,42624L,42626L,42626L, +42628L,42628L,42630L,42630L,42632L,42632L,42634L,42634L,42636L,42636L, +42638L,42638L,42640L,42640L,42642L,42642L,42644L,42644L,42646L,42646L, +42648L,42648L,42650L,42650L,42652L,42653L,42654L,42655L,42656L,42657L, +42658L,42659L,42660L,42661L,42662L,42663L,42664L,42665L,42666L,42667L, +42668L,42669L,42670L,42671L,42672L,42673L,42674L,42675L,42676L,42677L, +42678L,42679L,42680L,42681L,42682L,42683L,42684L,42685L,42686L,42687L, +42688L,42689L,42690L,42691L,42692L,42693L,42694L,42695L,42696L,42697L, +42698L,42699L,42700L,42701L,42702L,42703L,42704L,42705L,42706L,42707L, +42708L,42709L,42710L,42711L,42712L,42713L,42714L,42715L,42716L,42717L, +42718L,42719L,42720L,42721L,42722L,42723L,42724L,42725L,42726L,42727L, +42728L,42729L,42730L,42731L,42732L,42733L,42734L,42735L,42736L,42737L, +42738L,42739L,42740L,42741L,42742L,42743L,42744L,42745L,42746L,42747L, +42748L,42749L,42750L,42751L,42752L,42753L,42754L,42755L,42756L,42757L, +42758L,42759L,42760L,42761L,42762L,42763L,42764L,42765L,42766L,42767L, +42768L,42769L,42770L,42771L,42772L,42773L,42774L,42775L,42776L,42777L, +42778L,42779L,42780L,42781L,42782L,42783L,42784L,42785L,42786L,42786L, +42788L,42788L,42790L,42790L,42792L,42792L,42794L,42794L,42796L,42796L, +42798L,42798L,42800L,42801L,42802L,42802L,42804L,42804L,42806L,42806L, +42808L,42808L,42810L,42810L,42812L,42812L,42814L,42814L,42816L,42816L, +42818L,42818L,42820L,42820L,42822L,42822L,42824L,42824L,42826L,42826L, +42828L,42828L,42830L,42830L,42832L,42832L,42834L,42834L,42836L,42836L, +42838L,42838L,42840L,42840L,42842L,42842L,42844L,42844L,42846L,42846L, +42848L,42848L,42850L,42850L,42852L,42852L,42854L,42854L,42856L,42856L, +42858L,42858L,42860L,42860L,42862L,42862L,42864L,42865L,42866L,42867L, +42868L,42869L,42870L,42871L,42872L,42873L,42873L,42875L,42875L,42877L, +42878L,42878L,42880L,42880L,42882L,42882L,42884L,42884L,42886L,42886L, +42888L,42889L,42890L,42891L,42891L,42893L,42894L,42895L,42896L,42896L, +42898L,42898L,42948L,42901L,42902L,42902L,42904L,42904L,42906L,42906L, +42908L,42908L,42910L,42910L,42912L,42912L,42914L,42914L,42916L,42916L, +42918L,42918L,42920L,42920L,42922L,42923L,42924L,42925L,42926L,42927L, +42928L,42929L,42930L,42931L,42932L,42932L,42934L,42934L,42936L,42936L, +42938L,42938L,42940L,42940L,42942L,42942L,42944L,42945L,42946L,42946L, +42948L,42949L,42950L,42951L,42952L,42953L,42954L,42955L,42956L,42957L, +42958L,42959L,42960L,42961L,42962L,42963L,42964L,42965L,42966L,42967L, +42968L,42969L,42970L,42971L,42972L,42973L,42974L,42975L,42976L,42977L, +42978L,42979L,42980L,42981L,42982L,42983L,42984L,42985L,42986L,42987L, +42988L,42989L,42990L,42991L,42992L,42993L,42994L,42995L,42996L,42997L, +42998L,42999L,43000L,43001L,43002L,43003L,43004L,43005L,43006L,43007L, +43008L,43009L,43010L,43011L,43012L,43013L,43014L,43015L,43016L,43017L, +43018L,43019L,43020L,43021L,43022L,43023L,43024L,43025L,43026L,43027L, +43028L,43029L,43030L,43031L,43032L,43033L,43034L,43035L,43036L,43037L, +43038L,43039L,43040L,43041L,43042L,43043L,43044L,43045L,43046L,43047L, +43048L,43049L,43050L,43051L,43052L,43053L,43054L,43055L,43056L,43057L, +43058L,43059L,43060L,43061L,43062L,43063L,43064L,43065L,43066L,43067L, +43068L,43069L,43070L,43071L,43072L,43073L,43074L,43075L,43076L,43077L, +43078L,43079L,43080L,43081L,43082L,43083L,43084L,43085L,43086L,43087L, +43088L,43089L,43090L,43091L,43092L,43093L,43094L,43095L,43096L,43097L, +43098L,43099L,43100L,43101L,43102L,43103L,43104L,43105L,43106L,43107L, +43108L,43109L,43110L,43111L,43112L,43113L,43114L,43115L,43116L,43117L, +43118L,43119L,43120L,43121L,43122L,43123L,43124L,43125L,43126L,43127L, +43128L,43129L,43130L,43131L,43132L,43133L,43134L,43135L,43136L,43137L, +43138L,43139L,43140L,43141L,43142L,43143L,43144L,43145L,43146L,43147L, +43148L,43149L,43150L,43151L,43152L,43153L,43154L,43155L,43156L,43157L, +43158L,43159L,43160L,43161L,43162L,43163L,43164L,43165L,43166L,43167L, +43168L,43169L,43170L,43171L,43172L,43173L,43174L,43175L,43176L,43177L, +43178L,43179L,43180L,43181L,43182L,43183L,43184L,43185L,43186L,43187L, +43188L,43189L,43190L,43191L,43192L,43193L,43194L,43195L,43196L,43197L, +43198L,43199L,43200L,43201L,43202L,43203L,43204L,43205L,43206L,43207L, +43208L,43209L,43210L,43211L,43212L,43213L,43214L,43215L,43216L,43217L, +43218L,43219L,43220L,43221L,43222L,43223L,43224L,43225L,43226L,43227L, +43228L,43229L,43230L,43231L,43232L,43233L,43234L,43235L,43236L,43237L, +43238L,43239L,43240L,43241L,43242L,43243L,43244L,43245L,43246L,43247L, +43248L,43249L,43250L,43251L,43252L,43253L,43254L,43255L,43256L,43257L, +43258L,43259L,43260L,43261L,43262L,43263L,43264L,43265L,43266L,43267L, +43268L,43269L,43270L,43271L,43272L,43273L,43274L,43275L,43276L,43277L, +43278L,43279L,43280L,43281L,43282L,43283L,43284L,43285L,43286L,43287L, +43288L,43289L,43290L,43291L,43292L,43293L,43294L,43295L,43296L,43297L, +43298L,43299L,43300L,43301L,43302L,43303L,43304L,43305L,43306L,43307L, +43308L,43309L,43310L,43311L,43312L,43313L,43314L,43315L,43316L,43317L, +43318L,43319L,43320L,43321L,43322L,43323L,43324L,43325L,43326L,43327L, +43328L,43329L,43330L,43331L,43332L,43333L,43334L,43335L,43336L,43337L, +43338L,43339L,43340L,43341L,43342L,43343L,43344L,43345L,43346L,43347L, +43348L,43349L,43350L,43351L,43352L,43353L,43354L,43355L,43356L,43357L, +43358L,43359L,43360L,43361L,43362L,43363L,43364L,43365L,43366L,43367L, +43368L,43369L,43370L,43371L,43372L,43373L,43374L,43375L,43376L,43377L, +43378L,43379L,43380L,43381L,43382L,43383L,43384L,43385L,43386L,43387L, +43388L,43389L,43390L,43391L,43392L,43393L,43394L,43395L,43396L,43397L, +43398L,43399L,43400L,43401L,43402L,43403L,43404L,43405L,43406L,43407L, +43408L,43409L,43410L,43411L,43412L,43413L,43414L,43415L,43416L,43417L, +43418L,43419L,43420L,43421L,43422L,43423L,43424L,43425L,43426L,43427L, +43428L,43429L,43430L,43431L,43432L,43433L,43434L,43435L,43436L,43437L, +43438L,43439L,43440L,43441L,43442L,43443L,43444L,43445L,43446L,43447L, +43448L,43449L,43450L,43451L,43452L,43453L,43454L,43455L,43456L,43457L, +43458L,43459L,43460L,43461L,43462L,43463L,43464L,43465L,43466L,43467L, +43468L,43469L,43470L,43471L,43472L,43473L,43474L,43475L,43476L,43477L, +43478L,43479L,43480L,43481L,43482L,43483L,43484L,43485L,43486L,43487L, +43488L,43489L,43490L,43491L,43492L,43493L,43494L,43495L,43496L,43497L, +43498L,43499L,43500L,43501L,43502L,43503L,43504L,43505L,43506L,43507L, +43508L,43509L,43510L,43511L,43512L,43513L,43514L,43515L,43516L,43517L, +43518L,43519L,43520L,43521L,43522L,43523L,43524L,43525L,43526L,43527L, +43528L,43529L,43530L,43531L,43532L,43533L,43534L,43535L,43536L,43537L, +43538L,43539L,43540L,43541L,43542L,43543L,43544L,43545L,43546L,43547L, +43548L,43549L,43550L,43551L,43552L,43553L,43554L,43555L,43556L,43557L, +43558L,43559L,43560L,43561L,43562L,43563L,43564L,43565L,43566L,43567L, +43568L,43569L,43570L,43571L,43572L,43573L,43574L,43575L,43576L,43577L, +43578L,43579L,43580L,43581L,43582L,43583L,43584L,43585L,43586L,43587L, +43588L,43589L,43590L,43591L,43592L,43593L,43594L,43595L,43596L,43597L, +43598L,43599L,43600L,43601L,43602L,43603L,43604L,43605L,43606L,43607L, +43608L,43609L,43610L,43611L,43612L,43613L,43614L,43615L,43616L,43617L, +43618L,43619L,43620L,43621L,43622L,43623L,43624L,43625L,43626L,43627L, +43628L,43629L,43630L,43631L,43632L,43633L,43634L,43635L,43636L,43637L, +43638L,43639L,43640L,43641L,43642L,43643L,43644L,43645L,43646L,43647L, +43648L,43649L,43650L,43651L,43652L,43653L,43654L,43655L,43656L,43657L, +43658L,43659L,43660L,43661L,43662L,43663L,43664L,43665L,43666L,43667L, +43668L,43669L,43670L,43671L,43672L,43673L,43674L,43675L,43676L,43677L, +43678L,43679L,43680L,43681L,43682L,43683L,43684L,43685L,43686L,43687L, +43688L,43689L,43690L,43691L,43692L,43693L,43694L,43695L,43696L,43697L, +43698L,43699L,43700L,43701L,43702L,43703L,43704L,43705L,43706L,43707L, +43708L,43709L,43710L,43711L,43712L,43713L,43714L,43715L,43716L,43717L, +43718L,43719L,43720L,43721L,43722L,43723L,43724L,43725L,43726L,43727L, +43728L,43729L,43730L,43731L,43732L,43733L,43734L,43735L,43736L,43737L, +43738L,43739L,43740L,43741L,43742L,43743L,43744L,43745L,43746L,43747L, +43748L,43749L,43750L,43751L,43752L,43753L,43754L,43755L,43756L,43757L, +43758L,43759L,43760L,43761L,43762L,43763L,43764L,43765L,43766L,43767L, +43768L,43769L,43770L,43771L,43772L,43773L,43774L,43775L,43776L,43777L, +43778L,43779L,43780L,43781L,43782L,43783L,43784L,43785L,43786L,43787L, +43788L,43789L,43790L,43791L,43792L,43793L,43794L,43795L,43796L,43797L, +43798L,43799L,43800L,43801L,43802L,43803L,43804L,43805L,43806L,43807L, +43808L,43809L,43810L,43811L,43812L,43813L,43814L,43815L,43816L,43817L, +43818L,43819L,43820L,43821L,43822L,43823L,43824L,43825L,43826L,43827L, +43828L,43829L,43830L,43831L,43832L,43833L,43834L,43835L,43836L,43837L, +43838L,43839L,43840L,43841L,43842L,43843L,43844L,43845L,43846L,43847L, +43848L,43849L,43850L,43851L,43852L,43853L,43854L,43855L,43856L,43857L, +43858L,42931L,43860L,43861L,43862L,43863L,43864L,43865L,43866L,43867L, +43868L,43869L,43870L,43871L,43872L,43873L,43874L,43875L,43876L,43877L, +43878L,43879L,43880L,43881L,43882L,43883L,43884L,43885L,43886L,43887L,5024, +5025,5026,5027,5028,5029,5030,5031,5032,5033,5034,5035,5036,5037,5038,5039, +5040,5041,5042,5043,5044,5045,5046,5047,5048,5049,5050,5051,5052,5053,5054, +5055,5056,5057,5058,5059,5060,5061,5062,5063,5064,5065,5066,5067,5068,5069, +5070,5071,5072,5073,5074,5075,5076,5077,5078,5079,5080,5081,5082,5083,5084, +5085,5086,5087,5088,5089,5090,5091,5092,5093,5094,5095,5096,5097,5098,5099, +5100,5101,5102,5103,43968L,43969L,43970L,43971L,43972L,43973L,43974L, +43975L,43976L,43977L,43978L,43979L,43980L,43981L,43982L,43983L,43984L, +43985L,43986L,43987L,43988L,43989L,43990L,43991L,43992L,43993L,43994L, +43995L,43996L,43997L,43998L,43999L,44000L,44001L,44002L,44003L,44004L, +44005L,44006L,44007L,44008L,44009L,44010L,44011L,44012L,44013L,44014L, +44015L,44016L,44017L,44018L,44019L,44020L,44021L,44022L,44023L,44024L, +44025L,44026L,44027L,44028L,44029L,44030L,44031L,44032L,44033L,44034L, +44035L,44036L,44037L,44038L,44039L,44040L,44041L,44042L,44043L,44044L, +44045L,44046L,44047L,44048L,44049L,44050L,44051L,44052L,44053L,44054L, +44055L,44056L,44057L,44058L,44059L,44060L,44061L,44062L,44063L,44064L, +44065L,44066L,44067L,44068L,44069L,44070L,44071L,44072L,44073L,44074L, +44075L,44076L,44077L,44078L,44079L,44080L,44081L,44082L,44083L,44084L, +44085L,44086L,44087L,44088L,44089L,44090L,44091L,44092L,44093L,44094L, +44095L,44096L,44097L,44098L,44099L,44100L,44101L,44102L,44103L,44104L, +44105L,44106L,44107L,44108L,44109L,44110L,44111L,44112L,44113L,44114L, +44115L,44116L,44117L,44118L,44119L,44120L,44121L,44122L,44123L,44124L, +44125L,44126L,44127L,44128L,44129L,44130L,44131L,44132L,44133L,44134L, +44135L,44136L,44137L,44138L,44139L,44140L,44141L,44142L,44143L,44144L, +44145L,44146L,44147L,44148L,44149L,44150L,44151L,44152L,44153L,44154L, +44155L,44156L,44157L,44158L,44159L,44160L,44161L,44162L,44163L,44164L, +44165L,44166L,44167L,44168L,44169L,44170L,44171L,44172L,44173L,44174L, +44175L,44176L,44177L,44178L,44179L,44180L,44181L,44182L,44183L,44184L, +44185L,44186L,44187L,44188L,44189L,44190L,44191L,44192L,44193L,44194L, +44195L,44196L,44197L,44198L,44199L,44200L,44201L,44202L,44203L,44204L, +44205L,44206L,44207L,44208L,44209L,44210L,44211L,44212L,44213L,44214L, +44215L,44216L,44217L,44218L,44219L,44220L,44221L,44222L,44223L,44224L, +44225L,44226L,44227L,44228L,44229L,44230L,44231L,44232L,44233L,44234L, +44235L,44236L,44237L,44238L,44239L,44240L,44241L,44242L,44243L,44244L, +44245L,44246L,44247L,44248L,44249L,44250L,44251L,44252L,44253L,44254L, +44255L,44256L,44257L,44258L,44259L,44260L,44261L,44262L,44263L,44264L, +44265L,44266L,44267L,44268L,44269L,44270L,44271L,44272L,44273L,44274L, +44275L,44276L,44277L,44278L,44279L,44280L,44281L,44282L,44283L,44284L, +44285L,44286L,44287L,44288L,44289L,44290L,44291L,44292L,44293L,44294L, +44295L,44296L,44297L,44298L,44299L,44300L,44301L,44302L,44303L,44304L, +44305L,44306L,44307L,44308L,44309L,44310L,44311L,44312L,44313L,44314L, +44315L,44316L,44317L,44318L,44319L,44320L,44321L,44322L,44323L,44324L, +44325L,44326L,44327L,44328L,44329L,44330L,44331L,44332L,44333L,44334L, +44335L,44336L,44337L,44338L,44339L,44340L,44341L,44342L,44343L,44344L, +44345L,44346L,44347L,44348L,44349L,44350L,44351L,44352L,44353L,44354L, +44355L,44356L,44357L,44358L,44359L,44360L,44361L,44362L,44363L,44364L, +44365L,44366L,44367L,44368L,44369L,44370L,44371L,44372L,44373L,44374L, +44375L,44376L,44377L,44378L,44379L,44380L,44381L,44382L,44383L,44384L, +44385L,44386L,44387L,44388L,44389L,44390L,44391L,44392L,44393L,44394L, +44395L,44396L,44397L,44398L,44399L,44400L,44401L,44402L,44403L,44404L, +44405L,44406L,44407L,44408L,44409L,44410L,44411L,44412L,44413L,44414L, +44415L,44416L,44417L,44418L,44419L,44420L,44421L,44422L,44423L,44424L, +44425L,44426L,44427L,44428L,44429L,44430L,44431L,44432L,44433L,44434L, +44435L,44436L,44437L,44438L,44439L,44440L,44441L,44442L,44443L,44444L, +44445L,44446L,44447L,44448L,44449L,44450L,44451L,44452L,44453L,44454L, +44455L,44456L,44457L,44458L,44459L,44460L,44461L,44462L,44463L,44464L, +44465L,44466L,44467L,44468L,44469L,44470L,44471L,44472L,44473L,44474L, +44475L,44476L,44477L,44478L,44479L,44480L,44481L,44482L,44483L,44484L, +44485L,44486L,44487L,44488L,44489L,44490L,44491L,44492L,44493L,44494L, +44495L,44496L,44497L,44498L,44499L,44500L,44501L,44502L,44503L,44504L, +44505L,44506L,44507L,44508L,44509L,44510L,44511L,44512L,44513L,44514L, +44515L,44516L,44517L,44518L,44519L,44520L,44521L,44522L,44523L,44524L, +44525L,44526L,44527L,44528L,44529L,44530L,44531L,44532L,44533L,44534L, +44535L,44536L,44537L,44538L,44539L,44540L,44541L,44542L,44543L,44544L, +44545L,44546L,44547L,44548L,44549L,44550L,44551L,44552L,44553L,44554L, +44555L,44556L,44557L,44558L,44559L,44560L,44561L,44562L,44563L,44564L, +44565L,44566L,44567L,44568L,44569L,44570L,44571L,44572L,44573L,44574L, +44575L,44576L,44577L,44578L,44579L,44580L,44581L,44582L,44583L,44584L, +44585L,44586L,44587L,44588L,44589L,44590L,44591L,44592L,44593L,44594L, +44595L,44596L,44597L,44598L,44599L,44600L,44601L,44602L,44603L,44604L, +44605L,44606L,44607L,44608L,44609L,44610L,44611L,44612L,44613L,44614L, +44615L,44616L,44617L,44618L,44619L,44620L,44621L,44622L,44623L,44624L, +44625L,44626L,44627L,44628L,44629L,44630L,44631L,44632L,44633L,44634L, +44635L,44636L,44637L,44638L,44639L,44640L,44641L,44642L,44643L,44644L, +44645L,44646L,44647L,44648L,44649L,44650L,44651L,44652L,44653L,44654L, +44655L,44656L,44657L,44658L,44659L,44660L,44661L,44662L,44663L,44664L, +44665L,44666L,44667L,44668L,44669L,44670L,44671L,44672L,44673L,44674L, +44675L,44676L,44677L,44678L,44679L,44680L,44681L,44682L,44683L,44684L, +44685L,44686L,44687L,44688L,44689L,44690L,44691L,44692L,44693L,44694L, +44695L,44696L,44697L,44698L,44699L,44700L,44701L,44702L,44703L,44704L, +44705L,44706L,44707L,44708L,44709L,44710L,44711L,44712L,44713L,44714L, +44715L,44716L,44717L,44718L,44719L,44720L,44721L,44722L,44723L,44724L, +44725L,44726L,44727L,44728L,44729L,44730L,44731L,44732L,44733L,44734L, +44735L,44736L,44737L,44738L,44739L,44740L,44741L,44742L,44743L,44744L, +44745L,44746L,44747L,44748L,44749L,44750L,44751L,44752L,44753L,44754L, +44755L,44756L,44757L,44758L,44759L,44760L,44761L,44762L,44763L,44764L, +44765L,44766L,44767L,44768L,44769L,44770L,44771L,44772L,44773L,44774L, +44775L,44776L,44777L,44778L,44779L,44780L,44781L,44782L,44783L,44784L, +44785L,44786L,44787L,44788L,44789L,44790L,44791L,44792L,44793L,44794L, +44795L,44796L,44797L,44798L,44799L,44800L,44801L,44802L,44803L,44804L, +44805L,44806L,44807L,44808L,44809L,44810L,44811L,44812L,44813L,44814L, +44815L,44816L,44817L,44818L,44819L,44820L,44821L,44822L,44823L,44824L, +44825L,44826L,44827L,44828L,44829L,44830L,44831L,44832L,44833L,44834L, +44835L,44836L,44837L,44838L,44839L,44840L,44841L,44842L,44843L,44844L, +44845L,44846L,44847L,44848L,44849L,44850L,44851L,44852L,44853L,44854L, +44855L,44856L,44857L,44858L,44859L,44860L,44861L,44862L,44863L,44864L, +44865L,44866L,44867L,44868L,44869L,44870L,44871L,44872L,44873L,44874L, +44875L,44876L,44877L,44878L,44879L,44880L,44881L,44882L,44883L,44884L, +44885L,44886L,44887L,44888L,44889L,44890L,44891L,44892L,44893L,44894L, +44895L,44896L,44897L,44898L,44899L,44900L,44901L,44902L,44903L,44904L, +44905L,44906L,44907L,44908L,44909L,44910L,44911L,44912L,44913L,44914L, +44915L,44916L,44917L,44918L,44919L,44920L,44921L,44922L,44923L,44924L, +44925L,44926L,44927L,44928L,44929L,44930L,44931L,44932L,44933L,44934L, +44935L,44936L,44937L,44938L,44939L,44940L,44941L,44942L,44943L,44944L, +44945L,44946L,44947L,44948L,44949L,44950L,44951L,44952L,44953L,44954L, +44955L,44956L,44957L,44958L,44959L,44960L,44961L,44962L,44963L,44964L, +44965L,44966L,44967L,44968L,44969L,44970L,44971L,44972L,44973L,44974L, +44975L,44976L,44977L,44978L,44979L,44980L,44981L,44982L,44983L,44984L, +44985L,44986L,44987L,44988L,44989L,44990L,44991L,44992L,44993L,44994L, +44995L,44996L,44997L,44998L,44999L,45000L,45001L,45002L,45003L,45004L, +45005L,45006L,45007L,45008L,45009L,45010L,45011L,45012L,45013L,45014L, +45015L,45016L,45017L,45018L,45019L,45020L,45021L,45022L,45023L,45024L, +45025L,45026L,45027L,45028L,45029L,45030L,45031L,45032L,45033L,45034L, +45035L,45036L,45037L,45038L,45039L,45040L,45041L,45042L,45043L,45044L, +45045L,45046L,45047L,45048L,45049L,45050L,45051L,45052L,45053L,45054L, +45055L,45056L,45057L,45058L,45059L,45060L,45061L,45062L,45063L,45064L, +45065L,45066L,45067L,45068L,45069L,45070L,45071L,45072L,45073L,45074L, +45075L,45076L,45077L,45078L,45079L,45080L,45081L,45082L,45083L,45084L, +45085L,45086L,45087L,45088L,45089L,45090L,45091L,45092L,45093L,45094L, +45095L,45096L,45097L,45098L,45099L,45100L,45101L,45102L,45103L,45104L, +45105L,45106L,45107L,45108L,45109L,45110L,45111L,45112L,45113L,45114L, +45115L,45116L,45117L,45118L,45119L,45120L,45121L,45122L,45123L,45124L, +45125L,45126L,45127L,45128L,45129L,45130L,45131L,45132L,45133L,45134L, +45135L,45136L,45137L,45138L,45139L,45140L,45141L,45142L,45143L,45144L, +45145L,45146L,45147L,45148L,45149L,45150L,45151L,45152L,45153L,45154L, +45155L,45156L,45157L,45158L,45159L,45160L,45161L,45162L,45163L,45164L, +45165L,45166L,45167L,45168L,45169L,45170L,45171L,45172L,45173L,45174L, +45175L,45176L,45177L,45178L,45179L,45180L,45181L,45182L,45183L,45184L, +45185L,45186L,45187L,45188L,45189L,45190L,45191L,45192L,45193L,45194L, +45195L,45196L,45197L,45198L,45199L,45200L,45201L,45202L,45203L,45204L, +45205L,45206L,45207L,45208L,45209L,45210L,45211L,45212L,45213L,45214L, +45215L,45216L,45217L,45218L,45219L,45220L,45221L,45222L,45223L,45224L, +45225L,45226L,45227L,45228L,45229L,45230L,45231L,45232L,45233L,45234L, +45235L,45236L,45237L,45238L,45239L,45240L,45241L,45242L,45243L,45244L, +45245L,45246L,45247L,45248L,45249L,45250L,45251L,45252L,45253L,45254L, +45255L,45256L,45257L,45258L,45259L,45260L,45261L,45262L,45263L,45264L, +45265L,45266L,45267L,45268L,45269L,45270L,45271L,45272L,45273L,45274L, +45275L,45276L,45277L,45278L,45279L,45280L,45281L,45282L,45283L,45284L, +45285L,45286L,45287L,45288L,45289L,45290L,45291L,45292L,45293L,45294L, +45295L,45296L,45297L,45298L,45299L,45300L,45301L,45302L,45303L,45304L, +45305L,45306L,45307L,45308L,45309L,45310L,45311L,45312L,45313L,45314L, +45315L,45316L,45317L,45318L,45319L,45320L,45321L,45322L,45323L,45324L, +45325L,45326L,45327L,45328L,45329L,45330L,45331L,45332L,45333L,45334L, +45335L,45336L,45337L,45338L,45339L,45340L,45341L,45342L,45343L,45344L, +45345L,45346L,45347L,45348L,45349L,45350L,45351L,45352L,45353L,45354L, +45355L,45356L,45357L,45358L,45359L,45360L,45361L,45362L,45363L,45364L, +45365L,45366L,45367L,45368L,45369L,45370L,45371L,45372L,45373L,45374L, +45375L,45376L,45377L,45378L,45379L,45380L,45381L,45382L,45383L,45384L, +45385L,45386L,45387L,45388L,45389L,45390L,45391L,45392L,45393L,45394L, +45395L,45396L,45397L,45398L,45399L,45400L,45401L,45402L,45403L,45404L, +45405L,45406L,45407L,45408L,45409L,45410L,45411L,45412L,45413L,45414L, +45415L,45416L,45417L,45418L,45419L,45420L,45421L,45422L,45423L,45424L, +45425L,45426L,45427L,45428L,45429L,45430L,45431L,45432L,45433L,45434L, +45435L,45436L,45437L,45438L,45439L,45440L,45441L,45442L,45443L,45444L, +45445L,45446L,45447L,45448L,45449L,45450L,45451L,45452L,45453L,45454L, +45455L,45456L,45457L,45458L,45459L,45460L,45461L,45462L,45463L,45464L, +45465L,45466L,45467L,45468L,45469L,45470L,45471L,45472L,45473L,45474L, +45475L,45476L,45477L,45478L,45479L,45480L,45481L,45482L,45483L,45484L, +45485L,45486L,45487L,45488L,45489L,45490L,45491L,45492L,45493L,45494L, +45495L,45496L,45497L,45498L,45499L,45500L,45501L,45502L,45503L,45504L, +45505L,45506L,45507L,45508L,45509L,45510L,45511L,45512L,45513L,45514L, +45515L,45516L,45517L,45518L,45519L,45520L,45521L,45522L,45523L,45524L, +45525L,45526L,45527L,45528L,45529L,45530L,45531L,45532L,45533L,45534L, +45535L,45536L,45537L,45538L,45539L,45540L,45541L,45542L,45543L,45544L, +45545L,45546L,45547L,45548L,45549L,45550L,45551L,45552L,45553L,45554L, +45555L,45556L,45557L,45558L,45559L,45560L,45561L,45562L,45563L,45564L, +45565L,45566L,45567L,45568L,45569L,45570L,45571L,45572L,45573L,45574L, +45575L,45576L,45577L,45578L,45579L,45580L,45581L,45582L,45583L,45584L, +45585L,45586L,45587L,45588L,45589L,45590L,45591L,45592L,45593L,45594L, +45595L,45596L,45597L,45598L,45599L,45600L,45601L,45602L,45603L,45604L, +45605L,45606L,45607L,45608L,45609L,45610L,45611L,45612L,45613L,45614L, +45615L,45616L,45617L,45618L,45619L,45620L,45621L,45622L,45623L,45624L, +45625L,45626L,45627L,45628L,45629L,45630L,45631L,45632L,45633L,45634L, +45635L,45636L,45637L,45638L,45639L,45640L,45641L,45642L,45643L,45644L, +45645L,45646L,45647L,45648L,45649L,45650L,45651L,45652L,45653L,45654L, +45655L,45656L,45657L,45658L,45659L,45660L,45661L,45662L,45663L,45664L, +45665L,45666L,45667L,45668L,45669L,45670L,45671L,45672L,45673L,45674L, +45675L,45676L,45677L,45678L,45679L,45680L,45681L,45682L,45683L,45684L, +45685L,45686L,45687L,45688L,45689L,45690L,45691L,45692L,45693L,45694L, +45695L,45696L,45697L,45698L,45699L,45700L,45701L,45702L,45703L,45704L, +45705L,45706L,45707L,45708L,45709L,45710L,45711L,45712L,45713L,45714L, +45715L,45716L,45717L,45718L,45719L,45720L,45721L,45722L,45723L,45724L, +45725L,45726L,45727L,45728L,45729L,45730L,45731L,45732L,45733L,45734L, +45735L,45736L,45737L,45738L,45739L,45740L,45741L,45742L,45743L,45744L, +45745L,45746L,45747L,45748L,45749L,45750L,45751L,45752L,45753L,45754L, +45755L,45756L,45757L,45758L,45759L,45760L,45761L,45762L,45763L,45764L, +45765L,45766L,45767L,45768L,45769L,45770L,45771L,45772L,45773L,45774L, +45775L,45776L,45777L,45778L,45779L,45780L,45781L,45782L,45783L,45784L, +45785L,45786L,45787L,45788L,45789L,45790L,45791L,45792L,45793L,45794L, +45795L,45796L,45797L,45798L,45799L,45800L,45801L,45802L,45803L,45804L, +45805L,45806L,45807L,45808L,45809L,45810L,45811L,45812L,45813L,45814L, +45815L,45816L,45817L,45818L,45819L,45820L,45821L,45822L,45823L,45824L, +45825L,45826L,45827L,45828L,45829L,45830L,45831L,45832L,45833L,45834L, +45835L,45836L,45837L,45838L,45839L,45840L,45841L,45842L,45843L,45844L, +45845L,45846L,45847L,45848L,45849L,45850L,45851L,45852L,45853L,45854L, +45855L,45856L,45857L,45858L,45859L,45860L,45861L,45862L,45863L,45864L, +45865L,45866L,45867L,45868L,45869L,45870L,45871L,45872L,45873L,45874L, +45875L,45876L,45877L,45878L,45879L,45880L,45881L,45882L,45883L,45884L, +45885L,45886L,45887L,45888L,45889L,45890L,45891L,45892L,45893L,45894L, +45895L,45896L,45897L,45898L,45899L,45900L,45901L,45902L,45903L,45904L, +45905L,45906L,45907L,45908L,45909L,45910L,45911L,45912L,45913L,45914L, +45915L,45916L,45917L,45918L,45919L,45920L,45921L,45922L,45923L,45924L, +45925L,45926L,45927L,45928L,45929L,45930L,45931L,45932L,45933L,45934L, +45935L,45936L,45937L,45938L,45939L,45940L,45941L,45942L,45943L,45944L, +45945L,45946L,45947L,45948L,45949L,45950L,45951L,45952L,45953L,45954L, +45955L,45956L,45957L,45958L,45959L,45960L,45961L,45962L,45963L,45964L, +45965L,45966L,45967L,45968L,45969L,45970L,45971L,45972L,45973L,45974L, +45975L,45976L,45977L,45978L,45979L,45980L,45981L,45982L,45983L,45984L, +45985L,45986L,45987L,45988L,45989L,45990L,45991L,45992L,45993L,45994L, +45995L,45996L,45997L,45998L,45999L,46000L,46001L,46002L,46003L,46004L, +46005L,46006L,46007L,46008L,46009L,46010L,46011L,46012L,46013L,46014L, +46015L,46016L,46017L,46018L,46019L,46020L,46021L,46022L,46023L,46024L, +46025L,46026L,46027L,46028L,46029L,46030L,46031L,46032L,46033L,46034L, +46035L,46036L,46037L,46038L,46039L,46040L,46041L,46042L,46043L,46044L, +46045L,46046L,46047L,46048L,46049L,46050L,46051L,46052L,46053L,46054L, +46055L,46056L,46057L,46058L,46059L,46060L,46061L,46062L,46063L,46064L, +46065L,46066L,46067L,46068L,46069L,46070L,46071L,46072L,46073L,46074L, +46075L,46076L,46077L,46078L,46079L,46080L,46081L,46082L,46083L,46084L, +46085L,46086L,46087L,46088L,46089L,46090L,46091L,46092L,46093L,46094L, +46095L,46096L,46097L,46098L,46099L,46100L,46101L,46102L,46103L,46104L, +46105L,46106L,46107L,46108L,46109L,46110L,46111L,46112L,46113L,46114L, +46115L,46116L,46117L,46118L,46119L,46120L,46121L,46122L,46123L,46124L, +46125L,46126L,46127L,46128L,46129L,46130L,46131L,46132L,46133L,46134L, +46135L,46136L,46137L,46138L,46139L,46140L,46141L,46142L,46143L,46144L, +46145L,46146L,46147L,46148L,46149L,46150L,46151L,46152L,46153L,46154L, +46155L,46156L,46157L,46158L,46159L,46160L,46161L,46162L,46163L,46164L, +46165L,46166L,46167L,46168L,46169L,46170L,46171L,46172L,46173L,46174L, +46175L,46176L,46177L,46178L,46179L,46180L,46181L,46182L,46183L,46184L, +46185L,46186L,46187L,46188L,46189L,46190L,46191L,46192L,46193L,46194L, +46195L,46196L,46197L,46198L,46199L,46200L,46201L,46202L,46203L,46204L, +46205L,46206L,46207L,46208L,46209L,46210L,46211L,46212L,46213L,46214L, +46215L,46216L,46217L,46218L,46219L,46220L,46221L,46222L,46223L,46224L, +46225L,46226L,46227L,46228L,46229L,46230L,46231L,46232L,46233L,46234L, +46235L,46236L,46237L,46238L,46239L,46240L,46241L,46242L,46243L,46244L, +46245L,46246L,46247L,46248L,46249L,46250L,46251L,46252L,46253L,46254L, +46255L,46256L,46257L,46258L,46259L,46260L,46261L,46262L,46263L,46264L, +46265L,46266L,46267L,46268L,46269L,46270L,46271L,46272L,46273L,46274L, +46275L,46276L,46277L,46278L,46279L,46280L,46281L,46282L,46283L,46284L, +46285L,46286L,46287L,46288L,46289L,46290L,46291L,46292L,46293L,46294L, +46295L,46296L,46297L,46298L,46299L,46300L,46301L,46302L,46303L,46304L, +46305L,46306L,46307L,46308L,46309L,46310L,46311L,46312L,46313L,46314L, +46315L,46316L,46317L,46318L,46319L,46320L,46321L,46322L,46323L,46324L, +46325L,46326L,46327L,46328L,46329L,46330L,46331L,46332L,46333L,46334L, +46335L,46336L,46337L,46338L,46339L,46340L,46341L,46342L,46343L,46344L, +46345L,46346L,46347L,46348L,46349L,46350L,46351L,46352L,46353L,46354L, +46355L,46356L,46357L,46358L,46359L,46360L,46361L,46362L,46363L,46364L, +46365L,46366L,46367L,46368L,46369L,46370L,46371L,46372L,46373L,46374L, +46375L,46376L,46377L,46378L,46379L,46380L,46381L,46382L,46383L,46384L, +46385L,46386L,46387L,46388L,46389L,46390L,46391L,46392L,46393L,46394L, +46395L,46396L,46397L,46398L,46399L,46400L,46401L,46402L,46403L,46404L, +46405L,46406L,46407L,46408L,46409L,46410L,46411L,46412L,46413L,46414L, +46415L,46416L,46417L,46418L,46419L,46420L,46421L,46422L,46423L,46424L, +46425L,46426L,46427L,46428L,46429L,46430L,46431L,46432L,46433L,46434L, +46435L,46436L,46437L,46438L,46439L,46440L,46441L,46442L,46443L,46444L, +46445L,46446L,46447L,46448L,46449L,46450L,46451L,46452L,46453L,46454L, +46455L,46456L,46457L,46458L,46459L,46460L,46461L,46462L,46463L,46464L, +46465L,46466L,46467L,46468L,46469L,46470L,46471L,46472L,46473L,46474L, +46475L,46476L,46477L,46478L,46479L,46480L,46481L,46482L,46483L,46484L, +46485L,46486L,46487L,46488L,46489L,46490L,46491L,46492L,46493L,46494L, +46495L,46496L,46497L,46498L,46499L,46500L,46501L,46502L,46503L,46504L, +46505L,46506L,46507L,46508L,46509L,46510L,46511L,46512L,46513L,46514L, +46515L,46516L,46517L,46518L,46519L,46520L,46521L,46522L,46523L,46524L, +46525L,46526L,46527L,46528L,46529L,46530L,46531L,46532L,46533L,46534L, +46535L,46536L,46537L,46538L,46539L,46540L,46541L,46542L,46543L,46544L, +46545L,46546L,46547L,46548L,46549L,46550L,46551L,46552L,46553L,46554L, +46555L,46556L,46557L,46558L,46559L,46560L,46561L,46562L,46563L,46564L, +46565L,46566L,46567L,46568L,46569L,46570L,46571L,46572L,46573L,46574L, +46575L,46576L,46577L,46578L,46579L,46580L,46581L,46582L,46583L,46584L, +46585L,46586L,46587L,46588L,46589L,46590L,46591L,46592L,46593L,46594L, +46595L,46596L,46597L,46598L,46599L,46600L,46601L,46602L,46603L,46604L, +46605L,46606L,46607L,46608L,46609L,46610L,46611L,46612L,46613L,46614L, +46615L,46616L,46617L,46618L,46619L,46620L,46621L,46622L,46623L,46624L, +46625L,46626L,46627L,46628L,46629L,46630L,46631L,46632L,46633L,46634L, +46635L,46636L,46637L,46638L,46639L,46640L,46641L,46642L,46643L,46644L, +46645L,46646L,46647L,46648L,46649L,46650L,46651L,46652L,46653L,46654L, +46655L,46656L,46657L,46658L,46659L,46660L,46661L,46662L,46663L,46664L, +46665L,46666L,46667L,46668L,46669L,46670L,46671L,46672L,46673L,46674L, +46675L,46676L,46677L,46678L,46679L,46680L,46681L,46682L,46683L,46684L, +46685L,46686L,46687L,46688L,46689L,46690L,46691L,46692L,46693L,46694L, +46695L,46696L,46697L,46698L,46699L,46700L,46701L,46702L,46703L,46704L, +46705L,46706L,46707L,46708L,46709L,46710L,46711L,46712L,46713L,46714L, +46715L,46716L,46717L,46718L,46719L,46720L,46721L,46722L,46723L,46724L, +46725L,46726L,46727L,46728L,46729L,46730L,46731L,46732L,46733L,46734L, +46735L,46736L,46737L,46738L,46739L,46740L,46741L,46742L,46743L,46744L, +46745L,46746L,46747L,46748L,46749L,46750L,46751L,46752L,46753L,46754L, +46755L,46756L,46757L,46758L,46759L,46760L,46761L,46762L,46763L,46764L, +46765L,46766L,46767L,46768L,46769L,46770L,46771L,46772L,46773L,46774L, +46775L,46776L,46777L,46778L,46779L,46780L,46781L,46782L,46783L,46784L, +46785L,46786L,46787L,46788L,46789L,46790L,46791L,46792L,46793L,46794L, +46795L,46796L,46797L,46798L,46799L,46800L,46801L,46802L,46803L,46804L, +46805L,46806L,46807L,46808L,46809L,46810L,46811L,46812L,46813L,46814L, +46815L,46816L,46817L,46818L,46819L,46820L,46821L,46822L,46823L,46824L, +46825L,46826L,46827L,46828L,46829L,46830L,46831L,46832L,46833L,46834L, +46835L,46836L,46837L,46838L,46839L,46840L,46841L,46842L,46843L,46844L, +46845L,46846L,46847L,46848L,46849L,46850L,46851L,46852L,46853L,46854L, +46855L,46856L,46857L,46858L,46859L,46860L,46861L,46862L,46863L,46864L, +46865L,46866L,46867L,46868L,46869L,46870L,46871L,46872L,46873L,46874L, +46875L,46876L,46877L,46878L,46879L,46880L,46881L,46882L,46883L,46884L, +46885L,46886L,46887L,46888L,46889L,46890L,46891L,46892L,46893L,46894L, +46895L,46896L,46897L,46898L,46899L,46900L,46901L,46902L,46903L,46904L, +46905L,46906L,46907L,46908L,46909L,46910L,46911L,46912L,46913L,46914L, +46915L,46916L,46917L,46918L,46919L,46920L,46921L,46922L,46923L,46924L, +46925L,46926L,46927L,46928L,46929L,46930L,46931L,46932L,46933L,46934L, +46935L,46936L,46937L,46938L,46939L,46940L,46941L,46942L,46943L,46944L, +46945L,46946L,46947L,46948L,46949L,46950L,46951L,46952L,46953L,46954L, +46955L,46956L,46957L,46958L,46959L,46960L,46961L,46962L,46963L,46964L, +46965L,46966L,46967L,46968L,46969L,46970L,46971L,46972L,46973L,46974L, +46975L,46976L,46977L,46978L,46979L,46980L,46981L,46982L,46983L,46984L, +46985L,46986L,46987L,46988L,46989L,46990L,46991L,46992L,46993L,46994L, +46995L,46996L,46997L,46998L,46999L,47000L,47001L,47002L,47003L,47004L, +47005L,47006L,47007L,47008L,47009L,47010L,47011L,47012L,47013L,47014L, +47015L,47016L,47017L,47018L,47019L,47020L,47021L,47022L,47023L,47024L, +47025L,47026L,47027L,47028L,47029L,47030L,47031L,47032L,47033L,47034L, +47035L,47036L,47037L,47038L,47039L,47040L,47041L,47042L,47043L,47044L, +47045L,47046L,47047L,47048L,47049L,47050L,47051L,47052L,47053L,47054L, +47055L,47056L,47057L,47058L,47059L,47060L,47061L,47062L,47063L,47064L, +47065L,47066L,47067L,47068L,47069L,47070L,47071L,47072L,47073L,47074L, +47075L,47076L,47077L,47078L,47079L,47080L,47081L,47082L,47083L,47084L, +47085L,47086L,47087L,47088L,47089L,47090L,47091L,47092L,47093L,47094L, +47095L,47096L,47097L,47098L,47099L,47100L,47101L,47102L,47103L,47104L, +47105L,47106L,47107L,47108L,47109L,47110L,47111L,47112L,47113L,47114L, +47115L,47116L,47117L,47118L,47119L,47120L,47121L,47122L,47123L,47124L, +47125L,47126L,47127L,47128L,47129L,47130L,47131L,47132L,47133L,47134L, +47135L,47136L,47137L,47138L,47139L,47140L,47141L,47142L,47143L,47144L, +47145L,47146L,47147L,47148L,47149L,47150L,47151L,47152L,47153L,47154L, +47155L,47156L,47157L,47158L,47159L,47160L,47161L,47162L,47163L,47164L, +47165L,47166L,47167L,47168L,47169L,47170L,47171L,47172L,47173L,47174L, +47175L,47176L,47177L,47178L,47179L,47180L,47181L,47182L,47183L,47184L, +47185L,47186L,47187L,47188L,47189L,47190L,47191L,47192L,47193L,47194L, +47195L,47196L,47197L,47198L,47199L,47200L,47201L,47202L,47203L,47204L, +47205L,47206L,47207L,47208L,47209L,47210L,47211L,47212L,47213L,47214L, +47215L,47216L,47217L,47218L,47219L,47220L,47221L,47222L,47223L,47224L, +47225L,47226L,47227L,47228L,47229L,47230L,47231L,47232L,47233L,47234L, +47235L,47236L,47237L,47238L,47239L,47240L,47241L,47242L,47243L,47244L, +47245L,47246L,47247L,47248L,47249L,47250L,47251L,47252L,47253L,47254L, +47255L,47256L,47257L,47258L,47259L,47260L,47261L,47262L,47263L,47264L, +47265L,47266L,47267L,47268L,47269L,47270L,47271L,47272L,47273L,47274L, +47275L,47276L,47277L,47278L,47279L,47280L,47281L,47282L,47283L,47284L, +47285L,47286L,47287L,47288L,47289L,47290L,47291L,47292L,47293L,47294L, +47295L,47296L,47297L,47298L,47299L,47300L,47301L,47302L,47303L,47304L, +47305L,47306L,47307L,47308L,47309L,47310L,47311L,47312L,47313L,47314L, +47315L,47316L,47317L,47318L,47319L,47320L,47321L,47322L,47323L,47324L, +47325L,47326L,47327L,47328L,47329L,47330L,47331L,47332L,47333L,47334L, +47335L,47336L,47337L,47338L,47339L,47340L,47341L,47342L,47343L,47344L, +47345L,47346L,47347L,47348L,47349L,47350L,47351L,47352L,47353L,47354L, +47355L,47356L,47357L,47358L,47359L,47360L,47361L,47362L,47363L,47364L, +47365L,47366L,47367L,47368L,47369L,47370L,47371L,47372L,47373L,47374L, +47375L,47376L,47377L,47378L,47379L,47380L,47381L,47382L,47383L,47384L, +47385L,47386L,47387L,47388L,47389L,47390L,47391L,47392L,47393L,47394L, +47395L,47396L,47397L,47398L,47399L,47400L,47401L,47402L,47403L,47404L, +47405L,47406L,47407L,47408L,47409L,47410L,47411L,47412L,47413L,47414L, +47415L,47416L,47417L,47418L,47419L,47420L,47421L,47422L,47423L,47424L, +47425L,47426L,47427L,47428L,47429L,47430L,47431L,47432L,47433L,47434L, +47435L,47436L,47437L,47438L,47439L,47440L,47441L,47442L,47443L,47444L, +47445L,47446L,47447L,47448L,47449L,47450L,47451L,47452L,47453L,47454L, +47455L,47456L,47457L,47458L,47459L,47460L,47461L,47462L,47463L,47464L, +47465L,47466L,47467L,47468L,47469L,47470L,47471L,47472L,47473L,47474L, +47475L,47476L,47477L,47478L,47479L,47480L,47481L,47482L,47483L,47484L, +47485L,47486L,47487L,47488L,47489L,47490L,47491L,47492L,47493L,47494L, +47495L,47496L,47497L,47498L,47499L,47500L,47501L,47502L,47503L,47504L, +47505L,47506L,47507L,47508L,47509L,47510L,47511L,47512L,47513L,47514L, +47515L,47516L,47517L,47518L,47519L,47520L,47521L,47522L,47523L,47524L, +47525L,47526L,47527L,47528L,47529L,47530L,47531L,47532L,47533L,47534L, +47535L,47536L,47537L,47538L,47539L,47540L,47541L,47542L,47543L,47544L, +47545L,47546L,47547L,47548L,47549L,47550L,47551L,47552L,47553L,47554L, +47555L,47556L,47557L,47558L,47559L,47560L,47561L,47562L,47563L,47564L, +47565L,47566L,47567L,47568L,47569L,47570L,47571L,47572L,47573L,47574L, +47575L,47576L,47577L,47578L,47579L,47580L,47581L,47582L,47583L,47584L, +47585L,47586L,47587L,47588L,47589L,47590L,47591L,47592L,47593L,47594L, +47595L,47596L,47597L,47598L,47599L,47600L,47601L,47602L,47603L,47604L, +47605L,47606L,47607L,47608L,47609L,47610L,47611L,47612L,47613L,47614L, +47615L,47616L,47617L,47618L,47619L,47620L,47621L,47622L,47623L,47624L, +47625L,47626L,47627L,47628L,47629L,47630L,47631L,47632L,47633L,47634L, +47635L,47636L,47637L,47638L,47639L,47640L,47641L,47642L,47643L,47644L, +47645L,47646L,47647L,47648L,47649L,47650L,47651L,47652L,47653L,47654L, +47655L,47656L,47657L,47658L,47659L,47660L,47661L,47662L,47663L,47664L, +47665L,47666L,47667L,47668L,47669L,47670L,47671L,47672L,47673L,47674L, +47675L,47676L,47677L,47678L,47679L,47680L,47681L,47682L,47683L,47684L, +47685L,47686L,47687L,47688L,47689L,47690L,47691L,47692L,47693L,47694L, +47695L,47696L,47697L,47698L,47699L,47700L,47701L,47702L,47703L,47704L, +47705L,47706L,47707L,47708L,47709L,47710L,47711L,47712L,47713L,47714L, +47715L,47716L,47717L,47718L,47719L,47720L,47721L,47722L,47723L,47724L, +47725L,47726L,47727L,47728L,47729L,47730L,47731L,47732L,47733L,47734L, +47735L,47736L,47737L,47738L,47739L,47740L,47741L,47742L,47743L,47744L, +47745L,47746L,47747L,47748L,47749L,47750L,47751L,47752L,47753L,47754L, +47755L,47756L,47757L,47758L,47759L,47760L,47761L,47762L,47763L,47764L, +47765L,47766L,47767L,47768L,47769L,47770L,47771L,47772L,47773L,47774L, +47775L,47776L,47777L,47778L,47779L,47780L,47781L,47782L,47783L,47784L, +47785L,47786L,47787L,47788L,47789L,47790L,47791L,47792L,47793L,47794L, +47795L,47796L,47797L,47798L,47799L,47800L,47801L,47802L,47803L,47804L, +47805L,47806L,47807L,47808L,47809L,47810L,47811L,47812L,47813L,47814L, +47815L,47816L,47817L,47818L,47819L,47820L,47821L,47822L,47823L,47824L, +47825L,47826L,47827L,47828L,47829L,47830L,47831L,47832L,47833L,47834L, +47835L,47836L,47837L,47838L,47839L,47840L,47841L,47842L,47843L,47844L, +47845L,47846L,47847L,47848L,47849L,47850L,47851L,47852L,47853L,47854L, +47855L,47856L,47857L,47858L,47859L,47860L,47861L,47862L,47863L,47864L, +47865L,47866L,47867L,47868L,47869L,47870L,47871L,47872L,47873L,47874L, +47875L,47876L,47877L,47878L,47879L,47880L,47881L,47882L,47883L,47884L, +47885L,47886L,47887L,47888L,47889L,47890L,47891L,47892L,47893L,47894L, +47895L,47896L,47897L,47898L,47899L,47900L,47901L,47902L,47903L,47904L, +47905L,47906L,47907L,47908L,47909L,47910L,47911L,47912L,47913L,47914L, +47915L,47916L,47917L,47918L,47919L,47920L,47921L,47922L,47923L,47924L, +47925L,47926L,47927L,47928L,47929L,47930L,47931L,47932L,47933L,47934L, +47935L,47936L,47937L,47938L,47939L,47940L,47941L,47942L,47943L,47944L, +47945L,47946L,47947L,47948L,47949L,47950L,47951L,47952L,47953L,47954L, +47955L,47956L,47957L,47958L,47959L,47960L,47961L,47962L,47963L,47964L, +47965L,47966L,47967L,47968L,47969L,47970L,47971L,47972L,47973L,47974L, +47975L,47976L,47977L,47978L,47979L,47980L,47981L,47982L,47983L,47984L, +47985L,47986L,47987L,47988L,47989L,47990L,47991L,47992L,47993L,47994L, +47995L,47996L,47997L,47998L,47999L,48000L,48001L,48002L,48003L,48004L, +48005L,48006L,48007L,48008L,48009L,48010L,48011L,48012L,48013L,48014L, +48015L,48016L,48017L,48018L,48019L,48020L,48021L,48022L,48023L,48024L, +48025L,48026L,48027L,48028L,48029L,48030L,48031L,48032L,48033L,48034L, +48035L,48036L,48037L,48038L,48039L,48040L,48041L,48042L,48043L,48044L, +48045L,48046L,48047L,48048L,48049L,48050L,48051L,48052L,48053L,48054L, +48055L,48056L,48057L,48058L,48059L,48060L,48061L,48062L,48063L,48064L, +48065L,48066L,48067L,48068L,48069L,48070L,48071L,48072L,48073L,48074L, +48075L,48076L,48077L,48078L,48079L,48080L,48081L,48082L,48083L,48084L, +48085L,48086L,48087L,48088L,48089L,48090L,48091L,48092L,48093L,48094L, +48095L,48096L,48097L,48098L,48099L,48100L,48101L,48102L,48103L,48104L, +48105L,48106L,48107L,48108L,48109L,48110L,48111L,48112L,48113L,48114L, +48115L,48116L,48117L,48118L,48119L,48120L,48121L,48122L,48123L,48124L, +48125L,48126L,48127L,48128L,48129L,48130L,48131L,48132L,48133L,48134L, +48135L,48136L,48137L,48138L,48139L,48140L,48141L,48142L,48143L,48144L, +48145L,48146L,48147L,48148L,48149L,48150L,48151L,48152L,48153L,48154L, +48155L,48156L,48157L,48158L,48159L,48160L,48161L,48162L,48163L,48164L, +48165L,48166L,48167L,48168L,48169L,48170L,48171L,48172L,48173L,48174L, +48175L,48176L,48177L,48178L,48179L,48180L,48181L,48182L,48183L,48184L, +48185L,48186L,48187L,48188L,48189L,48190L,48191L,48192L,48193L,48194L, +48195L,48196L,48197L,48198L,48199L,48200L,48201L,48202L,48203L,48204L, +48205L,48206L,48207L,48208L,48209L,48210L,48211L,48212L,48213L,48214L, +48215L,48216L,48217L,48218L,48219L,48220L,48221L,48222L,48223L,48224L, +48225L,48226L,48227L,48228L,48229L,48230L,48231L,48232L,48233L,48234L, +48235L,48236L,48237L,48238L,48239L,48240L,48241L,48242L,48243L,48244L, +48245L,48246L,48247L,48248L,48249L,48250L,48251L,48252L,48253L,48254L, +48255L,48256L,48257L,48258L,48259L,48260L,48261L,48262L,48263L,48264L, +48265L,48266L,48267L,48268L,48269L,48270L,48271L,48272L,48273L,48274L, +48275L,48276L,48277L,48278L,48279L,48280L,48281L,48282L,48283L,48284L, +48285L,48286L,48287L,48288L,48289L,48290L,48291L,48292L,48293L,48294L, +48295L,48296L,48297L,48298L,48299L,48300L,48301L,48302L,48303L,48304L, +48305L,48306L,48307L,48308L,48309L,48310L,48311L,48312L,48313L,48314L, +48315L,48316L,48317L,48318L,48319L,48320L,48321L,48322L,48323L,48324L, +48325L,48326L,48327L,48328L,48329L,48330L,48331L,48332L,48333L,48334L, +48335L,48336L,48337L,48338L,48339L,48340L,48341L,48342L,48343L,48344L, +48345L,48346L,48347L,48348L,48349L,48350L,48351L,48352L,48353L,48354L, +48355L,48356L,48357L,48358L,48359L,48360L,48361L,48362L,48363L,48364L, +48365L,48366L,48367L,48368L,48369L,48370L,48371L,48372L,48373L,48374L, +48375L,48376L,48377L,48378L,48379L,48380L,48381L,48382L,48383L,48384L, +48385L,48386L,48387L,48388L,48389L,48390L,48391L,48392L,48393L,48394L, +48395L,48396L,48397L,48398L,48399L,48400L,48401L,48402L,48403L,48404L, +48405L,48406L,48407L,48408L,48409L,48410L,48411L,48412L,48413L,48414L, +48415L,48416L,48417L,48418L,48419L,48420L,48421L,48422L,48423L,48424L, +48425L,48426L,48427L,48428L,48429L,48430L,48431L,48432L,48433L,48434L, +48435L,48436L,48437L,48438L,48439L,48440L,48441L,48442L,48443L,48444L, +48445L,48446L,48447L,48448L,48449L,48450L,48451L,48452L,48453L,48454L, +48455L,48456L,48457L,48458L,48459L,48460L,48461L,48462L,48463L,48464L, +48465L,48466L,48467L,48468L,48469L,48470L,48471L,48472L,48473L,48474L, +48475L,48476L,48477L,48478L,48479L,48480L,48481L,48482L,48483L,48484L, +48485L,48486L,48487L,48488L,48489L,48490L,48491L,48492L,48493L,48494L, +48495L,48496L,48497L,48498L,48499L,48500L,48501L,48502L,48503L,48504L, +48505L,48506L,48507L,48508L,48509L,48510L,48511L,48512L,48513L,48514L, +48515L,48516L,48517L,48518L,48519L,48520L,48521L,48522L,48523L,48524L, +48525L,48526L,48527L,48528L,48529L,48530L,48531L,48532L,48533L,48534L, +48535L,48536L,48537L,48538L,48539L,48540L,48541L,48542L,48543L,48544L, +48545L,48546L,48547L,48548L,48549L,48550L,48551L,48552L,48553L,48554L, +48555L,48556L,48557L,48558L,48559L,48560L,48561L,48562L,48563L,48564L, +48565L,48566L,48567L,48568L,48569L,48570L,48571L,48572L,48573L,48574L, +48575L,48576L,48577L,48578L,48579L,48580L,48581L,48582L,48583L,48584L, +48585L,48586L,48587L,48588L,48589L,48590L,48591L,48592L,48593L,48594L, +48595L,48596L,48597L,48598L,48599L,48600L,48601L,48602L,48603L,48604L, +48605L,48606L,48607L,48608L,48609L,48610L,48611L,48612L,48613L,48614L, +48615L,48616L,48617L,48618L,48619L,48620L,48621L,48622L,48623L,48624L, +48625L,48626L,48627L,48628L,48629L,48630L,48631L,48632L,48633L,48634L, +48635L,48636L,48637L,48638L,48639L,48640L,48641L,48642L,48643L,48644L, +48645L,48646L,48647L,48648L,48649L,48650L,48651L,48652L,48653L,48654L, +48655L,48656L,48657L,48658L,48659L,48660L,48661L,48662L,48663L,48664L, +48665L,48666L,48667L,48668L,48669L,48670L,48671L,48672L,48673L,48674L, +48675L,48676L,48677L,48678L,48679L,48680L,48681L,48682L,48683L,48684L, +48685L,48686L,48687L,48688L,48689L,48690L,48691L,48692L,48693L,48694L, +48695L,48696L,48697L,48698L,48699L,48700L,48701L,48702L,48703L,48704L, +48705L,48706L,48707L,48708L,48709L,48710L,48711L,48712L,48713L,48714L, +48715L,48716L,48717L,48718L,48719L,48720L,48721L,48722L,48723L,48724L, +48725L,48726L,48727L,48728L,48729L,48730L,48731L,48732L,48733L,48734L, +48735L,48736L,48737L,48738L,48739L,48740L,48741L,48742L,48743L,48744L, +48745L,48746L,48747L,48748L,48749L,48750L,48751L,48752L,48753L,48754L, +48755L,48756L,48757L,48758L,48759L,48760L,48761L,48762L,48763L,48764L, +48765L,48766L,48767L,48768L,48769L,48770L,48771L,48772L,48773L,48774L, +48775L,48776L,48777L,48778L,48779L,48780L,48781L,48782L,48783L,48784L, +48785L,48786L,48787L,48788L,48789L,48790L,48791L,48792L,48793L,48794L, +48795L,48796L,48797L,48798L,48799L,48800L,48801L,48802L,48803L,48804L, +48805L,48806L,48807L,48808L,48809L,48810L,48811L,48812L,48813L,48814L, +48815L,48816L,48817L,48818L,48819L,48820L,48821L,48822L,48823L,48824L, +48825L,48826L,48827L,48828L,48829L,48830L,48831L,48832L,48833L,48834L, +48835L,48836L,48837L,48838L,48839L,48840L,48841L,48842L,48843L,48844L, +48845L,48846L,48847L,48848L,48849L,48850L,48851L,48852L,48853L,48854L, +48855L,48856L,48857L,48858L,48859L,48860L,48861L,48862L,48863L,48864L, +48865L,48866L,48867L,48868L,48869L,48870L,48871L,48872L,48873L,48874L, +48875L,48876L,48877L,48878L,48879L,48880L,48881L,48882L,48883L,48884L, +48885L,48886L,48887L,48888L,48889L,48890L,48891L,48892L,48893L,48894L, +48895L,48896L,48897L,48898L,48899L,48900L,48901L,48902L,48903L,48904L, +48905L,48906L,48907L,48908L,48909L,48910L,48911L,48912L,48913L,48914L, +48915L,48916L,48917L,48918L,48919L,48920L,48921L,48922L,48923L,48924L, +48925L,48926L,48927L,48928L,48929L,48930L,48931L,48932L,48933L,48934L, +48935L,48936L,48937L,48938L,48939L,48940L,48941L,48942L,48943L,48944L, +48945L,48946L,48947L,48948L,48949L,48950L,48951L,48952L,48953L,48954L, +48955L,48956L,48957L,48958L,48959L,48960L,48961L,48962L,48963L,48964L, +48965L,48966L,48967L,48968L,48969L,48970L,48971L,48972L,48973L,48974L, +48975L,48976L,48977L,48978L,48979L,48980L,48981L,48982L,48983L,48984L, +48985L,48986L,48987L,48988L,48989L,48990L,48991L,48992L,48993L,48994L, +48995L,48996L,48997L,48998L,48999L,49000L,49001L,49002L,49003L,49004L, +49005L,49006L,49007L,49008L,49009L,49010L,49011L,49012L,49013L,49014L, +49015L,49016L,49017L,49018L,49019L,49020L,49021L,49022L,49023L,49024L, +49025L,49026L,49027L,49028L,49029L,49030L,49031L,49032L,49033L,49034L, +49035L,49036L,49037L,49038L,49039L,49040L,49041L,49042L,49043L,49044L, +49045L,49046L,49047L,49048L,49049L,49050L,49051L,49052L,49053L,49054L, +49055L,49056L,49057L,49058L,49059L,49060L,49061L,49062L,49063L,49064L, +49065L,49066L,49067L,49068L,49069L,49070L,49071L,49072L,49073L,49074L, +49075L,49076L,49077L,49078L,49079L,49080L,49081L,49082L,49083L,49084L, +49085L,49086L,49087L,49088L,49089L,49090L,49091L,49092L,49093L,49094L, +49095L,49096L,49097L,49098L,49099L,49100L,49101L,49102L,49103L,49104L, +49105L,49106L,49107L,49108L,49109L,49110L,49111L,49112L,49113L,49114L, +49115L,49116L,49117L,49118L,49119L,49120L,49121L,49122L,49123L,49124L, +49125L,49126L,49127L,49128L,49129L,49130L,49131L,49132L,49133L,49134L, +49135L,49136L,49137L,49138L,49139L,49140L,49141L,49142L,49143L,49144L, +49145L,49146L,49147L,49148L,49149L,49150L,49151L,49152L,49153L,49154L, +49155L,49156L,49157L,49158L,49159L,49160L,49161L,49162L,49163L,49164L, +49165L,49166L,49167L,49168L,49169L,49170L,49171L,49172L,49173L,49174L, +49175L,49176L,49177L,49178L,49179L,49180L,49181L,49182L,49183L,49184L, +49185L,49186L,49187L,49188L,49189L,49190L,49191L,49192L,49193L,49194L, +49195L,49196L,49197L,49198L,49199L,49200L,49201L,49202L,49203L,49204L, +49205L,49206L,49207L,49208L,49209L,49210L,49211L,49212L,49213L,49214L, +49215L,49216L,49217L,49218L,49219L,49220L,49221L,49222L,49223L,49224L, +49225L,49226L,49227L,49228L,49229L,49230L,49231L,49232L,49233L,49234L, +49235L,49236L,49237L,49238L,49239L,49240L,49241L,49242L,49243L,49244L, +49245L,49246L,49247L,49248L,49249L,49250L,49251L,49252L,49253L,49254L, +49255L,49256L,49257L,49258L,49259L,49260L,49261L,49262L,49263L,49264L, +49265L,49266L,49267L,49268L,49269L,49270L,49271L,49272L,49273L,49274L, +49275L,49276L,49277L,49278L,49279L,49280L,49281L,49282L,49283L,49284L, +49285L,49286L,49287L,49288L,49289L,49290L,49291L,49292L,49293L,49294L, +49295L,49296L,49297L,49298L,49299L,49300L,49301L,49302L,49303L,49304L, +49305L,49306L,49307L,49308L,49309L,49310L,49311L,49312L,49313L,49314L, +49315L,49316L,49317L,49318L,49319L,49320L,49321L,49322L,49323L,49324L, +49325L,49326L,49327L,49328L,49329L,49330L,49331L,49332L,49333L,49334L, +49335L,49336L,49337L,49338L,49339L,49340L,49341L,49342L,49343L,49344L, +49345L,49346L,49347L,49348L,49349L,49350L,49351L,49352L,49353L,49354L, +49355L,49356L,49357L,49358L,49359L,49360L,49361L,49362L,49363L,49364L, +49365L,49366L,49367L,49368L,49369L,49370L,49371L,49372L,49373L,49374L, +49375L,49376L,49377L,49378L,49379L,49380L,49381L,49382L,49383L,49384L, +49385L,49386L,49387L,49388L,49389L,49390L,49391L,49392L,49393L,49394L, +49395L,49396L,49397L,49398L,49399L,49400L,49401L,49402L,49403L,49404L, +49405L,49406L,49407L,49408L,49409L,49410L,49411L,49412L,49413L,49414L, +49415L,49416L,49417L,49418L,49419L,49420L,49421L,49422L,49423L,49424L, +49425L,49426L,49427L,49428L,49429L,49430L,49431L,49432L,49433L,49434L, +49435L,49436L,49437L,49438L,49439L,49440L,49441L,49442L,49443L,49444L, +49445L,49446L,49447L,49448L,49449L,49450L,49451L,49452L,49453L,49454L, +49455L,49456L,49457L,49458L,49459L,49460L,49461L,49462L,49463L,49464L, +49465L,49466L,49467L,49468L,49469L,49470L,49471L,49472L,49473L,49474L, +49475L,49476L,49477L,49478L,49479L,49480L,49481L,49482L,49483L,49484L, +49485L,49486L,49487L,49488L,49489L,49490L,49491L,49492L,49493L,49494L, +49495L,49496L,49497L,49498L,49499L,49500L,49501L,49502L,49503L,49504L, +49505L,49506L,49507L,49508L,49509L,49510L,49511L,49512L,49513L,49514L, +49515L,49516L,49517L,49518L,49519L,49520L,49521L,49522L,49523L,49524L, +49525L,49526L,49527L,49528L,49529L,49530L,49531L,49532L,49533L,49534L, +49535L,49536L,49537L,49538L,49539L,49540L,49541L,49542L,49543L,49544L, +49545L,49546L,49547L,49548L,49549L,49550L,49551L,49552L,49553L,49554L, +49555L,49556L,49557L,49558L,49559L,49560L,49561L,49562L,49563L,49564L, +49565L,49566L,49567L,49568L,49569L,49570L,49571L,49572L,49573L,49574L, +49575L,49576L,49577L,49578L,49579L,49580L,49581L,49582L,49583L,49584L, +49585L,49586L,49587L,49588L,49589L,49590L,49591L,49592L,49593L,49594L, +49595L,49596L,49597L,49598L,49599L,49600L,49601L,49602L,49603L,49604L, +49605L,49606L,49607L,49608L,49609L,49610L,49611L,49612L,49613L,49614L, +49615L,49616L,49617L,49618L,49619L,49620L,49621L,49622L,49623L,49624L, +49625L,49626L,49627L,49628L,49629L,49630L,49631L,49632L,49633L,49634L, +49635L,49636L,49637L,49638L,49639L,49640L,49641L,49642L,49643L,49644L, +49645L,49646L,49647L,49648L,49649L,49650L,49651L,49652L,49653L,49654L, +49655L,49656L,49657L,49658L,49659L,49660L,49661L,49662L,49663L,49664L, +49665L,49666L,49667L,49668L,49669L,49670L,49671L,49672L,49673L,49674L, +49675L,49676L,49677L,49678L,49679L,49680L,49681L,49682L,49683L,49684L, +49685L,49686L,49687L,49688L,49689L,49690L,49691L,49692L,49693L,49694L, +49695L,49696L,49697L,49698L,49699L,49700L,49701L,49702L,49703L,49704L, +49705L,49706L,49707L,49708L,49709L,49710L,49711L,49712L,49713L,49714L, +49715L,49716L,49717L,49718L,49719L,49720L,49721L,49722L,49723L,49724L, +49725L,49726L,49727L,49728L,49729L,49730L,49731L,49732L,49733L,49734L, +49735L,49736L,49737L,49738L,49739L,49740L,49741L,49742L,49743L,49744L, +49745L,49746L,49747L,49748L,49749L,49750L,49751L,49752L,49753L,49754L, +49755L,49756L,49757L,49758L,49759L,49760L,49761L,49762L,49763L,49764L, +49765L,49766L,49767L,49768L,49769L,49770L,49771L,49772L,49773L,49774L, +49775L,49776L,49777L,49778L,49779L,49780L,49781L,49782L,49783L,49784L, +49785L,49786L,49787L,49788L,49789L,49790L,49791L,49792L,49793L,49794L, +49795L,49796L,49797L,49798L,49799L,49800L,49801L,49802L,49803L,49804L, +49805L,49806L,49807L,49808L,49809L,49810L,49811L,49812L,49813L,49814L, +49815L,49816L,49817L,49818L,49819L,49820L,49821L,49822L,49823L,49824L, +49825L,49826L,49827L,49828L,49829L,49830L,49831L,49832L,49833L,49834L, +49835L,49836L,49837L,49838L,49839L,49840L,49841L,49842L,49843L,49844L, +49845L,49846L,49847L,49848L,49849L,49850L,49851L,49852L,49853L,49854L, +49855L,49856L,49857L,49858L,49859L,49860L,49861L,49862L,49863L,49864L, +49865L,49866L,49867L,49868L,49869L,49870L,49871L,49872L,49873L,49874L, +49875L,49876L,49877L,49878L,49879L,49880L,49881L,49882L,49883L,49884L, +49885L,49886L,49887L,49888L,49889L,49890L,49891L,49892L,49893L,49894L, +49895L,49896L,49897L,49898L,49899L,49900L,49901L,49902L,49903L,49904L, +49905L,49906L,49907L,49908L,49909L,49910L,49911L,49912L,49913L,49914L, +49915L,49916L,49917L,49918L,49919L,49920L,49921L,49922L,49923L,49924L, +49925L,49926L,49927L,49928L,49929L,49930L,49931L,49932L,49933L,49934L, +49935L,49936L,49937L,49938L,49939L,49940L,49941L,49942L,49943L,49944L, +49945L,49946L,49947L,49948L,49949L,49950L,49951L,49952L,49953L,49954L, +49955L,49956L,49957L,49958L,49959L,49960L,49961L,49962L,49963L,49964L, +49965L,49966L,49967L,49968L,49969L,49970L,49971L,49972L,49973L,49974L, +49975L,49976L,49977L,49978L,49979L,49980L,49981L,49982L,49983L,49984L, +49985L,49986L,49987L,49988L,49989L,49990L,49991L,49992L,49993L,49994L, +49995L,49996L,49997L,49998L,49999L,50000L,50001L,50002L,50003L,50004L, +50005L,50006L,50007L,50008L,50009L,50010L,50011L,50012L,50013L,50014L, +50015L,50016L,50017L,50018L,50019L,50020L,50021L,50022L,50023L,50024L, +50025L,50026L,50027L,50028L,50029L,50030L,50031L,50032L,50033L,50034L, +50035L,50036L,50037L,50038L,50039L,50040L,50041L,50042L,50043L,50044L, +50045L,50046L,50047L,50048L,50049L,50050L,50051L,50052L,50053L,50054L, +50055L,50056L,50057L,50058L,50059L,50060L,50061L,50062L,50063L,50064L, +50065L,50066L,50067L,50068L,50069L,50070L,50071L,50072L,50073L,50074L, +50075L,50076L,50077L,50078L,50079L,50080L,50081L,50082L,50083L,50084L, +50085L,50086L,50087L,50088L,50089L,50090L,50091L,50092L,50093L,50094L, +50095L,50096L,50097L,50098L,50099L,50100L,50101L,50102L,50103L,50104L, +50105L,50106L,50107L,50108L,50109L,50110L,50111L,50112L,50113L,50114L, +50115L,50116L,50117L,50118L,50119L,50120L,50121L,50122L,50123L,50124L, +50125L,50126L,50127L,50128L,50129L,50130L,50131L,50132L,50133L,50134L, +50135L,50136L,50137L,50138L,50139L,50140L,50141L,50142L,50143L,50144L, +50145L,50146L,50147L,50148L,50149L,50150L,50151L,50152L,50153L,50154L, +50155L,50156L,50157L,50158L,50159L,50160L,50161L,50162L,50163L,50164L, +50165L,50166L,50167L,50168L,50169L,50170L,50171L,50172L,50173L,50174L, +50175L,50176L,50177L,50178L,50179L,50180L,50181L,50182L,50183L,50184L, +50185L,50186L,50187L,50188L,50189L,50190L,50191L,50192L,50193L,50194L, +50195L,50196L,50197L,50198L,50199L,50200L,50201L,50202L,50203L,50204L, +50205L,50206L,50207L,50208L,50209L,50210L,50211L,50212L,50213L,50214L, +50215L,50216L,50217L,50218L,50219L,50220L,50221L,50222L,50223L,50224L, +50225L,50226L,50227L,50228L,50229L,50230L,50231L,50232L,50233L,50234L, +50235L,50236L,50237L,50238L,50239L,50240L,50241L,50242L,50243L,50244L, +50245L,50246L,50247L,50248L,50249L,50250L,50251L,50252L,50253L,50254L, +50255L,50256L,50257L,50258L,50259L,50260L,50261L,50262L,50263L,50264L, +50265L,50266L,50267L,50268L,50269L,50270L,50271L,50272L,50273L,50274L, +50275L,50276L,50277L,50278L,50279L,50280L,50281L,50282L,50283L,50284L, +50285L,50286L,50287L,50288L,50289L,50290L,50291L,50292L,50293L,50294L, +50295L,50296L,50297L,50298L,50299L,50300L,50301L,50302L,50303L,50304L, +50305L,50306L,50307L,50308L,50309L,50310L,50311L,50312L,50313L,50314L, +50315L,50316L,50317L,50318L,50319L,50320L,50321L,50322L,50323L,50324L, +50325L,50326L,50327L,50328L,50329L,50330L,50331L,50332L,50333L,50334L, +50335L,50336L,50337L,50338L,50339L,50340L,50341L,50342L,50343L,50344L, +50345L,50346L,50347L,50348L,50349L,50350L,50351L,50352L,50353L,50354L, +50355L,50356L,50357L,50358L,50359L,50360L,50361L,50362L,50363L,50364L, +50365L,50366L,50367L,50368L,50369L,50370L,50371L,50372L,50373L,50374L, +50375L,50376L,50377L,50378L,50379L,50380L,50381L,50382L,50383L,50384L, +50385L,50386L,50387L,50388L,50389L,50390L,50391L,50392L,50393L,50394L, +50395L,50396L,50397L,50398L,50399L,50400L,50401L,50402L,50403L,50404L, +50405L,50406L,50407L,50408L,50409L,50410L,50411L,50412L,50413L,50414L, +50415L,50416L,50417L,50418L,50419L,50420L,50421L,50422L,50423L,50424L, +50425L,50426L,50427L,50428L,50429L,50430L,50431L,50432L,50433L,50434L, +50435L,50436L,50437L,50438L,50439L,50440L,50441L,50442L,50443L,50444L, +50445L,50446L,50447L,50448L,50449L,50450L,50451L,50452L,50453L,50454L, +50455L,50456L,50457L,50458L,50459L,50460L,50461L,50462L,50463L,50464L, +50465L,50466L,50467L,50468L,50469L,50470L,50471L,50472L,50473L,50474L, +50475L,50476L,50477L,50478L,50479L,50480L,50481L,50482L,50483L,50484L, +50485L,50486L,50487L,50488L,50489L,50490L,50491L,50492L,50493L,50494L, +50495L,50496L,50497L,50498L,50499L,50500L,50501L,50502L,50503L,50504L, +50505L,50506L,50507L,50508L,50509L,50510L,50511L,50512L,50513L,50514L, +50515L,50516L,50517L,50518L,50519L,50520L,50521L,50522L,50523L,50524L, +50525L,50526L,50527L,50528L,50529L,50530L,50531L,50532L,50533L,50534L, +50535L,50536L,50537L,50538L,50539L,50540L,50541L,50542L,50543L,50544L, +50545L,50546L,50547L,50548L,50549L,50550L,50551L,50552L,50553L,50554L, +50555L,50556L,50557L,50558L,50559L,50560L,50561L,50562L,50563L,50564L, +50565L,50566L,50567L,50568L,50569L,50570L,50571L,50572L,50573L,50574L, +50575L,50576L,50577L,50578L,50579L,50580L,50581L,50582L,50583L,50584L, +50585L,50586L,50587L,50588L,50589L,50590L,50591L,50592L,50593L,50594L, +50595L,50596L,50597L,50598L,50599L,50600L,50601L,50602L,50603L,50604L, +50605L,50606L,50607L,50608L,50609L,50610L,50611L,50612L,50613L,50614L, +50615L,50616L,50617L,50618L,50619L,50620L,50621L,50622L,50623L,50624L, +50625L,50626L,50627L,50628L,50629L,50630L,50631L,50632L,50633L,50634L, +50635L,50636L,50637L,50638L,50639L,50640L,50641L,50642L,50643L,50644L, +50645L,50646L,50647L,50648L,50649L,50650L,50651L,50652L,50653L,50654L, +50655L,50656L,50657L,50658L,50659L,50660L,50661L,50662L,50663L,50664L, +50665L,50666L,50667L,50668L,50669L,50670L,50671L,50672L,50673L,50674L, +50675L,50676L,50677L,50678L,50679L,50680L,50681L,50682L,50683L,50684L, +50685L,50686L,50687L,50688L,50689L,50690L,50691L,50692L,50693L,50694L, +50695L,50696L,50697L,50698L,50699L,50700L,50701L,50702L,50703L,50704L, +50705L,50706L,50707L,50708L,50709L,50710L,50711L,50712L,50713L,50714L, +50715L,50716L,50717L,50718L,50719L,50720L,50721L,50722L,50723L,50724L, +50725L,50726L,50727L,50728L,50729L,50730L,50731L,50732L,50733L,50734L, +50735L,50736L,50737L,50738L,50739L,50740L,50741L,50742L,50743L,50744L, +50745L,50746L,50747L,50748L,50749L,50750L,50751L,50752L,50753L,50754L, +50755L,50756L,50757L,50758L,50759L,50760L,50761L,50762L,50763L,50764L, +50765L,50766L,50767L,50768L,50769L,50770L,50771L,50772L,50773L,50774L, +50775L,50776L,50777L,50778L,50779L,50780L,50781L,50782L,50783L,50784L, +50785L,50786L,50787L,50788L,50789L,50790L,50791L,50792L,50793L,50794L, +50795L,50796L,50797L,50798L,50799L,50800L,50801L,50802L,50803L,50804L, +50805L,50806L,50807L,50808L,50809L,50810L,50811L,50812L,50813L,50814L, +50815L,50816L,50817L,50818L,50819L,50820L,50821L,50822L,50823L,50824L, +50825L,50826L,50827L,50828L,50829L,50830L,50831L,50832L,50833L,50834L, +50835L,50836L,50837L,50838L,50839L,50840L,50841L,50842L,50843L,50844L, +50845L,50846L,50847L,50848L,50849L,50850L,50851L,50852L,50853L,50854L, +50855L,50856L,50857L,50858L,50859L,50860L,50861L,50862L,50863L,50864L, +50865L,50866L,50867L,50868L,50869L,50870L,50871L,50872L,50873L,50874L, +50875L,50876L,50877L,50878L,50879L,50880L,50881L,50882L,50883L,50884L, +50885L,50886L,50887L,50888L,50889L,50890L,50891L,50892L,50893L,50894L, +50895L,50896L,50897L,50898L,50899L,50900L,50901L,50902L,50903L,50904L, +50905L,50906L,50907L,50908L,50909L,50910L,50911L,50912L,50913L,50914L, +50915L,50916L,50917L,50918L,50919L,50920L,50921L,50922L,50923L,50924L, +50925L,50926L,50927L,50928L,50929L,50930L,50931L,50932L,50933L,50934L, +50935L,50936L,50937L,50938L,50939L,50940L,50941L,50942L,50943L,50944L, +50945L,50946L,50947L,50948L,50949L,50950L,50951L,50952L,50953L,50954L, +50955L,50956L,50957L,50958L,50959L,50960L,50961L,50962L,50963L,50964L, +50965L,50966L,50967L,50968L,50969L,50970L,50971L,50972L,50973L,50974L, +50975L,50976L,50977L,50978L,50979L,50980L,50981L,50982L,50983L,50984L, +50985L,50986L,50987L,50988L,50989L,50990L,50991L,50992L,50993L,50994L, +50995L,50996L,50997L,50998L,50999L,51000L,51001L,51002L,51003L,51004L, +51005L,51006L,51007L,51008L,51009L,51010L,51011L,51012L,51013L,51014L, +51015L,51016L,51017L,51018L,51019L,51020L,51021L,51022L,51023L,51024L, +51025L,51026L,51027L,51028L,51029L,51030L,51031L,51032L,51033L,51034L, +51035L,51036L,51037L,51038L,51039L,51040L,51041L,51042L,51043L,51044L, +51045L,51046L,51047L,51048L,51049L,51050L,51051L,51052L,51053L,51054L, +51055L,51056L,51057L,51058L,51059L,51060L,51061L,51062L,51063L,51064L, +51065L,51066L,51067L,51068L,51069L,51070L,51071L,51072L,51073L,51074L, +51075L,51076L,51077L,51078L,51079L,51080L,51081L,51082L,51083L,51084L, +51085L,51086L,51087L,51088L,51089L,51090L,51091L,51092L,51093L,51094L, +51095L,51096L,51097L,51098L,51099L,51100L,51101L,51102L,51103L,51104L, +51105L,51106L,51107L,51108L,51109L,51110L,51111L,51112L,51113L,51114L, +51115L,51116L,51117L,51118L,51119L,51120L,51121L,51122L,51123L,51124L, +51125L,51126L,51127L,51128L,51129L,51130L,51131L,51132L,51133L,51134L, +51135L,51136L,51137L,51138L,51139L,51140L,51141L,51142L,51143L,51144L, +51145L,51146L,51147L,51148L,51149L,51150L,51151L,51152L,51153L,51154L, +51155L,51156L,51157L,51158L,51159L,51160L,51161L,51162L,51163L,51164L, +51165L,51166L,51167L,51168L,51169L,51170L,51171L,51172L,51173L,51174L, +51175L,51176L,51177L,51178L,51179L,51180L,51181L,51182L,51183L,51184L, +51185L,51186L,51187L,51188L,51189L,51190L,51191L,51192L,51193L,51194L, +51195L,51196L,51197L,51198L,51199L,51200L,51201L,51202L,51203L,51204L, +51205L,51206L,51207L,51208L,51209L,51210L,51211L,51212L,51213L,51214L, +51215L,51216L,51217L,51218L,51219L,51220L,51221L,51222L,51223L,51224L, +51225L,51226L,51227L,51228L,51229L,51230L,51231L,51232L,51233L,51234L, +51235L,51236L,51237L,51238L,51239L,51240L,51241L,51242L,51243L,51244L, +51245L,51246L,51247L,51248L,51249L,51250L,51251L,51252L,51253L,51254L, +51255L,51256L,51257L,51258L,51259L,51260L,51261L,51262L,51263L,51264L, +51265L,51266L,51267L,51268L,51269L,51270L,51271L,51272L,51273L,51274L, +51275L,51276L,51277L,51278L,51279L,51280L,51281L,51282L,51283L,51284L, +51285L,51286L,51287L,51288L,51289L,51290L,51291L,51292L,51293L,51294L, +51295L,51296L,51297L,51298L,51299L,51300L,51301L,51302L,51303L,51304L, +51305L,51306L,51307L,51308L,51309L,51310L,51311L,51312L,51313L,51314L, +51315L,51316L,51317L,51318L,51319L,51320L,51321L,51322L,51323L,51324L, +51325L,51326L,51327L,51328L,51329L,51330L,51331L,51332L,51333L,51334L, +51335L,51336L,51337L,51338L,51339L,51340L,51341L,51342L,51343L,51344L, +51345L,51346L,51347L,51348L,51349L,51350L,51351L,51352L,51353L,51354L, +51355L,51356L,51357L,51358L,51359L,51360L,51361L,51362L,51363L,51364L, +51365L,51366L,51367L,51368L,51369L,51370L,51371L,51372L,51373L,51374L, +51375L,51376L,51377L,51378L,51379L,51380L,51381L,51382L,51383L,51384L, +51385L,51386L,51387L,51388L,51389L,51390L,51391L,51392L,51393L,51394L, +51395L,51396L,51397L,51398L,51399L,51400L,51401L,51402L,51403L,51404L, +51405L,51406L,51407L,51408L,51409L,51410L,51411L,51412L,51413L,51414L, +51415L,51416L,51417L,51418L,51419L,51420L,51421L,51422L,51423L,51424L, +51425L,51426L,51427L,51428L,51429L,51430L,51431L,51432L,51433L,51434L, +51435L,51436L,51437L,51438L,51439L,51440L,51441L,51442L,51443L,51444L, +51445L,51446L,51447L,51448L,51449L,51450L,51451L,51452L,51453L,51454L, +51455L,51456L,51457L,51458L,51459L,51460L,51461L,51462L,51463L,51464L, +51465L,51466L,51467L,51468L,51469L,51470L,51471L,51472L,51473L,51474L, +51475L,51476L,51477L,51478L,51479L,51480L,51481L,51482L,51483L,51484L, +51485L,51486L,51487L,51488L,51489L,51490L,51491L,51492L,51493L,51494L, +51495L,51496L,51497L,51498L,51499L,51500L,51501L,51502L,51503L,51504L, +51505L,51506L,51507L,51508L,51509L,51510L,51511L,51512L,51513L,51514L, +51515L,51516L,51517L,51518L,51519L,51520L,51521L,51522L,51523L,51524L, +51525L,51526L,51527L,51528L,51529L,51530L,51531L,51532L,51533L,51534L, +51535L,51536L,51537L,51538L,51539L,51540L,51541L,51542L,51543L,51544L, +51545L,51546L,51547L,51548L,51549L,51550L,51551L,51552L,51553L,51554L, +51555L,51556L,51557L,51558L,51559L,51560L,51561L,51562L,51563L,51564L, +51565L,51566L,51567L,51568L,51569L,51570L,51571L,51572L,51573L,51574L, +51575L,51576L,51577L,51578L,51579L,51580L,51581L,51582L,51583L,51584L, +51585L,51586L,51587L,51588L,51589L,51590L,51591L,51592L,51593L,51594L, +51595L,51596L,51597L,51598L,51599L,51600L,51601L,51602L,51603L,51604L, +51605L,51606L,51607L,51608L,51609L,51610L,51611L,51612L,51613L,51614L, +51615L,51616L,51617L,51618L,51619L,51620L,51621L,51622L,51623L,51624L, +51625L,51626L,51627L,51628L,51629L,51630L,51631L,51632L,51633L,51634L, +51635L,51636L,51637L,51638L,51639L,51640L,51641L,51642L,51643L,51644L, +51645L,51646L,51647L,51648L,51649L,51650L,51651L,51652L,51653L,51654L, +51655L,51656L,51657L,51658L,51659L,51660L,51661L,51662L,51663L,51664L, +51665L,51666L,51667L,51668L,51669L,51670L,51671L,51672L,51673L,51674L, +51675L,51676L,51677L,51678L,51679L,51680L,51681L,51682L,51683L,51684L, +51685L,51686L,51687L,51688L,51689L,51690L,51691L,51692L,51693L,51694L, +51695L,51696L,51697L,51698L,51699L,51700L,51701L,51702L,51703L,51704L, +51705L,51706L,51707L,51708L,51709L,51710L,51711L,51712L,51713L,51714L, +51715L,51716L,51717L,51718L,51719L,51720L,51721L,51722L,51723L,51724L, +51725L,51726L,51727L,51728L,51729L,51730L,51731L,51732L,51733L,51734L, +51735L,51736L,51737L,51738L,51739L,51740L,51741L,51742L,51743L,51744L, +51745L,51746L,51747L,51748L,51749L,51750L,51751L,51752L,51753L,51754L, +51755L,51756L,51757L,51758L,51759L,51760L,51761L,51762L,51763L,51764L, +51765L,51766L,51767L,51768L,51769L,51770L,51771L,51772L,51773L,51774L, +51775L,51776L,51777L,51778L,51779L,51780L,51781L,51782L,51783L,51784L, +51785L,51786L,51787L,51788L,51789L,51790L,51791L,51792L,51793L,51794L, +51795L,51796L,51797L,51798L,51799L,51800L,51801L,51802L,51803L,51804L, +51805L,51806L,51807L,51808L,51809L,51810L,51811L,51812L,51813L,51814L, +51815L,51816L,51817L,51818L,51819L,51820L,51821L,51822L,51823L,51824L, +51825L,51826L,51827L,51828L,51829L,51830L,51831L,51832L,51833L,51834L, +51835L,51836L,51837L,51838L,51839L,51840L,51841L,51842L,51843L,51844L, +51845L,51846L,51847L,51848L,51849L,51850L,51851L,51852L,51853L,51854L, +51855L,51856L,51857L,51858L,51859L,51860L,51861L,51862L,51863L,51864L, +51865L,51866L,51867L,51868L,51869L,51870L,51871L,51872L,51873L,51874L, +51875L,51876L,51877L,51878L,51879L,51880L,51881L,51882L,51883L,51884L, +51885L,51886L,51887L,51888L,51889L,51890L,51891L,51892L,51893L,51894L, +51895L,51896L,51897L,51898L,51899L,51900L,51901L,51902L,51903L,51904L, +51905L,51906L,51907L,51908L,51909L,51910L,51911L,51912L,51913L,51914L, +51915L,51916L,51917L,51918L,51919L,51920L,51921L,51922L,51923L,51924L, +51925L,51926L,51927L,51928L,51929L,51930L,51931L,51932L,51933L,51934L, +51935L,51936L,51937L,51938L,51939L,51940L,51941L,51942L,51943L,51944L, +51945L,51946L,51947L,51948L,51949L,51950L,51951L,51952L,51953L,51954L, +51955L,51956L,51957L,51958L,51959L,51960L,51961L,51962L,51963L,51964L, +51965L,51966L,51967L,51968L,51969L,51970L,51971L,51972L,51973L,51974L, +51975L,51976L,51977L,51978L,51979L,51980L,51981L,51982L,51983L,51984L, +51985L,51986L,51987L,51988L,51989L,51990L,51991L,51992L,51993L,51994L, +51995L,51996L,51997L,51998L,51999L,52000L,52001L,52002L,52003L,52004L, +52005L,52006L,52007L,52008L,52009L,52010L,52011L,52012L,52013L,52014L, +52015L,52016L,52017L,52018L,52019L,52020L,52021L,52022L,52023L,52024L, +52025L,52026L,52027L,52028L,52029L,52030L,52031L,52032L,52033L,52034L, +52035L,52036L,52037L,52038L,52039L,52040L,52041L,52042L,52043L,52044L, +52045L,52046L,52047L,52048L,52049L,52050L,52051L,52052L,52053L,52054L, +52055L,52056L,52057L,52058L,52059L,52060L,52061L,52062L,52063L,52064L, +52065L,52066L,52067L,52068L,52069L,52070L,52071L,52072L,52073L,52074L, +52075L,52076L,52077L,52078L,52079L,52080L,52081L,52082L,52083L,52084L, +52085L,52086L,52087L,52088L,52089L,52090L,52091L,52092L,52093L,52094L, +52095L,52096L,52097L,52098L,52099L,52100L,52101L,52102L,52103L,52104L, +52105L,52106L,52107L,52108L,52109L,52110L,52111L,52112L,52113L,52114L, +52115L,52116L,52117L,52118L,52119L,52120L,52121L,52122L,52123L,52124L, +52125L,52126L,52127L,52128L,52129L,52130L,52131L,52132L,52133L,52134L, +52135L,52136L,52137L,52138L,52139L,52140L,52141L,52142L,52143L,52144L, +52145L,52146L,52147L,52148L,52149L,52150L,52151L,52152L,52153L,52154L, +52155L,52156L,52157L,52158L,52159L,52160L,52161L,52162L,52163L,52164L, +52165L,52166L,52167L,52168L,52169L,52170L,52171L,52172L,52173L,52174L, +52175L,52176L,52177L,52178L,52179L,52180L,52181L,52182L,52183L,52184L, +52185L,52186L,52187L,52188L,52189L,52190L,52191L,52192L,52193L,52194L, +52195L,52196L,52197L,52198L,52199L,52200L,52201L,52202L,52203L,52204L, +52205L,52206L,52207L,52208L,52209L,52210L,52211L,52212L,52213L,52214L, +52215L,52216L,52217L,52218L,52219L,52220L,52221L,52222L,52223L,52224L, +52225L,52226L,52227L,52228L,52229L,52230L,52231L,52232L,52233L,52234L, +52235L,52236L,52237L,52238L,52239L,52240L,52241L,52242L,52243L,52244L, +52245L,52246L,52247L,52248L,52249L,52250L,52251L,52252L,52253L,52254L, +52255L,52256L,52257L,52258L,52259L,52260L,52261L,52262L,52263L,52264L, +52265L,52266L,52267L,52268L,52269L,52270L,52271L,52272L,52273L,52274L, +52275L,52276L,52277L,52278L,52279L,52280L,52281L,52282L,52283L,52284L, +52285L,52286L,52287L,52288L,52289L,52290L,52291L,52292L,52293L,52294L, +52295L,52296L,52297L,52298L,52299L,52300L,52301L,52302L,52303L,52304L, +52305L,52306L,52307L,52308L,52309L,52310L,52311L,52312L,52313L,52314L, +52315L,52316L,52317L,52318L,52319L,52320L,52321L,52322L,52323L,52324L, +52325L,52326L,52327L,52328L,52329L,52330L,52331L,52332L,52333L,52334L, +52335L,52336L,52337L,52338L,52339L,52340L,52341L,52342L,52343L,52344L, +52345L,52346L,52347L,52348L,52349L,52350L,52351L,52352L,52353L,52354L, +52355L,52356L,52357L,52358L,52359L,52360L,52361L,52362L,52363L,52364L, +52365L,52366L,52367L,52368L,52369L,52370L,52371L,52372L,52373L,52374L, +52375L,52376L,52377L,52378L,52379L,52380L,52381L,52382L,52383L,52384L, +52385L,52386L,52387L,52388L,52389L,52390L,52391L,52392L,52393L,52394L, +52395L,52396L,52397L,52398L,52399L,52400L,52401L,52402L,52403L,52404L, +52405L,52406L,52407L,52408L,52409L,52410L,52411L,52412L,52413L,52414L, +52415L,52416L,52417L,52418L,52419L,52420L,52421L,52422L,52423L,52424L, +52425L,52426L,52427L,52428L,52429L,52430L,52431L,52432L,52433L,52434L, +52435L,52436L,52437L,52438L,52439L,52440L,52441L,52442L,52443L,52444L, +52445L,52446L,52447L,52448L,52449L,52450L,52451L,52452L,52453L,52454L, +52455L,52456L,52457L,52458L,52459L,52460L,52461L,52462L,52463L,52464L, +52465L,52466L,52467L,52468L,52469L,52470L,52471L,52472L,52473L,52474L, +52475L,52476L,52477L,52478L,52479L,52480L,52481L,52482L,52483L,52484L, +52485L,52486L,52487L,52488L,52489L,52490L,52491L,52492L,52493L,52494L, +52495L,52496L,52497L,52498L,52499L,52500L,52501L,52502L,52503L,52504L, +52505L,52506L,52507L,52508L,52509L,52510L,52511L,52512L,52513L,52514L, +52515L,52516L,52517L,52518L,52519L,52520L,52521L,52522L,52523L,52524L, +52525L,52526L,52527L,52528L,52529L,52530L,52531L,52532L,52533L,52534L, +52535L,52536L,52537L,52538L,52539L,52540L,52541L,52542L,52543L,52544L, +52545L,52546L,52547L,52548L,52549L,52550L,52551L,52552L,52553L,52554L, +52555L,52556L,52557L,52558L,52559L,52560L,52561L,52562L,52563L,52564L, +52565L,52566L,52567L,52568L,52569L,52570L,52571L,52572L,52573L,52574L, +52575L,52576L,52577L,52578L,52579L,52580L,52581L,52582L,52583L,52584L, +52585L,52586L,52587L,52588L,52589L,52590L,52591L,52592L,52593L,52594L, +52595L,52596L,52597L,52598L,52599L,52600L,52601L,52602L,52603L,52604L, +52605L,52606L,52607L,52608L,52609L,52610L,52611L,52612L,52613L,52614L, +52615L,52616L,52617L,52618L,52619L,52620L,52621L,52622L,52623L,52624L, +52625L,52626L,52627L,52628L,52629L,52630L,52631L,52632L,52633L,52634L, +52635L,52636L,52637L,52638L,52639L,52640L,52641L,52642L,52643L,52644L, +52645L,52646L,52647L,52648L,52649L,52650L,52651L,52652L,52653L,52654L, +52655L,52656L,52657L,52658L,52659L,52660L,52661L,52662L,52663L,52664L, +52665L,52666L,52667L,52668L,52669L,52670L,52671L,52672L,52673L,52674L, +52675L,52676L,52677L,52678L,52679L,52680L,52681L,52682L,52683L,52684L, +52685L,52686L,52687L,52688L,52689L,52690L,52691L,52692L,52693L,52694L, +52695L,52696L,52697L,52698L,52699L,52700L,52701L,52702L,52703L,52704L, +52705L,52706L,52707L,52708L,52709L,52710L,52711L,52712L,52713L,52714L, +52715L,52716L,52717L,52718L,52719L,52720L,52721L,52722L,52723L,52724L, +52725L,52726L,52727L,52728L,52729L,52730L,52731L,52732L,52733L,52734L, +52735L,52736L,52737L,52738L,52739L,52740L,52741L,52742L,52743L,52744L, +52745L,52746L,52747L,52748L,52749L,52750L,52751L,52752L,52753L,52754L, +52755L,52756L,52757L,52758L,52759L,52760L,52761L,52762L,52763L,52764L, +52765L,52766L,52767L,52768L,52769L,52770L,52771L,52772L,52773L,52774L, +52775L,52776L,52777L,52778L,52779L,52780L,52781L,52782L,52783L,52784L, +52785L,52786L,52787L,52788L,52789L,52790L,52791L,52792L,52793L,52794L, +52795L,52796L,52797L,52798L,52799L,52800L,52801L,52802L,52803L,52804L, +52805L,52806L,52807L,52808L,52809L,52810L,52811L,52812L,52813L,52814L, +52815L,52816L,52817L,52818L,52819L,52820L,52821L,52822L,52823L,52824L, +52825L,52826L,52827L,52828L,52829L,52830L,52831L,52832L,52833L,52834L, +52835L,52836L,52837L,52838L,52839L,52840L,52841L,52842L,52843L,52844L, +52845L,52846L,52847L,52848L,52849L,52850L,52851L,52852L,52853L,52854L, +52855L,52856L,52857L,52858L,52859L,52860L,52861L,52862L,52863L,52864L, +52865L,52866L,52867L,52868L,52869L,52870L,52871L,52872L,52873L,52874L, +52875L,52876L,52877L,52878L,52879L,52880L,52881L,52882L,52883L,52884L, +52885L,52886L,52887L,52888L,52889L,52890L,52891L,52892L,52893L,52894L, +52895L,52896L,52897L,52898L,52899L,52900L,52901L,52902L,52903L,52904L, +52905L,52906L,52907L,52908L,52909L,52910L,52911L,52912L,52913L,52914L, +52915L,52916L,52917L,52918L,52919L,52920L,52921L,52922L,52923L,52924L, +52925L,52926L,52927L,52928L,52929L,52930L,52931L,52932L,52933L,52934L, +52935L,52936L,52937L,52938L,52939L,52940L,52941L,52942L,52943L,52944L, +52945L,52946L,52947L,52948L,52949L,52950L,52951L,52952L,52953L,52954L, +52955L,52956L,52957L,52958L,52959L,52960L,52961L,52962L,52963L,52964L, +52965L,52966L,52967L,52968L,52969L,52970L,52971L,52972L,52973L,52974L, +52975L,52976L,52977L,52978L,52979L,52980L,52981L,52982L,52983L,52984L, +52985L,52986L,52987L,52988L,52989L,52990L,52991L,52992L,52993L,52994L, +52995L,52996L,52997L,52998L,52999L,53000L,53001L,53002L,53003L,53004L, +53005L,53006L,53007L,53008L,53009L,53010L,53011L,53012L,53013L,53014L, +53015L,53016L,53017L,53018L,53019L,53020L,53021L,53022L,53023L,53024L, +53025L,53026L,53027L,53028L,53029L,53030L,53031L,53032L,53033L,53034L, +53035L,53036L,53037L,53038L,53039L,53040L,53041L,53042L,53043L,53044L, +53045L,53046L,53047L,53048L,53049L,53050L,53051L,53052L,53053L,53054L, +53055L,53056L,53057L,53058L,53059L,53060L,53061L,53062L,53063L,53064L, +53065L,53066L,53067L,53068L,53069L,53070L,53071L,53072L,53073L,53074L, +53075L,53076L,53077L,53078L,53079L,53080L,53081L,53082L,53083L,53084L, +53085L,53086L,53087L,53088L,53089L,53090L,53091L,53092L,53093L,53094L, +53095L,53096L,53097L,53098L,53099L,53100L,53101L,53102L,53103L,53104L, +53105L,53106L,53107L,53108L,53109L,53110L,53111L,53112L,53113L,53114L, +53115L,53116L,53117L,53118L,53119L,53120L,53121L,53122L,53123L,53124L, +53125L,53126L,53127L,53128L,53129L,53130L,53131L,53132L,53133L,53134L, +53135L,53136L,53137L,53138L,53139L,53140L,53141L,53142L,53143L,53144L, +53145L,53146L,53147L,53148L,53149L,53150L,53151L,53152L,53153L,53154L, +53155L,53156L,53157L,53158L,53159L,53160L,53161L,53162L,53163L,53164L, +53165L,53166L,53167L,53168L,53169L,53170L,53171L,53172L,53173L,53174L, +53175L,53176L,53177L,53178L,53179L,53180L,53181L,53182L,53183L,53184L, +53185L,53186L,53187L,53188L,53189L,53190L,53191L,53192L,53193L,53194L, +53195L,53196L,53197L,53198L,53199L,53200L,53201L,53202L,53203L,53204L, +53205L,53206L,53207L,53208L,53209L,53210L,53211L,53212L,53213L,53214L, +53215L,53216L,53217L,53218L,53219L,53220L,53221L,53222L,53223L,53224L, +53225L,53226L,53227L,53228L,53229L,53230L,53231L,53232L,53233L,53234L, +53235L,53236L,53237L,53238L,53239L,53240L,53241L,53242L,53243L,53244L, +53245L,53246L,53247L,53248L,53249L,53250L,53251L,53252L,53253L,53254L, +53255L,53256L,53257L,53258L,53259L,53260L,53261L,53262L,53263L,53264L, +53265L,53266L,53267L,53268L,53269L,53270L,53271L,53272L,53273L,53274L, +53275L,53276L,53277L,53278L,53279L,53280L,53281L,53282L,53283L,53284L, +53285L,53286L,53287L,53288L,53289L,53290L,53291L,53292L,53293L,53294L, +53295L,53296L,53297L,53298L,53299L,53300L,53301L,53302L,53303L,53304L, +53305L,53306L,53307L,53308L,53309L,53310L,53311L,53312L,53313L,53314L, +53315L,53316L,53317L,53318L,53319L,53320L,53321L,53322L,53323L,53324L, +53325L,53326L,53327L,53328L,53329L,53330L,53331L,53332L,53333L,53334L, +53335L,53336L,53337L,53338L,53339L,53340L,53341L,53342L,53343L,53344L, +53345L,53346L,53347L,53348L,53349L,53350L,53351L,53352L,53353L,53354L, +53355L,53356L,53357L,53358L,53359L,53360L,53361L,53362L,53363L,53364L, +53365L,53366L,53367L,53368L,53369L,53370L,53371L,53372L,53373L,53374L, +53375L,53376L,53377L,53378L,53379L,53380L,53381L,53382L,53383L,53384L, +53385L,53386L,53387L,53388L,53389L,53390L,53391L,53392L,53393L,53394L, +53395L,53396L,53397L,53398L,53399L,53400L,53401L,53402L,53403L,53404L, +53405L,53406L,53407L,53408L,53409L,53410L,53411L,53412L,53413L,53414L, +53415L,53416L,53417L,53418L,53419L,53420L,53421L,53422L,53423L,53424L, +53425L,53426L,53427L,53428L,53429L,53430L,53431L,53432L,53433L,53434L, +53435L,53436L,53437L,53438L,53439L,53440L,53441L,53442L,53443L,53444L, +53445L,53446L,53447L,53448L,53449L,53450L,53451L,53452L,53453L,53454L, +53455L,53456L,53457L,53458L,53459L,53460L,53461L,53462L,53463L,53464L, +53465L,53466L,53467L,53468L,53469L,53470L,53471L,53472L,53473L,53474L, +53475L,53476L,53477L,53478L,53479L,53480L,53481L,53482L,53483L,53484L, +53485L,53486L,53487L,53488L,53489L,53490L,53491L,53492L,53493L,53494L, +53495L,53496L,53497L,53498L,53499L,53500L,53501L,53502L,53503L,53504L, +53505L,53506L,53507L,53508L,53509L,53510L,53511L,53512L,53513L,53514L, +53515L,53516L,53517L,53518L,53519L,53520L,53521L,53522L,53523L,53524L, +53525L,53526L,53527L,53528L,53529L,53530L,53531L,53532L,53533L,53534L, +53535L,53536L,53537L,53538L,53539L,53540L,53541L,53542L,53543L,53544L, +53545L,53546L,53547L,53548L,53549L,53550L,53551L,53552L,53553L,53554L, +53555L,53556L,53557L,53558L,53559L,53560L,53561L,53562L,53563L,53564L, +53565L,53566L,53567L,53568L,53569L,53570L,53571L,53572L,53573L,53574L, +53575L,53576L,53577L,53578L,53579L,53580L,53581L,53582L,53583L,53584L, +53585L,53586L,53587L,53588L,53589L,53590L,53591L,53592L,53593L,53594L, +53595L,53596L,53597L,53598L,53599L,53600L,53601L,53602L,53603L,53604L, +53605L,53606L,53607L,53608L,53609L,53610L,53611L,53612L,53613L,53614L, +53615L,53616L,53617L,53618L,53619L,53620L,53621L,53622L,53623L,53624L, +53625L,53626L,53627L,53628L,53629L,53630L,53631L,53632L,53633L,53634L, +53635L,53636L,53637L,53638L,53639L,53640L,53641L,53642L,53643L,53644L, +53645L,53646L,53647L,53648L,53649L,53650L,53651L,53652L,53653L,53654L, +53655L,53656L,53657L,53658L,53659L,53660L,53661L,53662L,53663L,53664L, +53665L,53666L,53667L,53668L,53669L,53670L,53671L,53672L,53673L,53674L, +53675L,53676L,53677L,53678L,53679L,53680L,53681L,53682L,53683L,53684L, +53685L,53686L,53687L,53688L,53689L,53690L,53691L,53692L,53693L,53694L, +53695L,53696L,53697L,53698L,53699L,53700L,53701L,53702L,53703L,53704L, +53705L,53706L,53707L,53708L,53709L,53710L,53711L,53712L,53713L,53714L, +53715L,53716L,53717L,53718L,53719L,53720L,53721L,53722L,53723L,53724L, +53725L,53726L,53727L,53728L,53729L,53730L,53731L,53732L,53733L,53734L, +53735L,53736L,53737L,53738L,53739L,53740L,53741L,53742L,53743L,53744L, +53745L,53746L,53747L,53748L,53749L,53750L,53751L,53752L,53753L,53754L, +53755L,53756L,53757L,53758L,53759L,53760L,53761L,53762L,53763L,53764L, +53765L,53766L,53767L,53768L,53769L,53770L,53771L,53772L,53773L,53774L, +53775L,53776L,53777L,53778L,53779L,53780L,53781L,53782L,53783L,53784L, +53785L,53786L,53787L,53788L,53789L,53790L,53791L,53792L,53793L,53794L, +53795L,53796L,53797L,53798L,53799L,53800L,53801L,53802L,53803L,53804L, +53805L,53806L,53807L,53808L,53809L,53810L,53811L,53812L,53813L,53814L, +53815L,53816L,53817L,53818L,53819L,53820L,53821L,53822L,53823L,53824L, +53825L,53826L,53827L,53828L,53829L,53830L,53831L,53832L,53833L,53834L, +53835L,53836L,53837L,53838L,53839L,53840L,53841L,53842L,53843L,53844L, +53845L,53846L,53847L,53848L,53849L,53850L,53851L,53852L,53853L,53854L, +53855L,53856L,53857L,53858L,53859L,53860L,53861L,53862L,53863L,53864L, +53865L,53866L,53867L,53868L,53869L,53870L,53871L,53872L,53873L,53874L, +53875L,53876L,53877L,53878L,53879L,53880L,53881L,53882L,53883L,53884L, +53885L,53886L,53887L,53888L,53889L,53890L,53891L,53892L,53893L,53894L, +53895L,53896L,53897L,53898L,53899L,53900L,53901L,53902L,53903L,53904L, +53905L,53906L,53907L,53908L,53909L,53910L,53911L,53912L,53913L,53914L, +53915L,53916L,53917L,53918L,53919L,53920L,53921L,53922L,53923L,53924L, +53925L,53926L,53927L,53928L,53929L,53930L,53931L,53932L,53933L,53934L, +53935L,53936L,53937L,53938L,53939L,53940L,53941L,53942L,53943L,53944L, +53945L,53946L,53947L,53948L,53949L,53950L,53951L,53952L,53953L,53954L, +53955L,53956L,53957L,53958L,53959L,53960L,53961L,53962L,53963L,53964L, +53965L,53966L,53967L,53968L,53969L,53970L,53971L,53972L,53973L,53974L, +53975L,53976L,53977L,53978L,53979L,53980L,53981L,53982L,53983L,53984L, +53985L,53986L,53987L,53988L,53989L,53990L,53991L,53992L,53993L,53994L, +53995L,53996L,53997L,53998L,53999L,54000L,54001L,54002L,54003L,54004L, +54005L,54006L,54007L,54008L,54009L,54010L,54011L,54012L,54013L,54014L, +54015L,54016L,54017L,54018L,54019L,54020L,54021L,54022L,54023L,54024L, +54025L,54026L,54027L,54028L,54029L,54030L,54031L,54032L,54033L,54034L, +54035L,54036L,54037L,54038L,54039L,54040L,54041L,54042L,54043L,54044L, +54045L,54046L,54047L,54048L,54049L,54050L,54051L,54052L,54053L,54054L, +54055L,54056L,54057L,54058L,54059L,54060L,54061L,54062L,54063L,54064L, +54065L,54066L,54067L,54068L,54069L,54070L,54071L,54072L,54073L,54074L, +54075L,54076L,54077L,54078L,54079L,54080L,54081L,54082L,54083L,54084L, +54085L,54086L,54087L,54088L,54089L,54090L,54091L,54092L,54093L,54094L, +54095L,54096L,54097L,54098L,54099L,54100L,54101L,54102L,54103L,54104L, +54105L,54106L,54107L,54108L,54109L,54110L,54111L,54112L,54113L,54114L, +54115L,54116L,54117L,54118L,54119L,54120L,54121L,54122L,54123L,54124L, +54125L,54126L,54127L,54128L,54129L,54130L,54131L,54132L,54133L,54134L, +54135L,54136L,54137L,54138L,54139L,54140L,54141L,54142L,54143L,54144L, +54145L,54146L,54147L,54148L,54149L,54150L,54151L,54152L,54153L,54154L, +54155L,54156L,54157L,54158L,54159L,54160L,54161L,54162L,54163L,54164L, +54165L,54166L,54167L,54168L,54169L,54170L,54171L,54172L,54173L,54174L, +54175L,54176L,54177L,54178L,54179L,54180L,54181L,54182L,54183L,54184L, +54185L,54186L,54187L,54188L,54189L,54190L,54191L,54192L,54193L,54194L, +54195L,54196L,54197L,54198L,54199L,54200L,54201L,54202L,54203L,54204L, +54205L,54206L,54207L,54208L,54209L,54210L,54211L,54212L,54213L,54214L, +54215L,54216L,54217L,54218L,54219L,54220L,54221L,54222L,54223L,54224L, +54225L,54226L,54227L,54228L,54229L,54230L,54231L,54232L,54233L,54234L, +54235L,54236L,54237L,54238L,54239L,54240L,54241L,54242L,54243L,54244L, +54245L,54246L,54247L,54248L,54249L,54250L,54251L,54252L,54253L,54254L, +54255L,54256L,54257L,54258L,54259L,54260L,54261L,54262L,54263L,54264L, +54265L,54266L,54267L,54268L,54269L,54270L,54271L,54272L,54273L,54274L, +54275L,54276L,54277L,54278L,54279L,54280L,54281L,54282L,54283L,54284L, +54285L,54286L,54287L,54288L,54289L,54290L,54291L,54292L,54293L,54294L, +54295L,54296L,54297L,54298L,54299L,54300L,54301L,54302L,54303L,54304L, +54305L,54306L,54307L,54308L,54309L,54310L,54311L,54312L,54313L,54314L, +54315L,54316L,54317L,54318L,54319L,54320L,54321L,54322L,54323L,54324L, +54325L,54326L,54327L,54328L,54329L,54330L,54331L,54332L,54333L,54334L, +54335L,54336L,54337L,54338L,54339L,54340L,54341L,54342L,54343L,54344L, +54345L,54346L,54347L,54348L,54349L,54350L,54351L,54352L,54353L,54354L, +54355L,54356L,54357L,54358L,54359L,54360L,54361L,54362L,54363L,54364L, +54365L,54366L,54367L,54368L,54369L,54370L,54371L,54372L,54373L,54374L, +54375L,54376L,54377L,54378L,54379L,54380L,54381L,54382L,54383L,54384L, +54385L,54386L,54387L,54388L,54389L,54390L,54391L,54392L,54393L,54394L, +54395L,54396L,54397L,54398L,54399L,54400L,54401L,54402L,54403L,54404L, +54405L,54406L,54407L,54408L,54409L,54410L,54411L,54412L,54413L,54414L, +54415L,54416L,54417L,54418L,54419L,54420L,54421L,54422L,54423L,54424L, +54425L,54426L,54427L,54428L,54429L,54430L,54431L,54432L,54433L,54434L, +54435L,54436L,54437L,54438L,54439L,54440L,54441L,54442L,54443L,54444L, +54445L,54446L,54447L,54448L,54449L,54450L,54451L,54452L,54453L,54454L, +54455L,54456L,54457L,54458L,54459L,54460L,54461L,54462L,54463L,54464L, +54465L,54466L,54467L,54468L,54469L,54470L,54471L,54472L,54473L,54474L, +54475L,54476L,54477L,54478L,54479L,54480L,54481L,54482L,54483L,54484L, +54485L,54486L,54487L,54488L,54489L,54490L,54491L,54492L,54493L,54494L, +54495L,54496L,54497L,54498L,54499L,54500L,54501L,54502L,54503L,54504L, +54505L,54506L,54507L,54508L,54509L,54510L,54511L,54512L,54513L,54514L, +54515L,54516L,54517L,54518L,54519L,54520L,54521L,54522L,54523L,54524L, +54525L,54526L,54527L,54528L,54529L,54530L,54531L,54532L,54533L,54534L, +54535L,54536L,54537L,54538L,54539L,54540L,54541L,54542L,54543L,54544L, +54545L,54546L,54547L,54548L,54549L,54550L,54551L,54552L,54553L,54554L, +54555L,54556L,54557L,54558L,54559L,54560L,54561L,54562L,54563L,54564L, +54565L,54566L,54567L,54568L,54569L,54570L,54571L,54572L,54573L,54574L, +54575L,54576L,54577L,54578L,54579L,54580L,54581L,54582L,54583L,54584L, +54585L,54586L,54587L,54588L,54589L,54590L,54591L,54592L,54593L,54594L, +54595L,54596L,54597L,54598L,54599L,54600L,54601L,54602L,54603L,54604L, +54605L,54606L,54607L,54608L,54609L,54610L,54611L,54612L,54613L,54614L, +54615L,54616L,54617L,54618L,54619L,54620L,54621L,54622L,54623L,54624L, +54625L,54626L,54627L,54628L,54629L,54630L,54631L,54632L,54633L,54634L, +54635L,54636L,54637L,54638L,54639L,54640L,54641L,54642L,54643L,54644L, +54645L,54646L,54647L,54648L,54649L,54650L,54651L,54652L,54653L,54654L, +54655L,54656L,54657L,54658L,54659L,54660L,54661L,54662L,54663L,54664L, +54665L,54666L,54667L,54668L,54669L,54670L,54671L,54672L,54673L,54674L, +54675L,54676L,54677L,54678L,54679L,54680L,54681L,54682L,54683L,54684L, +54685L,54686L,54687L,54688L,54689L,54690L,54691L,54692L,54693L,54694L, +54695L,54696L,54697L,54698L,54699L,54700L,54701L,54702L,54703L,54704L, +54705L,54706L,54707L,54708L,54709L,54710L,54711L,54712L,54713L,54714L, +54715L,54716L,54717L,54718L,54719L,54720L,54721L,54722L,54723L,54724L, +54725L,54726L,54727L,54728L,54729L,54730L,54731L,54732L,54733L,54734L, +54735L,54736L,54737L,54738L,54739L,54740L,54741L,54742L,54743L,54744L, +54745L,54746L,54747L,54748L,54749L,54750L,54751L,54752L,54753L,54754L, +54755L,54756L,54757L,54758L,54759L,54760L,54761L,54762L,54763L,54764L, +54765L,54766L,54767L,54768L,54769L,54770L,54771L,54772L,54773L,54774L, +54775L,54776L,54777L,54778L,54779L,54780L,54781L,54782L,54783L,54784L, +54785L,54786L,54787L,54788L,54789L,54790L,54791L,54792L,54793L,54794L, +54795L,54796L,54797L,54798L,54799L,54800L,54801L,54802L,54803L,54804L, +54805L,54806L,54807L,54808L,54809L,54810L,54811L,54812L,54813L,54814L, +54815L,54816L,54817L,54818L,54819L,54820L,54821L,54822L,54823L,54824L, +54825L,54826L,54827L,54828L,54829L,54830L,54831L,54832L,54833L,54834L, +54835L,54836L,54837L,54838L,54839L,54840L,54841L,54842L,54843L,54844L, +54845L,54846L,54847L,54848L,54849L,54850L,54851L,54852L,54853L,54854L, +54855L,54856L,54857L,54858L,54859L,54860L,54861L,54862L,54863L,54864L, +54865L,54866L,54867L,54868L,54869L,54870L,54871L,54872L,54873L,54874L, +54875L,54876L,54877L,54878L,54879L,54880L,54881L,54882L,54883L,54884L, +54885L,54886L,54887L,54888L,54889L,54890L,54891L,54892L,54893L,54894L, +54895L,54896L,54897L,54898L,54899L,54900L,54901L,54902L,54903L,54904L, +54905L,54906L,54907L,54908L,54909L,54910L,54911L,54912L,54913L,54914L, +54915L,54916L,54917L,54918L,54919L,54920L,54921L,54922L,54923L,54924L, +54925L,54926L,54927L,54928L,54929L,54930L,54931L,54932L,54933L,54934L, +54935L,54936L,54937L,54938L,54939L,54940L,54941L,54942L,54943L,54944L, +54945L,54946L,54947L,54948L,54949L,54950L,54951L,54952L,54953L,54954L, +54955L,54956L,54957L,54958L,54959L,54960L,54961L,54962L,54963L,54964L, +54965L,54966L,54967L,54968L,54969L,54970L,54971L,54972L,54973L,54974L, +54975L,54976L,54977L,54978L,54979L,54980L,54981L,54982L,54983L,54984L, +54985L,54986L,54987L,54988L,54989L,54990L,54991L,54992L,54993L,54994L, +54995L,54996L,54997L,54998L,54999L,55000L,55001L,55002L,55003L,55004L, +55005L,55006L,55007L,55008L,55009L,55010L,55011L,55012L,55013L,55014L, +55015L,55016L,55017L,55018L,55019L,55020L,55021L,55022L,55023L,55024L, +55025L,55026L,55027L,55028L,55029L,55030L,55031L,55032L,55033L,55034L, +55035L,55036L,55037L,55038L,55039L,55040L,55041L,55042L,55043L,55044L, +55045L,55046L,55047L,55048L,55049L,55050L,55051L,55052L,55053L,55054L, +55055L,55056L,55057L,55058L,55059L,55060L,55061L,55062L,55063L,55064L, +55065L,55066L,55067L,55068L,55069L,55070L,55071L,55072L,55073L,55074L, +55075L,55076L,55077L,55078L,55079L,55080L,55081L,55082L,55083L,55084L, +55085L,55086L,55087L,55088L,55089L,55090L,55091L,55092L,55093L,55094L, +55095L,55096L,55097L,55098L,55099L,55100L,55101L,55102L,55103L,55104L, +55105L,55106L,55107L,55108L,55109L,55110L,55111L,55112L,55113L,55114L, +55115L,55116L,55117L,55118L,55119L,55120L,55121L,55122L,55123L,55124L, +55125L,55126L,55127L,55128L,55129L,55130L,55131L,55132L,55133L,55134L, +55135L,55136L,55137L,55138L,55139L,55140L,55141L,55142L,55143L,55144L, +55145L,55146L,55147L,55148L,55149L,55150L,55151L,55152L,55153L,55154L, +55155L,55156L,55157L,55158L,55159L,55160L,55161L,55162L,55163L,55164L, +55165L,55166L,55167L,55168L,55169L,55170L,55171L,55172L,55173L,55174L, +55175L,55176L,55177L,55178L,55179L,55180L,55181L,55182L,55183L,55184L, +55185L,55186L,55187L,55188L,55189L,55190L,55191L,55192L,55193L,55194L, +55195L,55196L,55197L,55198L,55199L,55200L,55201L,55202L,55203L,55204L, +55205L,55206L,55207L,55208L,55209L,55210L,55211L,55212L,55213L,55214L, +55215L,55216L,55217L,55218L,55219L,55220L,55221L,55222L,55223L,55224L, +55225L,55226L,55227L,55228L,55229L,55230L,55231L,55232L,55233L,55234L, +55235L,55236L,55237L,55238L,55239L,55240L,55241L,55242L,55243L,55244L, +55245L,55246L,55247L,55248L,55249L,55250L,55251L,55252L,55253L,55254L, +55255L,55256L,55257L,55258L,55259L,55260L,55261L,55262L,55263L,55264L, +55265L,55266L,55267L,55268L,55269L,55270L,55271L,55272L,55273L,55274L, +55275L,55276L,55277L,55278L,55279L,55280L,55281L,55282L,55283L,55284L, +55285L,55286L,55287L,55288L,55289L,55290L,55291L,55292L,55293L,55294L, +55295L,55296L,55297L,55298L,55299L,55300L,55301L,55302L,55303L,55304L, +55305L,55306L,55307L,55308L,55309L,55310L,55311L,55312L,55313L,55314L, +55315L,55316L,55317L,55318L,55319L,55320L,55321L,55322L,55323L,55324L, +55325L,55326L,55327L,55328L,55329L,55330L,55331L,55332L,55333L,55334L, +55335L,55336L,55337L,55338L,55339L,55340L,55341L,55342L,55343L,55344L, +55345L,55346L,55347L,55348L,55349L,55350L,55351L,55352L,55353L,55354L, +55355L,55356L,55357L,55358L,55359L,55360L,55361L,55362L,55363L,55364L, +55365L,55366L,55367L,55368L,55369L,55370L,55371L,55372L,55373L,55374L, +55375L,55376L,55377L,55378L,55379L,55380L,55381L,55382L,55383L,55384L, +55385L,55386L,55387L,55388L,55389L,55390L,55391L,55392L,55393L,55394L, +55395L,55396L,55397L,55398L,55399L,55400L,55401L,55402L,55403L,55404L, +55405L,55406L,55407L,55408L,55409L,55410L,55411L,55412L,55413L,55414L, +55415L,55416L,55417L,55418L,55419L,55420L,55421L,55422L,55423L,55424L, +55425L,55426L,55427L,55428L,55429L,55430L,55431L,55432L,55433L,55434L, +55435L,55436L,55437L,55438L,55439L,55440L,55441L,55442L,55443L,55444L, +55445L,55446L,55447L,55448L,55449L,55450L,55451L,55452L,55453L,55454L, +55455L,55456L,55457L,55458L,55459L,55460L,55461L,55462L,55463L,55464L, +55465L,55466L,55467L,55468L,55469L,55470L,55471L,55472L,55473L,55474L, +55475L,55476L,55477L,55478L,55479L,55480L,55481L,55482L,55483L,55484L, +55485L,55486L,55487L,55488L,55489L,55490L,55491L,55492L,55493L,55494L, +55495L,55496L,55497L,55498L,55499L,55500L,55501L,55502L,55503L,55504L, +55505L,55506L,55507L,55508L,55509L,55510L,55511L,55512L,55513L,55514L, +55515L,55516L,55517L,55518L,55519L,55520L,55521L,55522L,55523L,55524L, +55525L,55526L,55527L,55528L,55529L,55530L,55531L,55532L,55533L,55534L, +55535L,55536L,55537L,55538L,55539L,55540L,55541L,55542L,55543L,55544L, +55545L,55546L,55547L,55548L,55549L,55550L,55551L,55552L,55553L,55554L, +55555L,55556L,55557L,55558L,55559L,55560L,55561L,55562L,55563L,55564L, +55565L,55566L,55567L,55568L,55569L,55570L,55571L,55572L,55573L,55574L, +55575L,55576L,55577L,55578L,55579L,55580L,55581L,55582L,55583L,55584L, +55585L,55586L,55587L,55588L,55589L,55590L,55591L,55592L,55593L,55594L, +55595L,55596L,55597L,55598L,55599L,55600L,55601L,55602L,55603L,55604L, +55605L,55606L,55607L,55608L,55609L,55610L,55611L,55612L,55613L,55614L, +55615L,55616L,55617L,55618L,55619L,55620L,55621L,55622L,55623L,55624L, +55625L,55626L,55627L,55628L,55629L,55630L,55631L,55632L,55633L,55634L, +55635L,55636L,55637L,55638L,55639L,55640L,55641L,55642L,55643L,55644L, +55645L,55646L,55647L,55648L,55649L,55650L,55651L,55652L,55653L,55654L, +55655L,55656L,55657L,55658L,55659L,55660L,55661L,55662L,55663L,55664L, +55665L,55666L,55667L,55668L,55669L,55670L,55671L,55672L,55673L,55674L, +55675L,55676L,55677L,55678L,55679L,55680L,55681L,55682L,55683L,55684L, +55685L,55686L,55687L,55688L,55689L,55690L,55691L,55692L,55693L,55694L, +55695L,55696L,55697L,55698L,55699L,55700L,55701L,55702L,55703L,55704L, +55705L,55706L,55707L,55708L,55709L,55710L,55711L,55712L,55713L,55714L, +55715L,55716L,55717L,55718L,55719L,55720L,55721L,55722L,55723L,55724L, +55725L,55726L,55727L,55728L,55729L,55730L,55731L,55732L,55733L,55734L, +55735L,55736L,55737L,55738L,55739L,55740L,55741L,55742L,55743L,55744L, +55745L,55746L,55747L,55748L,55749L,55750L,55751L,55752L,55753L,55754L, +55755L,55756L,55757L,55758L,55759L,55760L,55761L,55762L,55763L,55764L, +55765L,55766L,55767L,55768L,55769L,55770L,55771L,55772L,55773L,55774L, +55775L,55776L,55777L,55778L,55779L,55780L,55781L,55782L,55783L,55784L, +55785L,55786L,55787L,55788L,55789L,55790L,55791L,55792L,55793L,55794L, +55795L,55796L,55797L,55798L,55799L,55800L,55801L,55802L,55803L,55804L, +55805L,55806L,55807L,55808L,55809L,55810L,55811L,55812L,55813L,55814L, +55815L,55816L,55817L,55818L,55819L,55820L,55821L,55822L,55823L,55824L, +55825L,55826L,55827L,55828L,55829L,55830L,55831L,55832L,55833L,55834L, +55835L,55836L,55837L,55838L,55839L,55840L,55841L,55842L,55843L,55844L, +55845L,55846L,55847L,55848L,55849L,55850L,55851L,55852L,55853L,55854L, +55855L,55856L,55857L,55858L,55859L,55860L,55861L,55862L,55863L,55864L, +55865L,55866L,55867L,55868L,55869L,55870L,55871L,55872L,55873L,55874L, +55875L,55876L,55877L,55878L,55879L,55880L,55881L,55882L,55883L,55884L, +55885L,55886L,55887L,55888L,55889L,55890L,55891L,55892L,55893L,55894L, +55895L,55896L,55897L,55898L,55899L,55900L,55901L,55902L,55903L,55904L, +55905L,55906L,55907L,55908L,55909L,55910L,55911L,55912L,55913L,55914L, +55915L,55916L,55917L,55918L,55919L,55920L,55921L,55922L,55923L,55924L, +55925L,55926L,55927L,55928L,55929L,55930L,55931L,55932L,55933L,55934L, +55935L,55936L,55937L,55938L,55939L,55940L,55941L,55942L,55943L,55944L, +55945L,55946L,55947L,55948L,55949L,55950L,55951L,55952L,55953L,55954L, +55955L,55956L,55957L,55958L,55959L,55960L,55961L,55962L,55963L,55964L, +55965L,55966L,55967L,55968L,55969L,55970L,55971L,55972L,55973L,55974L, +55975L,55976L,55977L,55978L,55979L,55980L,55981L,55982L,55983L,55984L, +55985L,55986L,55987L,55988L,55989L,55990L,55991L,55992L,55993L,55994L, +55995L,55996L,55997L,55998L,55999L,56000L,56001L,56002L,56003L,56004L, +56005L,56006L,56007L,56008L,56009L,56010L,56011L,56012L,56013L,56014L, +56015L,56016L,56017L,56018L,56019L,56020L,56021L,56022L,56023L,56024L, +56025L,56026L,56027L,56028L,56029L,56030L,56031L,56032L,56033L,56034L, +56035L,56036L,56037L,56038L,56039L,56040L,56041L,56042L,56043L,56044L, +56045L,56046L,56047L,56048L,56049L,56050L,56051L,56052L,56053L,56054L, +56055L,56056L,56057L,56058L,56059L,56060L,56061L,56062L,56063L,56064L, +56065L,56066L,56067L,56068L,56069L,56070L,56071L,56072L,56073L,56074L, +56075L,56076L,56077L,56078L,56079L,56080L,56081L,56082L,56083L,56084L, +56085L,56086L,56087L,56088L,56089L,56090L,56091L,56092L,56093L,56094L, +56095L,56096L,56097L,56098L,56099L,56100L,56101L,56102L,56103L,56104L, +56105L,56106L,56107L,56108L,56109L,56110L,56111L,56112L,56113L,56114L, +56115L,56116L,56117L,56118L,56119L,56120L,56121L,56122L,56123L,56124L, +56125L,56126L,56127L,56128L,56129L,56130L,56131L,56132L,56133L,56134L, +56135L,56136L,56137L,56138L,56139L,56140L,56141L,56142L,56143L,56144L, +56145L,56146L,56147L,56148L,56149L,56150L,56151L,56152L,56153L,56154L, +56155L,56156L,56157L,56158L,56159L,56160L,56161L,56162L,56163L,56164L, +56165L,56166L,56167L,56168L,56169L,56170L,56171L,56172L,56173L,56174L, +56175L,56176L,56177L,56178L,56179L,56180L,56181L,56182L,56183L,56184L, +56185L,56186L,56187L,56188L,56189L,56190L,56191L,56192L,56193L,56194L, +56195L,56196L,56197L,56198L,56199L,56200L,56201L,56202L,56203L,56204L, +56205L,56206L,56207L,56208L,56209L,56210L,56211L,56212L,56213L,56214L, +56215L,56216L,56217L,56218L,56219L,56220L,56221L,56222L,56223L,56224L, +56225L,56226L,56227L,56228L,56229L,56230L,56231L,56232L,56233L,56234L, +56235L,56236L,56237L,56238L,56239L,56240L,56241L,56242L,56243L,56244L, +56245L,56246L,56247L,56248L,56249L,56250L,56251L,56252L,56253L,56254L, +56255L,56256L,56257L,56258L,56259L,56260L,56261L,56262L,56263L,56264L, +56265L,56266L,56267L,56268L,56269L,56270L,56271L,56272L,56273L,56274L, +56275L,56276L,56277L,56278L,56279L,56280L,56281L,56282L,56283L,56284L, +56285L,56286L,56287L,56288L,56289L,56290L,56291L,56292L,56293L,56294L, +56295L,56296L,56297L,56298L,56299L,56300L,56301L,56302L,56303L,56304L, +56305L,56306L,56307L,56308L,56309L,56310L,56311L,56312L,56313L,56314L, +56315L,56316L,56317L,56318L,56319L,56320L,56321L,56322L,56323L,56324L, +56325L,56326L,56327L,56328L,56329L,56330L,56331L,56332L,56333L,56334L, +56335L,56336L,56337L,56338L,56339L,56340L,56341L,56342L,56343L,56344L, +56345L,56346L,56347L,56348L,56349L,56350L,56351L,56352L,56353L,56354L, +56355L,56356L,56357L,56358L,56359L,56360L,56361L,56362L,56363L,56364L, +56365L,56366L,56367L,56368L,56369L,56370L,56371L,56372L,56373L,56374L, +56375L,56376L,56377L,56378L,56379L,56380L,56381L,56382L,56383L,56384L, +56385L,56386L,56387L,56388L,56389L,56390L,56391L,56392L,56393L,56394L, +56395L,56396L,56397L,56398L,56399L,56400L,56401L,56402L,56403L,56404L, +56405L,56406L,56407L,56408L,56409L,56410L,56411L,56412L,56413L,56414L, +56415L,56416L,56417L,56418L,56419L,56420L,56421L,56422L,56423L,56424L, +56425L,56426L,56427L,56428L,56429L,56430L,56431L,56432L,56433L,56434L, +56435L,56436L,56437L,56438L,56439L,56440L,56441L,56442L,56443L,56444L, +56445L,56446L,56447L,56448L,56449L,56450L,56451L,56452L,56453L,56454L, +56455L,56456L,56457L,56458L,56459L,56460L,56461L,56462L,56463L,56464L, +56465L,56466L,56467L,56468L,56469L,56470L,56471L,56472L,56473L,56474L, +56475L,56476L,56477L,56478L,56479L,56480L,56481L,56482L,56483L,56484L, +56485L,56486L,56487L,56488L,56489L,56490L,56491L,56492L,56493L,56494L, +56495L,56496L,56497L,56498L,56499L,56500L,56501L,56502L,56503L,56504L, +56505L,56506L,56507L,56508L,56509L,56510L,56511L,56512L,56513L,56514L, +56515L,56516L,56517L,56518L,56519L,56520L,56521L,56522L,56523L,56524L, +56525L,56526L,56527L,56528L,56529L,56530L,56531L,56532L,56533L,56534L, +56535L,56536L,56537L,56538L,56539L,56540L,56541L,56542L,56543L,56544L, +56545L,56546L,56547L,56548L,56549L,56550L,56551L,56552L,56553L,56554L, +56555L,56556L,56557L,56558L,56559L,56560L,56561L,56562L,56563L,56564L, +56565L,56566L,56567L,56568L,56569L,56570L,56571L,56572L,56573L,56574L, +56575L,56576L,56577L,56578L,56579L,56580L,56581L,56582L,56583L,56584L, +56585L,56586L,56587L,56588L,56589L,56590L,56591L,56592L,56593L,56594L, +56595L,56596L,56597L,56598L,56599L,56600L,56601L,56602L,56603L,56604L, +56605L,56606L,56607L,56608L,56609L,56610L,56611L,56612L,56613L,56614L, +56615L,56616L,56617L,56618L,56619L,56620L,56621L,56622L,56623L,56624L, +56625L,56626L,56627L,56628L,56629L,56630L,56631L,56632L,56633L,56634L, +56635L,56636L,56637L,56638L,56639L,56640L,56641L,56642L,56643L,56644L, +56645L,56646L,56647L,56648L,56649L,56650L,56651L,56652L,56653L,56654L, +56655L,56656L,56657L,56658L,56659L,56660L,56661L,56662L,56663L,56664L, +56665L,56666L,56667L,56668L,56669L,56670L,56671L,56672L,56673L,56674L, +56675L,56676L,56677L,56678L,56679L,56680L,56681L,56682L,56683L,56684L, +56685L,56686L,56687L,56688L,56689L,56690L,56691L,56692L,56693L,56694L, +56695L,56696L,56697L,56698L,56699L,56700L,56701L,56702L,56703L,56704L, +56705L,56706L,56707L,56708L,56709L,56710L,56711L,56712L,56713L,56714L, +56715L,56716L,56717L,56718L,56719L,56720L,56721L,56722L,56723L,56724L, +56725L,56726L,56727L,56728L,56729L,56730L,56731L,56732L,56733L,56734L, +56735L,56736L,56737L,56738L,56739L,56740L,56741L,56742L,56743L,56744L, +56745L,56746L,56747L,56748L,56749L,56750L,56751L,56752L,56753L,56754L, +56755L,56756L,56757L,56758L,56759L,56760L,56761L,56762L,56763L,56764L, +56765L,56766L,56767L,56768L,56769L,56770L,56771L,56772L,56773L,56774L, +56775L,56776L,56777L,56778L,56779L,56780L,56781L,56782L,56783L,56784L, +56785L,56786L,56787L,56788L,56789L,56790L,56791L,56792L,56793L,56794L, +56795L,56796L,56797L,56798L,56799L,56800L,56801L,56802L,56803L,56804L, +56805L,56806L,56807L,56808L,56809L,56810L,56811L,56812L,56813L,56814L, +56815L,56816L,56817L,56818L,56819L,56820L,56821L,56822L,56823L,56824L, +56825L,56826L,56827L,56828L,56829L,56830L,56831L,56832L,56833L,56834L, +56835L,56836L,56837L,56838L,56839L,56840L,56841L,56842L,56843L,56844L, +56845L,56846L,56847L,56848L,56849L,56850L,56851L,56852L,56853L,56854L, +56855L,56856L,56857L,56858L,56859L,56860L,56861L,56862L,56863L,56864L, +56865L,56866L,56867L,56868L,56869L,56870L,56871L,56872L,56873L,56874L, +56875L,56876L,56877L,56878L,56879L,56880L,56881L,56882L,56883L,56884L, +56885L,56886L,56887L,56888L,56889L,56890L,56891L,56892L,56893L,56894L, +56895L,56896L,56897L,56898L,56899L,56900L,56901L,56902L,56903L,56904L, +56905L,56906L,56907L,56908L,56909L,56910L,56911L,56912L,56913L,56914L, +56915L,56916L,56917L,56918L,56919L,56920L,56921L,56922L,56923L,56924L, +56925L,56926L,56927L,56928L,56929L,56930L,56931L,56932L,56933L,56934L, +56935L,56936L,56937L,56938L,56939L,56940L,56941L,56942L,56943L,56944L, +56945L,56946L,56947L,56948L,56949L,56950L,56951L,56952L,56953L,56954L, +56955L,56956L,56957L,56958L,56959L,56960L,56961L,56962L,56963L,56964L, +56965L,56966L,56967L,56968L,56969L,56970L,56971L,56972L,56973L,56974L, +56975L,56976L,56977L,56978L,56979L,56980L,56981L,56982L,56983L,56984L, +56985L,56986L,56987L,56988L,56989L,56990L,56991L,56992L,56993L,56994L, +56995L,56996L,56997L,56998L,56999L,57000L,57001L,57002L,57003L,57004L, +57005L,57006L,57007L,57008L,57009L,57010L,57011L,57012L,57013L,57014L, +57015L,57016L,57017L,57018L,57019L,57020L,57021L,57022L,57023L,57024L, +57025L,57026L,57027L,57028L,57029L,57030L,57031L,57032L,57033L,57034L, +57035L,57036L,57037L,57038L,57039L,57040L,57041L,57042L,57043L,57044L, +57045L,57046L,57047L,57048L,57049L,57050L,57051L,57052L,57053L,57054L, +57055L,57056L,57057L,57058L,57059L,57060L,57061L,57062L,57063L,57064L, +57065L,57066L,57067L,57068L,57069L,57070L,57071L,57072L,57073L,57074L, +57075L,57076L,57077L,57078L,57079L,57080L,57081L,57082L,57083L,57084L, +57085L,57086L,57087L,57088L,57089L,57090L,57091L,57092L,57093L,57094L, +57095L,57096L,57097L,57098L,57099L,57100L,57101L,57102L,57103L,57104L, +57105L,57106L,57107L,57108L,57109L,57110L,57111L,57112L,57113L,57114L, +57115L,57116L,57117L,57118L,57119L,57120L,57121L,57122L,57123L,57124L, +57125L,57126L,57127L,57128L,57129L,57130L,57131L,57132L,57133L,57134L, +57135L,57136L,57137L,57138L,57139L,57140L,57141L,57142L,57143L,57144L, +57145L,57146L,57147L,57148L,57149L,57150L,57151L,57152L,57153L,57154L, +57155L,57156L,57157L,57158L,57159L,57160L,57161L,57162L,57163L,57164L, +57165L,57166L,57167L,57168L,57169L,57170L,57171L,57172L,57173L,57174L, +57175L,57176L,57177L,57178L,57179L,57180L,57181L,57182L,57183L,57184L, +57185L,57186L,57187L,57188L,57189L,57190L,57191L,57192L,57193L,57194L, +57195L,57196L,57197L,57198L,57199L,57200L,57201L,57202L,57203L,57204L, +57205L,57206L,57207L,57208L,57209L,57210L,57211L,57212L,57213L,57214L, +57215L,57216L,57217L,57218L,57219L,57220L,57221L,57222L,57223L,57224L, +57225L,57226L,57227L,57228L,57229L,57230L,57231L,57232L,57233L,57234L, +57235L,57236L,57237L,57238L,57239L,57240L,57241L,57242L,57243L,57244L, +57245L,57246L,57247L,57248L,57249L,57250L,57251L,57252L,57253L,57254L, +57255L,57256L,57257L,57258L,57259L,57260L,57261L,57262L,57263L,57264L, +57265L,57266L,57267L,57268L,57269L,57270L,57271L,57272L,57273L,57274L, +57275L,57276L,57277L,57278L,57279L,57280L,57281L,57282L,57283L,57284L, +57285L,57286L,57287L,57288L,57289L,57290L,57291L,57292L,57293L,57294L, +57295L,57296L,57297L,57298L,57299L,57300L,57301L,57302L,57303L,57304L, +57305L,57306L,57307L,57308L,57309L,57310L,57311L,57312L,57313L,57314L, +57315L,57316L,57317L,57318L,57319L,57320L,57321L,57322L,57323L,57324L, +57325L,57326L,57327L,57328L,57329L,57330L,57331L,57332L,57333L,57334L, +57335L,57336L,57337L,57338L,57339L,57340L,57341L,57342L,57343L,57344L, +57345L,57346L,57347L,57348L,57349L,57350L,57351L,57352L,57353L,57354L, +57355L,57356L,57357L,57358L,57359L,57360L,57361L,57362L,57363L,57364L, +57365L,57366L,57367L,57368L,57369L,57370L,57371L,57372L,57373L,57374L, +57375L,57376L,57377L,57378L,57379L,57380L,57381L,57382L,57383L,57384L, +57385L,57386L,57387L,57388L,57389L,57390L,57391L,57392L,57393L,57394L, +57395L,57396L,57397L,57398L,57399L,57400L,57401L,57402L,57403L,57404L, +57405L,57406L,57407L,57408L,57409L,57410L,57411L,57412L,57413L,57414L, +57415L,57416L,57417L,57418L,57419L,57420L,57421L,57422L,57423L,57424L, +57425L,57426L,57427L,57428L,57429L,57430L,57431L,57432L,57433L,57434L, +57435L,57436L,57437L,57438L,57439L,57440L,57441L,57442L,57443L,57444L, +57445L,57446L,57447L,57448L,57449L,57450L,57451L,57452L,57453L,57454L, +57455L,57456L,57457L,57458L,57459L,57460L,57461L,57462L,57463L,57464L, +57465L,57466L,57467L,57468L,57469L,57470L,57471L,57472L,57473L,57474L, +57475L,57476L,57477L,57478L,57479L,57480L,57481L,57482L,57483L,57484L, +57485L,57486L,57487L,57488L,57489L,57490L,57491L,57492L,57493L,57494L, +57495L,57496L,57497L,57498L,57499L,57500L,57501L,57502L,57503L,57504L, +57505L,57506L,57507L,57508L,57509L,57510L,57511L,57512L,57513L,57514L, +57515L,57516L,57517L,57518L,57519L,57520L,57521L,57522L,57523L,57524L, +57525L,57526L,57527L,57528L,57529L,57530L,57531L,57532L,57533L,57534L, +57535L,57536L,57537L,57538L,57539L,57540L,57541L,57542L,57543L,57544L, +57545L,57546L,57547L,57548L,57549L,57550L,57551L,57552L,57553L,57554L, +57555L,57556L,57557L,57558L,57559L,57560L,57561L,57562L,57563L,57564L, +57565L,57566L,57567L,57568L,57569L,57570L,57571L,57572L,57573L,57574L, +57575L,57576L,57577L,57578L,57579L,57580L,57581L,57582L,57583L,57584L, +57585L,57586L,57587L,57588L,57589L,57590L,57591L,57592L,57593L,57594L, +57595L,57596L,57597L,57598L,57599L,57600L,57601L,57602L,57603L,57604L, +57605L,57606L,57607L,57608L,57609L,57610L,57611L,57612L,57613L,57614L, +57615L,57616L,57617L,57618L,57619L,57620L,57621L,57622L,57623L,57624L, +57625L,57626L,57627L,57628L,57629L,57630L,57631L,57632L,57633L,57634L, +57635L,57636L,57637L,57638L,57639L,57640L,57641L,57642L,57643L,57644L, +57645L,57646L,57647L,57648L,57649L,57650L,57651L,57652L,57653L,57654L, +57655L,57656L,57657L,57658L,57659L,57660L,57661L,57662L,57663L,57664L, +57665L,57666L,57667L,57668L,57669L,57670L,57671L,57672L,57673L,57674L, +57675L,57676L,57677L,57678L,57679L,57680L,57681L,57682L,57683L,57684L, +57685L,57686L,57687L,57688L,57689L,57690L,57691L,57692L,57693L,57694L, +57695L,57696L,57697L,57698L,57699L,57700L,57701L,57702L,57703L,57704L, +57705L,57706L,57707L,57708L,57709L,57710L,57711L,57712L,57713L,57714L, +57715L,57716L,57717L,57718L,57719L,57720L,57721L,57722L,57723L,57724L, +57725L,57726L,57727L,57728L,57729L,57730L,57731L,57732L,57733L,57734L, +57735L,57736L,57737L,57738L,57739L,57740L,57741L,57742L,57743L,57744L, +57745L,57746L,57747L,57748L,57749L,57750L,57751L,57752L,57753L,57754L, +57755L,57756L,57757L,57758L,57759L,57760L,57761L,57762L,57763L,57764L, +57765L,57766L,57767L,57768L,57769L,57770L,57771L,57772L,57773L,57774L, +57775L,57776L,57777L,57778L,57779L,57780L,57781L,57782L,57783L,57784L, +57785L,57786L,57787L,57788L,57789L,57790L,57791L,57792L,57793L,57794L, +57795L,57796L,57797L,57798L,57799L,57800L,57801L,57802L,57803L,57804L, +57805L,57806L,57807L,57808L,57809L,57810L,57811L,57812L,57813L,57814L, +57815L,57816L,57817L,57818L,57819L,57820L,57821L,57822L,57823L,57824L, +57825L,57826L,57827L,57828L,57829L,57830L,57831L,57832L,57833L,57834L, +57835L,57836L,57837L,57838L,57839L,57840L,57841L,57842L,57843L,57844L, +57845L,57846L,57847L,57848L,57849L,57850L,57851L,57852L,57853L,57854L, +57855L,57856L,57857L,57858L,57859L,57860L,57861L,57862L,57863L,57864L, +57865L,57866L,57867L,57868L,57869L,57870L,57871L,57872L,57873L,57874L, +57875L,57876L,57877L,57878L,57879L,57880L,57881L,57882L,57883L,57884L, +57885L,57886L,57887L,57888L,57889L,57890L,57891L,57892L,57893L,57894L, +57895L,57896L,57897L,57898L,57899L,57900L,57901L,57902L,57903L,57904L, +57905L,57906L,57907L,57908L,57909L,57910L,57911L,57912L,57913L,57914L, +57915L,57916L,57917L,57918L,57919L,57920L,57921L,57922L,57923L,57924L, +57925L,57926L,57927L,57928L,57929L,57930L,57931L,57932L,57933L,57934L, +57935L,57936L,57937L,57938L,57939L,57940L,57941L,57942L,57943L,57944L, +57945L,57946L,57947L,57948L,57949L,57950L,57951L,57952L,57953L,57954L, +57955L,57956L,57957L,57958L,57959L,57960L,57961L,57962L,57963L,57964L, +57965L,57966L,57967L,57968L,57969L,57970L,57971L,57972L,57973L,57974L, +57975L,57976L,57977L,57978L,57979L,57980L,57981L,57982L,57983L,57984L, +57985L,57986L,57987L,57988L,57989L,57990L,57991L,57992L,57993L,57994L, +57995L,57996L,57997L,57998L,57999L,58000L,58001L,58002L,58003L,58004L, +58005L,58006L,58007L,58008L,58009L,58010L,58011L,58012L,58013L,58014L, +58015L,58016L,58017L,58018L,58019L,58020L,58021L,58022L,58023L,58024L, +58025L,58026L,58027L,58028L,58029L,58030L,58031L,58032L,58033L,58034L, +58035L,58036L,58037L,58038L,58039L,58040L,58041L,58042L,58043L,58044L, +58045L,58046L,58047L,58048L,58049L,58050L,58051L,58052L,58053L,58054L, +58055L,58056L,58057L,58058L,58059L,58060L,58061L,58062L,58063L,58064L, +58065L,58066L,58067L,58068L,58069L,58070L,58071L,58072L,58073L,58074L, +58075L,58076L,58077L,58078L,58079L,58080L,58081L,58082L,58083L,58084L, +58085L,58086L,58087L,58088L,58089L,58090L,58091L,58092L,58093L,58094L, +58095L,58096L,58097L,58098L,58099L,58100L,58101L,58102L,58103L,58104L, +58105L,58106L,58107L,58108L,58109L,58110L,58111L,58112L,58113L,58114L, +58115L,58116L,58117L,58118L,58119L,58120L,58121L,58122L,58123L,58124L, +58125L,58126L,58127L,58128L,58129L,58130L,58131L,58132L,58133L,58134L, +58135L,58136L,58137L,58138L,58139L,58140L,58141L,58142L,58143L,58144L, +58145L,58146L,58147L,58148L,58149L,58150L,58151L,58152L,58153L,58154L, +58155L,58156L,58157L,58158L,58159L,58160L,58161L,58162L,58163L,58164L, +58165L,58166L,58167L,58168L,58169L,58170L,58171L,58172L,58173L,58174L, +58175L,58176L,58177L,58178L,58179L,58180L,58181L,58182L,58183L,58184L, +58185L,58186L,58187L,58188L,58189L,58190L,58191L,58192L,58193L,58194L, +58195L,58196L,58197L,58198L,58199L,58200L,58201L,58202L,58203L,58204L, +58205L,58206L,58207L,58208L,58209L,58210L,58211L,58212L,58213L,58214L, +58215L,58216L,58217L,58218L,58219L,58220L,58221L,58222L,58223L,58224L, +58225L,58226L,58227L,58228L,58229L,58230L,58231L,58232L,58233L,58234L, +58235L,58236L,58237L,58238L,58239L,58240L,58241L,58242L,58243L,58244L, +58245L,58246L,58247L,58248L,58249L,58250L,58251L,58252L,58253L,58254L, +58255L,58256L,58257L,58258L,58259L,58260L,58261L,58262L,58263L,58264L, +58265L,58266L,58267L,58268L,58269L,58270L,58271L,58272L,58273L,58274L, +58275L,58276L,58277L,58278L,58279L,58280L,58281L,58282L,58283L,58284L, +58285L,58286L,58287L,58288L,58289L,58290L,58291L,58292L,58293L,58294L, +58295L,58296L,58297L,58298L,58299L,58300L,58301L,58302L,58303L,58304L, +58305L,58306L,58307L,58308L,58309L,58310L,58311L,58312L,58313L,58314L, +58315L,58316L,58317L,58318L,58319L,58320L,58321L,58322L,58323L,58324L, +58325L,58326L,58327L,58328L,58329L,58330L,58331L,58332L,58333L,58334L, +58335L,58336L,58337L,58338L,58339L,58340L,58341L,58342L,58343L,58344L, +58345L,58346L,58347L,58348L,58349L,58350L,58351L,58352L,58353L,58354L, +58355L,58356L,58357L,58358L,58359L,58360L,58361L,58362L,58363L,58364L, +58365L,58366L,58367L,58368L,58369L,58370L,58371L,58372L,58373L,58374L, +58375L,58376L,58377L,58378L,58379L,58380L,58381L,58382L,58383L,58384L, +58385L,58386L,58387L,58388L,58389L,58390L,58391L,58392L,58393L,58394L, +58395L,58396L,58397L,58398L,58399L,58400L,58401L,58402L,58403L,58404L, +58405L,58406L,58407L,58408L,58409L,58410L,58411L,58412L,58413L,58414L, +58415L,58416L,58417L,58418L,58419L,58420L,58421L,58422L,58423L,58424L, +58425L,58426L,58427L,58428L,58429L,58430L,58431L,58432L,58433L,58434L, +58435L,58436L,58437L,58438L,58439L,58440L,58441L,58442L,58443L,58444L, +58445L,58446L,58447L,58448L,58449L,58450L,58451L,58452L,58453L,58454L, +58455L,58456L,58457L,58458L,58459L,58460L,58461L,58462L,58463L,58464L, +58465L,58466L,58467L,58468L,58469L,58470L,58471L,58472L,58473L,58474L, +58475L,58476L,58477L,58478L,58479L,58480L,58481L,58482L,58483L,58484L, +58485L,58486L,58487L,58488L,58489L,58490L,58491L,58492L,58493L,58494L, +58495L,58496L,58497L,58498L,58499L,58500L,58501L,58502L,58503L,58504L, +58505L,58506L,58507L,58508L,58509L,58510L,58511L,58512L,58513L,58514L, +58515L,58516L,58517L,58518L,58519L,58520L,58521L,58522L,58523L,58524L, +58525L,58526L,58527L,58528L,58529L,58530L,58531L,58532L,58533L,58534L, +58535L,58536L,58537L,58538L,58539L,58540L,58541L,58542L,58543L,58544L, +58545L,58546L,58547L,58548L,58549L,58550L,58551L,58552L,58553L,58554L, +58555L,58556L,58557L,58558L,58559L,58560L,58561L,58562L,58563L,58564L, +58565L,58566L,58567L,58568L,58569L,58570L,58571L,58572L,58573L,58574L, +58575L,58576L,58577L,58578L,58579L,58580L,58581L,58582L,58583L,58584L, +58585L,58586L,58587L,58588L,58589L,58590L,58591L,58592L,58593L,58594L, +58595L,58596L,58597L,58598L,58599L,58600L,58601L,58602L,58603L,58604L, +58605L,58606L,58607L,58608L,58609L,58610L,58611L,58612L,58613L,58614L, +58615L,58616L,58617L,58618L,58619L,58620L,58621L,58622L,58623L,58624L, +58625L,58626L,58627L,58628L,58629L,58630L,58631L,58632L,58633L,58634L, +58635L,58636L,58637L,58638L,58639L,58640L,58641L,58642L,58643L,58644L, +58645L,58646L,58647L,58648L,58649L,58650L,58651L,58652L,58653L,58654L, +58655L,58656L,58657L,58658L,58659L,58660L,58661L,58662L,58663L,58664L, +58665L,58666L,58667L,58668L,58669L,58670L,58671L,58672L,58673L,58674L, +58675L,58676L,58677L,58678L,58679L,58680L,58681L,58682L,58683L,58684L, +58685L,58686L,58687L,58688L,58689L,58690L,58691L,58692L,58693L,58694L, +58695L,58696L,58697L,58698L,58699L,58700L,58701L,58702L,58703L,58704L, +58705L,58706L,58707L,58708L,58709L,58710L,58711L,58712L,58713L,58714L, +58715L,58716L,58717L,58718L,58719L,58720L,58721L,58722L,58723L,58724L, +58725L,58726L,58727L,58728L,58729L,58730L,58731L,58732L,58733L,58734L, +58735L,58736L,58737L,58738L,58739L,58740L,58741L,58742L,58743L,58744L, +58745L,58746L,58747L,58748L,58749L,58750L,58751L,58752L,58753L,58754L, +58755L,58756L,58757L,58758L,58759L,58760L,58761L,58762L,58763L,58764L, +58765L,58766L,58767L,58768L,58769L,58770L,58771L,58772L,58773L,58774L, +58775L,58776L,58777L,58778L,58779L,58780L,58781L,58782L,58783L,58784L, +58785L,58786L,58787L,58788L,58789L,58790L,58791L,58792L,58793L,58794L, +58795L,58796L,58797L,58798L,58799L,58800L,58801L,58802L,58803L,58804L, +58805L,58806L,58807L,58808L,58809L,58810L,58811L,58812L,58813L,58814L, +58815L,58816L,58817L,58818L,58819L,58820L,58821L,58822L,58823L,58824L, +58825L,58826L,58827L,58828L,58829L,58830L,58831L,58832L,58833L,58834L, +58835L,58836L,58837L,58838L,58839L,58840L,58841L,58842L,58843L,58844L, +58845L,58846L,58847L,58848L,58849L,58850L,58851L,58852L,58853L,58854L, +58855L,58856L,58857L,58858L,58859L,58860L,58861L,58862L,58863L,58864L, +58865L,58866L,58867L,58868L,58869L,58870L,58871L,58872L,58873L,58874L, +58875L,58876L,58877L,58878L,58879L,58880L,58881L,58882L,58883L,58884L, +58885L,58886L,58887L,58888L,58889L,58890L,58891L,58892L,58893L,58894L, +58895L,58896L,58897L,58898L,58899L,58900L,58901L,58902L,58903L,58904L, +58905L,58906L,58907L,58908L,58909L,58910L,58911L,58912L,58913L,58914L, +58915L,58916L,58917L,58918L,58919L,58920L,58921L,58922L,58923L,58924L, +58925L,58926L,58927L,58928L,58929L,58930L,58931L,58932L,58933L,58934L, +58935L,58936L,58937L,58938L,58939L,58940L,58941L,58942L,58943L,58944L, +58945L,58946L,58947L,58948L,58949L,58950L,58951L,58952L,58953L,58954L, +58955L,58956L,58957L,58958L,58959L,58960L,58961L,58962L,58963L,58964L, +58965L,58966L,58967L,58968L,58969L,58970L,58971L,58972L,58973L,58974L, +58975L,58976L,58977L,58978L,58979L,58980L,58981L,58982L,58983L,58984L, +58985L,58986L,58987L,58988L,58989L,58990L,58991L,58992L,58993L,58994L, +58995L,58996L,58997L,58998L,58999L,59000L,59001L,59002L,59003L,59004L, +59005L,59006L,59007L,59008L,59009L,59010L,59011L,59012L,59013L,59014L, +59015L,59016L,59017L,59018L,59019L,59020L,59021L,59022L,59023L,59024L, +59025L,59026L,59027L,59028L,59029L,59030L,59031L,59032L,59033L,59034L, +59035L,59036L,59037L,59038L,59039L,59040L,59041L,59042L,59043L,59044L, +59045L,59046L,59047L,59048L,59049L,59050L,59051L,59052L,59053L,59054L, +59055L,59056L,59057L,59058L,59059L,59060L,59061L,59062L,59063L,59064L, +59065L,59066L,59067L,59068L,59069L,59070L,59071L,59072L,59073L,59074L, +59075L,59076L,59077L,59078L,59079L,59080L,59081L,59082L,59083L,59084L, +59085L,59086L,59087L,59088L,59089L,59090L,59091L,59092L,59093L,59094L, +59095L,59096L,59097L,59098L,59099L,59100L,59101L,59102L,59103L,59104L, +59105L,59106L,59107L,59108L,59109L,59110L,59111L,59112L,59113L,59114L, +59115L,59116L,59117L,59118L,59119L,59120L,59121L,59122L,59123L,59124L, +59125L,59126L,59127L,59128L,59129L,59130L,59131L,59132L,59133L,59134L, +59135L,59136L,59137L,59138L,59139L,59140L,59141L,59142L,59143L,59144L, +59145L,59146L,59147L,59148L,59149L,59150L,59151L,59152L,59153L,59154L, +59155L,59156L,59157L,59158L,59159L,59160L,59161L,59162L,59163L,59164L, +59165L,59166L,59167L,59168L,59169L,59170L,59171L,59172L,59173L,59174L, +59175L,59176L,59177L,59178L,59179L,59180L,59181L,59182L,59183L,59184L, +59185L,59186L,59187L,59188L,59189L,59190L,59191L,59192L,59193L,59194L, +59195L,59196L,59197L,59198L,59199L,59200L,59201L,59202L,59203L,59204L, +59205L,59206L,59207L,59208L,59209L,59210L,59211L,59212L,59213L,59214L, +59215L,59216L,59217L,59218L,59219L,59220L,59221L,59222L,59223L,59224L, +59225L,59226L,59227L,59228L,59229L,59230L,59231L,59232L,59233L,59234L, +59235L,59236L,59237L,59238L,59239L,59240L,59241L,59242L,59243L,59244L, +59245L,59246L,59247L,59248L,59249L,59250L,59251L,59252L,59253L,59254L, +59255L,59256L,59257L,59258L,59259L,59260L,59261L,59262L,59263L,59264L, +59265L,59266L,59267L,59268L,59269L,59270L,59271L,59272L,59273L,59274L, +59275L,59276L,59277L,59278L,59279L,59280L,59281L,59282L,59283L,59284L, +59285L,59286L,59287L,59288L,59289L,59290L,59291L,59292L,59293L,59294L, +59295L,59296L,59297L,59298L,59299L,59300L,59301L,59302L,59303L,59304L, +59305L,59306L,59307L,59308L,59309L,59310L,59311L,59312L,59313L,59314L, +59315L,59316L,59317L,59318L,59319L,59320L,59321L,59322L,59323L,59324L, +59325L,59326L,59327L,59328L,59329L,59330L,59331L,59332L,59333L,59334L, +59335L,59336L,59337L,59338L,59339L,59340L,59341L,59342L,59343L,59344L, +59345L,59346L,59347L,59348L,59349L,59350L,59351L,59352L,59353L,59354L, +59355L,59356L,59357L,59358L,59359L,59360L,59361L,59362L,59363L,59364L, +59365L,59366L,59367L,59368L,59369L,59370L,59371L,59372L,59373L,59374L, +59375L,59376L,59377L,59378L,59379L,59380L,59381L,59382L,59383L,59384L, +59385L,59386L,59387L,59388L,59389L,59390L,59391L,59392L,59393L,59394L, +59395L,59396L,59397L,59398L,59399L,59400L,59401L,59402L,59403L,59404L, +59405L,59406L,59407L,59408L,59409L,59410L,59411L,59412L,59413L,59414L, +59415L,59416L,59417L,59418L,59419L,59420L,59421L,59422L,59423L,59424L, +59425L,59426L,59427L,59428L,59429L,59430L,59431L,59432L,59433L,59434L, +59435L,59436L,59437L,59438L,59439L,59440L,59441L,59442L,59443L,59444L, +59445L,59446L,59447L,59448L,59449L,59450L,59451L,59452L,59453L,59454L, +59455L,59456L,59457L,59458L,59459L,59460L,59461L,59462L,59463L,59464L, +59465L,59466L,59467L,59468L,59469L,59470L,59471L,59472L,59473L,59474L, +59475L,59476L,59477L,59478L,59479L,59480L,59481L,59482L,59483L,59484L, +59485L,59486L,59487L,59488L,59489L,59490L,59491L,59492L,59493L,59494L, +59495L,59496L,59497L,59498L,59499L,59500L,59501L,59502L,59503L,59504L, +59505L,59506L,59507L,59508L,59509L,59510L,59511L,59512L,59513L,59514L, +59515L,59516L,59517L,59518L,59519L,59520L,59521L,59522L,59523L,59524L, +59525L,59526L,59527L,59528L,59529L,59530L,59531L,59532L,59533L,59534L, +59535L,59536L,59537L,59538L,59539L,59540L,59541L,59542L,59543L,59544L, +59545L,59546L,59547L,59548L,59549L,59550L,59551L,59552L,59553L,59554L, +59555L,59556L,59557L,59558L,59559L,59560L,59561L,59562L,59563L,59564L, +59565L,59566L,59567L,59568L,59569L,59570L,59571L,59572L,59573L,59574L, +59575L,59576L,59577L,59578L,59579L,59580L,59581L,59582L,59583L,59584L, +59585L,59586L,59587L,59588L,59589L,59590L,59591L,59592L,59593L,59594L, +59595L,59596L,59597L,59598L,59599L,59600L,59601L,59602L,59603L,59604L, +59605L,59606L,59607L,59608L,59609L,59610L,59611L,59612L,59613L,59614L, +59615L,59616L,59617L,59618L,59619L,59620L,59621L,59622L,59623L,59624L, +59625L,59626L,59627L,59628L,59629L,59630L,59631L,59632L,59633L,59634L, +59635L,59636L,59637L,59638L,59639L,59640L,59641L,59642L,59643L,59644L, +59645L,59646L,59647L,59648L,59649L,59650L,59651L,59652L,59653L,59654L, +59655L,59656L,59657L,59658L,59659L,59660L,59661L,59662L,59663L,59664L, +59665L,59666L,59667L,59668L,59669L,59670L,59671L,59672L,59673L,59674L, +59675L,59676L,59677L,59678L,59679L,59680L,59681L,59682L,59683L,59684L, +59685L,59686L,59687L,59688L,59689L,59690L,59691L,59692L,59693L,59694L, +59695L,59696L,59697L,59698L,59699L,59700L,59701L,59702L,59703L,59704L, +59705L,59706L,59707L,59708L,59709L,59710L,59711L,59712L,59713L,59714L, +59715L,59716L,59717L,59718L,59719L,59720L,59721L,59722L,59723L,59724L, +59725L,59726L,59727L,59728L,59729L,59730L,59731L,59732L,59733L,59734L, +59735L,59736L,59737L,59738L,59739L,59740L,59741L,59742L,59743L,59744L, +59745L,59746L,59747L,59748L,59749L,59750L,59751L,59752L,59753L,59754L, +59755L,59756L,59757L,59758L,59759L,59760L,59761L,59762L,59763L,59764L, +59765L,59766L,59767L,59768L,59769L,59770L,59771L,59772L,59773L,59774L, +59775L,59776L,59777L,59778L,59779L,59780L,59781L,59782L,59783L,59784L, +59785L,59786L,59787L,59788L,59789L,59790L,59791L,59792L,59793L,59794L, +59795L,59796L,59797L,59798L,59799L,59800L,59801L,59802L,59803L,59804L, +59805L,59806L,59807L,59808L,59809L,59810L,59811L,59812L,59813L,59814L, +59815L,59816L,59817L,59818L,59819L,59820L,59821L,59822L,59823L,59824L, +59825L,59826L,59827L,59828L,59829L,59830L,59831L,59832L,59833L,59834L, +59835L,59836L,59837L,59838L,59839L,59840L,59841L,59842L,59843L,59844L, +59845L,59846L,59847L,59848L,59849L,59850L,59851L,59852L,59853L,59854L, +59855L,59856L,59857L,59858L,59859L,59860L,59861L,59862L,59863L,59864L, +59865L,59866L,59867L,59868L,59869L,59870L,59871L,59872L,59873L,59874L, +59875L,59876L,59877L,59878L,59879L,59880L,59881L,59882L,59883L,59884L, +59885L,59886L,59887L,59888L,59889L,59890L,59891L,59892L,59893L,59894L, +59895L,59896L,59897L,59898L,59899L,59900L,59901L,59902L,59903L,59904L, +59905L,59906L,59907L,59908L,59909L,59910L,59911L,59912L,59913L,59914L, +59915L,59916L,59917L,59918L,59919L,59920L,59921L,59922L,59923L,59924L, +59925L,59926L,59927L,59928L,59929L,59930L,59931L,59932L,59933L,59934L, +59935L,59936L,59937L,59938L,59939L,59940L,59941L,59942L,59943L,59944L, +59945L,59946L,59947L,59948L,59949L,59950L,59951L,59952L,59953L,59954L, +59955L,59956L,59957L,59958L,59959L,59960L,59961L,59962L,59963L,59964L, +59965L,59966L,59967L,59968L,59969L,59970L,59971L,59972L,59973L,59974L, +59975L,59976L,59977L,59978L,59979L,59980L,59981L,59982L,59983L,59984L, +59985L,59986L,59987L,59988L,59989L,59990L,59991L,59992L,59993L,59994L, +59995L,59996L,59997L,59998L,59999L,60000L,60001L,60002L,60003L,60004L, +60005L,60006L,60007L,60008L,60009L,60010L,60011L,60012L,60013L,60014L, +60015L,60016L,60017L,60018L,60019L,60020L,60021L,60022L,60023L,60024L, +60025L,60026L,60027L,60028L,60029L,60030L,60031L,60032L,60033L,60034L, +60035L,60036L,60037L,60038L,60039L,60040L,60041L,60042L,60043L,60044L, +60045L,60046L,60047L,60048L,60049L,60050L,60051L,60052L,60053L,60054L, +60055L,60056L,60057L,60058L,60059L,60060L,60061L,60062L,60063L,60064L, +60065L,60066L,60067L,60068L,60069L,60070L,60071L,60072L,60073L,60074L, +60075L,60076L,60077L,60078L,60079L,60080L,60081L,60082L,60083L,60084L, +60085L,60086L,60087L,60088L,60089L,60090L,60091L,60092L,60093L,60094L, +60095L,60096L,60097L,60098L,60099L,60100L,60101L,60102L,60103L,60104L, +60105L,60106L,60107L,60108L,60109L,60110L,60111L,60112L,60113L,60114L, +60115L,60116L,60117L,60118L,60119L,60120L,60121L,60122L,60123L,60124L, +60125L,60126L,60127L,60128L,60129L,60130L,60131L,60132L,60133L,60134L, +60135L,60136L,60137L,60138L,60139L,60140L,60141L,60142L,60143L,60144L, +60145L,60146L,60147L,60148L,60149L,60150L,60151L,60152L,60153L,60154L, +60155L,60156L,60157L,60158L,60159L,60160L,60161L,60162L,60163L,60164L, +60165L,60166L,60167L,60168L,60169L,60170L,60171L,60172L,60173L,60174L, +60175L,60176L,60177L,60178L,60179L,60180L,60181L,60182L,60183L,60184L, +60185L,60186L,60187L,60188L,60189L,60190L,60191L,60192L,60193L,60194L, +60195L,60196L,60197L,60198L,60199L,60200L,60201L,60202L,60203L,60204L, +60205L,60206L,60207L,60208L,60209L,60210L,60211L,60212L,60213L,60214L, +60215L,60216L,60217L,60218L,60219L,60220L,60221L,60222L,60223L,60224L, +60225L,60226L,60227L,60228L,60229L,60230L,60231L,60232L,60233L,60234L, +60235L,60236L,60237L,60238L,60239L,60240L,60241L,60242L,60243L,60244L, +60245L,60246L,60247L,60248L,60249L,60250L,60251L,60252L,60253L,60254L, +60255L,60256L,60257L,60258L,60259L,60260L,60261L,60262L,60263L,60264L, +60265L,60266L,60267L,60268L,60269L,60270L,60271L,60272L,60273L,60274L, +60275L,60276L,60277L,60278L,60279L,60280L,60281L,60282L,60283L,60284L, +60285L,60286L,60287L,60288L,60289L,60290L,60291L,60292L,60293L,60294L, +60295L,60296L,60297L,60298L,60299L,60300L,60301L,60302L,60303L,60304L, +60305L,60306L,60307L,60308L,60309L,60310L,60311L,60312L,60313L,60314L, +60315L,60316L,60317L,60318L,60319L,60320L,60321L,60322L,60323L,60324L, +60325L,60326L,60327L,60328L,60329L,60330L,60331L,60332L,60333L,60334L, +60335L,60336L,60337L,60338L,60339L,60340L,60341L,60342L,60343L,60344L, +60345L,60346L,60347L,60348L,60349L,60350L,60351L,60352L,60353L,60354L, +60355L,60356L,60357L,60358L,60359L,60360L,60361L,60362L,60363L,60364L, +60365L,60366L,60367L,60368L,60369L,60370L,60371L,60372L,60373L,60374L, +60375L,60376L,60377L,60378L,60379L,60380L,60381L,60382L,60383L,60384L, +60385L,60386L,60387L,60388L,60389L,60390L,60391L,60392L,60393L,60394L, +60395L,60396L,60397L,60398L,60399L,60400L,60401L,60402L,60403L,60404L, +60405L,60406L,60407L,60408L,60409L,60410L,60411L,60412L,60413L,60414L, +60415L,60416L,60417L,60418L,60419L,60420L,60421L,60422L,60423L,60424L, +60425L,60426L,60427L,60428L,60429L,60430L,60431L,60432L,60433L,60434L, +60435L,60436L,60437L,60438L,60439L,60440L,60441L,60442L,60443L,60444L, +60445L,60446L,60447L,60448L,60449L,60450L,60451L,60452L,60453L,60454L, +60455L,60456L,60457L,60458L,60459L,60460L,60461L,60462L,60463L,60464L, +60465L,60466L,60467L,60468L,60469L,60470L,60471L,60472L,60473L,60474L, +60475L,60476L,60477L,60478L,60479L,60480L,60481L,60482L,60483L,60484L, +60485L,60486L,60487L,60488L,60489L,60490L,60491L,60492L,60493L,60494L, +60495L,60496L,60497L,60498L,60499L,60500L,60501L,60502L,60503L,60504L, +60505L,60506L,60507L,60508L,60509L,60510L,60511L,60512L,60513L,60514L, +60515L,60516L,60517L,60518L,60519L,60520L,60521L,60522L,60523L,60524L, +60525L,60526L,60527L,60528L,60529L,60530L,60531L,60532L,60533L,60534L, +60535L,60536L,60537L,60538L,60539L,60540L,60541L,60542L,60543L,60544L, +60545L,60546L,60547L,60548L,60549L,60550L,60551L,60552L,60553L,60554L, +60555L,60556L,60557L,60558L,60559L,60560L,60561L,60562L,60563L,60564L, +60565L,60566L,60567L,60568L,60569L,60570L,60571L,60572L,60573L,60574L, +60575L,60576L,60577L,60578L,60579L,60580L,60581L,60582L,60583L,60584L, +60585L,60586L,60587L,60588L,60589L,60590L,60591L,60592L,60593L,60594L, +60595L,60596L,60597L,60598L,60599L,60600L,60601L,60602L,60603L,60604L, +60605L,60606L,60607L,60608L,60609L,60610L,60611L,60612L,60613L,60614L, +60615L,60616L,60617L,60618L,60619L,60620L,60621L,60622L,60623L,60624L, +60625L,60626L,60627L,60628L,60629L,60630L,60631L,60632L,60633L,60634L, +60635L,60636L,60637L,60638L,60639L,60640L,60641L,60642L,60643L,60644L, +60645L,60646L,60647L,60648L,60649L,60650L,60651L,60652L,60653L,60654L, +60655L,60656L,60657L,60658L,60659L,60660L,60661L,60662L,60663L,60664L, +60665L,60666L,60667L,60668L,60669L,60670L,60671L,60672L,60673L,60674L, +60675L,60676L,60677L,60678L,60679L,60680L,60681L,60682L,60683L,60684L, +60685L,60686L,60687L,60688L,60689L,60690L,60691L,60692L,60693L,60694L, +60695L,60696L,60697L,60698L,60699L,60700L,60701L,60702L,60703L,60704L, +60705L,60706L,60707L,60708L,60709L,60710L,60711L,60712L,60713L,60714L, +60715L,60716L,60717L,60718L,60719L,60720L,60721L,60722L,60723L,60724L, +60725L,60726L,60727L,60728L,60729L,60730L,60731L,60732L,60733L,60734L, +60735L,60736L,60737L,60738L,60739L,60740L,60741L,60742L,60743L,60744L, +60745L,60746L,60747L,60748L,60749L,60750L,60751L,60752L,60753L,60754L, +60755L,60756L,60757L,60758L,60759L,60760L,60761L,60762L,60763L,60764L, +60765L,60766L,60767L,60768L,60769L,60770L,60771L,60772L,60773L,60774L, +60775L,60776L,60777L,60778L,60779L,60780L,60781L,60782L,60783L,60784L, +60785L,60786L,60787L,60788L,60789L,60790L,60791L,60792L,60793L,60794L, +60795L,60796L,60797L,60798L,60799L,60800L,60801L,60802L,60803L,60804L, +60805L,60806L,60807L,60808L,60809L,60810L,60811L,60812L,60813L,60814L, +60815L,60816L,60817L,60818L,60819L,60820L,60821L,60822L,60823L,60824L, +60825L,60826L,60827L,60828L,60829L,60830L,60831L,60832L,60833L,60834L, +60835L,60836L,60837L,60838L,60839L,60840L,60841L,60842L,60843L,60844L, +60845L,60846L,60847L,60848L,60849L,60850L,60851L,60852L,60853L,60854L, +60855L,60856L,60857L,60858L,60859L,60860L,60861L,60862L,60863L,60864L, +60865L,60866L,60867L,60868L,60869L,60870L,60871L,60872L,60873L,60874L, +60875L,60876L,60877L,60878L,60879L,60880L,60881L,60882L,60883L,60884L, +60885L,60886L,60887L,60888L,60889L,60890L,60891L,60892L,60893L,60894L, +60895L,60896L,60897L,60898L,60899L,60900L,60901L,60902L,60903L,60904L, +60905L,60906L,60907L,60908L,60909L,60910L,60911L,60912L,60913L,60914L, +60915L,60916L,60917L,60918L,60919L,60920L,60921L,60922L,60923L,60924L, +60925L,60926L,60927L,60928L,60929L,60930L,60931L,60932L,60933L,60934L, +60935L,60936L,60937L,60938L,60939L,60940L,60941L,60942L,60943L,60944L, +60945L,60946L,60947L,60948L,60949L,60950L,60951L,60952L,60953L,60954L, +60955L,60956L,60957L,60958L,60959L,60960L,60961L,60962L,60963L,60964L, +60965L,60966L,60967L,60968L,60969L,60970L,60971L,60972L,60973L,60974L, +60975L,60976L,60977L,60978L,60979L,60980L,60981L,60982L,60983L,60984L, +60985L,60986L,60987L,60988L,60989L,60990L,60991L,60992L,60993L,60994L, +60995L,60996L,60997L,60998L,60999L,61000L,61001L,61002L,61003L,61004L, +61005L,61006L,61007L,61008L,61009L,61010L,61011L,61012L,61013L,61014L, +61015L,61016L,61017L,61018L,61019L,61020L,61021L,61022L,61023L,61024L, +61025L,61026L,61027L,61028L,61029L,61030L,61031L,61032L,61033L,61034L, +61035L,61036L,61037L,61038L,61039L,61040L,61041L,61042L,61043L,61044L, +61045L,61046L,61047L,61048L,61049L,61050L,61051L,61052L,61053L,61054L, +61055L,61056L,61057L,61058L,61059L,61060L,61061L,61062L,61063L,61064L, +61065L,61066L,61067L,61068L,61069L,61070L,61071L,61072L,61073L,61074L, +61075L,61076L,61077L,61078L,61079L,61080L,61081L,61082L,61083L,61084L, +61085L,61086L,61087L,61088L,61089L,61090L,61091L,61092L,61093L,61094L, +61095L,61096L,61097L,61098L,61099L,61100L,61101L,61102L,61103L,61104L, +61105L,61106L,61107L,61108L,61109L,61110L,61111L,61112L,61113L,61114L, +61115L,61116L,61117L,61118L,61119L,61120L,61121L,61122L,61123L,61124L, +61125L,61126L,61127L,61128L,61129L,61130L,61131L,61132L,61133L,61134L, +61135L,61136L,61137L,61138L,61139L,61140L,61141L,61142L,61143L,61144L, +61145L,61146L,61147L,61148L,61149L,61150L,61151L,61152L,61153L,61154L, +61155L,61156L,61157L,61158L,61159L,61160L,61161L,61162L,61163L,61164L, +61165L,61166L,61167L,61168L,61169L,61170L,61171L,61172L,61173L,61174L, +61175L,61176L,61177L,61178L,61179L,61180L,61181L,61182L,61183L,61184L, +61185L,61186L,61187L,61188L,61189L,61190L,61191L,61192L,61193L,61194L, +61195L,61196L,61197L,61198L,61199L,61200L,61201L,61202L,61203L,61204L, +61205L,61206L,61207L,61208L,61209L,61210L,61211L,61212L,61213L,61214L, +61215L,61216L,61217L,61218L,61219L,61220L,61221L,61222L,61223L,61224L, +61225L,61226L,61227L,61228L,61229L,61230L,61231L,61232L,61233L,61234L, +61235L,61236L,61237L,61238L,61239L,61240L,61241L,61242L,61243L,61244L, +61245L,61246L,61247L,61248L,61249L,61250L,61251L,61252L,61253L,61254L, +61255L,61256L,61257L,61258L,61259L,61260L,61261L,61262L,61263L,61264L, +61265L,61266L,61267L,61268L,61269L,61270L,61271L,61272L,61273L,61274L, +61275L,61276L,61277L,61278L,61279L,61280L,61281L,61282L,61283L,61284L, +61285L,61286L,61287L,61288L,61289L,61290L,61291L,61292L,61293L,61294L, +61295L,61296L,61297L,61298L,61299L,61300L,61301L,61302L,61303L,61304L, +61305L,61306L,61307L,61308L,61309L,61310L,61311L,61312L,61313L,61314L, +61315L,61316L,61317L,61318L,61319L,61320L,61321L,61322L,61323L,61324L, +61325L,61326L,61327L,61328L,61329L,61330L,61331L,61332L,61333L,61334L, +61335L,61336L,61337L,61338L,61339L,61340L,61341L,61342L,61343L,61344L, +61345L,61346L,61347L,61348L,61349L,61350L,61351L,61352L,61353L,61354L, +61355L,61356L,61357L,61358L,61359L,61360L,61361L,61362L,61363L,61364L, +61365L,61366L,61367L,61368L,61369L,61370L,61371L,61372L,61373L,61374L, +61375L,61376L,61377L,61378L,61379L,61380L,61381L,61382L,61383L,61384L, +61385L,61386L,61387L,61388L,61389L,61390L,61391L,61392L,61393L,61394L, +61395L,61396L,61397L,61398L,61399L,61400L,61401L,61402L,61403L,61404L, +61405L,61406L,61407L,61408L,61409L,61410L,61411L,61412L,61413L,61414L, +61415L,61416L,61417L,61418L,61419L,61420L,61421L,61422L,61423L,61424L, +61425L,61426L,61427L,61428L,61429L,61430L,61431L,61432L,61433L,61434L, +61435L,61436L,61437L,61438L,61439L,61440L,61441L,61442L,61443L,61444L, +61445L,61446L,61447L,61448L,61449L,61450L,61451L,61452L,61453L,61454L, +61455L,61456L,61457L,61458L,61459L,61460L,61461L,61462L,61463L,61464L, +61465L,61466L,61467L,61468L,61469L,61470L,61471L,61472L,61473L,61474L, +61475L,61476L,61477L,61478L,61479L,61480L,61481L,61482L,61483L,61484L, +61485L,61486L,61487L,61488L,61489L,61490L,61491L,61492L,61493L,61494L, +61495L,61496L,61497L,61498L,61499L,61500L,61501L,61502L,61503L,61504L, +61505L,61506L,61507L,61508L,61509L,61510L,61511L,61512L,61513L,61514L, +61515L,61516L,61517L,61518L,61519L,61520L,61521L,61522L,61523L,61524L, +61525L,61526L,61527L,61528L,61529L,61530L,61531L,61532L,61533L,61534L, +61535L,61536L,61537L,61538L,61539L,61540L,61541L,61542L,61543L,61544L, +61545L,61546L,61547L,61548L,61549L,61550L,61551L,61552L,61553L,61554L, +61555L,61556L,61557L,61558L,61559L,61560L,61561L,61562L,61563L,61564L, +61565L,61566L,61567L,61568L,61569L,61570L,61571L,61572L,61573L,61574L, +61575L,61576L,61577L,61578L,61579L,61580L,61581L,61582L,61583L,61584L, +61585L,61586L,61587L,61588L,61589L,61590L,61591L,61592L,61593L,61594L, +61595L,61596L,61597L,61598L,61599L,61600L,61601L,61602L,61603L,61604L, +61605L,61606L,61607L,61608L,61609L,61610L,61611L,61612L,61613L,61614L, +61615L,61616L,61617L,61618L,61619L,61620L,61621L,61622L,61623L,61624L, +61625L,61626L,61627L,61628L,61629L,61630L,61631L,61632L,61633L,61634L, +61635L,61636L,61637L,61638L,61639L,61640L,61641L,61642L,61643L,61644L, +61645L,61646L,61647L,61648L,61649L,61650L,61651L,61652L,61653L,61654L, +61655L,61656L,61657L,61658L,61659L,61660L,61661L,61662L,61663L,61664L, +61665L,61666L,61667L,61668L,61669L,61670L,61671L,61672L,61673L,61674L, +61675L,61676L,61677L,61678L,61679L,61680L,61681L,61682L,61683L,61684L, +61685L,61686L,61687L,61688L,61689L,61690L,61691L,61692L,61693L,61694L, +61695L,61696L,61697L,61698L,61699L,61700L,61701L,61702L,61703L,61704L, +61705L,61706L,61707L,61708L,61709L,61710L,61711L,61712L,61713L,61714L, +61715L,61716L,61717L,61718L,61719L,61720L,61721L,61722L,61723L,61724L, +61725L,61726L,61727L,61728L,61729L,61730L,61731L,61732L,61733L,61734L, +61735L,61736L,61737L,61738L,61739L,61740L,61741L,61742L,61743L,61744L, +61745L,61746L,61747L,61748L,61749L,61750L,61751L,61752L,61753L,61754L, +61755L,61756L,61757L,61758L,61759L,61760L,61761L,61762L,61763L,61764L, +61765L,61766L,61767L,61768L,61769L,61770L,61771L,61772L,61773L,61774L, +61775L,61776L,61777L,61778L,61779L,61780L,61781L,61782L,61783L,61784L, +61785L,61786L,61787L,61788L,61789L,61790L,61791L,61792L,61793L,61794L, +61795L,61796L,61797L,61798L,61799L,61800L,61801L,61802L,61803L,61804L, +61805L,61806L,61807L,61808L,61809L,61810L,61811L,61812L,61813L,61814L, +61815L,61816L,61817L,61818L,61819L,61820L,61821L,61822L,61823L,61824L, +61825L,61826L,61827L,61828L,61829L,61830L,61831L,61832L,61833L,61834L, +61835L,61836L,61837L,61838L,61839L,61840L,61841L,61842L,61843L,61844L, +61845L,61846L,61847L,61848L,61849L,61850L,61851L,61852L,61853L,61854L, +61855L,61856L,61857L,61858L,61859L,61860L,61861L,61862L,61863L,61864L, +61865L,61866L,61867L,61868L,61869L,61870L,61871L,61872L,61873L,61874L, +61875L,61876L,61877L,61878L,61879L,61880L,61881L,61882L,61883L,61884L, +61885L,61886L,61887L,61888L,61889L,61890L,61891L,61892L,61893L,61894L, +61895L,61896L,61897L,61898L,61899L,61900L,61901L,61902L,61903L,61904L, +61905L,61906L,61907L,61908L,61909L,61910L,61911L,61912L,61913L,61914L, +61915L,61916L,61917L,61918L,61919L,61920L,61921L,61922L,61923L,61924L, +61925L,61926L,61927L,61928L,61929L,61930L,61931L,61932L,61933L,61934L, +61935L,61936L,61937L,61938L,61939L,61940L,61941L,61942L,61943L,61944L, +61945L,61946L,61947L,61948L,61949L,61950L,61951L,61952L,61953L,61954L, +61955L,61956L,61957L,61958L,61959L,61960L,61961L,61962L,61963L,61964L, +61965L,61966L,61967L,61968L,61969L,61970L,61971L,61972L,61973L,61974L, +61975L,61976L,61977L,61978L,61979L,61980L,61981L,61982L,61983L,61984L, +61985L,61986L,61987L,61988L,61989L,61990L,61991L,61992L,61993L,61994L, +61995L,61996L,61997L,61998L,61999L,62000L,62001L,62002L,62003L,62004L, +62005L,62006L,62007L,62008L,62009L,62010L,62011L,62012L,62013L,62014L, +62015L,62016L,62017L,62018L,62019L,62020L,62021L,62022L,62023L,62024L, +62025L,62026L,62027L,62028L,62029L,62030L,62031L,62032L,62033L,62034L, +62035L,62036L,62037L,62038L,62039L,62040L,62041L,62042L,62043L,62044L, +62045L,62046L,62047L,62048L,62049L,62050L,62051L,62052L,62053L,62054L, +62055L,62056L,62057L,62058L,62059L,62060L,62061L,62062L,62063L,62064L, +62065L,62066L,62067L,62068L,62069L,62070L,62071L,62072L,62073L,62074L, +62075L,62076L,62077L,62078L,62079L,62080L,62081L,62082L,62083L,62084L, +62085L,62086L,62087L,62088L,62089L,62090L,62091L,62092L,62093L,62094L, +62095L,62096L,62097L,62098L,62099L,62100L,62101L,62102L,62103L,62104L, +62105L,62106L,62107L,62108L,62109L,62110L,62111L,62112L,62113L,62114L, +62115L,62116L,62117L,62118L,62119L,62120L,62121L,62122L,62123L,62124L, +62125L,62126L,62127L,62128L,62129L,62130L,62131L,62132L,62133L,62134L, +62135L,62136L,62137L,62138L,62139L,62140L,62141L,62142L,62143L,62144L, +62145L,62146L,62147L,62148L,62149L,62150L,62151L,62152L,62153L,62154L, +62155L,62156L,62157L,62158L,62159L,62160L,62161L,62162L,62163L,62164L, +62165L,62166L,62167L,62168L,62169L,62170L,62171L,62172L,62173L,62174L, +62175L,62176L,62177L,62178L,62179L,62180L,62181L,62182L,62183L,62184L, +62185L,62186L,62187L,62188L,62189L,62190L,62191L,62192L,62193L,62194L, +62195L,62196L,62197L,62198L,62199L,62200L,62201L,62202L,62203L,62204L, +62205L,62206L,62207L,62208L,62209L,62210L,62211L,62212L,62213L,62214L, +62215L,62216L,62217L,62218L,62219L,62220L,62221L,62222L,62223L,62224L, +62225L,62226L,62227L,62228L,62229L,62230L,62231L,62232L,62233L,62234L, +62235L,62236L,62237L,62238L,62239L,62240L,62241L,62242L,62243L,62244L, +62245L,62246L,62247L,62248L,62249L,62250L,62251L,62252L,62253L,62254L, +62255L,62256L,62257L,62258L,62259L,62260L,62261L,62262L,62263L,62264L, +62265L,62266L,62267L,62268L,62269L,62270L,62271L,62272L,62273L,62274L, +62275L,62276L,62277L,62278L,62279L,62280L,62281L,62282L,62283L,62284L, +62285L,62286L,62287L,62288L,62289L,62290L,62291L,62292L,62293L,62294L, +62295L,62296L,62297L,62298L,62299L,62300L,62301L,62302L,62303L,62304L, +62305L,62306L,62307L,62308L,62309L,62310L,62311L,62312L,62313L,62314L, +62315L,62316L,62317L,62318L,62319L,62320L,62321L,62322L,62323L,62324L, +62325L,62326L,62327L,62328L,62329L,62330L,62331L,62332L,62333L,62334L, +62335L,62336L,62337L,62338L,62339L,62340L,62341L,62342L,62343L,62344L, +62345L,62346L,62347L,62348L,62349L,62350L,62351L,62352L,62353L,62354L, +62355L,62356L,62357L,62358L,62359L,62360L,62361L,62362L,62363L,62364L, +62365L,62366L,62367L,62368L,62369L,62370L,62371L,62372L,62373L,62374L, +62375L,62376L,62377L,62378L,62379L,62380L,62381L,62382L,62383L,62384L, +62385L,62386L,62387L,62388L,62389L,62390L,62391L,62392L,62393L,62394L, +62395L,62396L,62397L,62398L,62399L,62400L,62401L,62402L,62403L,62404L, +62405L,62406L,62407L,62408L,62409L,62410L,62411L,62412L,62413L,62414L, +62415L,62416L,62417L,62418L,62419L,62420L,62421L,62422L,62423L,62424L, +62425L,62426L,62427L,62428L,62429L,62430L,62431L,62432L,62433L,62434L, +62435L,62436L,62437L,62438L,62439L,62440L,62441L,62442L,62443L,62444L, +62445L,62446L,62447L,62448L,62449L,62450L,62451L,62452L,62453L,62454L, +62455L,62456L,62457L,62458L,62459L,62460L,62461L,62462L,62463L,62464L, +62465L,62466L,62467L,62468L,62469L,62470L,62471L,62472L,62473L,62474L, +62475L,62476L,62477L,62478L,62479L,62480L,62481L,62482L,62483L,62484L, +62485L,62486L,62487L,62488L,62489L,62490L,62491L,62492L,62493L,62494L, +62495L,62496L,62497L,62498L,62499L,62500L,62501L,62502L,62503L,62504L, +62505L,62506L,62507L,62508L,62509L,62510L,62511L,62512L,62513L,62514L, +62515L,62516L,62517L,62518L,62519L,62520L,62521L,62522L,62523L,62524L, +62525L,62526L,62527L,62528L,62529L,62530L,62531L,62532L,62533L,62534L, +62535L,62536L,62537L,62538L,62539L,62540L,62541L,62542L,62543L,62544L, +62545L,62546L,62547L,62548L,62549L,62550L,62551L,62552L,62553L,62554L, +62555L,62556L,62557L,62558L,62559L,62560L,62561L,62562L,62563L,62564L, +62565L,62566L,62567L,62568L,62569L,62570L,62571L,62572L,62573L,62574L, +62575L,62576L,62577L,62578L,62579L,62580L,62581L,62582L,62583L,62584L, +62585L,62586L,62587L,62588L,62589L,62590L,62591L,62592L,62593L,62594L, +62595L,62596L,62597L,62598L,62599L,62600L,62601L,62602L,62603L,62604L, +62605L,62606L,62607L,62608L,62609L,62610L,62611L,62612L,62613L,62614L, +62615L,62616L,62617L,62618L,62619L,62620L,62621L,62622L,62623L,62624L, +62625L,62626L,62627L,62628L,62629L,62630L,62631L,62632L,62633L,62634L, +62635L,62636L,62637L,62638L,62639L,62640L,62641L,62642L,62643L,62644L, +62645L,62646L,62647L,62648L,62649L,62650L,62651L,62652L,62653L,62654L, +62655L,62656L,62657L,62658L,62659L,62660L,62661L,62662L,62663L,62664L, +62665L,62666L,62667L,62668L,62669L,62670L,62671L,62672L,62673L,62674L, +62675L,62676L,62677L,62678L,62679L,62680L,62681L,62682L,62683L,62684L, +62685L,62686L,62687L,62688L,62689L,62690L,62691L,62692L,62693L,62694L, +62695L,62696L,62697L,62698L,62699L,62700L,62701L,62702L,62703L,62704L, +62705L,62706L,62707L,62708L,62709L,62710L,62711L,62712L,62713L,62714L, +62715L,62716L,62717L,62718L,62719L,62720L,62721L,62722L,62723L,62724L, +62725L,62726L,62727L,62728L,62729L,62730L,62731L,62732L,62733L,62734L, +62735L,62736L,62737L,62738L,62739L,62740L,62741L,62742L,62743L,62744L, +62745L,62746L,62747L,62748L,62749L,62750L,62751L,62752L,62753L,62754L, +62755L,62756L,62757L,62758L,62759L,62760L,62761L,62762L,62763L,62764L, +62765L,62766L,62767L,62768L,62769L,62770L,62771L,62772L,62773L,62774L, +62775L,62776L,62777L,62778L,62779L,62780L,62781L,62782L,62783L,62784L, +62785L,62786L,62787L,62788L,62789L,62790L,62791L,62792L,62793L,62794L, +62795L,62796L,62797L,62798L,62799L,62800L,62801L,62802L,62803L,62804L, +62805L,62806L,62807L,62808L,62809L,62810L,62811L,62812L,62813L,62814L, +62815L,62816L,62817L,62818L,62819L,62820L,62821L,62822L,62823L,62824L, +62825L,62826L,62827L,62828L,62829L,62830L,62831L,62832L,62833L,62834L, +62835L,62836L,62837L,62838L,62839L,62840L,62841L,62842L,62843L,62844L, +62845L,62846L,62847L,62848L,62849L,62850L,62851L,62852L,62853L,62854L, +62855L,62856L,62857L,62858L,62859L,62860L,62861L,62862L,62863L,62864L, +62865L,62866L,62867L,62868L,62869L,62870L,62871L,62872L,62873L,62874L, +62875L,62876L,62877L,62878L,62879L,62880L,62881L,62882L,62883L,62884L, +62885L,62886L,62887L,62888L,62889L,62890L,62891L,62892L,62893L,62894L, +62895L,62896L,62897L,62898L,62899L,62900L,62901L,62902L,62903L,62904L, +62905L,62906L,62907L,62908L,62909L,62910L,62911L,62912L,62913L,62914L, +62915L,62916L,62917L,62918L,62919L,62920L,62921L,62922L,62923L,62924L, +62925L,62926L,62927L,62928L,62929L,62930L,62931L,62932L,62933L,62934L, +62935L,62936L,62937L,62938L,62939L,62940L,62941L,62942L,62943L,62944L, +62945L,62946L,62947L,62948L,62949L,62950L,62951L,62952L,62953L,62954L, +62955L,62956L,62957L,62958L,62959L,62960L,62961L,62962L,62963L,62964L, +62965L,62966L,62967L,62968L,62969L,62970L,62971L,62972L,62973L,62974L, +62975L,62976L,62977L,62978L,62979L,62980L,62981L,62982L,62983L,62984L, +62985L,62986L,62987L,62988L,62989L,62990L,62991L,62992L,62993L,62994L, +62995L,62996L,62997L,62998L,62999L,63000L,63001L,63002L,63003L,63004L, +63005L,63006L,63007L,63008L,63009L,63010L,63011L,63012L,63013L,63014L, +63015L,63016L,63017L,63018L,63019L,63020L,63021L,63022L,63023L,63024L, +63025L,63026L,63027L,63028L,63029L,63030L,63031L,63032L,63033L,63034L, +63035L,63036L,63037L,63038L,63039L,63040L,63041L,63042L,63043L,63044L, +63045L,63046L,63047L,63048L,63049L,63050L,63051L,63052L,63053L,63054L, +63055L,63056L,63057L,63058L,63059L,63060L,63061L,63062L,63063L,63064L, +63065L,63066L,63067L,63068L,63069L,63070L,63071L,63072L,63073L,63074L, +63075L,63076L,63077L,63078L,63079L,63080L,63081L,63082L,63083L,63084L, +63085L,63086L,63087L,63088L,63089L,63090L,63091L,63092L,63093L,63094L, +63095L,63096L,63097L,63098L,63099L,63100L,63101L,63102L,63103L,63104L, +63105L,63106L,63107L,63108L,63109L,63110L,63111L,63112L,63113L,63114L, +63115L,63116L,63117L,63118L,63119L,63120L,63121L,63122L,63123L,63124L, +63125L,63126L,63127L,63128L,63129L,63130L,63131L,63132L,63133L,63134L, +63135L,63136L,63137L,63138L,63139L,63140L,63141L,63142L,63143L,63144L, +63145L,63146L,63147L,63148L,63149L,63150L,63151L,63152L,63153L,63154L, +63155L,63156L,63157L,63158L,63159L,63160L,63161L,63162L,63163L,63164L, +63165L,63166L,63167L,63168L,63169L,63170L,63171L,63172L,63173L,63174L, +63175L,63176L,63177L,63178L,63179L,63180L,63181L,63182L,63183L,63184L, +63185L,63186L,63187L,63188L,63189L,63190L,63191L,63192L,63193L,63194L, +63195L,63196L,63197L,63198L,63199L,63200L,63201L,63202L,63203L,63204L, +63205L,63206L,63207L,63208L,63209L,63210L,63211L,63212L,63213L,63214L, +63215L,63216L,63217L,63218L,63219L,63220L,63221L,63222L,63223L,63224L, +63225L,63226L,63227L,63228L,63229L,63230L,63231L,63232L,63233L,63234L, +63235L,63236L,63237L,63238L,63239L,63240L,63241L,63242L,63243L,63244L, +63245L,63246L,63247L,63248L,63249L,63250L,63251L,63252L,63253L,63254L, +63255L,63256L,63257L,63258L,63259L,63260L,63261L,63262L,63263L,63264L, +63265L,63266L,63267L,63268L,63269L,63270L,63271L,63272L,63273L,63274L, +63275L,63276L,63277L,63278L,63279L,63280L,63281L,63282L,63283L,63284L, +63285L,63286L,63287L,63288L,63289L,63290L,63291L,63292L,63293L,63294L, +63295L,63296L,63297L,63298L,63299L,63300L,63301L,63302L,63303L,63304L, +63305L,63306L,63307L,63308L,63309L,63310L,63311L,63312L,63313L,63314L, +63315L,63316L,63317L,63318L,63319L,63320L,63321L,63322L,63323L,63324L, +63325L,63326L,63327L,63328L,63329L,63330L,63331L,63332L,63333L,63334L, +63335L,63336L,63337L,63338L,63339L,63340L,63341L,63342L,63343L,63344L, +63345L,63346L,63347L,63348L,63349L,63350L,63351L,63352L,63353L,63354L, +63355L,63356L,63357L,63358L,63359L,63360L,63361L,63362L,63363L,63364L, +63365L,63366L,63367L,63368L,63369L,63370L,63371L,63372L,63373L,63374L, +63375L,63376L,63377L,63378L,63379L,63380L,63381L,63382L,63383L,63384L, +63385L,63386L,63387L,63388L,63389L,63390L,63391L,63392L,63393L,63394L, +63395L,63396L,63397L,63398L,63399L,63400L,63401L,63402L,63403L,63404L, +63405L,63406L,63407L,63408L,63409L,63410L,63411L,63412L,63413L,63414L, +63415L,63416L,63417L,63418L,63419L,63420L,63421L,63422L,63423L,63424L, +63425L,63426L,63427L,63428L,63429L,63430L,63431L,63432L,63433L,63434L, +63435L,63436L,63437L,63438L,63439L,63440L,63441L,63442L,63443L,63444L, +63445L,63446L,63447L,63448L,63449L,63450L,63451L,63452L,63453L,63454L, +63455L,63456L,63457L,63458L,63459L,63460L,63461L,63462L,63463L,63464L, +63465L,63466L,63467L,63468L,63469L,63470L,63471L,63472L,63473L,63474L, +63475L,63476L,63477L,63478L,63479L,63480L,63481L,63482L,63483L,63484L, +63485L,63486L,63487L,63488L,63489L,63490L,63491L,63492L,63493L,63494L, +63495L,63496L,63497L,63498L,63499L,63500L,63501L,63502L,63503L,63504L, +63505L,63506L,63507L,63508L,63509L,63510L,63511L,63512L,63513L,63514L, +63515L,63516L,63517L,63518L,63519L,63520L,63521L,63522L,63523L,63524L, +63525L,63526L,63527L,63528L,63529L,63530L,63531L,63532L,63533L,63534L, +63535L,63536L,63537L,63538L,63539L,63540L,63541L,63542L,63543L,63544L, +63545L,63546L,63547L,63548L,63549L,63550L,63551L,63552L,63553L,63554L, +63555L,63556L,63557L,63558L,63559L,63560L,63561L,63562L,63563L,63564L, +63565L,63566L,63567L,63568L,63569L,63570L,63571L,63572L,63573L,63574L, +63575L,63576L,63577L,63578L,63579L,63580L,63581L,63582L,63583L,63584L, +63585L,63586L,63587L,63588L,63589L,63590L,63591L,63592L,63593L,63594L, +63595L,63596L,63597L,63598L,63599L,63600L,63601L,63602L,63603L,63604L, +63605L,63606L,63607L,63608L,63609L,63610L,63611L,63612L,63613L,63614L, +63615L,63616L,63617L,63618L,63619L,63620L,63621L,63622L,63623L,63624L, +63625L,63626L,63627L,63628L,63629L,63630L,63631L,63632L,63633L,63634L, +63635L,63636L,63637L,63638L,63639L,63640L,63641L,63642L,63643L,63644L, +63645L,63646L,63647L,63648L,63649L,63650L,63651L,63652L,63653L,63654L, +63655L,63656L,63657L,63658L,63659L,63660L,63661L,63662L,63663L,63664L, +63665L,63666L,63667L,63668L,63669L,63670L,63671L,63672L,63673L,63674L, +63675L,63676L,63677L,63678L,63679L,63680L,63681L,63682L,63683L,63684L, +63685L,63686L,63687L,63688L,63689L,63690L,63691L,63692L,63693L,63694L, +63695L,63696L,63697L,63698L,63699L,63700L,63701L,63702L,63703L,63704L, +63705L,63706L,63707L,63708L,63709L,63710L,63711L,63712L,63713L,63714L, +63715L,63716L,63717L,63718L,63719L,63720L,63721L,63722L,63723L,63724L, +63725L,63726L,63727L,63728L,63729L,63730L,63731L,63732L,63733L,63734L, +63735L,63736L,63737L,63738L,63739L,63740L,63741L,63742L,63743L,63744L, +63745L,63746L,63747L,63748L,63749L,63750L,63751L,63752L,63753L,63754L, +63755L,63756L,63757L,63758L,63759L,63760L,63761L,63762L,63763L,63764L, +63765L,63766L,63767L,63768L,63769L,63770L,63771L,63772L,63773L,63774L, +63775L,63776L,63777L,63778L,63779L,63780L,63781L,63782L,63783L,63784L, +63785L,63786L,63787L,63788L,63789L,63790L,63791L,63792L,63793L,63794L, +63795L,63796L,63797L,63798L,63799L,63800L,63801L,63802L,63803L,63804L, +63805L,63806L,63807L,63808L,63809L,63810L,63811L,63812L,63813L,63814L, +63815L,63816L,63817L,63818L,63819L,63820L,63821L,63822L,63823L,63824L, +63825L,63826L,63827L,63828L,63829L,63830L,63831L,63832L,63833L,63834L, +63835L,63836L,63837L,63838L,63839L,63840L,63841L,63842L,63843L,63844L, +63845L,63846L,63847L,63848L,63849L,63850L,63851L,63852L,63853L,63854L, +63855L,63856L,63857L,63858L,63859L,63860L,63861L,63862L,63863L,63864L, +63865L,63866L,63867L,63868L,63869L,63870L,63871L,63872L,63873L,63874L, +63875L,63876L,63877L,63878L,63879L,63880L,63881L,63882L,63883L,63884L, +63885L,63886L,63887L,63888L,63889L,63890L,63891L,63892L,63893L,63894L, +63895L,63896L,63897L,63898L,63899L,63900L,63901L,63902L,63903L,63904L, +63905L,63906L,63907L,63908L,63909L,63910L,63911L,63912L,63913L,63914L, +63915L,63916L,63917L,63918L,63919L,63920L,63921L,63922L,63923L,63924L, +63925L,63926L,63927L,63928L,63929L,63930L,63931L,63932L,63933L,63934L, +63935L,63936L,63937L,63938L,63939L,63940L,63941L,63942L,63943L,63944L, +63945L,63946L,63947L,63948L,63949L,63950L,63951L,63952L,63953L,63954L, +63955L,63956L,63957L,63958L,63959L,63960L,63961L,63962L,63963L,63964L, +63965L,63966L,63967L,63968L,63969L,63970L,63971L,63972L,63973L,63974L, +63975L,63976L,63977L,63978L,63979L,63980L,63981L,63982L,63983L,63984L, +63985L,63986L,63987L,63988L,63989L,63990L,63991L,63992L,63993L,63994L, +63995L,63996L,63997L,63998L,63999L,64000L,64001L,64002L,64003L,64004L, +64005L,64006L,64007L,64008L,64009L,64010L,64011L,64012L,64013L,64014L, +64015L,64016L,64017L,64018L,64019L,64020L,64021L,64022L,64023L,64024L, +64025L,64026L,64027L,64028L,64029L,64030L,64031L,64032L,64033L,64034L, +64035L,64036L,64037L,64038L,64039L,64040L,64041L,64042L,64043L,64044L, +64045L,64046L,64047L,64048L,64049L,64050L,64051L,64052L,64053L,64054L, +64055L,64056L,64057L,64058L,64059L,64060L,64061L,64062L,64063L,64064L, +64065L,64066L,64067L,64068L,64069L,64070L,64071L,64072L,64073L,64074L, +64075L,64076L,64077L,64078L,64079L,64080L,64081L,64082L,64083L,64084L, +64085L,64086L,64087L,64088L,64089L,64090L,64091L,64092L,64093L,64094L, +64095L,64096L,64097L,64098L,64099L,64100L,64101L,64102L,64103L,64104L, +64105L,64106L,64107L,64108L,64109L,64110L,64111L,64112L,64113L,64114L, +64115L,64116L,64117L,64118L,64119L,64120L,64121L,64122L,64123L,64124L, +64125L,64126L,64127L,64128L,64129L,64130L,64131L,64132L,64133L,64134L, +64135L,64136L,64137L,64138L,64139L,64140L,64141L,64142L,64143L,64144L, +64145L,64146L,64147L,64148L,64149L,64150L,64151L,64152L,64153L,64154L, +64155L,64156L,64157L,64158L,64159L,64160L,64161L,64162L,64163L,64164L, +64165L,64166L,64167L,64168L,64169L,64170L,64171L,64172L,64173L,64174L, +64175L,64176L,64177L,64178L,64179L,64180L,64181L,64182L,64183L,64184L, +64185L,64186L,64187L,64188L,64189L,64190L,64191L,64192L,64193L,64194L, +64195L,64196L,64197L,64198L,64199L,64200L,64201L,64202L,64203L,64204L, +64205L,64206L,64207L,64208L,64209L,64210L,64211L,64212L,64213L,64214L, +64215L,64216L,64217L,64218L,64219L,64220L,64221L,64222L,64223L,64224L, +64225L,64226L,64227L,64228L,64229L,64230L,64231L,64232L,64233L,64234L, +64235L,64236L,64237L,64238L,64239L,64240L,64241L,64242L,64243L,64244L, +64245L,64246L,64247L,64248L,64249L,64250L,64251L,64252L,64253L,64254L, +64255L,64256L,64257L,64258L,64259L,64260L,64261L,64262L,64263L,64264L, +64265L,64266L,64267L,64268L,64269L,64270L,64271L,64272L,64273L,64274L, +64275L,64276L,64277L,64278L,64279L,64280L,64281L,64282L,64283L,64284L, +64285L,64286L,64287L,64288L,64289L,64290L,64291L,64292L,64293L,64294L, +64295L,64296L,64297L,64298L,64299L,64300L,64301L,64302L,64303L,64304L, +64305L,64306L,64307L,64308L,64309L,64310L,64311L,64312L,64313L,64314L, +64315L,64316L,64317L,64318L,64319L,64320L,64321L,64322L,64323L,64324L, +64325L,64326L,64327L,64328L,64329L,64330L,64331L,64332L,64333L,64334L, +64335L,64336L,64337L,64338L,64339L,64340L,64341L,64342L,64343L,64344L, +64345L,64346L,64347L,64348L,64349L,64350L,64351L,64352L,64353L,64354L, +64355L,64356L,64357L,64358L,64359L,64360L,64361L,64362L,64363L,64364L, +64365L,64366L,64367L,64368L,64369L,64370L,64371L,64372L,64373L,64374L, +64375L,64376L,64377L,64378L,64379L,64380L,64381L,64382L,64383L,64384L, +64385L,64386L,64387L,64388L,64389L,64390L,64391L,64392L,64393L,64394L, +64395L,64396L,64397L,64398L,64399L,64400L,64401L,64402L,64403L,64404L, +64405L,64406L,64407L,64408L,64409L,64410L,64411L,64412L,64413L,64414L, +64415L,64416L,64417L,64418L,64419L,64420L,64421L,64422L,64423L,64424L, +64425L,64426L,64427L,64428L,64429L,64430L,64431L,64432L,64433L,64434L, +64435L,64436L,64437L,64438L,64439L,64440L,64441L,64442L,64443L,64444L, +64445L,64446L,64447L,64448L,64449L,64450L,64451L,64452L,64453L,64454L, +64455L,64456L,64457L,64458L,64459L,64460L,64461L,64462L,64463L,64464L, +64465L,64466L,64467L,64468L,64469L,64470L,64471L,64472L,64473L,64474L, +64475L,64476L,64477L,64478L,64479L,64480L,64481L,64482L,64483L,64484L, +64485L,64486L,64487L,64488L,64489L,64490L,64491L,64492L,64493L,64494L, +64495L,64496L,64497L,64498L,64499L,64500L,64501L,64502L,64503L,64504L, +64505L,64506L,64507L,64508L,64509L,64510L,64511L,64512L,64513L,64514L, +64515L,64516L,64517L,64518L,64519L,64520L,64521L,64522L,64523L,64524L, +64525L,64526L,64527L,64528L,64529L,64530L,64531L,64532L,64533L,64534L, +64535L,64536L,64537L,64538L,64539L,64540L,64541L,64542L,64543L,64544L, +64545L,64546L,64547L,64548L,64549L,64550L,64551L,64552L,64553L,64554L, +64555L,64556L,64557L,64558L,64559L,64560L,64561L,64562L,64563L,64564L, +64565L,64566L,64567L,64568L,64569L,64570L,64571L,64572L,64573L,64574L, +64575L,64576L,64577L,64578L,64579L,64580L,64581L,64582L,64583L,64584L, +64585L,64586L,64587L,64588L,64589L,64590L,64591L,64592L,64593L,64594L, +64595L,64596L,64597L,64598L,64599L,64600L,64601L,64602L,64603L,64604L, +64605L,64606L,64607L,64608L,64609L,64610L,64611L,64612L,64613L,64614L, +64615L,64616L,64617L,64618L,64619L,64620L,64621L,64622L,64623L,64624L, +64625L,64626L,64627L,64628L,64629L,64630L,64631L,64632L,64633L,64634L, +64635L,64636L,64637L,64638L,64639L,64640L,64641L,64642L,64643L,64644L, +64645L,64646L,64647L,64648L,64649L,64650L,64651L,64652L,64653L,64654L, +64655L,64656L,64657L,64658L,64659L,64660L,64661L,64662L,64663L,64664L, +64665L,64666L,64667L,64668L,64669L,64670L,64671L,64672L,64673L,64674L, +64675L,64676L,64677L,64678L,64679L,64680L,64681L,64682L,64683L,64684L, +64685L,64686L,64687L,64688L,64689L,64690L,64691L,64692L,64693L,64694L, +64695L,64696L,64697L,64698L,64699L,64700L,64701L,64702L,64703L,64704L, +64705L,64706L,64707L,64708L,64709L,64710L,64711L,64712L,64713L,64714L, +64715L,64716L,64717L,64718L,64719L,64720L,64721L,64722L,64723L,64724L, +64725L,64726L,64727L,64728L,64729L,64730L,64731L,64732L,64733L,64734L, +64735L,64736L,64737L,64738L,64739L,64740L,64741L,64742L,64743L,64744L, +64745L,64746L,64747L,64748L,64749L,64750L,64751L,64752L,64753L,64754L, +64755L,64756L,64757L,64758L,64759L,64760L,64761L,64762L,64763L,64764L, +64765L,64766L,64767L,64768L,64769L,64770L,64771L,64772L,64773L,64774L, +64775L,64776L,64777L,64778L,64779L,64780L,64781L,64782L,64783L,64784L, +64785L,64786L,64787L,64788L,64789L,64790L,64791L,64792L,64793L,64794L, +64795L,64796L,64797L,64798L,64799L,64800L,64801L,64802L,64803L,64804L, +64805L,64806L,64807L,64808L,64809L,64810L,64811L,64812L,64813L,64814L, +64815L,64816L,64817L,64818L,64819L,64820L,64821L,64822L,64823L,64824L, +64825L,64826L,64827L,64828L,64829L,64830L,64831L,64832L,64833L,64834L, +64835L,64836L,64837L,64838L,64839L,64840L,64841L,64842L,64843L,64844L, +64845L,64846L,64847L,64848L,64849L,64850L,64851L,64852L,64853L,64854L, +64855L,64856L,64857L,64858L,64859L,64860L,64861L,64862L,64863L,64864L, +64865L,64866L,64867L,64868L,64869L,64870L,64871L,64872L,64873L,64874L, +64875L,64876L,64877L,64878L,64879L,64880L,64881L,64882L,64883L,64884L, +64885L,64886L,64887L,64888L,64889L,64890L,64891L,64892L,64893L,64894L, +64895L,64896L,64897L,64898L,64899L,64900L,64901L,64902L,64903L,64904L, +64905L,64906L,64907L,64908L,64909L,64910L,64911L,64912L,64913L,64914L, +64915L,64916L,64917L,64918L,64919L,64920L,64921L,64922L,64923L,64924L, +64925L,64926L,64927L,64928L,64929L,64930L,64931L,64932L,64933L,64934L, +64935L,64936L,64937L,64938L,64939L,64940L,64941L,64942L,64943L,64944L, +64945L,64946L,64947L,64948L,64949L,64950L,64951L,64952L,64953L,64954L, +64955L,64956L,64957L,64958L,64959L,64960L,64961L,64962L,64963L,64964L, +64965L,64966L,64967L,64968L,64969L,64970L,64971L,64972L,64973L,64974L, +64975L,64976L,64977L,64978L,64979L,64980L,64981L,64982L,64983L,64984L, +64985L,64986L,64987L,64988L,64989L,64990L,64991L,64992L,64993L,64994L, +64995L,64996L,64997L,64998L,64999L,65000L,65001L,65002L,65003L,65004L, +65005L,65006L,65007L,65008L,65009L,65010L,65011L,65012L,65013L,65014L, +65015L,65016L,65017L,65018L,65019L,65020L,65021L,65022L,65023L,65024L, +65025L,65026L,65027L,65028L,65029L,65030L,65031L,65032L,65033L,65034L, +65035L,65036L,65037L,65038L,65039L,65040L,65041L,65042L,65043L,65044L, +65045L,65046L,65047L,65048L,65049L,65050L,65051L,65052L,65053L,65054L, +65055L,65056L,65057L,65058L,65059L,65060L,65061L,65062L,65063L,65064L, +65065L,65066L,65067L,65068L,65069L,65070L,65071L,65072L,65073L,65074L, +65075L,65076L,65077L,65078L,65079L,65080L,65081L,65082L,65083L,65084L, +65085L,65086L,65087L,65088L,65089L,65090L,65091L,65092L,65093L,65094L, +65095L,65096L,65097L,65098L,65099L,65100L,65101L,65102L,65103L,65104L, +65105L,65106L,65107L,65108L,65109L,65110L,65111L,65112L,65113L,65114L, +65115L,65116L,65117L,65118L,65119L,65120L,65121L,65122L,65123L,65124L, +65125L,65126L,65127L,65128L,65129L,65130L,65131L,65132L,65133L,65134L, +65135L,65136L,65137L,65138L,65139L,65140L,65141L,65142L,65143L,65144L, +65145L,65146L,65147L,65148L,65149L,65150L,65151L,65152L,65153L,65154L, +65155L,65156L,65157L,65158L,65159L,65160L,65161L,65162L,65163L,65164L, +65165L,65166L,65167L,65168L,65169L,65170L,65171L,65172L,65173L,65174L, +65175L,65176L,65177L,65178L,65179L,65180L,65181L,65182L,65183L,65184L, +65185L,65186L,65187L,65188L,65189L,65190L,65191L,65192L,65193L,65194L, +65195L,65196L,65197L,65198L,65199L,65200L,65201L,65202L,65203L,65204L, +65205L,65206L,65207L,65208L,65209L,65210L,65211L,65212L,65213L,65214L, +65215L,65216L,65217L,65218L,65219L,65220L,65221L,65222L,65223L,65224L, +65225L,65226L,65227L,65228L,65229L,65230L,65231L,65232L,65233L,65234L, +65235L,65236L,65237L,65238L,65239L,65240L,65241L,65242L,65243L,65244L, +65245L,65246L,65247L,65248L,65249L,65250L,65251L,65252L,65253L,65254L, +65255L,65256L,65257L,65258L,65259L,65260L,65261L,65262L,65263L,65264L, +65265L,65266L,65267L,65268L,65269L,65270L,65271L,65272L,65273L,65274L, +65275L,65276L,65277L,65278L,65279L,65280L,65281L,65282L,65283L,65284L, +65285L,65286L,65287L,65288L,65289L,65290L,65291L,65292L,65293L,65294L, +65295L,65296L,65297L,65298L,65299L,65300L,65301L,65302L,65303L,65304L, +65305L,65306L,65307L,65308L,65309L,65310L,65311L,65312L,65313L,65314L, +65315L,65316L,65317L,65318L,65319L,65320L,65321L,65322L,65323L,65324L, +65325L,65326L,65327L,65328L,65329L,65330L,65331L,65332L,65333L,65334L, +65335L,65336L,65337L,65338L,65339L,65340L,65341L,65342L,65343L,65344L, +65313L,65314L,65315L,65316L,65317L,65318L,65319L,65320L,65321L,65322L, +65323L,65324L,65325L,65326L,65327L,65328L,65329L,65330L,65331L,65332L, +65333L,65334L,65335L,65336L,65337L,65338L,65371L,65372L,65373L,65374L, +65375L,65376L,65377L,65378L,65379L,65380L,65381L,65382L,65383L,65384L, +65385L,65386L,65387L,65388L,65389L,65390L,65391L,65392L,65393L,65394L, +65395L,65396L,65397L,65398L,65399L,65400L,65401L,65402L,65403L,65404L, +65405L,65406L,65407L,65408L,65409L,65410L,65411L,65412L,65413L,65414L, +65415L,65416L,65417L,65418L,65419L,65420L,65421L,65422L,65423L,65424L, +65425L,65426L,65427L,65428L,65429L,65430L,65431L,65432L,65433L,65434L, +65435L,65436L,65437L,65438L,65439L,65440L,65441L,65442L,65443L,65444L, +65445L,65446L,65447L,65448L,65449L,65450L,65451L,65452L,65453L,65454L, +65455L,65456L,65457L,65458L,65459L,65460L,65461L,65462L,65463L,65464L, +65465L,65466L,65467L,65468L,65469L,65470L,65471L,65472L,65473L,65474L, +65475L,65476L,65477L,65478L,65479L,65480L,65481L,65482L,65483L,65484L, +65485L,65486L,65487L,65488L,65489L,65490L,65491L,65492L,65493L,65494L, +65495L,65496L,65497L,65498L,65499L,65500L,65501L,65502L,65503L,65504L, +65505L,65506L,65507L,65508L,65509L,65510L,65511L,65512L,65513L,65514L, +65515L,65516L,65517L,65518L,65519L,65520L,65521L,65522L,65523L,65524L, +65525L,65526L,65527L,65528L,65529L,65530L,65531L,65532L,65533L,65534L, +65535L, +}; +#endif + +#if defined(DUK_USE_REGEXP_CANON_BITMAP) +/* + * Automatically generated by extract_caseconv.py, do not edit! + */ + +const duk_uint8_t duk_unicode_re_canon_bitmap[256] = { +23,0,224,19,1,228,255,255,255,255,255,255,255,255,255,255,63,254,255,127, +255,255,255,255,255,255,255,255,231,231,0,16,255,227,255,255,63,255,255, +255,255,255,255,255,1,252,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, +227,129,255,255,255,147,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, +255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,251, +}; +#endif +#line 1 "duk_util_bitdecoder.c" +/* + * Bitstream decoder. + */ + +/* #include duk_internal.h -> already included */ + +/* Decode 'bits' bits from the input stream (bits must be 1...24). + * When reading past bitstream end, zeroes are shifted in. The result + * is signed to match duk_bd_decode_flagged. + */ +DUK_INTERNAL duk_uint32_t duk_bd_decode(duk_bitdecoder_ctx *ctx, duk_small_int_t bits) { + duk_small_int_t shift; + duk_uint32_t mask; + duk_uint32_t tmp; + + /* Note: cannot read more than 24 bits without possibly shifting top bits out. + * Fixable, but adds complexity. + */ + DUK_ASSERT(bits >= 1 && bits <= 24); + + while (ctx->currbits < bits) { +#if 0 + DUK_DDD(DUK_DDDPRINT("decode_bits: shift more data (bits=%ld, currbits=%ld)", + (long) bits, (long) ctx->currbits)); +#endif + ctx->currval <<= 8; + if (ctx->offset < ctx->length) { + /* If ctx->offset >= ctx->length, we "shift zeroes in" + * instead of croaking. + */ + ctx->currval |= ctx->data[ctx->offset++]; + } + ctx->currbits += 8; + } +#if 0 + DUK_DDD(DUK_DDDPRINT("decode_bits: bits=%ld, currbits=%ld, currval=0x%08lx", + (long) bits, (long) ctx->currbits, (unsigned long) ctx->currval)); +#endif + + /* Extract 'top' bits of currval; note that the extracted bits do not need + * to be cleared, we just ignore them on next round. + */ + shift = ctx->currbits - bits; + mask = (((duk_uint32_t) 1U) << bits) - 1U; + tmp = (ctx->currval >> shift) & mask; + ctx->currbits = shift; /* remaining */ + +#if 0 + DUK_DDD(DUK_DDDPRINT("decode_bits: %ld bits -> 0x%08lx (%ld), currbits=%ld, currval=0x%08lx", + (long) bits, (unsigned long) tmp, (long) tmp, (long) ctx->currbits, (unsigned long) ctx->currval)); +#endif + + return tmp; +} + +DUK_INTERNAL duk_small_uint_t duk_bd_decode_flag(duk_bitdecoder_ctx *ctx) { + return (duk_small_uint_t) duk_bd_decode(ctx, 1); +} + +/* Decode a one-bit flag, and if set, decode a value of 'bits', otherwise return + * default value. + */ +DUK_INTERNAL duk_uint32_t duk_bd_decode_flagged(duk_bitdecoder_ctx *ctx, duk_small_int_t bits, duk_uint32_t def_value) { + if (duk_bd_decode_flag(ctx)) { + return duk_bd_decode(ctx, bits); + } else { + return def_value; + } +} + +/* Signed variant, allows negative marker value. */ +DUK_INTERNAL duk_int32_t duk_bd_decode_flagged_signed(duk_bitdecoder_ctx *ctx, duk_small_int_t bits, duk_int32_t def_value) { + return (duk_int32_t) duk_bd_decode_flagged(ctx, bits, (duk_uint32_t) def_value); +} + +/* Shared varint encoding. Match dukutil.py BitEncode.varuint(). */ +DUK_INTERNAL duk_uint32_t duk_bd_decode_varuint(duk_bitdecoder_ctx *ctx) { + duk_small_uint_t t; + + /* The bit encoding choices here are based on manual testing against + * the actual varuints generated by genbuiltins.py. + */ + switch (duk_bd_decode(ctx, 2)) { + case 0: + return 0; /* [0,0] */ + case 1: + return duk_bd_decode(ctx, 2) + 1; /* [1,4] */ + case 2: + return duk_bd_decode(ctx, 5) + 5; /* [5,36] */ + default: + t = duk_bd_decode(ctx, 7); + if (t == 0) { + return duk_bd_decode(ctx, 20); + } + return (t - 1) + 37; /* [37,163] */ + } +} + +/* Decode a bit packed string from a custom format used by genbuiltins.py. + * This function is here because it's used for both heap and thread inits. + * Caller must supply the output buffer whose size is NOT checked! + */ + +#define DUK__BITPACK_LETTER_LIMIT 26 +#define DUK__BITPACK_LOOKUP1 26 +#define DUK__BITPACK_LOOKUP2 27 +#define DUK__BITPACK_SWITCH1 28 +#define DUK__BITPACK_SWITCH 29 +#define DUK__BITPACK_UNUSED1 30 +#define DUK__BITPACK_EIGHTBIT 31 + +DUK_LOCAL const duk_uint8_t duk__bitpacked_lookup[16] = { DUK_ASC_0, DUK_ASC_1, DUK_ASC_2, DUK_ASC_3, + DUK_ASC_4, DUK_ASC_5, DUK_ASC_6, DUK_ASC_7, + DUK_ASC_8, DUK_ASC_9, DUK_ASC_UNDERSCORE, DUK_ASC_SPACE, + 0x82, 0x80, DUK_ASC_DOUBLEQUOTE, DUK_ASC_LCURLY }; + +DUK_INTERNAL duk_small_uint_t duk_bd_decode_bitpacked_string(duk_bitdecoder_ctx *bd, duk_uint8_t *out) { + duk_small_uint_t len; + duk_small_uint_t mode; + duk_small_uint_t t; + duk_small_uint_t i; + + len = duk_bd_decode(bd, 5); + if (len == 31) { + len = duk_bd_decode(bd, 8); /* Support up to 256 bytes; rare. */ + } + + mode = 32; /* 0 = uppercase, 32 = lowercase (= 'a' - 'A') */ + for (i = 0; i < len; i++) { + t = duk_bd_decode(bd, 5); + if (t < DUK__BITPACK_LETTER_LIMIT) { + t = t + DUK_ASC_UC_A + mode; + } else if (t == DUK__BITPACK_LOOKUP1) { + t = duk__bitpacked_lookup[duk_bd_decode(bd, 3)]; + } else if (t == DUK__BITPACK_LOOKUP2) { + t = duk__bitpacked_lookup[8 + duk_bd_decode(bd, 3)]; + } else if (t == DUK__BITPACK_SWITCH1) { + t = duk_bd_decode(bd, 5); + DUK_ASSERT_DISABLE(t >= 0); /* unsigned */ + DUK_ASSERT(t <= 25); + t = t + DUK_ASC_UC_A + (mode ^ 32); + } else if (t == DUK__BITPACK_SWITCH) { + mode = mode ^ 32; + t = duk_bd_decode(bd, 5); + DUK_ASSERT_DISABLE(t >= 0); + DUK_ASSERT(t <= 25); + t = t + DUK_ASC_UC_A + mode; + } else if (t == DUK__BITPACK_EIGHTBIT) { + t = duk_bd_decode(bd, 8); + } + out[i] = (duk_uint8_t) t; + } + + return len; +} + +/* automatic undefs */ +#undef DUK__BITPACK_EIGHTBIT +#undef DUK__BITPACK_LETTER_LIMIT +#undef DUK__BITPACK_LOOKUP1 +#undef DUK__BITPACK_LOOKUP2 +#undef DUK__BITPACK_SWITCH +#undef DUK__BITPACK_SWITCH1 +#undef DUK__BITPACK_UNUSED1 +#line 1 "duk_util_bitencoder.c" +/* + * Bitstream encoder. + */ + +/* #include duk_internal.h -> already included */ + +DUK_INTERNAL void duk_be_encode(duk_bitencoder_ctx *ctx, duk_uint32_t data, duk_small_int_t bits) { + duk_uint8_t tmp; + + DUK_ASSERT(ctx != NULL); + DUK_ASSERT(ctx->currbits < 8); + + /* This limitation would be fixable but adds unnecessary complexity. */ + DUK_ASSERT(bits >= 1 && bits <= 24); + + ctx->currval = (ctx->currval << bits) | data; + ctx->currbits += bits; + + while (ctx->currbits >= 8) { + if (ctx->offset < ctx->length) { + tmp = (duk_uint8_t) ((ctx->currval >> (ctx->currbits - 8)) & 0xff); + ctx->data[ctx->offset++] = tmp; + } else { + /* If buffer has been exhausted, truncate bitstream */ + ctx->truncated = 1; + } + + ctx->currbits -= 8; + } +} + +DUK_INTERNAL void duk_be_finish(duk_bitencoder_ctx *ctx) { + duk_small_int_t npad; + + DUK_ASSERT(ctx != NULL); + DUK_ASSERT(ctx->currbits < 8); + + npad = (duk_small_int_t) (8 - ctx->currbits); + if (npad > 0) { + duk_be_encode(ctx, 0, npad); + } + DUK_ASSERT(ctx->currbits == 0); +} +#line 1 "duk_util_bufwriter.c" +/* + * Fast buffer writer with slack management. + */ + +/* #include duk_internal.h -> already included */ + +/* XXX: Avoid duk_{memcmp,memmove}_unsafe() by imposing a minimum length of + * >0 for the underlying dynamic buffer. + */ + +/* + * Macro support functions (use only macros in calling code) + */ + +DUK_LOCAL void duk__bw_update_ptrs(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx, duk_size_t curr_offset, duk_size_t new_length) { + duk_uint8_t *p; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw_ctx != NULL); + DUK_UNREF(thr); + + /* 'p' might be NULL when the underlying buffer is zero size. If so, + * the resulting pointers are not used unsafely. + */ + p = (duk_uint8_t *) DUK_HBUFFER_DYNAMIC_GET_DATA_PTR(thr->heap, bw_ctx->buf); + DUK_ASSERT(p != NULL || (DUK_HBUFFER_DYNAMIC_GET_SIZE(bw_ctx->buf) == 0 && curr_offset == 0 && new_length == 0)); + bw_ctx->p = p + curr_offset; + bw_ctx->p_base = p; + bw_ctx->p_limit = p + new_length; +} + +DUK_INTERNAL void duk_bw_init(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx, duk_hbuffer_dynamic *h_buf) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw_ctx != NULL); + DUK_ASSERT(h_buf != NULL); + + bw_ctx->buf = h_buf; + duk__bw_update_ptrs(thr, bw_ctx, 0, DUK_HBUFFER_DYNAMIC_GET_SIZE(h_buf)); +} + +DUK_INTERNAL void duk_bw_init_pushbuf(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx, duk_size_t buf_size) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw_ctx != NULL); + + (void) duk_push_dynamic_buffer(thr, buf_size); + bw_ctx->buf = (duk_hbuffer_dynamic *) duk_known_hbuffer(thr, -1); + DUK_ASSERT(bw_ctx->buf != NULL); + duk__bw_update_ptrs(thr, bw_ctx, 0, buf_size); +} + +/* Resize target buffer for requested size. Called by the macro only when the + * fast path test (= there is space) fails. + */ +DUK_INTERNAL duk_uint8_t *duk_bw_resize(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx, duk_size_t sz) { + duk_size_t curr_off; + duk_size_t add_sz; + duk_size_t new_sz; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw_ctx != NULL); + + /* We could do this operation without caller updating bw_ctx->ptr, + * but by writing it back here we can share code better. + */ + + curr_off = (duk_size_t) (bw_ctx->p - bw_ctx->p_base); + add_sz = (curr_off >> DUK_BW_SLACK_SHIFT) + DUK_BW_SLACK_ADD; + new_sz = curr_off + sz + add_sz; + if (DUK_UNLIKELY(new_sz < curr_off)) { + /* overflow */ + DUK_ERROR_RANGE(thr, DUK_STR_BUFFER_TOO_LONG); + DUK_WO_NORETURN(return NULL;); + } +#if 0 /* for manual torture testing: tight allocation, useful with valgrind */ + new_sz = curr_off + sz; +#endif + + /* This is important to ensure dynamic buffer data pointer is not + * NULL (which is possible if buffer size is zero), which in turn + * causes portability issues with e.g. memmove() and memcpy(). + */ + DUK_ASSERT(new_sz >= 1); + + DUK_DD(DUK_DDPRINT("resize bufferwriter from %ld to %ld (add_sz=%ld)", (long) curr_off, (long) new_sz, (long) add_sz)); + + duk_hbuffer_resize(thr, bw_ctx->buf, new_sz); + duk__bw_update_ptrs(thr, bw_ctx, curr_off, new_sz); + return bw_ctx->p; +} + +/* Make buffer compact, matching current written size. */ +DUK_INTERNAL void duk_bw_compact(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx) { + duk_size_t len; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw_ctx != NULL); + DUK_UNREF(thr); + + len = (duk_size_t) (bw_ctx->p - bw_ctx->p_base); + duk_hbuffer_resize(thr, bw_ctx->buf, len); + duk__bw_update_ptrs(thr, bw_ctx, len, len); +} + +DUK_INTERNAL void duk_bw_write_raw_slice(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t src_off, duk_size_t len) { + duk_uint8_t *p_base; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw != NULL); + DUK_ASSERT(src_off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(len <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(src_off + len <= DUK_BW_GET_SIZE(thr, bw)); + DUK_UNREF(thr); + + p_base = bw->p_base; + duk_memcpy_unsafe((void *) bw->p, (const void *) (p_base + src_off), (size_t) len); + bw->p += len; +} + +DUK_INTERNAL void duk_bw_write_ensure_slice(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t src_off, duk_size_t len) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw != NULL); + DUK_ASSERT(src_off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(len <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(src_off + len <= DUK_BW_GET_SIZE(thr, bw)); + + DUK_BW_ENSURE(thr, bw, len); + duk_bw_write_raw_slice(thr, bw, src_off, len); +} + +DUK_INTERNAL void duk_bw_insert_raw_bytes(duk_hthread *thr, + duk_bufwriter_ctx *bw, + duk_size_t dst_off, + const duk_uint8_t *buf, + duk_size_t len) { + duk_uint8_t *p_base; + duk_size_t buf_sz, move_sz; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw != NULL); + DUK_ASSERT(dst_off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(buf != NULL); + DUK_UNREF(thr); + + p_base = bw->p_base; + buf_sz = (duk_size_t) (bw->p - p_base); /* constrained by maximum buffer size */ + move_sz = buf_sz - dst_off; + + DUK_ASSERT(p_base != NULL); /* buffer size is >= 1 */ + duk_memmove_unsafe((void *) (p_base + dst_off + len), (const void *) (p_base + dst_off), (size_t) move_sz); + duk_memcpy_unsafe((void *) (p_base + dst_off), (const void *) buf, (size_t) len); + bw->p += len; +} + +DUK_INTERNAL void duk_bw_insert_ensure_bytes(duk_hthread *thr, + duk_bufwriter_ctx *bw, + duk_size_t dst_off, + const duk_uint8_t *buf, + duk_size_t len) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw != NULL); + DUK_ASSERT(dst_off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(buf != NULL); + + DUK_BW_ENSURE(thr, bw, len); + duk_bw_insert_raw_bytes(thr, bw, dst_off, buf, len); +} + +DUK_INTERNAL void duk_bw_insert_raw_slice(duk_hthread *thr, + duk_bufwriter_ctx *bw, + duk_size_t dst_off, + duk_size_t src_off, + duk_size_t len) { + duk_uint8_t *p_base; + duk_size_t buf_sz, move_sz; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw != NULL); + DUK_ASSERT(dst_off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(src_off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(len <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(src_off + len <= DUK_BW_GET_SIZE(thr, bw)); + DUK_UNREF(thr); + + p_base = bw->p_base; + + /* Don't support "straddled" source now. */ + DUK_ASSERT(dst_off <= src_off || dst_off >= src_off + len); + + if (dst_off <= src_off) { + /* Target is before source. Source offset is expressed as + * a "before change" offset. Account for the memmove. + */ + src_off += len; + } + + buf_sz = (duk_size_t) (bw->p - p_base); + move_sz = buf_sz - dst_off; + + DUK_ASSERT(p_base != NULL); /* buffer size is >= 1 */ + duk_memmove_unsafe((void *) (p_base + dst_off + len), (const void *) (p_base + dst_off), (size_t) move_sz); + duk_memcpy_unsafe((void *) (p_base + dst_off), (const void *) (p_base + src_off), (size_t) len); + bw->p += len; +} + +DUK_INTERNAL void duk_bw_insert_ensure_slice(duk_hthread *thr, + duk_bufwriter_ctx *bw, + duk_size_t dst_off, + duk_size_t src_off, + duk_size_t len) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw != NULL); + DUK_ASSERT(dst_off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(src_off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(len <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(src_off + len <= DUK_BW_GET_SIZE(thr, bw)); + + /* Don't support "straddled" source now. */ + DUK_ASSERT(dst_off <= src_off || dst_off >= src_off + len); + + DUK_BW_ENSURE(thr, bw, len); + duk_bw_insert_raw_slice(thr, bw, dst_off, src_off, len); +} + +DUK_INTERNAL duk_uint8_t *duk_bw_insert_raw_area(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t off, duk_size_t len) { + duk_uint8_t *p_base, *p_dst, *p_src; + duk_size_t buf_sz, move_sz; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw != NULL); + DUK_ASSERT(off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_UNREF(thr); + + p_base = bw->p_base; + buf_sz = (duk_size_t) (bw->p - p_base); + move_sz = buf_sz - off; + p_dst = p_base + off + len; + p_src = p_base + off; + duk_memmove_unsafe((void *) p_dst, (const void *) p_src, (size_t) move_sz); + return p_src; /* point to start of 'reserved area' */ +} + +DUK_INTERNAL duk_uint8_t *duk_bw_insert_ensure_area(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t off, duk_size_t len) { + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw != NULL); + DUK_ASSERT(off <= DUK_BW_GET_SIZE(thr, bw)); + + DUK_BW_ENSURE(thr, bw, len); + return duk_bw_insert_raw_area(thr, bw, off, len); +} + +DUK_INTERNAL void duk_bw_remove_raw_slice(duk_hthread *thr, duk_bufwriter_ctx *bw, duk_size_t off, duk_size_t len) { + duk_size_t move_sz; + + duk_uint8_t *p_base; + duk_uint8_t *p_src; + duk_uint8_t *p_dst; + + DUK_ASSERT(thr != NULL); + DUK_ASSERT(bw != NULL); + DUK_ASSERT(off <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(len <= DUK_BW_GET_SIZE(thr, bw)); + DUK_ASSERT(off + len <= DUK_BW_GET_SIZE(thr, bw)); + DUK_UNREF(thr); + + p_base = bw->p_base; + p_dst = p_base + off; + p_src = p_dst + len; + move_sz = (duk_size_t) (bw->p - p_src); + duk_memmove_unsafe((void *) p_dst, (const void *) p_src, (size_t) move_sz); + bw->p -= len; +} + +/* + * Assertion helpers + */ + +#if defined(DUK_USE_ASSERTIONS) +DUK_INTERNAL void duk_bw_assert_valid(duk_hthread *thr, duk_bufwriter_ctx *bw_ctx) { + DUK_UNREF(thr); + DUK_ASSERT(bw_ctx != NULL); + DUK_ASSERT(bw_ctx->buf != NULL); + DUK_ASSERT((DUK_HBUFFER_DYNAMIC_GET_SIZE(bw_ctx->buf) == 0) || + (bw_ctx->p != NULL && bw_ctx->p_base != NULL && bw_ctx->p_limit != NULL && bw_ctx->p_limit >= bw_ctx->p_base && + bw_ctx->p >= bw_ctx->p_base && bw_ctx->p <= bw_ctx->p_limit)); +} +#endif +#line 1 "duk_util_cast.c" +/* + * Cast helpers. + * + * C99+ coercion is challenging portability-wise because out-of-range casts + * may invoke implementation defined or even undefined behavior. See e.g. + * http://blog.frama-c.com/index.php?post/2013/10/09/Overflow-float-integer. + * + * Provide explicit cast helpers which try to avoid implementation defined + * or undefined behavior. These helpers can then be simplified in the vast + * majority of cases where the implementation defined or undefined behavior + * is not problematic. + */ + +/* #include duk_internal.h -> already included */ + +/* Portable double-to-integer cast which avoids undefined behavior and avoids + * relying on fmin(), fmax(), or other intrinsics. Out-of-range results are + * not assumed by caller, but here value is clamped, NaN converts to minval. + */ +#define DUK__DOUBLE_INT_CAST1(tname, minval, maxval) \ + do { \ + if (DUK_LIKELY(x >= (duk_double_t) (minval))) { \ + DUK_ASSERT(!DUK_ISNAN(x)); \ + if (DUK_LIKELY(x <= (duk_double_t) (maxval))) { \ + return (tname) x; \ + } else { \ + return (tname) (maxval); \ + } \ + } else { \ + /* NaN or below minval. Since we don't care about the result \ + * for out-of-range values, just return the minimum value for \ + * both. \ + */ \ + return (tname) (minval); \ + } \ + } while (0) + +/* Rely on specific NaN behavior for duk_double_{fmin,fmax}(): if either + * argument is a NaN, return the second argument. This avoids a + * NaN-to-integer cast which is undefined behavior. + */ +#define DUK__DOUBLE_INT_CAST2(tname, minval, maxval) \ + do { \ + return (tname) duk_double_fmin(duk_double_fmax(x, (duk_double_t) (minval)), (duk_double_t) (maxval)); \ + } while (0) + +/* Another solution which doesn't need C99+ behavior for fmin() and fmax(). */ +#define DUK__DOUBLE_INT_CAST3(tname, minval, maxval) \ + do { \ + if (DUK_ISNAN(x)) { \ + /* 0 or any other value is fine. */ \ + return (tname) 0; \ + } else \ + return (tname) DUK_FMIN(DUK_FMAX(x, (duk_double_t) (minval)), (duk_double_t) (maxval)); \ + } \ + } \ + while (0) + +/* C99+ solution: relies on specific fmin() and fmax() behavior in C99: if + * one argument is NaN but the other isn't, the non-NaN argument is returned. + * Because the limits are non-NaN values, explicit NaN check is not needed. + * This may not work on all legacy platforms, and also doesn't seem to inline + * the fmin() and fmax() calls (unless one uses -ffast-math which we don't + * support). + */ +#define DUK__DOUBLE_INT_CAST4(tname, minval, maxval) \ + do { \ + return (tname) DUK_FMIN(DUK_FMAX(x, (duk_double_t) (minval)), (duk_double_t) (maxval)); \ + } while (0) + +DUK_INTERNAL duk_int_t duk_double_to_int_t(duk_double_t x) { +#if defined(DUK_USE_ALLOW_UNDEFINED_BEHAVIOR) + /* Real world solution: almost any practical platform will provide + * an integer value without any guarantees what it is (which is fine). + */ + return (duk_int_t) x; +#else + DUK__DOUBLE_INT_CAST1(duk_int_t, DUK_INT_MIN, DUK_INT_MAX); +#endif +} + +DUK_INTERNAL duk_uint_t duk_double_to_uint_t(duk_double_t x) { +#if defined(DUK_USE_ALLOW_UNDEFINED_BEHAVIOR) + return (duk_uint_t) x; +#else + DUK__DOUBLE_INT_CAST1(duk_uint_t, DUK_UINT_MIN, DUK_UINT_MAX); +#endif +} + +DUK_INTERNAL duk_int32_t duk_double_to_int32_t(duk_double_t x) { +#if defined(DUK_USE_ALLOW_UNDEFINED_BEHAVIOR) + return (duk_int32_t) x; +#else + DUK__DOUBLE_INT_CAST1(duk_int32_t, DUK_INT32_MIN, DUK_INT32_MAX); +#endif +} + +DUK_INTERNAL duk_uint32_t duk_double_to_uint32_t(duk_double_t x) { +#if defined(DUK_USE_ALLOW_UNDEFINED_BEHAVIOR) + return (duk_uint32_t) x; +#else + DUK__DOUBLE_INT_CAST1(duk_uint32_t, DUK_UINT32_MIN, DUK_UINT32_MAX); +#endif +} + +/* Largest IEEE double that doesn't round to infinity in the default rounding + * mode. The exact midpoint between (1 - 2^(-24)) * 2^128 and 2^128 rounds to + * infinity, at least on x64. This number is one double unit below that + * midpoint. See misc/float_cast.c. + */ +#define DUK__FLOAT_ROUND_LIMIT 340282356779733623858607532500980858880.0 + +/* Maximum IEEE float. Double-to-float conversion above this would be out of + * range and thus technically undefined behavior. + */ +#define DUK__FLOAT_MAX 340282346638528859811704183484516925440.0 + +DUK_INTERNAL duk_float_t duk_double_to_float_t(duk_double_t x) { + /* Even a double-to-float cast is technically undefined behavior if + * the double is out-of-range. C99 Section 6.3.1.5: + * + * If the value being converted is in the range of values that can + * be represented but cannot be represented exactly, the result is + * either the nearest higher or nearest lower representable value, + * chosen in an implementation-defined manner. If the value being + * converted is outside the range of values that can be represented, + * the behavior is undefined. + */ +#if defined(DUK_USE_ALLOW_UNDEFINED_BEHAVIOR) + return (duk_float_t) x; +#else + duk_double_t t; + + t = DUK_FABS(x); + DUK_ASSERT((DUK_ISNAN(x) && DUK_ISNAN(t)) || (!DUK_ISNAN(x) && !DUK_ISNAN(t))); + + if (DUK_LIKELY(t <= DUK__FLOAT_MAX)) { + /* Standard in-range case, try to get here with a minimum + * number of checks and branches. + */ + DUK_ASSERT(!DUK_ISNAN(x)); + return (duk_float_t) x; + } else if (t <= DUK__FLOAT_ROUND_LIMIT) { + /* Out-of-range, but rounds to min/max float. */ + DUK_ASSERT(!DUK_ISNAN(x)); + if (x < 0.0) { + return (duk_float_t) -DUK__FLOAT_MAX; + } else { + return (duk_float_t) DUK__FLOAT_MAX; + } + } else if (DUK_ISNAN(x)) { + /* Assumes double NaN -> float NaN considered "in range". */ + DUK_ASSERT(DUK_ISNAN(x)); + return (duk_float_t) x; + } else { + /* Out-of-range, rounds to +/- Infinity. */ + if (x < 0.0) { + return (duk_float_t) -DUK_DOUBLE_INFINITY; + } else { + return (duk_float_t) DUK_DOUBLE_INFINITY; + } + } +#endif +} + +/* automatic undefs */ +#undef DUK__DOUBLE_INT_CAST1 +#undef DUK__DOUBLE_INT_CAST2 +#undef DUK__DOUBLE_INT_CAST3 +#undef DUK__DOUBLE_INT_CAST4 +#undef DUK__FLOAT_MAX +#undef DUK__FLOAT_ROUND_LIMIT +#line 1 "duk_util_double.c" +/* + * IEEE double helpers. + */ + +/* #include duk_internal.h -> already included */ + +DUK_INTERNAL duk_bool_t duk_double_is_anyinf(duk_double_t x) { + duk_double_union du; + du.d = x; + return DUK_DBLUNION_IS_ANYINF(&du); +} + +DUK_INTERNAL duk_bool_t duk_double_is_posinf(duk_double_t x) { + duk_double_union du; + du.d = x; + return DUK_DBLUNION_IS_POSINF(&du); +} + +DUK_INTERNAL duk_bool_t duk_double_is_neginf(duk_double_t x) { + duk_double_union du; + du.d = x; + return DUK_DBLUNION_IS_NEGINF(&du); +} + +DUK_INTERNAL duk_bool_t duk_double_is_nan(duk_double_t x) { + duk_double_union du; + du.d = x; + /* Assumes we're dealing with a Duktape internal NaN which is + * NaN normalized if duk_tval requires it. + */ + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&du)); + return DUK_DBLUNION_IS_NAN(&du); +} + +DUK_INTERNAL duk_bool_t duk_double_is_nan_or_zero(duk_double_t x) { + duk_double_union du; + du.d = x; + /* Assumes we're dealing with a Duktape internal NaN which is + * NaN normalized if duk_tval requires it. + */ + DUK_ASSERT(DUK_DBLUNION_IS_NORMALIZED(&du)); + return DUK_DBLUNION_IS_NAN(&du) || DUK_DBLUNION_IS_ANYZERO(&du); +} + +DUK_INTERNAL duk_bool_t duk_double_is_nan_or_inf(duk_double_t x) { + duk_double_union du; + du.d = x; + /* If exponent is 0x7FF the argument is either a NaN or an + * infinity. We don't need to check any other fields. + */ +#if defined(DUK_USE_64BIT_OPS) +#if defined(DUK_USE_DOUBLE_ME) + return (du.ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x000000007ff00000)) == DUK_U64_CONSTANT(0x000000007ff00000); +#else + return (du.ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x7ff0000000000000)) == DUK_U64_CONSTANT(0x7ff0000000000000); +#endif +#else + return (du.ui[DUK_DBL_IDX_UI0] & 0x7ff00000UL) == 0x7ff00000UL; +#endif +} + +DUK_INTERNAL duk_bool_t duk_double_is_nan_zero_inf(duk_double_t x) { + duk_double_union du; +#if defined(DUK_USE_64BIT_OPS) + duk_uint64_t t; +#else + duk_uint32_t t; +#endif + du.d = x; +#if defined(DUK_USE_64BIT_OPS) +#if defined(DUK_USE_DOUBLE_ME) + t = du.ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x000000007ff00000); + if (t == DUK_U64_CONSTANT(0x0000000000000000)) { + t = du.ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x0000000080000000); + return t == 0; + } + if (t == DUK_U64_CONSTANT(0x000000007ff00000)) { + return 1; + } +#else + t = du.ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x7ff0000000000000); + if (t == DUK_U64_CONSTANT(0x0000000000000000)) { + t = du.ull[DUK_DBL_IDX_ULL0] & DUK_U64_CONSTANT(0x8000000000000000); + return t == 0; + } + if (t == DUK_U64_CONSTANT(0x7ff0000000000000)) { + return 1; + } +#endif +#else + t = du.ui[DUK_DBL_IDX_UI0] & 0x7ff00000UL; + if (t == 0x00000000UL) { + return DUK_DBLUNION_IS_ANYZERO(&du); + } + if (t == 0x7ff00000UL) { + return 1; + } +#endif + return 0; +} + +DUK_INTERNAL duk_small_uint_t duk_double_signbit(duk_double_t x) { + duk_double_union du; + du.d = x; + return (duk_small_uint_t) DUK_DBLUNION_GET_SIGNBIT(&du); +} + +DUK_INTERNAL duk_double_t duk_double_trunc_towards_zero(duk_double_t x) { + /* XXX: optimize */ + duk_small_uint_t s = duk_double_signbit(x); + x = DUK_FLOOR(DUK_FABS(x)); /* truncate towards zero */ + if (s) { + x = -x; + } + return x; +} + +DUK_INTERNAL duk_bool_t duk_double_same_sign(duk_double_t x, duk_double_t y) { + duk_double_union du1; + duk_double_union du2; + du1.d = x; + du2.d = y; + + return (((du1.ui[DUK_DBL_IDX_UI0] ^ du2.ui[DUK_DBL_IDX_UI0]) & 0x80000000UL) == 0); +} + +DUK_INTERNAL duk_double_t duk_double_fmin(duk_double_t x, duk_double_t y) { + /* Doesn't replicate fmin() behavior exactly: for fmin() if one + * argument is a NaN, the other argument should be returned. + * Duktape doesn't rely on this behavior so the replacement can + * be simplified. + */ + return (x < y ? x : y); +} + +DUK_INTERNAL duk_double_t duk_double_fmax(duk_double_t x, duk_double_t y) { + /* Doesn't replicate fmax() behavior exactly: for fmax() if one + * argument is a NaN, the other argument should be returned. + * Duktape doesn't rely on this behavior so the replacement can + * be simplified. + */ + return (x > y ? x : y); +} + +DUK_INTERNAL duk_bool_t duk_double_is_finite(duk_double_t x) { + return !duk_double_is_nan_or_inf(x); +} + +DUK_INTERNAL duk_bool_t duk_double_is_integer(duk_double_t x) { + if (duk_double_is_nan_or_inf(x)) { + return 0; + } else { + return duk_double_equals(duk_js_tointeger_number(x), x); + } +} + +DUK_INTERNAL duk_bool_t duk_double_is_safe_integer(duk_double_t x) { + /* >>> 2**53-1 + * 9007199254740991 + */ + return duk_double_is_integer(x) && DUK_FABS(x) <= 9007199254740991.0; +} + +/* Check whether a duk_double_t is a whole number in the 32-bit range (reject + * negative zero), and if so, return a duk_int32_t. + * For compiler use: don't allow negative zero as it will cause trouble with + * LDINT+LDINTX, positive zero is OK. + */ +DUK_INTERNAL duk_bool_t duk_is_whole_get_int32_nonegzero(duk_double_t x, duk_int32_t *ival) { + duk_int32_t t; + + t = duk_double_to_int32_t(x); + if (!duk_double_equals((duk_double_t) t, x)) { + return 0; + } + if (t == 0) { + duk_double_union du; + du.d = x; + if (DUK_DBLUNION_HAS_SIGNBIT(&du)) { + return 0; + } + } + *ival = t; + return 1; +} + +/* Check whether a duk_double_t is a whole number in the 32-bit range, and if + * so, return a duk_int32_t. + */ +DUK_INTERNAL duk_bool_t duk_is_whole_get_int32(duk_double_t x, duk_int32_t *ival) { + duk_int32_t t; + + t = duk_double_to_int32_t(x); + if (!duk_double_equals((duk_double_t) t, x)) { + return 0; + } + *ival = t; + return 1; +} + +/* Division: division by zero is undefined behavior (and may in fact trap) + * so it needs special handling for portability. + */ + +DUK_INTERNAL DUK_INLINE duk_double_t duk_double_div(duk_double_t x, duk_double_t y) { +#if !defined(DUK_USE_ALLOW_UNDEFINED_BEHAVIOR) + if (DUK_UNLIKELY(duk_double_equals(y, 0.0) != 0)) { + /* In C99+ division by zero is undefined behavior so + * avoid it entirely. Hopefully the compiler is + * smart enough to avoid emitting any actual code + * because almost all practical platforms behave as + * expected. + */ + if (x > 0.0) { + if (DUK_SIGNBIT(y)) { + return -DUK_DOUBLE_INFINITY; + } else { + return DUK_DOUBLE_INFINITY; + } + } else if (x < 0.0) { + if (DUK_SIGNBIT(y)) { + return DUK_DOUBLE_INFINITY; + } else { + return -DUK_DOUBLE_INFINITY; + } + } else { + /* +/- 0, NaN */ + return DUK_DOUBLE_NAN; + } + } +#endif + + return x / y; +} + +/* Double and float byteorder changes. */ + +DUK_INTERNAL DUK_INLINE void duk_dblunion_host_to_little(duk_double_union *u) { +#if defined(DUK_USE_DOUBLE_LE) + /* HGFEDCBA -> HGFEDCBA */ + DUK_UNREF(u); +#elif defined(DUK_USE_DOUBLE_ME) + duk_uint32_t a, b; + + /* DCBAHGFE -> HGFEDCBA */ + a = u->ui[0]; + b = u->ui[1]; + u->ui[0] = b; + u->ui[1] = a; +#elif defined(DUK_USE_DOUBLE_BE) + /* ABCDEFGH -> HGFEDCBA */ +#if defined(DUK_USE_64BIT_OPS) + u->ull[0] = DUK_BSWAP64(u->ull[0]); +#else + duk_uint32_t a, b; + + a = u->ui[0]; + b = u->ui[1]; + u->ui[0] = DUK_BSWAP32(b); + u->ui[1] = DUK_BSWAP32(a); +#endif +#else +#error internal error +#endif +} + +DUK_INTERNAL DUK_INLINE void duk_dblunion_little_to_host(duk_double_union *u) { + duk_dblunion_host_to_little(u); +} + +DUK_INTERNAL DUK_INLINE void duk_dblunion_host_to_big(duk_double_union *u) { +#if defined(DUK_USE_DOUBLE_LE) + /* HGFEDCBA -> ABCDEFGH */ +#if defined(DUK_USE_64BIT_OPS) + u->ull[0] = DUK_BSWAP64(u->ull[0]); +#else + duk_uint32_t a, b; + + a = u->ui[0]; + b = u->ui[1]; + u->ui[0] = DUK_BSWAP32(b); + u->ui[1] = DUK_BSWAP32(a); +#endif +#elif defined(DUK_USE_DOUBLE_ME) + duk_uint32_t a, b; + + /* DCBAHGFE -> ABCDEFGH */ + a = u->ui[0]; + b = u->ui[1]; + u->ui[0] = DUK_BSWAP32(a); + u->ui[1] = DUK_BSWAP32(b); +#elif defined(DUK_USE_DOUBLE_BE) + /* ABCDEFGH -> ABCDEFGH */ + DUK_UNREF(u); +#else +#error internal error +#endif +} + +DUK_INTERNAL DUK_INLINE void duk_dblunion_big_to_host(duk_double_union *u) { + duk_dblunion_host_to_big(u); +} + +DUK_INTERNAL DUK_INLINE void duk_fltunion_host_to_big(duk_float_union *u) { +#if defined(DUK_USE_DOUBLE_LE) || defined(DUK_USE_DOUBLE_ME) + /* DCBA -> ABCD */ + u->ui[0] = DUK_BSWAP32(u->ui[0]); +#elif defined(DUK_USE_DOUBLE_BE) + /* ABCD -> ABCD */ + DUK_UNREF(u); +#else +#error internal error +#endif +} + +DUK_INTERNAL DUK_INLINE void duk_fltunion_big_to_host(duk_float_union *u) { + duk_fltunion_host_to_big(u); +} + +/* Comparison: ensures comparison operates on exactly correct types, avoiding + * some floating point comparison pitfalls (e.g. atan2() assertions failed on + * -m32 with direct comparison, even with explicit casts). + */ +#if defined(DUK_USE_GCC_PRAGMAS) +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wfloat-equal" +#elif defined(DUK_USE_CLANG_PRAGMAS) +#pragma clang diagnostic push +#pragma clang diagnostic ignored "-Wfloat-equal" +#endif + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_bool_t duk_double_equals(duk_double_t x, duk_double_t y) { + return x == y; +} + +DUK_INTERNAL DUK_ALWAYS_INLINE duk_bool_t duk_float_equals(duk_float_t x, duk_float_t y) { + return x == y; +} +#if defined(DUK_USE_GCC_PRAGMAS) +#pragma GCC diagnostic pop +#elif defined(DUK_USE_CLANG_PRAGMAS) +#pragma clang diagnostic pop +#endif +#line 1 "duk_util_hashbytes.c" +/* + * Hash function duk_util_hashbytes(). + * + * Currently, 32-bit MurmurHash2. + * + * Don't rely on specific hash values; hash function may be endianness + * dependent, for instance. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_STRHASH_DENSE) +/* 'magic' constants for Murmurhash2 */ +#define DUK__MAGIC_M ((duk_uint32_t) 0x5bd1e995UL) +#define DUK__MAGIC_R 24 + +DUK_INTERNAL duk_uint32_t duk_util_hashbytes(const duk_uint8_t *data, duk_size_t len, duk_uint32_t seed) { + duk_uint32_t h = seed ^ ((duk_uint32_t) len); + + while (len >= 4) { + /* Portability workaround is required for platforms without + * unaligned access. The replacement code emulates little + * endian access even on big endian architectures, which is + * OK as long as it is consistent for a build. + */ +#if defined(DUK_USE_HASHBYTES_UNALIGNED_U32_ACCESS) + duk_uint32_t k = *((const duk_uint32_t *) (const void *) data); +#else + duk_uint32_t k = ((duk_uint32_t) data[0]) | (((duk_uint32_t) data[1]) << 8) | (((duk_uint32_t) data[2]) << 16) | + (((duk_uint32_t) data[3]) << 24); +#endif + + k *= DUK__MAGIC_M; + k ^= k >> DUK__MAGIC_R; + k *= DUK__MAGIC_M; + h *= DUK__MAGIC_M; + h ^= k; + data += 4; + len -= 4; + } + + switch (len) { + case 3: + h ^= data[2] << 16; + case 2: + h ^= data[1] << 8; + case 1: + h ^= data[0]; + h *= DUK__MAGIC_M; + } + + h ^= h >> 13; + h *= DUK__MAGIC_M; + h ^= h >> 15; + + return h; +} +#endif /* DUK_USE_STRHASH_DENSE */ + +/* automatic undefs */ +#undef DUK__MAGIC_M +#undef DUK__MAGIC_R +#line 1 "duk_util_memory.c" +/* + * Memory utils. + */ + +/* #include duk_internal.h -> already included */ + +#if defined(DUK_USE_ALLOW_UNDEFINED_BEHAVIOR) +DUK_INTERNAL DUK_INLINE duk_small_int_t duk_memcmp_unsafe(const void *s1, const void *s2, duk_size_t len) { + DUK_ASSERT(s1 != NULL || len == 0U); + DUK_ASSERT(s2 != NULL || len == 0U); + return DUK_MEMCMP(s1, s2, (size_t) len); +} + +DUK_INTERNAL DUK_INLINE duk_small_int_t duk_memcmp(const void *s1, const void *s2, duk_size_t len) { + DUK_ASSERT(s1 != NULL); + DUK_ASSERT(s2 != NULL); + return DUK_MEMCMP(s1, s2, (size_t) len); +} +#else /* DUK_USE_ALLOW_UNDEFINED_BEHAVIOR */ +DUK_INTERNAL DUK_INLINE duk_small_int_t duk_memcmp_unsafe(const void *s1, const void *s2, duk_size_t len) { + DUK_ASSERT(s1 != NULL || len == 0U); + DUK_ASSERT(s2 != NULL || len == 0U); + if (DUK_UNLIKELY(len == 0U)) { + return 0; + } + DUK_ASSERT(s1 != NULL); + DUK_ASSERT(s2 != NULL); + return duk_memcmp(s1, s2, len); +} + +DUK_INTERNAL DUK_INLINE duk_small_int_t duk_memcmp(const void *s1, const void *s2, duk_size_t len) { + DUK_ASSERT(s1 != NULL); + DUK_ASSERT(s2 != NULL); + return DUK_MEMCMP(s1, s2, (size_t) len); +} +#endif /* DUK_USE_ALLOW_UNDEFINED_BEHAVIOR */ +#line 1 "duk_util_tinyrandom.c" +/* + * A tiny random number generator used for Math.random() and other internals. + * + * Default algorithm is xoroshiro128+: http://xoroshiro.di.unimi.it/xoroshiro128plus.c + * with SplitMix64 seed preparation: http://xorshift.di.unimi.it/splitmix64.c. + * + * Low memory targets and targets without 64-bit types use a slightly smaller + * (but slower) algorithm by Adi Shamir: + * http://www.woodmann.com/forum/archive/index.php/t-3100.html. + * + */ + +/* #include duk_internal.h -> already included */ + +#if !defined(DUK_USE_GET_RANDOM_DOUBLE) + +#if defined(DUK_USE_PREFER_SIZE) || !defined(DUK_USE_64BIT_OPS) +#define DUK__RANDOM_SHAMIR3OP +#else +#define DUK__RANDOM_XOROSHIRO128PLUS +#endif + +#if defined(DUK__RANDOM_SHAMIR3OP) +#define DUK__UPDATE_RND(rnd) \ + do { \ + (rnd) += ((rnd) * (rnd)) | 0x05UL; \ + (rnd) = ((rnd) &0xffffffffUL); /* if duk_uint32_t is exactly 32 bits, this is a NOP */ \ + } while (0) + +#define DUK__RND_BIT(rnd) ((rnd) >> 31) /* only use the highest bit */ + +DUK_INTERNAL void duk_util_tinyrandom_prepare_seed(duk_hthread *thr) { + DUK_UNREF(thr); /* Nothing now. */ +} + +DUK_INTERNAL duk_double_t duk_util_tinyrandom_get_double(duk_hthread *thr) { + duk_double_t t; + duk_small_int_t n; + duk_uint32_t rnd; + + rnd = thr->heap->rnd_state; + + n = 53; /* enough to cover the whole mantissa */ + t = 0.0; + + do { + DUK__UPDATE_RND(rnd); + t += DUK__RND_BIT(rnd); + t /= 2.0; + } while (--n); + + thr->heap->rnd_state = rnd; + + DUK_ASSERT(t >= (duk_double_t) 0.0); + DUK_ASSERT(t < (duk_double_t) 1.0); + + return t; +} +#endif /* DUK__RANDOM_SHAMIR3OP */ + +#if defined(DUK__RANDOM_XOROSHIRO128PLUS) +DUK_LOCAL DUK_ALWAYS_INLINE duk_uint64_t duk__rnd_splitmix64(duk_uint64_t *x) { + duk_uint64_t z; + z = (*x += DUK_U64_CONSTANT(0x9E3779B97F4A7C15)); + z = (z ^ (z >> 30U)) * DUK_U64_CONSTANT(0xBF58476D1CE4E5B9); + z = (z ^ (z >> 27U)) * DUK_U64_CONSTANT(0x94D049BB133111EB); + return z ^ (z >> 31U); +} + +DUK_LOCAL DUK_ALWAYS_INLINE duk_uint64_t duk__rnd_rotl(const duk_uint64_t x, duk_small_uint_t k) { + return (x << k) | (x >> (64U - k)); +} + +DUK_LOCAL DUK_ALWAYS_INLINE duk_uint64_t duk__xoroshiro128plus(duk_uint64_t *s) { + duk_uint64_t s0; + duk_uint64_t s1; + duk_uint64_t res; + + s0 = s[0]; + s1 = s[1]; + res = s0 + s1; + s1 ^= s0; + s[0] = duk__rnd_rotl(s0, 55) ^ s1 ^ (s1 << 14U); + s[1] = duk__rnd_rotl(s1, 36); + + return res; +} + +DUK_INTERNAL void duk_util_tinyrandom_prepare_seed(duk_hthread *thr) { + duk_small_uint_t i; + duk_uint64_t x; + + /* Mix both halves of the initial seed with SplitMix64. The intent + * is to ensure that very similar raw seeds (which is usually the case + * because current seed is Date.now()) result in different xoroshiro128+ + * seeds. + */ + x = thr->heap->rnd_state[0]; /* Only [0] is used as input here. */ + for (i = 0; i < 64; i++) { + thr->heap->rnd_state[i & 0x01] = duk__rnd_splitmix64(&x); /* Keep last 2 values. */ + } +} + +DUK_INTERNAL duk_double_t duk_util_tinyrandom_get_double(duk_hthread *thr) { + duk_uint64_t v; + duk_double_union du; + + /* For big and little endian the integer and IEEE double byte order + * is the same so a direct assignment works. For mixed endian the + * 32-bit parts must be swapped. + */ + v = (DUK_U64_CONSTANT(0x3ff) << 52U) | (duk__xoroshiro128plus((duk_uint64_t *) thr->heap->rnd_state) >> 12U); + du.ull[0] = v; +#if defined(DUK_USE_DOUBLE_ME) + do { + duk_uint32_t tmp; + tmp = du.ui[0]; + du.ui[0] = du.ui[1]; + du.ui[1] = tmp; + } while (0); +#endif + return du.d - 1.0; +} +#endif /* DUK__RANDOM_XOROSHIRO128PLUS */ + +#endif /* !DUK_USE_GET_RANDOM_DOUBLE */ + +/* automatic undefs */ +#undef DUK__RANDOM_SHAMIR3OP +#undef DUK__RANDOM_XOROSHIRO128PLUS +#undef DUK__RND_BIT +#undef DUK__UPDATE_RND diff --git a/source/engine/duktape.h b/source/engine/duktape.h new file mode 100644 index 00000000..d1583cd5 --- /dev/null +++ b/source/engine/duktape.h @@ -0,0 +1,1456 @@ +/* + * Duktape public API for Duktape 2.7.0. + * + * See the API reference for documentation on call semantics. The exposed, + * supported API is between the "BEGIN PUBLIC API" and "END PUBLIC API" + * comments. Other parts of the header are Duktape internal and related to + * e.g. platform/compiler/feature detection. + * + * Git commit 03d4d728f8365021de6955c649e6dcd05dcca99f (03d4d72-dirty). + * Git branch HEAD. + * + * See Duktape AUTHORS.rst and LICENSE.txt for copyright and + * licensing information. + */ + +/* LICENSE.txt */ +/* + * =============== + * Duktape license + * =============== + * + * (http://opensource.org/licenses/MIT) + * + * Copyright (c) 2013-present by Duktape authors (see AUTHORS.rst) + * + * Permission is hereby granted, free of charge, to any person obtaining a copy + * of this software and associated documentation files (the "Software"), to deal + * in the Software without restriction, including without limitation the rights + * to use, copy, modify, merge, publish, distribute, sublicense, and/or sell + * copies of the Software, and to permit persons to whom the Software is + * furnished to do so, subject to the following conditions: + * + * The above copyright notice and this permission notice shall be included in + * all copies or substantial portions of the Software. + * + * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR + * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE + * AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER + * LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, + * OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN + * THE SOFTWARE. + */ + +/* AUTHORS.rst */ +/* + * =============== + * Duktape authors + * =============== + * + * Copyright + * ========= + * + * Duktape copyrights are held by its authors. Each author has a copyright + * to their contribution, and agrees to irrevocably license the contribution + * under the Duktape ``LICENSE.txt``. + * + * Authors + * ======= + * + * Please include an e-mail address, a link to your GitHub profile, or something + * similar to allow your contribution to be identified accurately. + * + * The following people have contributed code, website contents, or Wiki contents, + * and agreed to irrevocably license their contributions under the Duktape + * ``LICENSE.txt`` (in order of appearance): + * + * * Sami Vaarala + * * Niki Dobrev + * * Andreas \u00d6man + * * L\u00e1szl\u00f3 Lang\u00f3 + * * Legimet + * * Karl Skomski + * * Bruce Pascoe + * * Ren\u00e9 Hollander + * * Julien Hamaide (https://github.com/crazyjul) + * * Sebastian G\u00f6tte (https://github.com/jaseg) + * * Tomasz Magulski (https://github.com/magul) + * * \D. Bohdan (https://github.com/dbohdan) + * * Ond\u0159ej Jirman (https://github.com/megous) + * * Sa\u00fal Ibarra Corretg\u00e9 + * * Jeremy HU + * * Ole Andr\u00e9 Vadla Ravn\u00e5s (https://github.com/oleavr) + * * Harold Brenes (https://github.com/harold-b) + * * Oliver Crow (https://github.com/ocrow) + * * Jakub Ch\u0142api\u0144ski (https://github.com/jchlapinski) + * * Brett Vickers (https://github.com/beevik) + * * Dominik Okwieka (https://github.com/okitec) + * * Remko Tron\u00e7on (https://el-tramo.be) + * * Romero Malaquias (rbsm@ic.ufal.br) + * * Michael Drake + * * Steven Don (https://github.com/shdon) + * * Simon Stone (https://github.com/sstone1) + * * \J. McC. (https://github.com/jmhmccr) + * * Jakub Nowakowski (https://github.com/jimvonmoon) + * * Tommy Nguyen (https://github.com/tn0502) + * * Fabrice Fontaine (https://github.com/ffontaine) + * * Christopher Hiller (https://github.com/boneskull) + * * Gonzalo Diethelm (https://github.com/gonzus) + * * Michal Kasperek (https://github.com/michalkas) + * * Andrew Janke (https://github.com/apjanke) + * * Steve Fan (https://github.com/stevefan1999) + * * Edward Betts (https://github.com/edwardbetts) + * * Ozhan Duz (https://github.com/webfolderio) + * * Akos Kiss (https://github.com/akosthekiss) + * * TheBrokenRail (https://github.com/TheBrokenRail) + * * Jesse Doyle (https://github.com/jessedoyle) + * * Gero Kuehn (https://github.com/dc6jgk) + * * James Swift (https://github.com/phraemer) + * * Luis de Bethencourt (https://github.com/luisbg) + * * Ian Whyman (https://github.com/v00d00) + * * Rick Sayre (https://github.com/whorfin) + * * Craig Leres (https://github.com/leres) + * * Maurici Abad (https://github.com/mauriciabad) + * * Nancy Li (https://github.com/NancyLi1013) + * * William Parks (https://github.com/WilliamParks) + * * Sam Hellawell (https://github.com/samhellawell) + * * Vladislavs Sokurenko (https://github.com/sokurenko) + * + * Other contributions + * =================== + * + * The following people have contributed something other than code (e.g. reported + * bugs, provided ideas, etc; roughly in order of appearance): + * + * * Greg Burns + * * Anthony Rabine + * * Carlos Costa + * * Aur\u00e9lien Bouilland + * * Preet Desai (Pris Matic) + * * judofyr (http://www.reddit.com/user/judofyr) + * * Jason Woofenden + * * Micha\u0142 Przyby\u015b + * * Anthony Howe + * * Conrad Pankoff + * * Jim Schimpf + * * Rajaran Gaunker (https://github.com/zimbabao) + * * Andreas \u00d6man + * * Doug Sanden + * * Josh Engebretson (https://github.com/JoshEngebretson) + * * Remo Eichenberger (https://github.com/remoe) + * * Mamod Mehyar (https://github.com/mamod) + * * David Demelier (https://github.com/markand) + * * Tim Caswell (https://github.com/creationix) + * * Mitchell Blank Jr (https://github.com/mitchblank) + * * https://github.com/yushli + * * Seo Sanghyeon (https://github.com/sanxiyn) + * * Han ChoongWoo (https://github.com/tunz) + * * Joshua Peek (https://github.com/josh) + * * Bruce E. Pascoe (https://github.com/fatcerberus) + * * https://github.com/Kelledin + * * https://github.com/sstruchtrup + * * Michael Drake (https://github.com/tlsa) + * * https://github.com/chris-y + * * Laurent Zubiaur (https://github.com/lzubiaur) + * * Neil Kolban (https://github.com/nkolban) + * * Wilhelm Wanecek (https://github.com/wanecek) + * * Andrew Janke (https://github.com/apjanke) + * * Unamer (https://github.com/unamer) + * * Karl Dahlke (eklhad@gmail.com) + * + * If you are accidentally missing from this list, send me an e-mail + * (``sami.vaarala@iki.fi``) and I'll fix the omission. + */ + +#if !defined(DUKTAPE_H_INCLUDED) +#define DUKTAPE_H_INCLUDED + +#define DUK_SINGLE_FILE + +/* + * BEGIN PUBLIC API + */ + +/* + * Version and Git commit identification + */ + +/* Duktape version, (major * 10000) + (minor * 100) + patch. Allows C code + * to #if (DUK_VERSION >= NNN) against Duktape API version. The same value + * is also available to ECMAScript code in Duktape.version. Unofficial + * development snapshots have 99 for patch level (e.g. 0.10.99 would be a + * development version after 0.10.0 but before the next official release). + */ +#define DUK_VERSION 20700L + +/* Git commit, describe, and branch for Duktape build. Useful for + * non-official snapshot builds so that application code can easily log + * which Duktape snapshot was used. Not available in the ECMAScript + * environment. + */ +#define DUK_GIT_COMMIT "03d4d728f8365021de6955c649e6dcd05dcca99f" +#define DUK_GIT_DESCRIBE "03d4d72-dirty" +#define DUK_GIT_BRANCH "HEAD" + +/* External duk_config.h provides platform/compiler/OS dependent + * typedefs and macros, and DUK_USE_xxx config options so that + * the rest of Duktape doesn't need to do any feature detection. + * DUK_VERSION is defined before including so that configuration + * snippets can react to it. + */ +#include "duk_config.h" + +/* + * Avoid C++ name mangling + */ + +#if defined(__cplusplus) +extern "C" { +#endif + +/* + * Some defines forwarded from feature detection + */ + +#undef DUK_API_VARIADIC_MACROS +#if defined(DUK_USE_VARIADIC_MACROS) +#define DUK_API_VARIADIC_MACROS +#endif + +#define DUK_API_NORETURN(decl) DUK_NORETURN(decl) + +/* + * Public API specific typedefs + * + * Many types are wrapped by Duktape for portability to rare platforms + * where e.g. 'int' is a 16-bit type. See practical typing discussion + * in Duktape web documentation. + */ + +struct duk_thread_state; +struct duk_memory_functions; +struct duk_function_list_entry; +struct duk_number_list_entry; +struct duk_time_components; + +/* duk_context is now defined in duk_config.h because it may also be + * referenced there by prototypes. + */ +typedef struct duk_thread_state duk_thread_state; +typedef struct duk_memory_functions duk_memory_functions; +typedef struct duk_function_list_entry duk_function_list_entry; +typedef struct duk_number_list_entry duk_number_list_entry; +typedef struct duk_time_components duk_time_components; + +typedef duk_ret_t (*duk_c_function)(duk_context *ctx); +typedef void *(*duk_alloc_function) (void *udata, duk_size_t size); +typedef void *(*duk_realloc_function) (void *udata, void *ptr, duk_size_t size); +typedef void (*duk_free_function) (void *udata, void *ptr); +typedef void (*duk_fatal_function) (void *udata, const char *msg); +typedef void (*duk_decode_char_function) (void *udata, duk_codepoint_t codepoint); +typedef duk_codepoint_t (*duk_map_char_function) (void *udata, duk_codepoint_t codepoint); +typedef duk_ret_t (*duk_safe_call_function) (duk_context *ctx, void *udata); +typedef duk_size_t (*duk_debug_read_function) (void *udata, char *buffer, duk_size_t length); +typedef duk_size_t (*duk_debug_write_function) (void *udata, const char *buffer, duk_size_t length); +typedef duk_size_t (*duk_debug_peek_function) (void *udata); +typedef void (*duk_debug_read_flush_function) (void *udata); +typedef void (*duk_debug_write_flush_function) (void *udata); +typedef duk_idx_t (*duk_debug_request_function) (duk_context *ctx, void *udata, duk_idx_t nvalues); +typedef void (*duk_debug_detached_function) (duk_context *ctx, void *udata); + +struct duk_thread_state { + /* XXX: Enough space to hold internal suspend/resume structure. + * This is rather awkward and to be fixed when the internal + * structure is visible for the public API header. + */ + char data[128]; +}; + +struct duk_memory_functions { + duk_alloc_function alloc_func; + duk_realloc_function realloc_func; + duk_free_function free_func; + void *udata; +}; + +struct duk_function_list_entry { + const char *key; + duk_c_function value; + duk_idx_t nargs; +}; + +struct duk_number_list_entry { + const char *key; + duk_double_t value; +}; + +struct duk_time_components { + duk_double_t year; /* year, e.g. 2016, ECMAScript year range */ + duk_double_t month; /* month: 1-12 */ + duk_double_t day; /* day: 1-31 */ + duk_double_t hours; /* hour: 0-59 */ + duk_double_t minutes; /* minute: 0-59 */ + duk_double_t seconds; /* second: 0-59 (in POSIX time no leap second) */ + duk_double_t milliseconds; /* may contain sub-millisecond fractions */ + duk_double_t weekday; /* weekday: 0-6, 0=Sunday, 1=Monday, ..., 6=Saturday */ +}; + +/* + * Constants + */ + +/* Duktape debug protocol version used by this build. */ +#define DUK_DEBUG_PROTOCOL_VERSION 2 + +/* Used to represent invalid index; if caller uses this without checking, + * this index will map to a non-existent stack entry. Also used in some + * API calls as a marker to denote "no value". + */ +#define DUK_INVALID_INDEX DUK_IDX_MIN + +/* Indicates that a native function does not have a fixed number of args, + * and the argument stack should not be capped/extended at all. + */ +#define DUK_VARARGS ((duk_int_t) (-1)) + +/* Number of value stack entries (in addition to actual call arguments) + * guaranteed to be allocated on entry to a Duktape/C function. + */ +#define DUK_API_ENTRY_STACK 64U + +/* Value types, used by e.g. duk_get_type() */ +#define DUK_TYPE_MIN 0U +#define DUK_TYPE_NONE 0U /* no value, e.g. invalid index */ +#define DUK_TYPE_UNDEFINED 1U /* ECMAScript undefined */ +#define DUK_TYPE_NULL 2U /* ECMAScript null */ +#define DUK_TYPE_BOOLEAN 3U /* ECMAScript boolean: 0 or 1 */ +#define DUK_TYPE_NUMBER 4U /* ECMAScript number: double */ +#define DUK_TYPE_STRING 5U /* ECMAScript string: CESU-8 / extended UTF-8 encoded */ +#define DUK_TYPE_OBJECT 6U /* ECMAScript object: includes objects, arrays, functions, threads */ +#define DUK_TYPE_BUFFER 7U /* fixed or dynamic, garbage collected byte buffer */ +#define DUK_TYPE_POINTER 8U /* raw void pointer */ +#define DUK_TYPE_LIGHTFUNC 9U /* lightweight function pointer */ +#define DUK_TYPE_MAX 9U + +/* Value mask types, used by e.g. duk_get_type_mask() */ +#define DUK_TYPE_MASK_NONE (1U << DUK_TYPE_NONE) +#define DUK_TYPE_MASK_UNDEFINED (1U << DUK_TYPE_UNDEFINED) +#define DUK_TYPE_MASK_NULL (1U << DUK_TYPE_NULL) +#define DUK_TYPE_MASK_BOOLEAN (1U << DUK_TYPE_BOOLEAN) +#define DUK_TYPE_MASK_NUMBER (1U << DUK_TYPE_NUMBER) +#define DUK_TYPE_MASK_STRING (1U << DUK_TYPE_STRING) +#define DUK_TYPE_MASK_OBJECT (1U << DUK_TYPE_OBJECT) +#define DUK_TYPE_MASK_BUFFER (1U << DUK_TYPE_BUFFER) +#define DUK_TYPE_MASK_POINTER (1U << DUK_TYPE_POINTER) +#define DUK_TYPE_MASK_LIGHTFUNC (1U << DUK_TYPE_LIGHTFUNC) +#define DUK_TYPE_MASK_THROW (1U << 10) /* internal flag value: throw if mask doesn't match */ +#define DUK_TYPE_MASK_PROMOTE (1U << 11) /* internal flag value: promote to object if mask matches */ + +/* Coercion hints */ +#define DUK_HINT_NONE 0 /* prefer number, unless input is a Date, in which + * case prefer string (E5 Section 8.12.8) + */ +#define DUK_HINT_STRING 1 /* prefer string */ +#define DUK_HINT_NUMBER 2 /* prefer number */ + +/* Enumeration flags for duk_enum() */ +#define DUK_ENUM_INCLUDE_NONENUMERABLE (1U << 0) /* enumerate non-numerable properties in addition to enumerable */ +#define DUK_ENUM_INCLUDE_HIDDEN (1U << 1) /* enumerate hidden symbols too (in Duktape 1.x called internal properties) */ +#define DUK_ENUM_INCLUDE_SYMBOLS (1U << 2) /* enumerate symbols */ +#define DUK_ENUM_EXCLUDE_STRINGS (1U << 3) /* exclude strings */ +#define DUK_ENUM_OWN_PROPERTIES_ONLY (1U << 4) /* don't walk prototype chain, only check own properties */ +#define DUK_ENUM_ARRAY_INDICES_ONLY (1U << 5) /* only enumerate array indices */ +/* XXX: misleading name */ +#define DUK_ENUM_SORT_ARRAY_INDICES (1U << 6) /* sort array indices (applied to full enumeration result, including inherited array indices); XXX: misleading name */ +#define DUK_ENUM_NO_PROXY_BEHAVIOR (1U << 7) /* enumerate a proxy object itself without invoking proxy behavior */ + +/* Compilation flags for duk_compile() and duk_eval() */ +/* DUK_COMPILE_xxx bits 0-2 are reserved for an internal 'nargs' argument. + */ +#define DUK_COMPILE_EVAL (1U << 3) /* compile eval code (instead of global code) */ +#define DUK_COMPILE_FUNCTION (1U << 4) /* compile function code (instead of global code) */ +#define DUK_COMPILE_STRICT (1U << 5) /* use strict (outer) context for global, eval, or function code */ +#define DUK_COMPILE_SHEBANG (1U << 6) /* allow shebang ('#! ...') comment on first line of source */ +#define DUK_COMPILE_SAFE (1U << 7) /* (internal) catch compilation errors */ +#define DUK_COMPILE_NORESULT (1U << 8) /* (internal) omit eval result */ +#define DUK_COMPILE_NOSOURCE (1U << 9) /* (internal) no source string on stack */ +#define DUK_COMPILE_STRLEN (1U << 10) /* (internal) take strlen() of src_buffer (avoids double evaluation in macro) */ +#define DUK_COMPILE_NOFILENAME (1U << 11) /* (internal) no filename on stack */ +#define DUK_COMPILE_FUNCEXPR (1U << 12) /* (internal) source is a function expression (used for Function constructor) */ + +/* Flags for duk_def_prop() and its variants; base flags + a lot of convenience shorthands */ +#define DUK_DEFPROP_WRITABLE (1U << 0) /* set writable (effective if DUK_DEFPROP_HAVE_WRITABLE set) */ +#define DUK_DEFPROP_ENUMERABLE (1U << 1) /* set enumerable (effective if DUK_DEFPROP_HAVE_ENUMERABLE set) */ +#define DUK_DEFPROP_CONFIGURABLE (1U << 2) /* set configurable (effective if DUK_DEFPROP_HAVE_CONFIGURABLE set) */ +#define DUK_DEFPROP_HAVE_WRITABLE (1U << 3) /* set/clear writable */ +#define DUK_DEFPROP_HAVE_ENUMERABLE (1U << 4) /* set/clear enumerable */ +#define DUK_DEFPROP_HAVE_CONFIGURABLE (1U << 5) /* set/clear configurable */ +#define DUK_DEFPROP_HAVE_VALUE (1U << 6) /* set value (given on value stack) */ +#define DUK_DEFPROP_HAVE_GETTER (1U << 7) /* set getter (given on value stack) */ +#define DUK_DEFPROP_HAVE_SETTER (1U << 8) /* set setter (given on value stack) */ +#define DUK_DEFPROP_FORCE (1U << 9) /* force change if possible, may still fail for e.g. virtual properties */ +#define DUK_DEFPROP_SET_WRITABLE (DUK_DEFPROP_HAVE_WRITABLE | DUK_DEFPROP_WRITABLE) +#define DUK_DEFPROP_CLEAR_WRITABLE DUK_DEFPROP_HAVE_WRITABLE +#define DUK_DEFPROP_SET_ENUMERABLE (DUK_DEFPROP_HAVE_ENUMERABLE | DUK_DEFPROP_ENUMERABLE) +#define DUK_DEFPROP_CLEAR_ENUMERABLE DUK_DEFPROP_HAVE_ENUMERABLE +#define DUK_DEFPROP_SET_CONFIGURABLE (DUK_DEFPROP_HAVE_CONFIGURABLE | DUK_DEFPROP_CONFIGURABLE) +#define DUK_DEFPROP_CLEAR_CONFIGURABLE DUK_DEFPROP_HAVE_CONFIGURABLE +#define DUK_DEFPROP_W DUK_DEFPROP_WRITABLE +#define DUK_DEFPROP_E DUK_DEFPROP_ENUMERABLE +#define DUK_DEFPROP_C DUK_DEFPROP_CONFIGURABLE +#define DUK_DEFPROP_WE (DUK_DEFPROP_WRITABLE | DUK_DEFPROP_ENUMERABLE) +#define DUK_DEFPROP_WC (DUK_DEFPROP_WRITABLE | DUK_DEFPROP_CONFIGURABLE) +#define DUK_DEFPROP_EC (DUK_DEFPROP_ENUMERABLE | DUK_DEFPROP_CONFIGURABLE) +#define DUK_DEFPROP_WEC (DUK_DEFPROP_WRITABLE | DUK_DEFPROP_ENUMERABLE | DUK_DEFPROP_CONFIGURABLE) +#define DUK_DEFPROP_HAVE_W DUK_DEFPROP_HAVE_WRITABLE +#define DUK_DEFPROP_HAVE_E DUK_DEFPROP_HAVE_ENUMERABLE +#define DUK_DEFPROP_HAVE_C DUK_DEFPROP_HAVE_CONFIGURABLE +#define DUK_DEFPROP_HAVE_WE (DUK_DEFPROP_HAVE_WRITABLE | DUK_DEFPROP_HAVE_ENUMERABLE) +#define DUK_DEFPROP_HAVE_WC (DUK_DEFPROP_HAVE_WRITABLE | DUK_DEFPROP_HAVE_CONFIGURABLE) +#define DUK_DEFPROP_HAVE_EC (DUK_DEFPROP_HAVE_ENUMERABLE | DUK_DEFPROP_HAVE_CONFIGURABLE) +#define DUK_DEFPROP_HAVE_WEC (DUK_DEFPROP_HAVE_WRITABLE | DUK_DEFPROP_HAVE_ENUMERABLE | DUK_DEFPROP_HAVE_CONFIGURABLE) +#define DUK_DEFPROP_SET_W DUK_DEFPROP_SET_WRITABLE +#define DUK_DEFPROP_SET_E DUK_DEFPROP_SET_ENUMERABLE +#define DUK_DEFPROP_SET_C DUK_DEFPROP_SET_CONFIGURABLE +#define DUK_DEFPROP_SET_WE (DUK_DEFPROP_SET_WRITABLE | DUK_DEFPROP_SET_ENUMERABLE) +#define DUK_DEFPROP_SET_WC (DUK_DEFPROP_SET_WRITABLE | DUK_DEFPROP_SET_CONFIGURABLE) +#define DUK_DEFPROP_SET_EC (DUK_DEFPROP_SET_ENUMERABLE | DUK_DEFPROP_SET_CONFIGURABLE) +#define DUK_DEFPROP_SET_WEC (DUK_DEFPROP_SET_WRITABLE | DUK_DEFPROP_SET_ENUMERABLE | DUK_DEFPROP_SET_CONFIGURABLE) +#define DUK_DEFPROP_CLEAR_W DUK_DEFPROP_CLEAR_WRITABLE +#define DUK_DEFPROP_CLEAR_E DUK_DEFPROP_CLEAR_ENUMERABLE +#define DUK_DEFPROP_CLEAR_C DUK_DEFPROP_CLEAR_CONFIGURABLE +#define DUK_DEFPROP_CLEAR_WE (DUK_DEFPROP_CLEAR_WRITABLE | DUK_DEFPROP_CLEAR_ENUMERABLE) +#define DUK_DEFPROP_CLEAR_WC (DUK_DEFPROP_CLEAR_WRITABLE | DUK_DEFPROP_CLEAR_CONFIGURABLE) +#define DUK_DEFPROP_CLEAR_EC (DUK_DEFPROP_CLEAR_ENUMERABLE | DUK_DEFPROP_CLEAR_CONFIGURABLE) +#define DUK_DEFPROP_CLEAR_WEC (DUK_DEFPROP_CLEAR_WRITABLE | DUK_DEFPROP_CLEAR_ENUMERABLE | DUK_DEFPROP_CLEAR_CONFIGURABLE) +#define DUK_DEFPROP_ATTR_W (DUK_DEFPROP_HAVE_WEC | DUK_DEFPROP_W) +#define DUK_DEFPROP_ATTR_E (DUK_DEFPROP_HAVE_WEC | DUK_DEFPROP_E) +#define DUK_DEFPROP_ATTR_C (DUK_DEFPROP_HAVE_WEC | DUK_DEFPROP_C) +#define DUK_DEFPROP_ATTR_WE (DUK_DEFPROP_HAVE_WEC | DUK_DEFPROP_WE) +#define DUK_DEFPROP_ATTR_WC (DUK_DEFPROP_HAVE_WEC | DUK_DEFPROP_WC) +#define DUK_DEFPROP_ATTR_EC (DUK_DEFPROP_HAVE_WEC | DUK_DEFPROP_EC) +#define DUK_DEFPROP_ATTR_WEC (DUK_DEFPROP_HAVE_WEC | DUK_DEFPROP_WEC) + +/* Flags for duk_push_thread_raw() */ +#define DUK_THREAD_NEW_GLOBAL_ENV (1U << 0) /* create a new global environment */ + +/* Flags for duk_gc() */ +#define DUK_GC_COMPACT (1U << 0) /* compact heap objects */ + +/* Error codes (must be 8 bits at most, see duk_error.h) */ +#define DUK_ERR_NONE 0 /* no error (e.g. from duk_get_error_code()) */ +#define DUK_ERR_ERROR 1 /* Error */ +#define DUK_ERR_EVAL_ERROR 2 /* EvalError */ +#define DUK_ERR_RANGE_ERROR 3 /* RangeError */ +#define DUK_ERR_REFERENCE_ERROR 4 /* ReferenceError */ +#define DUK_ERR_SYNTAX_ERROR 5 /* SyntaxError */ +#define DUK_ERR_TYPE_ERROR 6 /* TypeError */ +#define DUK_ERR_URI_ERROR 7 /* URIError */ + +/* Return codes for C functions (shortcut for throwing an error) */ +#define DUK_RET_ERROR (-DUK_ERR_ERROR) +#define DUK_RET_EVAL_ERROR (-DUK_ERR_EVAL_ERROR) +#define DUK_RET_RANGE_ERROR (-DUK_ERR_RANGE_ERROR) +#define DUK_RET_REFERENCE_ERROR (-DUK_ERR_REFERENCE_ERROR) +#define DUK_RET_SYNTAX_ERROR (-DUK_ERR_SYNTAX_ERROR) +#define DUK_RET_TYPE_ERROR (-DUK_ERR_TYPE_ERROR) +#define DUK_RET_URI_ERROR (-DUK_ERR_URI_ERROR) + +/* Return codes for protected calls (duk_safe_call(), duk_pcall()) */ +#define DUK_EXEC_SUCCESS 0 +#define DUK_EXEC_ERROR 1 + +/* Debug levels for DUK_USE_DEBUG_WRITE(). */ +#define DUK_LEVEL_DEBUG 0 +#define DUK_LEVEL_DDEBUG 1 +#define DUK_LEVEL_DDDEBUG 2 + +/* + * Macros to create Symbols as C statically constructed strings. + * + * Call e.g. as DUK_HIDDEN_SYMBOL("myProperty") <=> ("\xFF" "myProperty"). + * + * Local symbols have a unique suffix, caller should take care to avoid + * conflicting with the Duktape internal representation by e.g. prepending + * a '!' character: DUK_LOCAL_SYMBOL("myLocal", "!123"). + * + * Note that these can only be used for string constants, not dynamically + * created strings. + * + * You shouldn't normally use DUK_INTERNAL_SYMBOL() at all. It is reserved + * for Duktape internal symbols only. There are no versioning guarantees + * for internal symbols. + */ + +#define DUK_HIDDEN_SYMBOL(x) ("\xFF" x) +#define DUK_GLOBAL_SYMBOL(x) ("\x80" x) +#define DUK_LOCAL_SYMBOL(x,uniq) ("\x81" x "\xff" uniq) +#define DUK_WELLKNOWN_SYMBOL(x) ("\x81" x "\xff") +#define DUK_INTERNAL_SYMBOL(x) ("\x82" x) + +/* + * If no variadic macros, __FILE__ and __LINE__ are passed through globals + * which is ugly and not thread safe. + */ + +#if !defined(DUK_API_VARIADIC_MACROS) +DUK_EXTERNAL_DECL const char *duk_api_global_filename; +DUK_EXTERNAL_DECL duk_int_t duk_api_global_line; +#endif + +/* + * Context management + */ + +DUK_EXTERNAL_DECL +duk_context *duk_create_heap(duk_alloc_function alloc_func, + duk_realloc_function realloc_func, + duk_free_function free_func, + void *heap_udata, + duk_fatal_function fatal_handler); +DUK_EXTERNAL_DECL void duk_destroy_heap(duk_context *ctx); + +DUK_EXTERNAL_DECL void duk_suspend(duk_context *ctx, duk_thread_state *state); +DUK_EXTERNAL_DECL void duk_resume(duk_context *ctx, const duk_thread_state *state); + +#define duk_create_heap_default() \ + duk_create_heap(NULL, NULL, NULL, NULL, NULL) + +/* + * Memory management + * + * Raw functions have no side effects (cannot trigger GC). + */ + +DUK_EXTERNAL_DECL void *duk_alloc_raw(duk_context *ctx, duk_size_t size); +DUK_EXTERNAL_DECL void duk_free_raw(duk_context *ctx, void *ptr); +DUK_EXTERNAL_DECL void *duk_realloc_raw(duk_context *ctx, void *ptr, duk_size_t size); +DUK_EXTERNAL_DECL void *duk_alloc(duk_context *ctx, duk_size_t size); +DUK_EXTERNAL_DECL void duk_free(duk_context *ctx, void *ptr); +DUK_EXTERNAL_DECL void *duk_realloc(duk_context *ctx, void *ptr, duk_size_t size); +DUK_EXTERNAL_DECL void duk_get_memory_functions(duk_context *ctx, duk_memory_functions *out_funcs); +DUK_EXTERNAL_DECL void duk_gc(duk_context *ctx, duk_uint_t flags); + +/* + * Error handling + */ + +DUK_API_NORETURN(DUK_EXTERNAL_DECL void duk_throw_raw(duk_context *ctx)); +#define duk_throw(ctx) \ + (duk_throw_raw((ctx)), (duk_ret_t) 0) +DUK_API_NORETURN(DUK_EXTERNAL_DECL void duk_fatal_raw(duk_context *ctx, const char *err_msg)); +#define duk_fatal(ctx,err_msg) \ + (duk_fatal_raw((ctx), (err_msg)), (duk_ret_t) 0) +DUK_API_NORETURN(DUK_EXTERNAL_DECL void duk_error_raw(duk_context *ctx, duk_errcode_t err_code, const char *filename, duk_int_t line, const char *fmt, ...)); + +#if defined(DUK_API_VARIADIC_MACROS) +#define duk_error(ctx,err_code,...) \ + (duk_error_raw((ctx), (duk_errcode_t) (err_code), (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), __VA_ARGS__), (duk_ret_t) 0) +#define duk_generic_error(ctx,...) \ + (duk_error_raw((ctx), (duk_errcode_t) DUK_ERR_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), __VA_ARGS__), (duk_ret_t) 0) +#define duk_eval_error(ctx,...) \ + (duk_error_raw((ctx), (duk_errcode_t) DUK_ERR_EVAL_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), __VA_ARGS__), (duk_ret_t) 0) +#define duk_range_error(ctx,...) \ + (duk_error_raw((ctx), (duk_errcode_t) DUK_ERR_RANGE_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), __VA_ARGS__), (duk_ret_t) 0) +#define duk_reference_error(ctx,...) \ + (duk_error_raw((ctx), (duk_errcode_t) DUK_ERR_REFERENCE_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), __VA_ARGS__), (duk_ret_t) 0) +#define duk_syntax_error(ctx,...) \ + (duk_error_raw((ctx), (duk_errcode_t) DUK_ERR_SYNTAX_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), __VA_ARGS__), (duk_ret_t) 0) +#define duk_type_error(ctx,...) \ + (duk_error_raw((ctx), (duk_errcode_t) DUK_ERR_TYPE_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), __VA_ARGS__), (duk_ret_t) 0) +#define duk_uri_error(ctx,...) \ + (duk_error_raw((ctx), (duk_errcode_t) DUK_ERR_URI_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), __VA_ARGS__), (duk_ret_t) 0) +#else /* DUK_API_VARIADIC_MACROS */ +/* For legacy compilers without variadic macros a macro hack is used to allow + * variable arguments. While the macro allows "return duk_error(...)", it + * will fail with e.g. "(void) duk_error(...)". The calls are noreturn but + * with a return value to allow the "return duk_error(...)" idiom. This may + * cause some compiler warnings, but without noreturn the generated code is + * often worse. The same approach as with variadic macros (using + * "(duk_error(...), 0)") won't work due to the macro hack structure. + */ +DUK_API_NORETURN(DUK_EXTERNAL_DECL duk_ret_t duk_error_stash(duk_context *ctx, duk_errcode_t err_code, const char *fmt, ...)); +DUK_API_NORETURN(DUK_EXTERNAL_DECL duk_ret_t duk_generic_error_stash(duk_context *ctx, const char *fmt, ...)); +DUK_API_NORETURN(DUK_EXTERNAL_DECL duk_ret_t duk_eval_error_stash(duk_context *ctx, const char *fmt, ...)); +DUK_API_NORETURN(DUK_EXTERNAL_DECL duk_ret_t duk_range_error_stash(duk_context *ctx, const char *fmt, ...)); +DUK_API_NORETURN(DUK_EXTERNAL_DECL duk_ret_t duk_reference_error_stash(duk_context *ctx, const char *fmt, ...)); +DUK_API_NORETURN(DUK_EXTERNAL_DECL duk_ret_t duk_syntax_error_stash(duk_context *ctx, const char *fmt, ...)); +DUK_API_NORETURN(DUK_EXTERNAL_DECL duk_ret_t duk_type_error_stash(duk_context *ctx, const char *fmt, ...)); +DUK_API_NORETURN(DUK_EXTERNAL_DECL duk_ret_t duk_uri_error_stash(duk_context *ctx, const char *fmt, ...)); +#define duk_error \ + (duk_api_global_filename = (const char *) (DUK_FILE_MACRO), \ + duk_api_global_line = (duk_int_t) (DUK_LINE_MACRO), \ + duk_error_stash) /* last value is func pointer, arguments follow in parens */ +#define duk_generic_error \ + (duk_api_global_filename = (const char *) (DUK_FILE_MACRO), \ + duk_api_global_line = (duk_int_t) (DUK_LINE_MACRO), \ + duk_generic_error_stash) +#define duk_eval_error \ + (duk_api_global_filename = (const char *) (DUK_FILE_MACRO), \ + duk_api_global_line = (duk_int_t) (DUK_LINE_MACRO), \ + duk_eval_error_stash) +#define duk_range_error \ + (duk_api_global_filename = (const char *) (DUK_FILE_MACRO), \ + duk_api_global_line = (duk_int_t) (DUK_LINE_MACRO), \ + duk_range_error_stash) +#define duk_reference_error \ + (duk_api_global_filename = (const char *) (DUK_FILE_MACRO), \ + duk_api_global_line = (duk_int_t) (DUK_LINE_MACRO), \ + duk_reference_error_stash) +#define duk_syntax_error \ + (duk_api_global_filename = (const char *) (DUK_FILE_MACRO), \ + duk_api_global_line = (duk_int_t) (DUK_LINE_MACRO), \ + duk_syntax_error_stash) +#define duk_type_error \ + (duk_api_global_filename = (const char *) (DUK_FILE_MACRO), \ + duk_api_global_line = (duk_int_t) (DUK_LINE_MACRO), \ + duk_type_error_stash) +#define duk_uri_error \ + (duk_api_global_filename = (const char *) (DUK_FILE_MACRO), \ + duk_api_global_line = (duk_int_t) (DUK_LINE_MACRO), \ + duk_uri_error_stash) +#endif /* DUK_API_VARIADIC_MACROS */ + +DUK_API_NORETURN(DUK_EXTERNAL_DECL void duk_error_va_raw(duk_context *ctx, duk_errcode_t err_code, const char *filename, duk_int_t line, const char *fmt, va_list ap)); + +#define duk_error_va(ctx,err_code,fmt,ap) \ + (duk_error_va_raw((ctx), (duk_errcode_t) (err_code), (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), (fmt), (ap)), (duk_ret_t) 0) +#define duk_generic_error_va(ctx,fmt,ap) \ + (duk_error_va_raw((ctx), (duk_errcode_t) DUK_ERR_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), (fmt), (ap)), (duk_ret_t) 0) +#define duk_eval_error_va(ctx,fmt,ap) \ + (duk_error_va_raw((ctx), (duk_errcode_t) DUK_ERR_EVAL_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), (fmt), (ap)), (duk_ret_t) 0) +#define duk_range_error_va(ctx,fmt,ap) \ + (duk_error_va_raw((ctx), (duk_errcode_t) DUK_ERR_RANGE_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), (fmt), (ap)), (duk_ret_t) 0) +#define duk_reference_error_va(ctx,fmt,ap) \ + (duk_error_va_raw((ctx), (duk_errcode_t) DUK_ERR_REFERENCE_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), (fmt), (ap)), (duk_ret_t) 0) +#define duk_syntax_error_va(ctx,fmt,ap) \ + (duk_error_va_raw((ctx), (duk_errcode_t) DUK_ERR_SYNTAX_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), (fmt), (ap)), (duk_ret_t) 0) +#define duk_type_error_va(ctx,fmt,ap) \ + (duk_error_va_raw((ctx), (duk_errcode_t) DUK_ERR_TYPE_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), (fmt), (ap)), (duk_ret_t) 0) +#define duk_uri_error_va(ctx,fmt,ap) \ + (duk_error_va_raw((ctx), (duk_errcode_t) DUK_ERR_URI_ERROR, (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), (fmt), (ap)), (duk_ret_t) 0) + +/* + * Other state related functions + */ + +DUK_EXTERNAL_DECL duk_bool_t duk_is_strict_call(duk_context *ctx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_constructor_call(duk_context *ctx); + +/* + * Stack management + */ + +DUK_EXTERNAL_DECL duk_idx_t duk_normalize_index(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_idx_t duk_require_normalize_index(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_valid_index(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_require_valid_index(duk_context *ctx, duk_idx_t idx); + +DUK_EXTERNAL_DECL duk_idx_t duk_get_top(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_set_top(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_idx_t duk_get_top_index(duk_context *ctx); +DUK_EXTERNAL_DECL duk_idx_t duk_require_top_index(duk_context *ctx); + +/* Although extra/top could be an unsigned type here, using a signed type + * makes the API more robust to calling code calculation errors or corner + * cases (where caller might occasionally come up with negative values). + * Negative values are treated as zero, which is better than casting them + * to a large unsigned number. (This principle is used elsewhere in the + * API too.) + */ +DUK_EXTERNAL_DECL duk_bool_t duk_check_stack(duk_context *ctx, duk_idx_t extra); +DUK_EXTERNAL_DECL void duk_require_stack(duk_context *ctx, duk_idx_t extra); +DUK_EXTERNAL_DECL duk_bool_t duk_check_stack_top(duk_context *ctx, duk_idx_t top); +DUK_EXTERNAL_DECL void duk_require_stack_top(duk_context *ctx, duk_idx_t top); + +/* + * Stack manipulation (other than push/pop) + */ + +DUK_EXTERNAL_DECL void duk_swap(duk_context *ctx, duk_idx_t idx1, duk_idx_t idx2); +DUK_EXTERNAL_DECL void duk_swap_top(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_dup(duk_context *ctx, duk_idx_t from_idx); +DUK_EXTERNAL_DECL void duk_dup_top(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_insert(duk_context *ctx, duk_idx_t to_idx); +DUK_EXTERNAL_DECL void duk_pull(duk_context *ctx, duk_idx_t from_idx); +DUK_EXTERNAL_DECL void duk_replace(duk_context *ctx, duk_idx_t to_idx); +DUK_EXTERNAL_DECL void duk_copy(duk_context *ctx, duk_idx_t from_idx, duk_idx_t to_idx); +DUK_EXTERNAL_DECL void duk_remove(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_xcopymove_raw(duk_context *to_ctx, duk_context *from_ctx, duk_idx_t count, duk_bool_t is_copy); + +#define duk_xmove_top(to_ctx,from_ctx,count) \ + duk_xcopymove_raw((to_ctx), (from_ctx), (count), 0 /*is_copy*/) +#define duk_xcopy_top(to_ctx,from_ctx,count) \ + duk_xcopymove_raw((to_ctx), (from_ctx), (count), 1 /*is_copy*/) + +/* + * Push operations + * + * Push functions return the absolute (relative to bottom of frame) + * position of the pushed value for convenience. + * + * Note: duk_dup() is technically a push. + */ + +DUK_EXTERNAL_DECL void duk_push_undefined(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_null(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_boolean(duk_context *ctx, duk_bool_t val); +DUK_EXTERNAL_DECL void duk_push_true(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_false(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_number(duk_context *ctx, duk_double_t val); +DUK_EXTERNAL_DECL void duk_push_nan(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_int(duk_context *ctx, duk_int_t val); +DUK_EXTERNAL_DECL void duk_push_uint(duk_context *ctx, duk_uint_t val); +DUK_EXTERNAL_DECL const char *duk_push_string(duk_context *ctx, const char *str); +DUK_EXTERNAL_DECL const char *duk_push_lstring(duk_context *ctx, const char *str, duk_size_t len); +DUK_EXTERNAL_DECL void duk_push_pointer(duk_context *ctx, void *p); +DUK_EXTERNAL_DECL const char *duk_push_sprintf(duk_context *ctx, const char *fmt, ...); +DUK_EXTERNAL_DECL const char *duk_push_vsprintf(duk_context *ctx, const char *fmt, va_list ap); + +/* duk_push_literal() may evaluate its argument (a C string literal) more than + * once on purpose. When speed is preferred, sizeof() avoids an unnecessary + * strlen() at runtime. Sizeof("foo") == 4, so subtract 1. The argument + * must be non-NULL and should not contain internal NUL characters as the + * behavior will then depend on config options. + */ +#if defined(DUK_USE_PREFER_SIZE) +#define duk_push_literal(ctx,cstring) duk_push_string((ctx), (cstring)) +#else +DUK_EXTERNAL_DECL const char *duk_push_literal_raw(duk_context *ctx, const char *str, duk_size_t len); +#define duk_push_literal(ctx,cstring) duk_push_literal_raw((ctx), (cstring), sizeof((cstring)) - 1U) +#endif + +DUK_EXTERNAL_DECL void duk_push_this(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_new_target(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_current_function(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_current_thread(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_global_object(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_heap_stash(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_global_stash(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_push_thread_stash(duk_context *ctx, duk_context *target_ctx); + +DUK_EXTERNAL_DECL duk_idx_t duk_push_object(duk_context *ctx); +DUK_EXTERNAL_DECL duk_idx_t duk_push_bare_object(duk_context *ctx); +DUK_EXTERNAL_DECL duk_idx_t duk_push_array(duk_context *ctx); +DUK_EXTERNAL_DECL duk_idx_t duk_push_bare_array(duk_context *ctx); +DUK_EXTERNAL_DECL duk_idx_t duk_push_c_function(duk_context *ctx, duk_c_function func, duk_idx_t nargs); +DUK_EXTERNAL_DECL duk_idx_t duk_push_c_lightfunc(duk_context *ctx, duk_c_function func, duk_idx_t nargs, duk_idx_t length, duk_int_t magic); +DUK_EXTERNAL_DECL duk_idx_t duk_push_thread_raw(duk_context *ctx, duk_uint_t flags); +DUK_EXTERNAL_DECL duk_idx_t duk_push_proxy(duk_context *ctx, duk_uint_t proxy_flags); + +#define duk_push_thread(ctx) \ + duk_push_thread_raw((ctx), 0 /*flags*/) + +#define duk_push_thread_new_globalenv(ctx) \ + duk_push_thread_raw((ctx), DUK_THREAD_NEW_GLOBAL_ENV /*flags*/) + +DUK_EXTERNAL_DECL duk_idx_t duk_push_error_object_raw(duk_context *ctx, duk_errcode_t err_code, const char *filename, duk_int_t line, const char *fmt, ...); + +#if defined(DUK_API_VARIADIC_MACROS) +#define duk_push_error_object(ctx,err_code,...) \ + duk_push_error_object_raw((ctx), (err_code), (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), __VA_ARGS__) +#else +DUK_EXTERNAL_DECL duk_idx_t duk_push_error_object_stash(duk_context *ctx, duk_errcode_t err_code, const char *fmt, ...); +/* Note: parentheses are required so that the comma expression works in assignments. */ +#define duk_push_error_object \ + (duk_api_global_filename = (const char *) (DUK_FILE_MACRO), \ + duk_api_global_line = (duk_int_t) (DUK_LINE_MACRO), \ + duk_push_error_object_stash) /* last value is func pointer, arguments follow in parens */ +#endif + +DUK_EXTERNAL_DECL duk_idx_t duk_push_error_object_va_raw(duk_context *ctx, duk_errcode_t err_code, const char *filename, duk_int_t line, const char *fmt, va_list ap); +#define duk_push_error_object_va(ctx,err_code,fmt,ap) \ + duk_push_error_object_va_raw((ctx), (err_code), (const char *) (DUK_FILE_MACRO), (duk_int_t) (DUK_LINE_MACRO), (fmt), (ap)) + +#define DUK_BUF_FLAG_DYNAMIC (1 << 0) /* internal flag: dynamic buffer */ +#define DUK_BUF_FLAG_EXTERNAL (1 << 1) /* internal flag: external buffer */ +#define DUK_BUF_FLAG_NOZERO (1 << 2) /* internal flag: don't zero allocated buffer */ + +DUK_EXTERNAL_DECL void *duk_push_buffer_raw(duk_context *ctx, duk_size_t size, duk_small_uint_t flags); + +#define duk_push_buffer(ctx,size,dynamic) \ + duk_push_buffer_raw((ctx), (size), (dynamic) ? DUK_BUF_FLAG_DYNAMIC : 0) +#define duk_push_fixed_buffer(ctx,size) \ + duk_push_buffer_raw((ctx), (size), 0 /*flags*/) +#define duk_push_dynamic_buffer(ctx,size) \ + duk_push_buffer_raw((ctx), (size), DUK_BUF_FLAG_DYNAMIC /*flags*/) +#define duk_push_external_buffer(ctx) \ + ((void) duk_push_buffer_raw((ctx), 0, DUK_BUF_FLAG_DYNAMIC | DUK_BUF_FLAG_EXTERNAL)) + +#define DUK_BUFOBJ_ARRAYBUFFER 0 +#define DUK_BUFOBJ_NODEJS_BUFFER 1 +#define DUK_BUFOBJ_DATAVIEW 2 +#define DUK_BUFOBJ_INT8ARRAY 3 +#define DUK_BUFOBJ_UINT8ARRAY 4 +#define DUK_BUFOBJ_UINT8CLAMPEDARRAY 5 +#define DUK_BUFOBJ_INT16ARRAY 6 +#define DUK_BUFOBJ_UINT16ARRAY 7 +#define DUK_BUFOBJ_INT32ARRAY 8 +#define DUK_BUFOBJ_UINT32ARRAY 9 +#define DUK_BUFOBJ_FLOAT32ARRAY 10 +#define DUK_BUFOBJ_FLOAT64ARRAY 11 + +DUK_EXTERNAL_DECL void duk_push_buffer_object(duk_context *ctx, duk_idx_t idx_buffer, duk_size_t byte_offset, duk_size_t byte_length, duk_uint_t flags); + +DUK_EXTERNAL_DECL duk_idx_t duk_push_heapptr(duk_context *ctx, void *ptr); + +/* + * Pop operations + */ + +DUK_EXTERNAL_DECL void duk_pop(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_pop_n(duk_context *ctx, duk_idx_t count); +DUK_EXTERNAL_DECL void duk_pop_2(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_pop_3(duk_context *ctx); + +/* + * Type checks + * + * duk_is_none(), which would indicate whether index it outside of stack, + * is not needed; duk_is_valid_index() gives the same information. + */ + +DUK_EXTERNAL_DECL duk_int_t duk_get_type(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_check_type(duk_context *ctx, duk_idx_t idx, duk_int_t type); +DUK_EXTERNAL_DECL duk_uint_t duk_get_type_mask(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_check_type_mask(duk_context *ctx, duk_idx_t idx, duk_uint_t mask); + +DUK_EXTERNAL_DECL duk_bool_t duk_is_undefined(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_null(duk_context *ctx, duk_idx_t idx); +#define duk_is_null_or_undefined(ctx, idx) \ + ((duk_get_type_mask((ctx), (idx)) & (DUK_TYPE_MASK_NULL | DUK_TYPE_MASK_UNDEFINED)) ? 1 : 0) + +DUK_EXTERNAL_DECL duk_bool_t duk_is_boolean(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_number(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_nan(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_string(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_object(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_buffer(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_buffer_data(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_pointer(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_lightfunc(duk_context *ctx, duk_idx_t idx); + +DUK_EXTERNAL_DECL duk_bool_t duk_is_symbol(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_array(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_function(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_c_function(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_ecmascript_function(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_bound_function(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_thread(duk_context *ctx, duk_idx_t idx); + +#define duk_is_callable(ctx,idx) \ + duk_is_function((ctx), (idx)) +DUK_EXTERNAL_DECL duk_bool_t duk_is_constructable(duk_context *ctx, duk_idx_t idx); + +DUK_EXTERNAL_DECL duk_bool_t duk_is_dynamic_buffer(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_fixed_buffer(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_is_external_buffer(duk_context *ctx, duk_idx_t idx); + +/* Buffers and lightfuncs are not considered primitive because they mimic + * objects and e.g. duk_to_primitive() will coerce them instead of returning + * them as is. Symbols are represented as strings internally. + */ +#define duk_is_primitive(ctx,idx) \ + duk_check_type_mask((ctx), (idx), DUK_TYPE_MASK_UNDEFINED | \ + DUK_TYPE_MASK_NULL | \ + DUK_TYPE_MASK_BOOLEAN | \ + DUK_TYPE_MASK_NUMBER | \ + DUK_TYPE_MASK_STRING | \ + DUK_TYPE_MASK_POINTER) + +/* Symbols are object coercible, covered by DUK_TYPE_MASK_STRING. */ +#define duk_is_object_coercible(ctx,idx) \ + duk_check_type_mask((ctx), (idx), DUK_TYPE_MASK_BOOLEAN | \ + DUK_TYPE_MASK_NUMBER | \ + DUK_TYPE_MASK_STRING | \ + DUK_TYPE_MASK_OBJECT | \ + DUK_TYPE_MASK_BUFFER | \ + DUK_TYPE_MASK_POINTER | \ + DUK_TYPE_MASK_LIGHTFUNC) + +DUK_EXTERNAL_DECL duk_errcode_t duk_get_error_code(duk_context *ctx, duk_idx_t idx); +#define duk_is_error(ctx,idx) \ + (duk_get_error_code((ctx), (idx)) != 0) +#define duk_is_eval_error(ctx,idx) \ + (duk_get_error_code((ctx), (idx)) == DUK_ERR_EVAL_ERROR) +#define duk_is_range_error(ctx,idx) \ + (duk_get_error_code((ctx), (idx)) == DUK_ERR_RANGE_ERROR) +#define duk_is_reference_error(ctx,idx) \ + (duk_get_error_code((ctx), (idx)) == DUK_ERR_REFERENCE_ERROR) +#define duk_is_syntax_error(ctx,idx) \ + (duk_get_error_code((ctx), (idx)) == DUK_ERR_SYNTAX_ERROR) +#define duk_is_type_error(ctx,idx) \ + (duk_get_error_code((ctx), (idx)) == DUK_ERR_TYPE_ERROR) +#define duk_is_uri_error(ctx,idx) \ + (duk_get_error_code((ctx), (idx)) == DUK_ERR_URI_ERROR) + +/* + * Get operations: no coercion, returns default value for invalid + * indices and invalid value types. + * + * duk_get_undefined() and duk_get_null() would be pointless and + * are not included. + */ + +DUK_EXTERNAL_DECL duk_bool_t duk_get_boolean(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_double_t duk_get_number(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_int_t duk_get_int(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_uint_t duk_get_uint(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL const char *duk_get_string(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL const char *duk_get_lstring(duk_context *ctx, duk_idx_t idx, duk_size_t *out_len); +DUK_EXTERNAL_DECL void *duk_get_buffer(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size); +DUK_EXTERNAL_DECL void *duk_get_buffer_data(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size); +DUK_EXTERNAL_DECL void *duk_get_pointer(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_c_function duk_get_c_function(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_context *duk_get_context(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void *duk_get_heapptr(duk_context *ctx, duk_idx_t idx); + +/* + * Get-with-explicit default operations: like get operations but with an + * explicit default value. + */ + +DUK_EXTERNAL_DECL duk_bool_t duk_get_boolean_default(duk_context *ctx, duk_idx_t idx, duk_bool_t def_value); +DUK_EXTERNAL_DECL duk_double_t duk_get_number_default(duk_context *ctx, duk_idx_t idx, duk_double_t def_value); +DUK_EXTERNAL_DECL duk_int_t duk_get_int_default(duk_context *ctx, duk_idx_t idx, duk_int_t def_value); +DUK_EXTERNAL_DECL duk_uint_t duk_get_uint_default(duk_context *ctx, duk_idx_t idx, duk_uint_t def_value); +DUK_EXTERNAL_DECL const char *duk_get_string_default(duk_context *ctx, duk_idx_t idx, const char *def_value); +DUK_EXTERNAL_DECL const char *duk_get_lstring_default(duk_context *ctx, duk_idx_t idx, duk_size_t *out_len, const char *def_ptr, duk_size_t def_len); +DUK_EXTERNAL_DECL void *duk_get_buffer_default(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size, void *def_ptr, duk_size_t def_len); +DUK_EXTERNAL_DECL void *duk_get_buffer_data_default(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size, void *def_ptr, duk_size_t def_len); +DUK_EXTERNAL_DECL void *duk_get_pointer_default(duk_context *ctx, duk_idx_t idx, void *def_value); +DUK_EXTERNAL_DECL duk_c_function duk_get_c_function_default(duk_context *ctx, duk_idx_t idx, duk_c_function def_value); +DUK_EXTERNAL_DECL duk_context *duk_get_context_default(duk_context *ctx, duk_idx_t idx, duk_context *def_value); +DUK_EXTERNAL_DECL void *duk_get_heapptr_default(duk_context *ctx, duk_idx_t idx, void *def_value); + +/* + * Opt operations: like require operations but with an explicit default value + * when value is undefined or index is invalid, null and non-matching types + * cause a TypeError. + */ + +DUK_EXTERNAL_DECL duk_bool_t duk_opt_boolean(duk_context *ctx, duk_idx_t idx, duk_bool_t def_value); +DUK_EXTERNAL_DECL duk_double_t duk_opt_number(duk_context *ctx, duk_idx_t idx, duk_double_t def_value); +DUK_EXTERNAL_DECL duk_int_t duk_opt_int(duk_context *ctx, duk_idx_t idx, duk_int_t def_value); +DUK_EXTERNAL_DECL duk_uint_t duk_opt_uint(duk_context *ctx, duk_idx_t idx, duk_uint_t def_value); +DUK_EXTERNAL_DECL const char *duk_opt_string(duk_context *ctx, duk_idx_t idx, const char *def_ptr); +DUK_EXTERNAL_DECL const char *duk_opt_lstring(duk_context *ctx, duk_idx_t idx, duk_size_t *out_len, const char *def_ptr, duk_size_t def_len); +DUK_EXTERNAL_DECL void *duk_opt_buffer(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size, void *def_ptr, duk_size_t def_size); +DUK_EXTERNAL_DECL void *duk_opt_buffer_data(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size, void *def_ptr, duk_size_t def_size); +DUK_EXTERNAL_DECL void *duk_opt_pointer(duk_context *ctx, duk_idx_t idx, void *def_value); +DUK_EXTERNAL_DECL duk_c_function duk_opt_c_function(duk_context *ctx, duk_idx_t idx, duk_c_function def_value); +DUK_EXTERNAL_DECL duk_context *duk_opt_context(duk_context *ctx, duk_idx_t idx, duk_context *def_value); +DUK_EXTERNAL_DECL void *duk_opt_heapptr(duk_context *ctx, duk_idx_t idx, void *def_value); + +/* + * Require operations: no coercion, throw error if index or type + * is incorrect. No defaulting. + */ + +#define duk_require_type_mask(ctx,idx,mask) \ + ((void) duk_check_type_mask((ctx), (idx), (mask) | DUK_TYPE_MASK_THROW)) + +DUK_EXTERNAL_DECL void duk_require_undefined(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_require_null(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_require_boolean(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_double_t duk_require_number(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_int_t duk_require_int(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_uint_t duk_require_uint(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL const char *duk_require_string(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL const char *duk_require_lstring(duk_context *ctx, duk_idx_t idx, duk_size_t *out_len); +DUK_EXTERNAL_DECL void duk_require_object(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void *duk_require_buffer(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size); +DUK_EXTERNAL_DECL void *duk_require_buffer_data(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size); +DUK_EXTERNAL_DECL void *duk_require_pointer(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_c_function duk_require_c_function(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_context *duk_require_context(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_require_function(duk_context *ctx, duk_idx_t idx); +#define duk_require_callable(ctx,idx) \ + duk_require_function((ctx), (idx)) +DUK_EXTERNAL_DECL void duk_require_constructor_call(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_require_constructable(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void *duk_require_heapptr(duk_context *ctx, duk_idx_t idx); + +/* Symbols are object coercible and covered by DUK_TYPE_MASK_STRING. */ +#define duk_require_object_coercible(ctx,idx) \ + ((void) duk_check_type_mask((ctx), (idx), DUK_TYPE_MASK_BOOLEAN | \ + DUK_TYPE_MASK_NUMBER | \ + DUK_TYPE_MASK_STRING | \ + DUK_TYPE_MASK_OBJECT | \ + DUK_TYPE_MASK_BUFFER | \ + DUK_TYPE_MASK_POINTER | \ + DUK_TYPE_MASK_LIGHTFUNC | \ + DUK_TYPE_MASK_THROW)) + +/* + * Coercion operations: in-place coercion, return coerced value where + * applicable. If index is invalid, throw error. Some coercions may + * throw an expected error (e.g. from a toString() or valueOf() call) + * or an internal error (e.g. from out of memory). + */ + +DUK_EXTERNAL_DECL void duk_to_undefined(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_to_null(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_bool_t duk_to_boolean(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_double_t duk_to_number(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_int_t duk_to_int(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_uint_t duk_to_uint(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_int32_t duk_to_int32(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_uint32_t duk_to_uint32(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_uint16_t duk_to_uint16(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL const char *duk_to_string(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL const char *duk_to_lstring(duk_context *ctx, duk_idx_t idx, duk_size_t *out_len); +DUK_EXTERNAL_DECL void *duk_to_buffer_raw(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size, duk_uint_t flags); +DUK_EXTERNAL_DECL void *duk_to_pointer(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_to_object(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_to_primitive(duk_context *ctx, duk_idx_t idx, duk_int_t hint); + +#define DUK_BUF_MODE_FIXED 0 /* internal: request fixed buffer result */ +#define DUK_BUF_MODE_DYNAMIC 1 /* internal: request dynamic buffer result */ +#define DUK_BUF_MODE_DONTCARE 2 /* internal: don't care about fixed/dynamic nature */ + +#define duk_to_buffer(ctx,idx,out_size) \ + duk_to_buffer_raw((ctx), (idx), (out_size), DUK_BUF_MODE_DONTCARE) +#define duk_to_fixed_buffer(ctx,idx,out_size) \ + duk_to_buffer_raw((ctx), (idx), (out_size), DUK_BUF_MODE_FIXED) +#define duk_to_dynamic_buffer(ctx,idx,out_size) \ + duk_to_buffer_raw((ctx), (idx), (out_size), DUK_BUF_MODE_DYNAMIC) + +/* safe variants of a few coercion operations */ +DUK_EXTERNAL_DECL const char *duk_safe_to_lstring(duk_context *ctx, duk_idx_t idx, duk_size_t *out_len); +DUK_EXTERNAL_DECL const char *duk_to_stacktrace(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL const char *duk_safe_to_stacktrace(duk_context *ctx, duk_idx_t idx); +#define duk_safe_to_string(ctx,idx) \ + duk_safe_to_lstring((ctx), (idx), NULL) + +/* + * Value length + */ + +DUK_EXTERNAL_DECL duk_size_t duk_get_length(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_set_length(duk_context *ctx, duk_idx_t idx, duk_size_t len); +#if 0 +/* duk_require_length()? */ +/* duk_opt_length()? */ +#endif + +/* + * Misc conversion + */ + +DUK_EXTERNAL_DECL const char *duk_base64_encode(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_base64_decode(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL const char *duk_hex_encode(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_hex_decode(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL const char *duk_json_encode(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_json_decode(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_cbor_encode(duk_context *ctx, duk_idx_t idx, duk_uint_t encode_flags); +DUK_EXTERNAL_DECL void duk_cbor_decode(duk_context *ctx, duk_idx_t idx, duk_uint_t decode_flags); + +DUK_EXTERNAL_DECL const char *duk_buffer_to_string(duk_context *ctx, duk_idx_t idx); + +/* + * Buffer + */ + +DUK_EXTERNAL_DECL void *duk_resize_buffer(duk_context *ctx, duk_idx_t idx, duk_size_t new_size); +DUK_EXTERNAL_DECL void *duk_steal_buffer(duk_context *ctx, duk_idx_t idx, duk_size_t *out_size); +DUK_EXTERNAL_DECL void duk_config_buffer(duk_context *ctx, duk_idx_t idx, void *ptr, duk_size_t len); + +/* + * Property access + * + * The basic function assumes key is on stack. The _(l)string variant takes + * a C string as a property name; the _literal variant takes a C literal. + * The _index variant takes an array index as a property name (e.g. 123 is + * equivalent to the key "123"). The _heapptr variant takes a raw, borrowed + * heap pointer. + */ + +DUK_EXTERNAL_DECL duk_bool_t duk_get_prop(duk_context *ctx, duk_idx_t obj_idx); +DUK_EXTERNAL_DECL duk_bool_t duk_get_prop_string(duk_context *ctx, duk_idx_t obj_idx, const char *key); +DUK_EXTERNAL_DECL duk_bool_t duk_get_prop_lstring(duk_context *ctx, duk_idx_t obj_idx, const char *key, duk_size_t key_len); +#if defined(DUK_USE_PREFER_SIZE) +#define duk_get_prop_literal(ctx,obj_idx,key) duk_get_prop_string((ctx), (obj_idx), (key)) +#else +DUK_EXTERNAL_DECL duk_bool_t duk_get_prop_literal_raw(duk_context *ctx, duk_idx_t obj_idx, const char *key, duk_size_t key_len); +#define duk_get_prop_literal(ctx,obj_idx,key) duk_get_prop_literal_raw((ctx), (obj_idx), (key), sizeof((key)) - 1U) +#endif +DUK_EXTERNAL_DECL duk_bool_t duk_get_prop_index(duk_context *ctx, duk_idx_t obj_idx, duk_uarridx_t arr_idx); +DUK_EXTERNAL_DECL duk_bool_t duk_get_prop_heapptr(duk_context *ctx, duk_idx_t obj_idx, void *ptr); +DUK_EXTERNAL_DECL duk_bool_t duk_put_prop(duk_context *ctx, duk_idx_t obj_idx); +DUK_EXTERNAL_DECL duk_bool_t duk_put_prop_string(duk_context *ctx, duk_idx_t obj_idx, const char *key); +DUK_EXTERNAL_DECL duk_bool_t duk_put_prop_lstring(duk_context *ctx, duk_idx_t obj_idx, const char *key, duk_size_t key_len); +#if defined(DUK_USE_PREFER_SIZE) +#define duk_put_prop_literal(ctx,obj_idx,key) duk_put_prop_string((ctx), (obj_idx), (key)) +#else +DUK_EXTERNAL_DECL duk_bool_t duk_put_prop_literal_raw(duk_context *ctx, duk_idx_t obj_idx, const char *key, duk_size_t key_len); +#define duk_put_prop_literal(ctx,obj_idx,key) duk_put_prop_literal_raw((ctx), (obj_idx), (key), sizeof((key)) - 1U) +#endif +DUK_EXTERNAL_DECL duk_bool_t duk_put_prop_index(duk_context *ctx, duk_idx_t obj_idx, duk_uarridx_t arr_idx); +DUK_EXTERNAL_DECL duk_bool_t duk_put_prop_heapptr(duk_context *ctx, duk_idx_t obj_idx, void *ptr); +DUK_EXTERNAL_DECL duk_bool_t duk_del_prop(duk_context *ctx, duk_idx_t obj_idx); +DUK_EXTERNAL_DECL duk_bool_t duk_del_prop_string(duk_context *ctx, duk_idx_t obj_idx, const char *key); +DUK_EXTERNAL_DECL duk_bool_t duk_del_prop_lstring(duk_context *ctx, duk_idx_t obj_idx, const char *key, duk_size_t key_len); +#if defined(DUK_USE_PREFER_SIZE) +#define duk_del_prop_literal(ctx,obj_idx,key) duk_del_prop_string((ctx), (obj_idx), (key)) +#else +DUK_EXTERNAL_DECL duk_bool_t duk_del_prop_literal_raw(duk_context *ctx, duk_idx_t obj_idx, const char *key, duk_size_t key_len); +#define duk_del_prop_literal(ctx,obj_idx,key) duk_del_prop_literal_raw((ctx), (obj_idx), (key), sizeof((key)) - 1U) +#endif +DUK_EXTERNAL_DECL duk_bool_t duk_del_prop_index(duk_context *ctx, duk_idx_t obj_idx, duk_uarridx_t arr_idx); +DUK_EXTERNAL_DECL duk_bool_t duk_del_prop_heapptr(duk_context *ctx, duk_idx_t obj_idx, void *ptr); +DUK_EXTERNAL_DECL duk_bool_t duk_has_prop(duk_context *ctx, duk_idx_t obj_idx); +DUK_EXTERNAL_DECL duk_bool_t duk_has_prop_string(duk_context *ctx, duk_idx_t obj_idx, const char *key); +DUK_EXTERNAL_DECL duk_bool_t duk_has_prop_lstring(duk_context *ctx, duk_idx_t obj_idx, const char *key, duk_size_t key_len); +#if defined(DUK_USE_PREFER_SIZE) +#define duk_has_prop_literal(ctx,obj_idx,key) duk_has_prop_string((ctx), (obj_idx), (key)) +#else +DUK_EXTERNAL_DECL duk_bool_t duk_has_prop_literal_raw(duk_context *ctx, duk_idx_t obj_idx, const char *key, duk_size_t key_len); +#define duk_has_prop_literal(ctx,obj_idx,key) duk_has_prop_literal_raw((ctx), (obj_idx), (key), sizeof((key)) - 1U) +#endif +DUK_EXTERNAL_DECL duk_bool_t duk_has_prop_index(duk_context *ctx, duk_idx_t obj_idx, duk_uarridx_t arr_idx); +DUK_EXTERNAL_DECL duk_bool_t duk_has_prop_heapptr(duk_context *ctx, duk_idx_t obj_idx, void *ptr); + +DUK_EXTERNAL_DECL void duk_get_prop_desc(duk_context *ctx, duk_idx_t obj_idx, duk_uint_t flags); +DUK_EXTERNAL_DECL void duk_def_prop(duk_context *ctx, duk_idx_t obj_idx, duk_uint_t flags); + +DUK_EXTERNAL_DECL duk_bool_t duk_get_global_string(duk_context *ctx, const char *key); +DUK_EXTERNAL_DECL duk_bool_t duk_get_global_lstring(duk_context *ctx, const char *key, duk_size_t key_len); +#if defined(DUK_USE_PREFER_SIZE) +#define duk_get_global_literal(ctx,key) duk_get_global_string((ctx), (key)) +#else +DUK_EXTERNAL_DECL duk_bool_t duk_get_global_literal_raw(duk_context *ctx, const char *key, duk_size_t key_len); +#define duk_get_global_literal(ctx,key) duk_get_global_literal_raw((ctx), (key), sizeof((key)) - 1U) +#endif +DUK_EXTERNAL_DECL duk_bool_t duk_get_global_heapptr(duk_context *ctx, void *ptr); +DUK_EXTERNAL_DECL duk_bool_t duk_put_global_string(duk_context *ctx, const char *key); +DUK_EXTERNAL_DECL duk_bool_t duk_put_global_lstring(duk_context *ctx, const char *key, duk_size_t key_len); +#if defined(DUK_USE_PREFER_SIZE) +#define duk_put_global_literal(ctx,key) duk_put_global_string((ctx), (key)) +#else +DUK_EXTERNAL_DECL duk_bool_t duk_put_global_literal_raw(duk_context *ctx, const char *key, duk_size_t key_len); +#define duk_put_global_literal(ctx,key) duk_put_global_literal_raw((ctx), (key), sizeof((key)) - 1U) +#endif +DUK_EXTERNAL_DECL duk_bool_t duk_put_global_heapptr(duk_context *ctx, void *ptr); + +/* + * Inspection + */ + +DUK_EXTERNAL_DECL void duk_inspect_value(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_inspect_callstack_entry(duk_context *ctx, duk_int_t level); + +/* + * Object prototype + */ + +DUK_EXTERNAL_DECL void duk_get_prototype(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_set_prototype(duk_context *ctx, duk_idx_t idx); + +/* + * Object finalizer + */ + +DUK_EXTERNAL_DECL void duk_get_finalizer(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_set_finalizer(duk_context *ctx, duk_idx_t idx); + +/* + * Global object + */ + +DUK_EXTERNAL_DECL void duk_set_global_object(duk_context *ctx); + +/* + * Duktape/C function magic value + */ + +DUK_EXTERNAL_DECL duk_int_t duk_get_magic(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL void duk_set_magic(duk_context *ctx, duk_idx_t idx, duk_int_t magic); +DUK_EXTERNAL_DECL duk_int_t duk_get_current_magic(duk_context *ctx); + +/* + * Module helpers: put multiple function or constant properties + */ + +DUK_EXTERNAL_DECL void duk_put_function_list(duk_context *ctx, duk_idx_t obj_idx, const duk_function_list_entry *funcs); +DUK_EXTERNAL_DECL void duk_put_number_list(duk_context *ctx, duk_idx_t obj_idx, const duk_number_list_entry *numbers); + +/* + * Object operations + */ + +DUK_EXTERNAL_DECL void duk_compact(duk_context *ctx, duk_idx_t obj_idx); +DUK_EXTERNAL_DECL void duk_enum(duk_context *ctx, duk_idx_t obj_idx, duk_uint_t enum_flags); +DUK_EXTERNAL_DECL duk_bool_t duk_next(duk_context *ctx, duk_idx_t enum_idx, duk_bool_t get_value); +DUK_EXTERNAL_DECL void duk_seal(duk_context *ctx, duk_idx_t obj_idx); +DUK_EXTERNAL_DECL void duk_freeze(duk_context *ctx, duk_idx_t obj_idx); + +/* + * String manipulation + */ + +DUK_EXTERNAL_DECL void duk_concat(duk_context *ctx, duk_idx_t count); +DUK_EXTERNAL_DECL void duk_join(duk_context *ctx, duk_idx_t count); +DUK_EXTERNAL_DECL void duk_decode_string(duk_context *ctx, duk_idx_t idx, duk_decode_char_function callback, void *udata); +DUK_EXTERNAL_DECL void duk_map_string(duk_context *ctx, duk_idx_t idx, duk_map_char_function callback, void *udata); +DUK_EXTERNAL_DECL void duk_substring(duk_context *ctx, duk_idx_t idx, duk_size_t start_char_offset, duk_size_t end_char_offset); +DUK_EXTERNAL_DECL void duk_trim(duk_context *ctx, duk_idx_t idx); +DUK_EXTERNAL_DECL duk_codepoint_t duk_char_code_at(duk_context *ctx, duk_idx_t idx, duk_size_t char_offset); + +/* + * ECMAScript operators + */ + +DUK_EXTERNAL_DECL duk_bool_t duk_equals(duk_context *ctx, duk_idx_t idx1, duk_idx_t idx2); +DUK_EXTERNAL_DECL duk_bool_t duk_strict_equals(duk_context *ctx, duk_idx_t idx1, duk_idx_t idx2); +DUK_EXTERNAL_DECL duk_bool_t duk_samevalue(duk_context *ctx, duk_idx_t idx1, duk_idx_t idx2); +DUK_EXTERNAL_DECL duk_bool_t duk_instanceof(duk_context *ctx, duk_idx_t idx1, duk_idx_t idx2); + +/* + * Random + */ + +DUK_EXTERNAL_DECL duk_double_t duk_random(duk_context *ctx); + +/* + * Function (method) calls + */ + +DUK_EXTERNAL_DECL void duk_call(duk_context *ctx, duk_idx_t nargs); +DUK_EXTERNAL_DECL void duk_call_method(duk_context *ctx, duk_idx_t nargs); +DUK_EXTERNAL_DECL void duk_call_prop(duk_context *ctx, duk_idx_t obj_idx, duk_idx_t nargs); +DUK_EXTERNAL_DECL duk_int_t duk_pcall(duk_context *ctx, duk_idx_t nargs); +DUK_EXTERNAL_DECL duk_int_t duk_pcall_method(duk_context *ctx, duk_idx_t nargs); +DUK_EXTERNAL_DECL duk_int_t duk_pcall_prop(duk_context *ctx, duk_idx_t obj_idx, duk_idx_t nargs); +DUK_EXTERNAL_DECL void duk_new(duk_context *ctx, duk_idx_t nargs); +DUK_EXTERNAL_DECL duk_int_t duk_pnew(duk_context *ctx, duk_idx_t nargs); +DUK_EXTERNAL_DECL duk_int_t duk_safe_call(duk_context *ctx, duk_safe_call_function func, void *udata, duk_idx_t nargs, duk_idx_t nrets); + +/* + * Thread management + */ + +/* There are currently no native functions to yield/resume, due to the internal + * limitations on coroutine handling. These will be added later. + */ + +/* + * Compilation and evaluation + */ + +DUK_EXTERNAL_DECL duk_int_t duk_eval_raw(duk_context *ctx, const char *src_buffer, duk_size_t src_length, duk_uint_t flags); +DUK_EXTERNAL_DECL duk_int_t duk_compile_raw(duk_context *ctx, const char *src_buffer, duk_size_t src_length, duk_uint_t flags); + +/* plain */ +#define duk_eval(ctx) \ + ((void) duk_eval_raw((ctx), NULL, 0, 1 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_NOFILENAME)) + +#define duk_eval_noresult(ctx) \ + ((void) duk_eval_raw((ctx), NULL, 0, 1 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_NORESULT | DUK_COMPILE_NOFILENAME)) + +#define duk_peval(ctx) \ + (duk_eval_raw((ctx), NULL, 0, 1 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_SAFE | DUK_COMPILE_NOFILENAME)) + +#define duk_peval_noresult(ctx) \ + (duk_eval_raw((ctx), NULL, 0, 1 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_SAFE | DUK_COMPILE_NORESULT | DUK_COMPILE_NOFILENAME)) + +#define duk_compile(ctx,flags) \ + ((void) duk_compile_raw((ctx), NULL, 0, 2 /*args*/ | (flags))) + +#define duk_pcompile(ctx,flags) \ + (duk_compile_raw((ctx), NULL, 0, 2 /*args*/ | (flags) | DUK_COMPILE_SAFE)) + +/* string */ +#define duk_eval_string(ctx,src) \ + ((void) duk_eval_raw((ctx), (src), 0, 0 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_NOSOURCE | DUK_COMPILE_STRLEN | DUK_COMPILE_NOFILENAME)) + +#define duk_eval_string_noresult(ctx,src) \ + ((void) duk_eval_raw((ctx), (src), 0, 0 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_NOSOURCE | DUK_COMPILE_STRLEN | DUK_COMPILE_NORESULT | DUK_COMPILE_NOFILENAME)) + +#define duk_peval_string(ctx,src) \ + (duk_eval_raw((ctx), (src), 0, 0 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_SAFE | DUK_COMPILE_NOSOURCE | DUK_COMPILE_STRLEN | DUK_COMPILE_NOFILENAME)) + +#define duk_peval_string_noresult(ctx,src) \ + (duk_eval_raw((ctx), (src), 0, 0 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_SAFE | DUK_COMPILE_NOSOURCE | DUK_COMPILE_STRLEN | DUK_COMPILE_NORESULT | DUK_COMPILE_NOFILENAME)) + +#define duk_compile_string(ctx,flags,src) \ + ((void) duk_compile_raw((ctx), (src), 0, 0 /*args*/ | (flags) | DUK_COMPILE_NOSOURCE | DUK_COMPILE_STRLEN | DUK_COMPILE_NOFILENAME)) + +#define duk_compile_string_filename(ctx,flags,src) \ + ((void) duk_compile_raw((ctx), (src), 0, 1 /*args*/ | (flags) | DUK_COMPILE_NOSOURCE | DUK_COMPILE_STRLEN)) + +#define duk_pcompile_string(ctx,flags,src) \ + (duk_compile_raw((ctx), (src), 0, 0 /*args*/ | (flags) | DUK_COMPILE_SAFE | DUK_COMPILE_NOSOURCE | DUK_COMPILE_STRLEN | DUK_COMPILE_NOFILENAME)) + +#define duk_pcompile_string_filename(ctx,flags,src) \ + (duk_compile_raw((ctx), (src), 0, 1 /*args*/ | (flags) | DUK_COMPILE_SAFE | DUK_COMPILE_NOSOURCE | DUK_COMPILE_STRLEN)) + +/* lstring */ +#define duk_eval_lstring(ctx,buf,len) \ + ((void) duk_eval_raw((ctx), buf, len, 0 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_NOSOURCE | DUK_COMPILE_NOFILENAME)) + +#define duk_eval_lstring_noresult(ctx,buf,len) \ + ((void) duk_eval_raw((ctx), buf, len, 0 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_NOSOURCE | DUK_COMPILE_NORESULT | DUK_COMPILE_NOFILENAME)) + +#define duk_peval_lstring(ctx,buf,len) \ + (duk_eval_raw((ctx), buf, len, 0 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_NOSOURCE | DUK_COMPILE_SAFE | DUK_COMPILE_NOFILENAME)) + +#define duk_peval_lstring_noresult(ctx,buf,len) \ + (duk_eval_raw((ctx), buf, len, 0 /*args*/ | DUK_COMPILE_EVAL | DUK_COMPILE_SAFE | DUK_COMPILE_NOSOURCE | DUK_COMPILE_NORESULT | DUK_COMPILE_NOFILENAME)) + +#define duk_compile_lstring(ctx,flags,buf,len) \ + ((void) duk_compile_raw((ctx), buf, len, 0 /*args*/ | (flags) | DUK_COMPILE_NOSOURCE | DUK_COMPILE_NOFILENAME)) + +#define duk_compile_lstring_filename(ctx,flags,buf,len) \ + ((void) duk_compile_raw((ctx), buf, len, 1 /*args*/ | (flags) | DUK_COMPILE_NOSOURCE)) + +#define duk_pcompile_lstring(ctx,flags,buf,len) \ + (duk_compile_raw((ctx), buf, len, 0 /*args*/ | (flags) | DUK_COMPILE_SAFE | DUK_COMPILE_NOSOURCE | DUK_COMPILE_NOFILENAME)) + +#define duk_pcompile_lstring_filename(ctx,flags,buf,len) \ + (duk_compile_raw((ctx), buf, len, 1 /*args*/ | (flags) | DUK_COMPILE_SAFE | DUK_COMPILE_NOSOURCE)) + +/* + * Bytecode load/dump + */ + +DUK_EXTERNAL_DECL void duk_dump_function(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_load_function(duk_context *ctx); + +/* + * Debugging + */ + +DUK_EXTERNAL_DECL void duk_push_context_dump(duk_context *ctx); + +/* + * Debugger (debug protocol) + */ + +DUK_EXTERNAL_DECL void duk_debugger_attach(duk_context *ctx, + duk_debug_read_function read_cb, + duk_debug_write_function write_cb, + duk_debug_peek_function peek_cb, + duk_debug_read_flush_function read_flush_cb, + duk_debug_write_flush_function write_flush_cb, + duk_debug_request_function request_cb, + duk_debug_detached_function detached_cb, + void *udata); +DUK_EXTERNAL_DECL void duk_debugger_detach(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_debugger_cooperate(duk_context *ctx); +DUK_EXTERNAL_DECL duk_bool_t duk_debugger_notify(duk_context *ctx, duk_idx_t nvalues); +DUK_EXTERNAL_DECL void duk_debugger_pause(duk_context *ctx); + +/* + * Time handling + */ + +DUK_EXTERNAL_DECL duk_double_t duk_get_now(duk_context *ctx); +DUK_EXTERNAL_DECL void duk_time_to_components(duk_context *ctx, duk_double_t timeval, duk_time_components *comp); +DUK_EXTERNAL_DECL duk_double_t duk_components_to_time(duk_context *ctx, duk_time_components *comp); + +/* + * Date provider related constants + * + * NOTE: These are "semi public" - you should only use these if you write + * your own platform specific Date provider, see doc/datetime.rst. + */ + +/* Millisecond count constants. */ +#define DUK_DATE_MSEC_SECOND 1000L +#define DUK_DATE_MSEC_MINUTE (60L * 1000L) +#define DUK_DATE_MSEC_HOUR (60L * 60L * 1000L) +#define DUK_DATE_MSEC_DAY (24L * 60L * 60L * 1000L) + +/* ECMAScript date range is 100 million days from Epoch: + * > 100e6 * 24 * 60 * 60 * 1000 // 100M days in millisecs + * 8640000000000000 + * (= 8.64e15) + */ +#define DUK_DATE_MSEC_100M_DAYS (8.64e15) +#define DUK_DATE_MSEC_100M_DAYS_LEEWAY (8.64e15 + 24 * 3600e3) + +/* ECMAScript year range: + * > new Date(100e6 * 24 * 3600e3).toISOString() + * '+275760-09-13T00:00:00.000Z' + * > new Date(-100e6 * 24 * 3600e3).toISOString() + * '-271821-04-20T00:00:00.000Z' + */ +#define DUK_DATE_MIN_ECMA_YEAR (-271821L) +#define DUK_DATE_MAX_ECMA_YEAR 275760L + +/* Part indices for internal breakdowns. Part order from DUK_DATE_IDX_YEAR + * to DUK_DATE_IDX_MILLISECOND matches argument ordering of ECMAScript API + * calls (like Date constructor call). Some functions in duk_bi_date.c + * depend on the specific ordering, so change with care. 16 bits are not + * enough for all parts (year, specifically). + * + * Must be in-sync with genbuiltins.py. + */ +#define DUK_DATE_IDX_YEAR 0 /* year */ +#define DUK_DATE_IDX_MONTH 1 /* month: 0 to 11 */ +#define DUK_DATE_IDX_DAY 2 /* day within month: 0 to 30 */ +#define DUK_DATE_IDX_HOUR 3 +#define DUK_DATE_IDX_MINUTE 4 +#define DUK_DATE_IDX_SECOND 5 +#define DUK_DATE_IDX_MILLISECOND 6 +#define DUK_DATE_IDX_WEEKDAY 7 /* weekday: 0 to 6, 0=sunday, 1=monday, etc */ +#define DUK_DATE_IDX_NUM_PARTS 8 + +/* Internal API call flags, used for various functions in duk_bi_date.c. + * Certain flags are used by only certain functions, but since the flags + * don't overlap, a single flags value can be passed around to multiple + * functions. + * + * The unused top bits of the flags field are also used to pass values + * to helpers (duk__get_part_helper() and duk__set_part_helper()). + * + * Must be in-sync with genbuiltins.py. + */ + +/* NOTE: when writing a Date provider you only need a few specific + * flags from here, the rest are internal. Avoid using anything you + * don't need. + */ + +#define DUK_DATE_FLAG_NAN_TO_ZERO (1 << 0) /* timeval breakdown: internal time value NaN -> zero */ +#define DUK_DATE_FLAG_NAN_TO_RANGE_ERROR (1 << 1) /* timeval breakdown: internal time value NaN -> RangeError (toISOString) */ +#define DUK_DATE_FLAG_ONEBASED (1 << 2) /* timeval breakdown: convert month and day-of-month parts to one-based (default is zero-based) */ +#define DUK_DATE_FLAG_EQUIVYEAR (1 << 3) /* timeval breakdown: replace year with equivalent year in the [1971,2037] range for DST calculations */ +#define DUK_DATE_FLAG_LOCALTIME (1 << 4) /* convert time value to local time */ +#define DUK_DATE_FLAG_SUB1900 (1 << 5) /* getter: subtract 1900 from year when getting year part */ +#define DUK_DATE_FLAG_TOSTRING_DATE (1 << 6) /* include date part in string conversion result */ +#define DUK_DATE_FLAG_TOSTRING_TIME (1 << 7) /* include time part in string conversion result */ +#define DUK_DATE_FLAG_TOSTRING_LOCALE (1 << 8) /* use locale specific formatting if available */ +#define DUK_DATE_FLAG_TIMESETTER (1 << 9) /* setter: call is a time setter (affects hour, min, sec, ms); otherwise date setter (affects year, month, day-in-month) */ +#define DUK_DATE_FLAG_YEAR_FIXUP (1 << 10) /* setter: perform 2-digit year fixup (00...99 -> 1900...1999) */ +#define DUK_DATE_FLAG_SEP_T (1 << 11) /* string conversion: use 'T' instead of ' ' as a separator */ +#define DUK_DATE_FLAG_VALUE_SHIFT 12 /* additional values begin at bit 12 */ + +/* + * ROM pointer compression + */ + +/* Support array for ROM pointer compression. Only declared when ROM + * pointer compression is active. + */ +#if defined(DUK_USE_ROM_OBJECTS) && defined(DUK_USE_HEAPPTR16) +DUK_EXTERNAL_DECL const void * const duk_rom_compressed_pointers[]; +#endif + +/* + * C++ name mangling + */ + +#if defined(__cplusplus) +/* end 'extern "C"' wrapper */ +} +#endif + +/* + * END PUBLIC API + */ + +#endif /* DUKTAPE_H_INCLUDED */ diff --git a/source/engine/ffi.c b/source/engine/ffi.c new file mode 100644 index 00000000..b0d1be00 --- /dev/null +++ b/source/engine/ffi.c @@ -0,0 +1,110 @@ +#include "ffi.h" + +#include "script.h" + +cpVect duk2vec2(duk_context *duk, int p) { + cpVect pos; + duk_get_prop_index(duk, p, 0); + duk_get_prop_index(duk, p, 1); + + pos.x = duk_to_number(duk, -2); + pos.y = duk_to_number(duk, -1); + + return pos; +} + +duk_ret_t duk_gui_text(duk_context *duk) { + const char *s = duk_to_string(duk, 0); + cpVect pos = duk2vec2(duk, 1); + duk_get_prop_index(duk, 1, 0); + float fpos[2] = {pos.x, pos.y}; + + float size = duk_to_number(duk, 2); + renderText(s, fpos, size, white, 1800); + + return 0; +} + +duk_ret_t duk_win_make(duk_context *duk) { + const char *title = duk_to_string(duk, 0); + int w = duk_to_int(duk, 1); + int h = duk_to_int(duk, 2); + struct window *win = MakeSDLWindow(title, w, h, 0); + + duk_push_int(duk, win->id); + return 1; +} + +duk_ret_t duk_sys_cmd(duk_context *duk) { + int cmd = duk_to_int(duk, 0); + + switch (cmd) { + case 0: + quit(); + break; + + case 1: + sim_start(); + break; + + case 2: + sim_stop(); + break; + + case 3: + sim_pause(); + break; + + case 4: + sim_step(); + break; + + case 5: + duk_push_boolean(duk, sim_playing()); + return 1; + + case 6: + duk_push_boolean(duk, sim_paused()); + return 1; + + case 7: + duk_push_int(duk, MakeGameobject()); + return 1; + + case 8: + duk_push_int(duk, frame_fps()); + return 1; + + case 9: /* Clear the level out */ + new_level(); + break; + + } + + return 0; +} + +duk_ret_t duk_ + +duk_ret_t duk_make_gameobject(duk_context *duk) { + int g = MakeGameobject(); + struct gameobject *go = get_gameobject_from_id(g); + + go->scale = duk_to_number(duk, 0); + go->bodytype = duk_to_int(duk, 1); + go->mass = duk_to_number(duk, 2); + go->f = duk_to_number(duk, 3); + go->e = duk_to_number(duk, 4); + go->flipx = duk_to_boolean(5); + go->flipy = duk_to_boolean(6); + + gameobject_apply(go); + + duk_push_int(g); + return 1; +} + +void ffi_load() +{ + +} \ No newline at end of file diff --git a/source/engine/ffi.h b/source/engine/ffi.h new file mode 100644 index 00000000..3b0ca600 --- /dev/null +++ b/source/engine/ffi.h @@ -0,0 +1,8 @@ +#ifndef FFI_H +#define FFI_H + +#include "duktape.h" + +void ffi_load(); + +#endif \ No newline at end of file diff --git a/source/engine/s7.c b/source/engine/s7.c deleted file mode 100644 index a003a537..00000000 --- a/source/engine/s7.c +++ /dev/null @@ -1,96029 +0,0 @@ -/* s7, a Scheme interpreter - * - * derived from TinyScheme 1.39, but not a single byte of that code remains - * SPDX-License-Identifier: 0BSD - * - * Bill Schottstaedt, bil@ccrma.stanford.edu - * - * Mike Scholz provided the FreeBSD support (complex trig funcs, etc) - * Rick Taube, Andrew Burnson, Donny Ward, Greg Santucci, and Christos Vagias provided the MS Visual C++ support - * Kjetil Matheussen provided the mingw support - * - * Documentation is in s7.h and s7.html. - * s7test.scm is a regression test. - * repl.scm is a vt100-based listener. - * nrepl.scm is a notcurses-based listener. - * cload.scm and lib*.scm tie in various C libraries. - * lint.scm checks Scheme code for infelicities. - * r7rs.scm implements some of r7rs (small). - * write.scm currrently has pretty-print. - * mockery.scm has the mock-data definitions. - * reactive.scm has reactive-set and friends. - * stuff.scm has some stuff. - * profile.scm has code to display profile data. - * debug.scm has debugging aids. - * case.scm has case*, an extension of case to pattern matching. - * timing tests are in the s7 tools directory - * - * s7.c is organized as follows: - * structs and type flags - * internal debugging stuff - * constants - * GC - * stacks - * symbols and keywords - * lets - * continuations - * numbers - * characters - * strings - * ports - * format - * lists - * vectors - * hash-tables - * c-objects - * functions - * equal? - * generic length, copy, reverse, fill!, append - * error handlers - * sundry leftovers - * the optimizers - * multiple-values, quasiquote - * eval - * *s7* - * initialization and free - * repl - * - * naming conventions: s7_* usually are C accessible (s7.h), g_* are scheme accessible, - * H_* are documentation strings, Q_* are procedure signatures, scheme "?" corresponds to C "is_", scheme "->" to C "_to_", - * *_1 are ancillary functions, big_* refer to gmp, *_nr means no return, inline_* means always-inline. - * - * ---------------- compile time switches ---------------- - */ - -#include "config.h" - -/* - * Your config file goes here, or just replace that #include line with the defines you need. - * The compile-time switches involve booleans, complex numbers, and multiprecision arithmetic. - * Currently we assume we have setjmp.h (used by the error handlers). - * - * Complex number support, which is problematic in C++, Solaris, and netBSD - * is on the HAVE_COMPLEX_NUMBERS switch. In OSX or Linux, if you're not using C++, - * - * #define HAVE_COMPLEX_NUMBERS 1 - * #define HAVE_COMPLEX_TRIG 1 - * - * In C++ I use: - * - * #define HAVE_COMPLEX_NUMBERS 1 - * #define HAVE_COMPLEX_TRIG 0 - * - * In Windows and tcc, both are 0. - * - * Some systems (FreeBSD) have complex.h, but some random subset of the trig funcs, so - * HAVE_COMPLEX_NUMBERS means we can find - * cimag creal cabs csqrt carg conj - * and HAVE_COMPLEX_TRIG means we have - * cacos cacosh casin casinh catan catanh ccos ccosh cexp clog cpow csin csinh ctan ctanh - * - * When HAVE_COMPLEX_NUMBERS is 0, the complex functions are stubs that simply return their - * argument -- this will be very confusing for the s7 user because, for example, (sqrt -2) - * will return something bogus (it might not signal an error). - * - * so the incoming (non-s7-specific) compile-time switches are - * HAVE_COMPLEX_NUMBERS, HAVE_COMPLEX_TRIG, SIZEOF_VOID_P - * if SIZEOF_VOID_P is not defined, we look for __SIZEOF_POINTER__ instead, - * the default is to assume that we're running on a 64-bit machine. - * - * To get multiprecision arithmetic, set WITH_GMP to 1. - * You'll also need libgmp, libmpfr, and libmpc (version 0.8.0 or later) - * - * and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, __clang__, __ANDROID__ - * - * if WITH_SYSTEM_EXTRAS is 1 (default is 1 unless _MSC_VER), various OS and file related functions are included. - * if you want this file to compile into a stand-alone interpreter, define WITH_MAIN - * to use nrepl, also define WITH_NOTCURSES - * - * -O3 is often slower than -O2 (at least according to callgrind) - * -march=native seems to improve tree-vectorization which is important in Snd - * -ffast-math makes a mess of NaNs, and does not appear to be faster - * this code doesn't compile anymore in gcc 4.3 - */ - -#if (defined(__GNUC__) || defined(__clang__) || defined(__TINYC__)) /* s7 uses PRId64 so (for example) g++ 4.4 is too old */ - #define WITH_GCC 1 -#else - #define WITH_GCC 0 -#endif - - -/* ---------------- initial sizes ---------------- */ - -#ifndef INITIAL_HEAP_SIZE - #define INITIAL_HEAP_SIZE 64000 /* 29-Jul-21 -- seems faster */ -#endif -/* the heap grows as needed, this is its initial size. If the initial heap is small, s7 can run in about 2.5 Mbytes of memory. - * There are many cases where a bigger heap is faster (but harware cache size probably matters more). - * The heap size must be a multiple of 32. Each object takes 48 bytes. - */ - -#ifndef SYMBOL_TABLE_SIZE - #define SYMBOL_TABLE_SIZE 32749 -#endif -/* names are hashed into the symbol table (a vector) and collisions are chained as lists */ -/* 16381: thash +80 [string_to_symbol_p_p] +40 if 24001, tlet +80 [symbol_p_p], +32 24001 */ - -#ifndef INITIAL_STACK_SIZE - #define INITIAL_STACK_SIZE 4096 /* was 2048 17-Mar-21 */ -#endif -/* the stack grows as needed, each frame takes 4 entries, this is its initial size. (*s7* 'stack-top) divides size by 4 */ - -#define STACK_RESIZE_TRIGGER (INITIAL_STACK_SIZE / 2) - -#ifndef INITIAL_PROTECTED_OBJECTS_SIZE - #define INITIAL_PROTECTED_OBJECTS_SIZE 16 -#endif -/* a vector of objects that are (semi-permanently) protected from the GC, grows as needed */ - -#ifndef GC_TEMPS_SIZE - #define GC_TEMPS_SIZE 256 -#endif -/* the number of recent objects that are temporarily gc-protected; 8 works for s7test and snd-test. - * For the FFI, this sets the lag between a call on s7_cons and the first moment when its result - * might be vulnerable to the GC. - */ - - -/* ---------------- scheme choices ---------------- */ - -#ifndef WITH_GMP - #define WITH_GMP 0 - /* this includes multiprecision arithmetic for all numeric types and functions, using gmp, mpfr, and mpc - * WITH_GMP adds the following functions: bignum and bignum?, and (*s7* 'bignum-precision) - */ -#endif - -#ifndef DEFAULT_BIGNUM_PRECISION - #define DEFAULT_BIGNUM_PRECISION 128 /* (*s7* 'bignum-precision) initial value, must be >= 2 */ -#endif - -#ifndef WITH_PURE_S7 - #define WITH_PURE_S7 0 -#endif -#if WITH_PURE_S7 - #define WITH_EXTRA_EXPONENT_MARKERS 0 - #define WITH_IMMUTABLE_UNQUOTE 1 - /* also omitted: *-ci* functions, char-ready?, cond-expand, multiple-values-bind|set!, call-with-values - * and a lot more (inexact/exact, integer-length, etc) -- see s7.html. - */ -#endif - -#ifndef WITH_EXTRA_EXPONENT_MARKERS - #define WITH_EXTRA_EXPONENT_MARKERS 0 -#endif -/* if 1, s7 recognizes "d", "f", "l", and "s" as exponent markers, in addition to "e" (also "D", "F", "L", "S") */ - -#ifndef WITH_SYSTEM_EXTRAS - #define WITH_SYSTEM_EXTRAS (!_MSC_VER) - /* this adds several functions that access file info, directories, times, etc */ -#endif - -#ifndef WITH_IMMUTABLE_UNQUOTE - #define WITH_IMMUTABLE_UNQUOTE 0 - /* this removes the name "unquote" */ -#endif - -#ifndef WITH_C_LOADER - #if WITH_GCC && (!__MINGW32__) && (!__CYGWIN__) - #define WITH_C_LOADER 1 - /* (load file.so [e]) looks for (e 'init_func) and if found, calls it as the shared object init function. - * If WITH_SYSTEM_EXTRAS is 0, the caller needs to supply system and delete-file so that cload.scm works. - */ - #else - #define WITH_C_LOADER 0 - /* I think dlopen et al are available in MS C, but I have no way to test them; see load_shared_object below */ - #endif -#endif - -#ifndef WITH_HISTORY - #define WITH_HISTORY 0 - /* this includes a circular buffer of previous evaluations for debugging, ((owlet) 'error-history) and (*s7* 'history-size) */ -#endif - -#ifndef DEFAULT_HISTORY_SIZE - #define DEFAULT_HISTORY_SIZE 8 - /* this is the default length of the eval history buffer */ -#endif -#if WITH_HISTORY - #define MAX_HISTORY_SIZE 1048576 -#endif - -#ifndef DEFAULT_PRINT_LENGTH - #define DEFAULT_PRINT_LENGTH 12 /* (*s7* 'print-length) initial value, was 32 but Snd uses 12, 23-Jul-21 */ -#endif - -#ifndef WITH_NUMBER_SEPARATOR - #define WITH_NUMBER_SEPARATOR 0 -#endif - -/* in case mus-config.h forgets these */ -#ifdef _MSC_VER - #ifndef HAVE_COMPLEX_NUMBERS - #define HAVE_COMPLEX_NUMBERS 0 - #endif - #ifndef HAVE_COMPLEX_TRIG - #define HAVE_COMPLEX_TRIG 0 - #endif -#else - #ifndef HAVE_COMPLEX_NUMBERS - #if __TINYC__ - #define HAVE_COMPLEX_NUMBERS 0 - #else - #define HAVE_COMPLEX_NUMBERS 1 - #endif - #endif - #if __cplusplus || __TINYC__ - #ifndef HAVE_COMPLEX_TRIG - #define HAVE_COMPLEX_TRIG 0 - #endif - #else - #ifndef HAVE_COMPLEX_TRIG - #define HAVE_COMPLEX_TRIG 1 - #endif - #endif -#endif - -#ifndef WITH_MULTITHREAD_CHECKS - #define WITH_MULTITHREAD_CHECKS 0 - /* debugging aid if using s7 in a multithreaded program -- this code courtesy of Kjetil Matheussen */ -#endif - -#ifndef WITH_WARNINGS - #define WITH_WARNINGS 0 - /* int+int overflows to real, etc: this adds warnings which are expensive even though they are never called (procedure overhead) */ -#endif - -#ifndef S7_DEBUGGING - #define S7_DEBUGGING 0 -#endif - -#undef DEBUGGING -#define DEBUGGING typo! -#define HAVE_GMP typo! - -#define SHOW_EVAL_OPS 0 -#ifndef _GNU_SOURCE - #define _GNU_SOURCE /* for qsort_r, grumble... */ -#endif - -#ifndef _MSC_VER - #include - #include - #include - #include - #include -#else - /* in Snd these are in mus-config.h */ - #ifndef MUS_CONFIG_H_LOADED - #if _MSC_VER < 1900 - #define snprintf _snprintf - #endif - #if _MSC_VER > 1200 - #define _CRT_SECURE_NO_DEPRECATE 1 - #define _CRT_NONSTDC_NO_DEPRECATE 1 - #define _CRT_SECURE_CPP_OVERLOAD_STANDARD_NAMES 1 - #endif - #endif - #include - #pragma warning(disable: 4244) /* conversion might cause loss of data warning */ -#endif - -#if WITH_GCC && (!S7_DEBUGGING) - #define Inline inline __attribute__((__always_inline__)) -#else - #ifdef _MSC_VER - #define Inline __forceinline - #else - #define Inline inline - #endif -#endif - -#ifndef WITH_VECTORIZE - #define WITH_VECTORIZE 1 -#endif - -#if (WITH_VECTORIZE) && (defined(__GNUC__) && __GNUC__ >= 5) /* is this included -in -O2 now? */ - #define Vectorized __attribute__((optimize("tree-vectorize"))) -#else - #define Vectorized -#endif - -#if WITH_GCC - #define Sentinel __attribute__((sentinel)) -#else - #define Sentinel -#endif - -#ifdef _MSC_VER - #define noreturn _Noreturn /* deprecated in C23 */ -#else - #define noreturn __attribute__((noreturn)) - /* this is ok in gcc/g++/clang and tcc; pure attribute is rarely applicable here, and does not seem to be helpful (maybe safe_strlen) */ -#endif - -#ifndef S7_ALIGNED - #define S7_ALIGNED 0 - /* memclr, local_strcmp and local_memset */ -#endif - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -#ifdef _MSC_VER - #define MS_WINDOWS 1 -#else - #define MS_WINDOWS 0 -#endif - -#if defined(_MSC_VER) || defined(__MINGW32__) - #define Jmp_Buf jmp_buf - #define SetJmp(A, B) setjmp(A) - #define LongJmp(A, B) longjmp(A, B) -#else - #define Jmp_Buf sigjmp_buf - #define SetJmp(A, B) sigsetjmp(A, B) - #define LongJmp(A, B) siglongjmp(A, B) - /* we need sigsetjmp, not setjmp for nrepl's interrupt (something to do with signal masks??) - * unfortunately sigsetjmp is noticeably slower than setjmp, especially when s7_optimize_1 is called a lot. - * In one case, the sigsetjmp version runs in 24 seconds, but the setjmp version takes 10 seconds, and - * yet callgrind says there is almost no difference? I removed setjmp from s7_optimize. - */ -#endif - -#if (!MS_WINDOWS) - #include -#endif - -#if __cplusplus - #include -#else - #include -#endif - -/* there is also apparently __STDC_NO_COMPLEX__ */ -#if HAVE_COMPLEX_NUMBERS - #if __cplusplus - #include - #else - #include - #ifndef __SUNPRO_C - #if defined(__sun) && defined(__SVR4) - #undef _Complex_I - #define _Complex_I 1.0fi - #endif - #endif - #endif - - #ifndef CMPLX - #if (!(defined(__cplusplus))) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)) && !defined(__INTEL_COMPILER) - #define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y)) - #else - #define CMPLX(r, i) ((r) + ((i) * _Complex_I)) - #endif - #endif -#endif - -#include "s7.h" - -#ifndef M_PI - #define M_PI 3.1415926535897932384626433832795029L -#endif - -#ifndef INFINITY - #ifndef HUGE_VAL - #define INFINITY (1.0/0.0) /* -log(0.0) is triggering dumb complaints from cppcheck */ - /* there is sometimes a function, infinity(), MSC apparently uses HUGE_VALF, gcc has __builtin_huge_val() */ - #else - #define INFINITY HUGE_VAL - #endif -#endif - -#ifndef NAN - #define NAN (INFINITY / INFINITY) /* apparently ieee754 suggests 0.0/0.0 */ -#endif - -#define BOLD_TEXT "\033[1m" -#define UNBOLD_TEXT "\033[22m" - -#if ((!__NetBSD__) && ((_MSC_VER) || (!defined(__STC__)) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ < 199901L)))) - #define __func__ __FUNCTION__ -#endif - -#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__))) - #define NUMBER_NAME_SIZE 2 /* pointless */ - #define POINTER_32 true -#else - #define NUMBER_NAME_SIZE 22 /* leave 1 for uint8_t name len (byte 0), 1 for terminating nul */ - #define POINTER_32 false -#endif - -#define WRITE_REAL_PRECISION 16 -typedef long double long_double; - -#define ld64 PRId64 -#define p64 PRIdPTR - -#define MAX_FLOAT_FORMAT_PRECISION 128 - -/* types */ -enum {T_FREE = 0, - T_PAIR, T_NIL, T_UNUSED, T_UNDEFINED, T_UNSPECIFIED, T_EOF, T_BOOLEAN, T_CHARACTER, T_SYNTAX, T_SYMBOL, - T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, T_BIG_INTEGER, T_BIG_RATIO, T_BIG_REAL, T_BIG_COMPLEX, - T_STRING, T_C_OBJECT, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, - T_CATCH, T_DYNAMIC_WIND, T_HASH_TABLE, T_LET, T_ITERATOR, - T_STACK, T_COUNTER, T_SLOT, T_C_POINTER, T_OUTPUT_PORT, T_INPUT_PORT, T_RANDOM_STATE, T_CONTINUATION, T_GOTO, - T_CLOSURE, T_CLOSURE_STAR, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR, - T_C_MACRO, T_C_FUNCTION_STAR, T_C_FUNCTION, T_C_RST_NO_REQ_FUNCTION, - NUM_TYPES}; -/* T_UNUSED, T_STACK, T_SLOT, T_DYNAMIC_WIND, T_CATCH, and T_COUNTER are internal */ - -static const char *s7_type_names[] = - {"free", "pair", "nil", "unused", "undefined", "unspecified", "eof_object", "boolean", "character", "syntax", "symbol", - "integer", "ratio", "real", "complex", "big_integer", "big_ratio", "big_real", "big_complex", - "string", "c_object", "vector", "int_vector", "float_vector", "byte_vector", - "catch", "dynamic_wind", "hash_table", "let", "iterator", - "stack", "counter", "slot", "c_pointer", "output_port", "input_port", "random_state", "continuation", "goto", - "closure", "closure*", "macro", "macro*", "bacro", "bacro*", - "c_macro", "c_function*", "c_function", "c_rst_no_req_function", - }; - -/* 1:T_PAIR, 2:T_NIL, 3:T_UNUSED, 4:T_UNDEFINED, 5:T_UNSPECIFIED, 6:T_EOF, 7:T_BOOLEAN, 8:T_CHARACTER, 9:T_SYNTAX, 10:T_SYMBOL, - 11:T_INTEGER, 12:T_RATIO, 13:T_REAL, 14:T_COMPLEX, 15:T_BIG_INTEGER, 16:T_BIG_RATIO, 17:T_BIG_REAL, 18:T_BIG_COMPLEX, - 19:T_STRING, 20:T_C_OBJECT, 21:T_VECTOR, 22:T_INT_VECTOR, 23:T_FLOAT_VECTOR, 24:T_BYTE_VECTOR, - 25:T_CATCH, 26:T_DYNAMIC_WIND, 27:T_HASH_TABLE, 28:T_LET, 29:T_ITERATOR, - 30:T_STACK, 31:T_COUNTER, 32:T_SLOT, 33:T_C_POINTER, 34:T_OUTPUT_PORT, 35:T_INPUT_PORT, 36:T_RANDOM_STATE, 37:T_CONTINUATION, 38:T_GOTO, - 39:T_CLOSURE, 40:T_CLOSURE_STAR, 41:T_MACRO, 42:T_MACRO_STAR, 43:T_BACRO, 44:T_BACRO_STAR, - 45:T_C_MACRO, 46:T_C_FUNCTION_STAR, 47:T_C_FUNCTION, 48:T_C_RST_NO_REQ_FUNCTION, - 49:NUM_TYPES -*/ - -typedef struct block_t { - union { - void *data; - s7_pointer d_ptr; - s7_int *i_ptr; - } dx; - int32_t index; - union { - bool needs_free; - uint32_t tag; - } ln; - s7_int size; - union { - struct block_t *next; - char *documentation; - s7_pointer ksym; - s7_int nx_int; - s7_int *ix_ptr; - struct { - uint32_t i1, i2; - } ix; - } nx; - union { - s7_pointer ex_ptr; - void *ex_info; - s7_int ckey; - } ex; -} block_t; - -#define NUM_BLOCK_LISTS 18 -#define TOP_BLOCK_LIST 17 -#define BLOCK_LIST 0 - -#define block_data(p) p->dx.data -#define block_index(p) p->index -#define block_set_index(p, Index) p->index = Index -#define block_size(p) p->size -#define block_set_size(p, Size) p->size = Size -#define block_next(p) p->nx.next -#define block_info(p) p->ex.ex_info - -typedef block_t hash_entry_t; /* I think this means we waste 8 bytes per entry but can use the mallocate functions */ -#define hash_entry_key(p) p->dx.d_ptr -#define hash_entry_value(p) (p)->ex.ex_ptr -#define hash_entry_set_value(p, Val) p->ex.ex_ptr = Val -#define hash_entry_next(p) block_next(p) -#define hash_entry_raw_hash(p) block_size(p) -#define hash_entry_set_raw_hash(p, Hash) block_set_size(p, Hash) - -typedef block_t vdims_t; -#define vdims_rank(p) p->size -#define vector_elements_should_be_freed(p) p->ln.needs_free -#define vdims_dims(p) p->dx.i_ptr -#define vdims_offsets(p) p->nx.ix_ptr -#define vdims_original(p) p->ex.ex_ptr - - -typedef enum {TOKEN_EOF, TOKEN_LEFT_PAREN, TOKEN_RIGHT_PAREN, TOKEN_DOT, TOKEN_ATOM, TOKEN_QUOTE, TOKEN_DOUBLE_QUOTE, TOKEN_BACK_QUOTE, - TOKEN_COMMA, TOKEN_AT_MARK, TOKEN_SHARP_CONST, TOKEN_VECTOR, TOKEN_BYTE_VECTOR, TOKEN_INT_VECTOR, TOKEN_FLOAT_VECTOR} token_t; - -typedef enum {NO_ARTICLE, INDEFINITE_ARTICLE} article_t; -typedef enum {DWIND_INIT, DWIND_BODY, DWIND_FINISH} dwind_t; -enum {NO_SAFETY = 0, IMMUTABLE_VECTOR_SAFETY, MORE_SAFETY_WARNINGS}; /* (*s7* 'safety) settings */ - -typedef enum {FILE_PORT, STRING_PORT, FUNCTION_PORT} port_type_t; - -typedef struct { - int32_t (*read_character)(s7_scheme *sc, s7_pointer port); /* function to read a character, int32_t for EOF */ - void (*write_character)(s7_scheme *sc, uint8_t c, s7_pointer port); /* function to write a character */ - void (*write_string)(s7_scheme *sc, const char *str, s7_int len, s7_pointer port); /* function to write a string of known length */ - token_t (*read_semicolon)(s7_scheme *sc, s7_pointer port); /* internal skip-to-semicolon reader */ - int32_t (*read_white_space)(s7_scheme *sc, s7_pointer port); /* internal skip white space reader */ - s7_pointer (*read_name)(s7_scheme *sc, s7_pointer pt); /* internal get-next-name reader */ - s7_pointer (*read_sharp)(s7_scheme *sc, s7_pointer pt); /* internal get-next-sharp-constant reader */ - s7_pointer (*read_line)(s7_scheme *sc, s7_pointer pt, bool eol_case); /* function to read a string up to \n */ - void (*displayer)(s7_scheme *sc, const char *s, s7_pointer pt); - void (*close_port)(s7_scheme *sc, s7_pointer p); /* close-in|output-port */ -} port_functions_t; - -typedef struct { - bool needs_free, is_closed; - port_type_t ptype; - FILE *file; - char *filename; - block_t *filename_block; - uint32_t line_number, file_number; - s7_int filename_length; - block_t *block; - s7_pointer orig_str; /* GC protection for string port string or function port function */ - const port_functions_t *pf; - s7_pointer (*input_function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port); - void (*output_function)(s7_scheme *sc, uint8_t c, s7_pointer port); -} port_t; - -typedef enum {o_d_v, o_d_vd, o_d_vdd, o_d_vid, o_d_id, o_d_7pi, o_d_7pii, o_d_7piid, o_d_7piii, o_d_7piiid, - o_d_ip, o_d_pd, o_d_7pid, o_d, o_d_d, o_d_dd, o_d_7dd, o_d_ddd, o_d_dddd, - o_i_i, o_i_7i, o_i_ii, o_i_7ii, o_i_iii, o_i_7pi, o_i_7pii, o_i_7piii, o_d_p, - o_b_p, o_b_7p, o_b_pp, o_b_7pp, o_b_pp_unchecked, o_b_pi, o_b_ii, o_b_7ii, o_b_dd, - o_p, o_p_p, o_p_ii, o_p_d, o_p_dd, o_i_7d, o_i_7p, o_d_7d, o_p_pp, o_p_ppp, o_p_pi, o_p_pi_unchecked, - o_p_ppi, o_p_i, o_p_pii, o_p_pip, o_p_pip_unchecked, o_p_piip, o_b_i, o_b_d} opt_func_t; - -typedef struct opt_funcs_t { - opt_func_t typ; - void *func; - struct opt_funcs_t *next; -} opt_funcs_t; - -typedef struct { - const char *name; - int32_t name_length; - uint32_t id; - const char *doc; - opt_funcs_t *opt_data; /* vunion-functions (see below) */ - s7_pointer generic_ff, setter, signature, pars; - s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops); - /* arg_defaults|names call_args only T_C_FUNCTION_STAR -- call args for GC protection */ - union { - s7_pointer *arg_defaults; - s7_pointer bool_setter; - } dam; - union { - s7_pointer *arg_names; - s7_pointer c_sym; - } sam; - union { - s7_pointer call_args; - void (*marker)(s7_pointer p, s7_int len); - } cam; -} c_proc_t; - - -typedef struct { - s7_int type, outer_type; - s7_pointer scheme_name, getter, setter; - void (*mark)(void *val); - void (*free)(void *value); /* this will go away someday (use gc_free) */ - bool (*eql)(void *val1, void *val2); /* this will go away someday (use equal) */ -#if (!DISABLE_DEPRECATED) - char *(*print)(s7_scheme *sc, void *value); -#endif - s7_pointer (*equal) (s7_scheme *sc, s7_pointer args); - s7_pointer (*equivalent) (s7_scheme *sc, s7_pointer args); - s7_pointer (*ref) (s7_scheme *sc, s7_pointer args); - s7_pointer (*set) (s7_scheme *sc, s7_pointer args); - s7_pointer (*length) (s7_scheme *sc, s7_pointer args); - s7_pointer (*reverse) (s7_scheme *sc, s7_pointer args); - s7_pointer (*copy) (s7_scheme *sc, s7_pointer args); - s7_pointer (*fill) (s7_scheme *sc, s7_pointer args); - s7_pointer (*to_list) (s7_scheme *sc, s7_pointer args); - s7_pointer (*to_string) (s7_scheme *sc, s7_pointer args); - s7_pointer (*gc_mark) (s7_scheme *sc, s7_pointer args); - s7_pointer (*gc_free) (s7_scheme *sc, s7_pointer args); -} c_object_t; - - -typedef s7_int (*hash_map_t)(s7_scheme *sc, s7_pointer table, s7_pointer key); /* hash-table object->location mapper */ -typedef hash_entry_t *(*hash_check_t)(s7_scheme *sc, s7_pointer table, s7_pointer key); /* hash-table object equality function */ -static hash_map_t default_hash_map[NUM_TYPES]; - -typedef s7_int (*s7_i_7pi_t)(s7_scheme *sc, s7_pointer p, s7_int i1); -typedef s7_int (*s7_i_7pii_t)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2); -typedef s7_int (*s7_i_7piii_t)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2, s7_int i3); -typedef s7_int (*s7_i_iii_t)(s7_int i1, s7_int i2, s7_int i3); -typedef s7_int (*s7_i_7i_t)(s7_scheme *sc, s7_int i1); -typedef s7_int (*s7_i_7ii_t)(s7_scheme *sc, s7_int i1, s7_int i2); -typedef bool (*s7_b_pp_t)(s7_pointer p1, s7_pointer p2); -typedef bool (*s7_b_7pp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2); -typedef bool (*s7_b_7p_t)(s7_scheme *sc, s7_pointer p1); -typedef bool (*s7_b_pi_t)(s7_scheme *sc, s7_pointer p1, s7_int i2); -typedef bool (*s7_b_d_t)(s7_double p1); -typedef bool (*s7_b_i_t)(s7_int p1); -typedef bool (*s7_b_ii_t)(s7_int p1, s7_int p2); -typedef bool (*s7_b_7ii_t)(s7_scheme *sc, s7_int p1, s7_int p2); -typedef bool (*s7_b_dd_t)(s7_double p1, s7_double p2); -typedef s7_pointer (*s7_p_t)(s7_scheme *sc); -typedef s7_pointer (*s7_p_ppi_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int i1); -typedef s7_pointer (*s7_p_pi_t)(s7_scheme *sc, s7_pointer p1, s7_int i1); -typedef s7_pointer (*s7_p_pii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2); -typedef s7_pointer (*s7_p_pip_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2); -typedef s7_pointer (*s7_p_piip_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_pointer p3); -typedef s7_pointer (*s7_p_i_t)(s7_scheme *sc, s7_int i); -typedef s7_pointer (*s7_p_ii_t)(s7_scheme *sc, s7_int i1, s7_int i2); -typedef s7_pointer (*s7_p_dd_t)(s7_scheme *sc, s7_double x1, s7_double x2); -typedef s7_double (*s7_d_7d_t)(s7_scheme *sc, s7_double p1); -typedef s7_double (*s7_d_7dd_t)(s7_scheme *sc, s7_double p1, s7_double p2); -typedef s7_double (*s7_d_7pii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2); -typedef s7_double (*s7_d_7piid_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_double x1); -typedef s7_double (*s7_d_7piii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_int i3); -typedef s7_double (*s7_d_7piiid_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_int i3, s7_double x1); - -typedef struct opt_info opt_info; - -typedef union { - s7_int i; - s7_double x; - s7_pointer p; - void *obj; - opt_info *o1; - s7_function call; - s7_double (*d_f)(void); - s7_double (*d_d_f)(s7_double x); - s7_double (*d_7d_f)(s7_scheme *sc, s7_double x); - s7_double (*d_dd_f)(s7_double x1, s7_double x2); - s7_double (*d_7dd_f)(s7_scheme *sc, s7_double x1, s7_double x2); - s7_double (*d_ddd_f)(s7_double x1, s7_double x2, s7_double x3); - s7_double (*d_dddd_f)(s7_double x1, s7_double x2, s7_double x3, s7_double x4); - s7_double (*d_v_f)(void *obj); - s7_double (*d_vd_f)(void *obj, s7_double fm); - s7_double (*d_vdd_f)(void *obj, s7_double x1, s7_double x2); - s7_double (*d_vid_f)(void *obj, s7_int i, s7_double fm); - s7_double (*d_id_f)(s7_int i, s7_double fm); - s7_double (*d_7pi_f)(s7_scheme *sc, s7_pointer obj, s7_int i1); - s7_double (*d_7pid_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_double x); - s7_double (*d_7pii_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2); - s7_double (*d_7piid_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2, s7_double x); - s7_double (*d_7piii_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2, s7_int i3); - s7_double (*d_7piiid_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2, s7_int i3, s7_double x); - s7_double (*d_ip_f)(s7_int i1, s7_pointer p); - s7_double (*d_pd_f)(s7_pointer obj, s7_double x); - s7_double (*d_p_f)(s7_pointer p); - s7_int (*i_7d_f)(s7_scheme *sc, s7_double i1); - s7_int (*i_7p_f)(s7_scheme *sc, s7_pointer i1); - s7_int (*i_i_f)(s7_int i1); - s7_int (*i_7i_f)(s7_scheme *sc, s7_int i1); - s7_int (*i_ii_f)(s7_int i1, s7_int i2); - s7_int (*i_7ii_f)(s7_scheme *sc, s7_int i1, s7_int i2); - s7_int (*i_iii_f)(s7_int i1, s7_int i2, s7_int i3); - s7_int (*i_7pi_f)(s7_scheme *sc, s7_pointer p, s7_int i1); - s7_int (*i_7pii_f)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2); - s7_int (*i_7piii_f)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2, s7_int i3); - bool (*b_i_f)(s7_int p); - bool (*b_d_f)(s7_double p); - bool (*b_p_f)(s7_pointer p); - bool (*b_pp_f)(s7_pointer p1, s7_pointer p2); - bool (*b_7pp_f)(s7_scheme *sc, s7_pointer p1, s7_pointer p2); - bool (*b_7p_f)(s7_scheme *sc, s7_pointer p1); - bool (*b_pi_f)(s7_scheme *sc, s7_pointer p1, s7_int i2); - bool (*b_ii_f)(s7_int i1, s7_int i2); - bool (*b_7ii_f)(s7_scheme *sc, s7_int i1, s7_int i2); - bool (*b_dd_f)(s7_double x1, s7_double x2); - s7_pointer (*p_f)(s7_scheme *sc); - s7_pointer (*p_p_f)(s7_scheme *sc, s7_pointer p); - s7_pointer (*p_pp_f)(s7_scheme *sc, s7_pointer p1, s7_pointer p2); - s7_pointer (*p_ppp_f)(s7_scheme *sc, s7_pointer p, s7_pointer p2, s7_pointer p3); - s7_pointer (*p_pi_f)(s7_scheme *sc, s7_pointer p1, s7_int i1); - s7_pointer (*p_pii_f)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2); - s7_pointer (*p_ppi_f)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int i1); - s7_pointer (*p_pip_f)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2); - s7_pointer (*p_piip_f)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_pointer p3); - s7_pointer (*p_i_f)(s7_scheme *sc, s7_int i); - s7_pointer (*p_ii_f)(s7_scheme *sc, s7_int x1, s7_int x2); - s7_pointer (*p_d_f)(s7_scheme *sc, s7_double x); - s7_pointer (*p_dd_f)(s7_scheme *sc, s7_double x1, s7_double x2); - s7_double (*fd)(opt_info *o); - s7_int (*fi)(opt_info *o); - bool (*fb)(opt_info *o); - s7_pointer (*fp)(opt_info *o); -} vunion; - -#define NUM_VUNIONS 15 -struct opt_info { - vunion v[NUM_VUNIONS]; - s7_scheme *sc; -}; - -#define O_WRAP (NUM_VUNIONS - 1) - -#if WITH_GMP -typedef struct bigint {mpz_t n; struct bigint *nxt;} bigint; -typedef struct bigrat {mpq_t q; struct bigrat *nxt;} bigrat; -typedef struct bigflt {mpfr_t x; struct bigflt *nxt;} bigflt; -typedef struct bigcmp {mpc_t z; struct bigcmp *nxt;} bigcmp; - -typedef struct { - mpfr_t error, ux, x0, x1; - mpz_t i, i0, i1, n; - mpz_t p0, q0, r, r1, p1, q1, old_p1, old_q1; - mpfr_t val, e0, e1, e0p, e1p, old_e0, old_e1, old_e0p; - mpq_t q; -} rat_locals_t; -#endif - -typedef intptr_t opcode_t; - - -/* -------------------------------- cell structure -------------------------------- */ - -typedef struct s7_cell { - union { - uint64_t flag; /* type info */ - int64_t signed_flag; - uint8_t type_field; - uint16_t sflag; - struct { - uint32_t unused_low_flag; - uint16_t opt_choice; - uint16_t high_flag; - } opts; - } tf; - union { - - union { /* integers, floats */ - s7_int integer_value; - s7_double real_value; - - struct { /* ratios */ - s7_int numerator; - s7_int denominator; - } fraction_value; - - struct { /* complex numbers */ - s7_double rl; - s7_double im; - } complex_value; - -#if WITH_GMP - bigint *bgi; /* bignums */ - bigrat *bgr; - bigflt *bgf; - bigcmp *bgc; -#endif - } number; - - struct { - s7_int unused1, unused2; /* always int64_t so this is 16 bytes */ - uint8_t name[24]; - } number_name; - - struct { /* ports */ - port_t *port; - uint8_t *data; - s7_int size, point; - block_t *block; - } prt; - - struct{ /* characters */ - uint8_t c, up_c; - int32_t length; - bool alpha_c, digit_c, space_c, upper_c, lower_c; - char c_name[12]; - } chr; - - struct { /* c-pointers */ - void *c_pointer; - s7_pointer c_type, info, weak1, weak2; - } cptr; - - struct { /* vectors */ - s7_int length; - union { - s7_pointer *objects; - s7_int *ints; - s7_double *floats; - uint8_t *bytes; - } elements; - block_t *block; - s7_pointer (*vget)(s7_scheme *sc, s7_pointer vec, s7_int loc); - union { - s7_pointer (*vset)(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val); - s7_pointer fset; - } setv; - } vector; - - struct { /* stacks (internal) struct must match vector above for length/objects */ - s7_int length; - s7_pointer *objects; - block_t *block; - int64_t top, flags; - } stk; - - struct { /* hash-tables */ - s7_int mask; - hash_entry_t **elements; /* a pointer into block below: takes up a field in object.hasher but is faster (50 in thash) */ - hash_check_t hash_func; - hash_map_t *loc; - block_t *block; - } hasher; - - struct { /* iterators */ - s7_pointer obj, cur; - union { - s7_int loc; - s7_pointer lcur; - } lc; - union { - s7_int len; - s7_pointer slow; - hash_entry_t *hcur; - } lw; - s7_pointer (*next)(s7_scheme *sc, s7_pointer iterator); - } iter; - - struct { - c_proc_t *c_proc; /* C functions, macros */ - s7_function ff; - s7_int required_args, optional_args, all_args; /* these could be uint32_t */ - } fnc; - - struct { /* pairs */ - s7_pointer car, cdr, opt1; - union - { - s7_pointer opt2; - s7_int n; - } o2; - union { - s7_pointer opt3; - s7_int n; - uint8_t opt_type; - } o3; - } cons; - - struct { /* special purpose pairs (symbol-table etc) */ - s7_pointer unused_car, unused_cdr; - uint64_t hash; - const char *fstr; - uint64_t location; /* line/file/position, also used in symbol_table as raw_len */ - } sym_cons; - - struct { /* scheme functions */ - s7_pointer args, body, env, setter; /* args can be a symbol, as well as a list, setter can be #f as well as a procedure/closure */ - int32_t arity; - } func; - - struct { /* strings */ - s7_int length; - char *svalue; - uint64_t hash; /* string hash-index */ - block_t *block; - block_t *gensym_block; - } string; - - struct { /* symbols */ - s7_pointer name, global_slot, local_slot; - int64_t id; /* which let last bound the symbol -- for faster symbol lookup */ - uint32_t ctr; /* how many times has symbol been bound */ - uint32_t tag; /* symbol as member of a set (tree-set-memq etc), high 32 bits are in symbol_info (the string block) */ - } sym; - - struct { /* syntax */ - s7_pointer symbol; - opcode_t op; - int32_t min_args, max_args; - const char *documentation; - } syn; - - struct { /* slots (bindings) */ - s7_pointer sym, val, nxt, pending_value, expr; /* pending_value is also the setter field which works by a whisker */ - } slt; - - struct { /* lets (environments) */ - s7_pointer slots, nxt; - int64_t id; /* id of rootlet is -1 */ - union { - struct { - s7_pointer function; /* *function* (symbol) if this is a funclet */ - uint32_t line, file; /* *function* location if it is known */ - } efnc; - struct { - s7_pointer dox1, dox2; /* do loop variables */ - } dox; - s7_int key; /* sc->baffle_ctr type */ - } edat; - } envr; - - struct { /* special stuff like # */ - s7_pointer car, cdr; /* unique_car|cdr, for sc->nil these are sc->unspecified for faster assoc etc */ - int64_t unused_let_id; /* let_id(sc->nil) is -1, so this needs to align with envr.id above, only used by sc->nil, so free elsewhere */ - const char *name; - s7_int len; - } unq; - - struct { /* #<...> */ - char *name; /* not const because the GC frees it */ - s7_int len; - } undef; - - struct { /* # */ - const char *name; - s7_int len; - } eof; - - struct { /* counter (internal) */ - s7_pointer result, list, env, slots; /* env = counter_let (curlet after map/for-each let created) */ - uint64_t cap; /* sc->capture_let_counter for let reuse */ - } ctr; - - struct { /* random-state */ -#if WITH_GMP - gmp_randstate_t state; -#else - uint64_t seed, carry; -#endif - } rng; - - struct { /* additional object types (C) */ - s7_int type; - void *value; /* the value the caller associates with the c_object */ - s7_pointer e; /* the method list, if any (openlet) */ - s7_scheme *sc; - } c_obj; - - struct { /* continuations */ - block_t *block; - s7_pointer stack, op_stack; - s7_pointer *stack_start, *stack_end; - } cwcc; - - struct { /* call-with-exit */ - uint64_t goto_loc, op_stack_loc; - bool active; - s7_pointer name; - } rexit; - - struct { /* catch */ - uint64_t goto_loc, op_stack_loc; - s7_pointer tag; - s7_pointer handler; - Jmp_Buf *cstack; - } rcatch; /* C++ reserves "catch" I guess */ - - struct { /* dynamic-wind */ - s7_pointer in, out, body; - dwind_t state; - } winder; - } object; - -#if S7_DEBUGGING - int32_t alloc_line, uses, explicit_free_line, gc_line, holders; - int64_t alloc_type, debugger_bits; - const char *alloc_func, *gc_func, *root; - s7_pointer holder; -#endif -} s7_cell; - - -typedef struct s7_big_cell { - s7_cell cell; - int64_t big_hloc; -} s7_big_cell; -typedef struct s7_big_cell *s7_big_pointer; - -typedef struct heap_block_t { - intptr_t start, end; - int64_t offset; - struct heap_block_t *next; -} heap_block_t; - -typedef struct { - s7_pointer *objs; - int32_t size, top, ref, size2; - bool has_hits; - int32_t *refs; - s7_pointer cycle_port, init_port; - s7_int cycle_loc, init_loc, ctr; - bool *defined; -} shared_info_t; - -typedef struct { - s7_int loc, curly_len, ctr; - char *curly_str; - s7_pointer args, orig_str, curly_arg, port, strport; -} format_data_t; - -typedef struct gc_obj_t { - s7_pointer p; - struct gc_obj_t *nxt; -} gc_obj_t; - -typedef struct { - s7_pointer *list; - s7_int size, loc; -} gc_list_t; - -typedef struct { - s7_int size, top, excl_size, excl_top; - s7_pointer *funcs, *let_names, *files; - s7_int *timing_data, *excl, *lines; -} profile_data_t; - - -/* -------------------------------- s7_scheme struct -------------------------------- */ -struct s7_scheme { - s7_pointer code; /* layout of first 4 entries should match stack frame layout */ - s7_pointer curlet; - s7_pointer args; - opcode_t cur_op; - s7_pointer value, cur_code; - token_t tok; - - s7_pointer stack; /* stack is a vector */ - uint32_t stack_size; - s7_pointer *stack_start, *stack_end, *stack_resize_trigger; - - s7_pointer *op_stack, *op_stack_now, *op_stack_end; - uint32_t op_stack_size, max_stack_size; - - s7_cell **heap, **free_heap, **free_heap_top, **free_heap_trigger, **previous_free_heap_top; - int64_t heap_size, gc_freed, gc_total_freed, max_heap_size, gc_temps_size; - s7_double gc_resize_heap_fraction, gc_resize_heap_by_4_fraction; - s7_int gc_calls, gc_total_time, gc_start, gc_end; - heap_block_t *heap_blocks; - -#if WITH_HISTORY - s7_pointer eval_history1, eval_history2, error_history, history_sink, history_pairs, old_cur_code; - bool using_history1; -#endif - -#if WITH_MULTITHREAD_CHECKS - int32_t lock_count; - pthread_mutex_t lock; -#endif - - gc_obj_t *semipermanent_objects, *semipermanent_lets; - s7_pointer protected_objects, protected_setters, protected_setter_symbols; /* vectors of gc-protected objects */ - s7_int *protected_objects_free_list; /* to avoid a linear search for a place to store an object in sc->protected_objects */ - s7_int protected_objects_size, protected_setters_size, protected_setters_loc; - s7_int protected_objects_free_list_loc; - - s7_pointer nil; /* empty list */ - s7_pointer T; /* #t */ - s7_pointer F; /* #f */ - s7_pointer undefined; /* # */ - s7_pointer unspecified; /* # */ - s7_pointer no_value; /* the (values) value */ - s7_pointer unused; /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */ - - s7_pointer symbol_table; /* symbol table */ - s7_pointer rootlet, shadow_rootlet; /* rootlet */ - s7_int rootlet_entries; - s7_pointer unlet; /* original bindings of predefined functions */ - - s7_pointer input_port; /* current-input-port */ - s7_pointer *input_port_stack; /* input port stack (load and read internally) */ - uint32_t input_port_stack_size, input_port_stack_loc; - - s7_pointer output_port; /* current-output-port */ - s7_pointer error_port; /* current-error-port */ - s7_pointer owlet; /* owlet */ - s7_pointer error_type, error_data, error_code, error_line, error_file, error_position; /* owlet slots */ - s7_pointer standard_input, standard_output, standard_error; - - s7_pointer sharp_readers; /* the binding pair for the global *#readers* list */ - s7_pointer load_hook; /* *load-hook* hook object */ - s7_pointer autoload_hook; /* *autoload-hook* hook object */ - s7_pointer unbound_variable_hook; /* *unbound-variable-hook* hook object */ - s7_pointer missing_close_paren_hook, rootlet_redefinition_hook; - s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */ - bool gc_off, gc_in_progress; /* gc_off: if true, the GC won't run */ - uint32_t gc_stats, gensym_counter, f_class, add_class, multiply_class, subtract_class, num_eq_class; - int32_t format_column, error_argnum; - uint64_t capture_let_counter; - bool short_print, is_autoloading, in_with_let, object_out_locked, has_openlets, is_expanding, accept_all_keyword_arguments, muffle_warnings; - bool got_tc, got_rec, not_tc; - s7_int rec_tc_args, continuation_counter; - int64_t let_number; - unsigned char number_separator; - s7_double default_rationalize_error, equivalent_float_epsilon, hash_table_float_epsilon; - s7_int default_hash_table_length, initial_string_port_length, print_length, objstr_max_len, history_size, true_history_size, output_port_data_size; - s7_int max_vector_length, max_string_length, max_list_length, max_vector_dimensions, max_format_length, max_port_data_size, rec_loc, rec_len; - s7_pointer stacktrace_defaults; - - s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, rec_f6p, rec_f7p, rec_f8p, rec_f9p; - s7_pointer rec_resp, rec_slot1, rec_slot2, rec_slot3, rec_p1, rec_p2; - s7_pointer *rec_els; - s7_function rec_testf, rec_f1f, rec_f2f, rec_f3f, rec_f4f, rec_f5f, rec_f6f, rec_f7f, rec_f8f, rec_f9f, rec_resf, rec_fn; - s7_int (*rec_fi1)(opt_info *o); - s7_int (*rec_fi2)(opt_info *o); - s7_int (*rec_fi3)(opt_info *o); - s7_int (*rec_fi4)(opt_info *o); - s7_int (*rec_fi5)(opt_info *o); - s7_int (*rec_fi6)(opt_info *o); - bool (*rec_fb1)(opt_info *o); - bool (*rec_fb2)(opt_info *o); - - opt_info *rec_test_o, *rec_result_o, *rec_a1_o, *rec_a2_o, *rec_a3_o, *rec_a4_o, *rec_a5_o, *rec_a6_o; - s7_i_ii_t rec_i_ii_f; - s7_d_dd_t rec_d_dd_f; - s7_pointer rec_val1, rec_val2; - - int32_t float_format_precision; - vdims_t *wrap_only; - - char *typnam; - int32_t typnam_len, print_width; - s7_pointer *singletons; - block_t *unentry; /* hash-table lookup failure indicator */ - - #define INITIAL_FILE_NAMES_SIZE 8 - s7_pointer *file_names; - int32_t file_names_size, file_names_top; - - #define INITIAL_STRBUF_SIZE 1024 - s7_int strbuf_size; - char *strbuf; - - char *read_line_buf; - s7_int read_line_buf_size; - - s7_pointer w, x, y, z; - s7_pointer temp1, temp2, temp3, temp4, temp5, temp7, temp8, temp9, temp10; - s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, t4_1, u1_1; - s7_pointer elist_1, elist_2, elist_3, elist_4, elist_5, elist_6, elist_7; - s7_pointer plist_1, plist_2, plist_2_2, plist_3, qlist_2, qlist_3, clist_1, clist_2, dlist_1, mlist_1, mlist_2; /* dlist|clist and ulist can't overlap */ - - Jmp_Buf *goto_start; - bool longjmp_ok; - int32_t setjmp_loc; - - void (*begin_hook)(s7_scheme *sc, bool *val); - opcode_t begin_op; - - bool debug_or_profile, profiling_gensyms; - s7_int current_line, s7_call_line, debug, profile, profile_position; - s7_pointer profile_prefix; - profile_data_t *profile_data; - const char *current_file, *s7_call_file, *s7_call_name; - - shared_info_t *circle_info; - format_data_t **fdats; - int32_t num_fdats, safety; - gc_list_t *strings, *vectors, *input_ports, *output_ports, *input_string_ports, *continuations, *c_objects, *hash_tables; - gc_list_t *gensyms, *undefineds, *multivectors, *weak_refs, *weak_hash_iterators, *opt1_funcs; -#if (WITH_GMP) - gc_list_t *big_integers, *big_ratios, *big_reals, *big_complexes, *big_random_states; - mpz_t mpz_1, mpz_2, mpz_3, mpz_4; - mpq_t mpq_1, mpq_2, mpq_3; - mpfr_t mpfr_1, mpfr_2, mpfr_3; - mpc_t mpc_1, mpc_2; - rat_locals_t *ratloc; - bigint *bigints; - bigrat *bigrats; - bigflt *bigflts; - bigcmp *bigcmps; -#endif - s7_pointer *setters; - s7_int setters_size, setters_loc; - s7_pointer *tree_pointers; - int32_t tree_pointers_size, tree_pointers_top, semipermanent_cells, num_to_str_size; - s7_pointer format_ports; - uint32_t alloc_pointer_k, alloc_function_k, alloc_symbol_k; - s7_cell *alloc_pointer_cells; - c_proc_t *alloc_function_cells; - uint32_t alloc_big_pointer_k; - s7_big_cell *alloc_big_pointer_cells; - s7_pointer string_wrappers, integer_wrappers, real_wrappers; - uint8_t *alloc_symbol_cells; - char *num_to_str; - - block_t *block_lists[NUM_BLOCK_LISTS]; - size_t alloc_string_k; - char *alloc_string_cells; - - c_object_t **c_object_types; - int32_t c_object_types_size, num_c_object_types; - s7_pointer type_to_typers[NUM_TYPES]; - - uint32_t syms_tag, syms_tag2; - int32_t bignum_precision; - s7_int baffle_ctr, map_call_ctr; - s7_pointer default_random_state; - - s7_pointer sort_body, sort_begin, sort_v1, sort_v2; - opcode_t sort_op; - s7_int sort_body_len; - s7_b_7pp_t sort_f; - opt_info *sort_o; - bool (*sort_fb)(opt_info *o); - - #define INT_TO_STR_SIZE 32 - char int_to_str1[INT_TO_STR_SIZE], int_to_str2[INT_TO_STR_SIZE], int_to_str3[INT_TO_STR_SIZE], int_to_str4[INT_TO_STR_SIZE], int_to_str5[INT_TO_STR_SIZE]; - - s7_pointer abs_symbol, acos_symbol, acosh_symbol, add_symbol, angle_symbol, append_symbol, apply_symbol, apply_values_symbol, arity_symbol, - ash_symbol, asin_symbol, asinh_symbol, assoc_symbol, assq_symbol, assv_symbol, atan_symbol, atanh_symbol, autoload_symbol, autoloader_symbol, - bacro_symbol, bacro_star_symbol, bignum_symbol, byte_vector_symbol, byte_vector_ref_symbol, byte_vector_set_symbol, byte_vector_to_string_symbol, - c_pointer_symbol, c_pointer_info_symbol, c_pointer_to_list_symbol, c_pointer_type_symbol, c_pointer_weak1_symbol, c_pointer_weak2_symbol, - caaaar_symbol, caaadr_symbol, caaar_symbol, caadar_symbol, caaddr_symbol, caadr_symbol, - caar_symbol, cadaar_symbol, cadadr_symbol, cadar_symbol, caddar_symbol, cadddr_symbol, caddr_symbol, cadr_symbol, - call_cc_symbol, call_with_current_continuation_symbol, call_with_exit_symbol, call_with_input_file_symbol, - call_with_input_string_symbol, call_with_output_file_symbol, call_with_output_string_symbol, car_symbol, - catch_symbol, cdaaar_symbol, cdaadr_symbol, cdaar_symbol, cdadar_symbol, cdaddr_symbol, cdadr_symbol, cdar_symbol, - cddaar_symbol, cddadr_symbol, cddar_symbol, cdddar_symbol, cddddr_symbol, cdddr_symbol, cddr_symbol, cdr_symbol, - ceiling_symbol, char_downcase_symbol, char_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, char_lt_symbol, - char_position_symbol, char_to_integer_symbol, char_upcase_symbol, cload_directory_symbol, close_input_port_symbol, - close_output_port_symbol, complex_symbol, cons_symbol, copy_symbol, cos_symbol, cosh_symbol, coverlet_symbol, - curlet_symbol, current_error_port_symbol, current_input_port_symbol, current_output_port_symbol, cutlet_symbol, cyclic_sequences_symbol, - denominator_symbol, dilambda_symbol, display_symbol, divide_symbol, documentation_symbol, dynamic_wind_symbol, dynamic_unwind_symbol, - num_eq_symbol, error_symbol, eval_string_symbol, eval_symbol, exact_to_inexact_symbol, exit_symbol, exp_symbol, expt_symbol, - features_symbol, file__symbol, fill_symbol, float_vector_ref_symbol, float_vector_set_symbol, float_vector_symbol, floor_symbol, - flush_output_port_symbol, for_each_symbol, format_symbol, funclet_symbol, _function__symbol, - gc_symbol, gcd_symbol, gensym_symbol, geq_symbol, get_output_string_symbol, gt_symbol, - hash_table_entries_symbol, hash_table_key_typer_symbol, hash_table_ref_symbol, hash_table_set_symbol, hash_table_symbol, - hash_table_value_typer_symbol, help_symbol, - imag_part_symbol, immutable_symbol, inexact_to_exact_symbol, inlet_symbol, int_vector_ref_symbol, int_vector_set_symbol, int_vector_symbol, - integer_decode_float_symbol, integer_to_char_symbol, - is_aritable_symbol, is_bignum_symbol, is_boolean_symbol, is_byte_symbol, is_byte_vector_symbol, - is_c_object_symbol, c_object_type_symbol, is_c_pointer_symbol, is_char_alphabetic_symbol, is_char_lower_case_symbol, is_char_numeric_symbol, - is_char_symbol, is_char_upper_case_symbol, is_char_whitespace_symbol, is_complex_symbol, is_constant_symbol, - is_continuation_symbol, is_defined_symbol, is_dilambda_symbol, is_eof_object_symbol, is_eq_symbol, is_equal_symbol, - is_eqv_symbol, is_even_symbol, is_exact_symbol, is_float_vector_symbol, is_funclet_symbol, - is_gensym_symbol, is_goto_symbol, is_hash_table_symbol, is_immutable_symbol, - is_inexact_symbol, is_infinite_symbol, is_input_port_symbol, is_int_vector_symbol, is_integer_symbol, is_iterator_symbol, - is_keyword_symbol, is_let_symbol, is_list_symbol, is_macro_symbol, is_equivalent_symbol, is_nan_symbol, is_negative_symbol, - is_null_symbol, is_number_symbol, is_odd_symbol, is_openlet_symbol, is_output_port_symbol, is_pair_symbol, - is_port_closed_symbol, is_positive_symbol, is_procedure_symbol, is_proper_list_symbol, is_provided_symbol, - is_random_state_symbol, is_rational_symbol, is_real_symbol, is_sequence_symbol, is_string_symbol, is_subvector_symbol, - is_symbol_symbol, is_syntax_symbol, is_vector_symbol, is_weak_hash_table_symbol, is_zero_symbol, - is_float_symbol, is_integer_or_real_at_end_symbol, is_integer_or_any_at_end_symbol, is_unspecified_symbol, is_undefined_symbol, - iterate_symbol, iterator_is_at_end_symbol, iterator_sequence_symbol, - keyword_to_symbol_symbol, - lcm_symbol, length_symbol, leq_symbol, let_ref_fallback_symbol, let_ref_symbol, let_set_fallback_symbol, - let_set_symbol, let_temporarily_symbol, libraries_symbol, list_ref_symbol, list_set_symbol, list_symbol, list_tail_symbol, list_values_symbol, - load_path_symbol, load_symbol, log_symbol, logand_symbol, logbit_symbol, logior_symbol, lognot_symbol, logxor_symbol, lt_symbol, - macro_symbol, macro_star_symbol, magnitude_symbol, make_byte_vector_symbol, make_float_vector_symbol, make_hash_table_symbol, - make_weak_hash_table_symbol, make_int_vector_symbol, make_iterator_symbol, string_to_keyword_symbol, make_list_symbol, make_string_symbol, - make_vector_symbol, map_symbol, max_symbol, member_symbol, memq_symbol, memv_symbol, min_symbol, modulo_symbol, multiply_symbol, - name_symbol, nan_symbol, nan_payload_symbol, newline_symbol, not_symbol, number_to_string_symbol, numerator_symbol, - object_to_string_symbol, object_to_let_symbol, open_input_file_symbol, open_input_function_symbol, open_input_string_symbol, - open_output_file_symbol, open_output_function_symbol, open_output_string_symbol, openlet_symbol, outlet_symbol, owlet_symbol, - pair_filename_symbol, pair_line_number_symbol, peek_char_symbol, pi_symbol, port_filename_symbol, port_line_number_symbol, - port_file_symbol, port_position_symbol, procedure_source_symbol, provide_symbol, - qq_append_symbol, quotient_symbol, - random_state_symbol, random_state_to_list_symbol, random_symbol, rationalize_symbol, read_byte_symbol, - read_char_symbol, read_line_symbol, read_string_symbol, read_symbol, real_part_symbol, remainder_symbol, - require_symbol, reverse_symbol, reverseb_symbol, rootlet_symbol, round_symbol, - setter_symbol, set_car_symbol, set_cdr_symbol, - set_current_error_port_symbol, set_current_input_port_symbol, set_current_output_port_symbol, - signature_symbol, sin_symbol, sinh_symbol, sort_symbol, sqrt_symbol, - stacktrace_symbol, string_append_symbol, string_copy_symbol, string_downcase_symbol, string_eq_symbol, string_fill_symbol, - string_geq_symbol, string_gt_symbol, string_leq_symbol, string_lt_symbol, string_position_symbol, string_ref_symbol, - string_set_symbol, string_symbol, string_to_number_symbol, string_to_symbol_symbol, string_upcase_symbol, - sublet_symbol, substring_symbol, subtract_symbol, subvector_symbol, subvector_position_symbol, subvector_vector_symbol, - symbol_symbol, symbol_to_dynamic_value_symbol, - symbol_to_keyword_symbol, symbol_to_string_symbol, symbol_to_value_symbol, - tan_symbol, tanh_symbol, throw_symbol, string_to_byte_vector_symbol, - tree_count_symbol, tree_leaves_symbol, tree_memq_symbol, tree_set_memq_symbol, tree_is_cyclic_symbol, truncate_symbol, type_of_symbol, - unlet_symbol, - values_symbol, varlet_symbol, vector_append_symbol, vector_dimension_symbol, vector_dimensions_symbol, vector_fill_symbol, - vector_rank_symbol, vector_ref_symbol, vector_set_symbol, vector_symbol, vector_typer_symbol, - weak_hash_table_symbol, with_input_from_file_symbol, with_input_from_string_symbol, with_output_to_file_symbol, with_output_to_string_symbol, - write_byte_symbol, write_char_symbol, write_string_symbol, write_symbol, - local_documentation_symbol, local_signature_symbol, local_setter_symbol, local_iterator_symbol; - s7_pointer hash_code_symbol, dummy_equal_hash_table; -#if (!WITH_PURE_S7) - s7_pointer is_char_ready_symbol, char_ci_leq_symbol, char_ci_lt_symbol, char_ci_eq_symbol, char_ci_geq_symbol, char_ci_gt_symbol, - let_to_list_symbol, integer_length_symbol, string_ci_leq_symbol, string_ci_lt_symbol, string_ci_eq_symbol, - string_ci_geq_symbol, string_ci_gt_symbol, string_to_list_symbol, vector_to_list_symbol, string_length_symbol, - list_to_string_symbol, list_to_vector_symbol, vector_length_symbol; -#endif - - /* syntax symbols et al */ - s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, quote_symbol, quasiquote_symbol, unquote_symbol, macroexpand_symbol, - define_expansion_symbol, define_expansion_star_symbol, with_let_symbol, if_symbol, autoload_error_symbol, - when_symbol, unless_symbol, begin_symbol, cond_symbol, case_symbol, and_symbol, or_symbol, do_symbol, number_to_real_symbol, - define_symbol, define_star_symbol, define_constant_symbol, with_baffle_symbol, define_macro_symbol, no_setter_symbol, - define_macro_star_symbol, define_bacro_symbol, define_bacro_star_symbol, letrec_symbol, letrec_star_symbol, let_star_symbol, - rest_keyword, allow_other_keys_keyword, readable_keyword, display_keyword, write_keyword, value_symbol, type_symbol, - baffled_symbol, set_symbol, body_symbol, class_name_symbol, feed_to_symbol, format_error_symbol, immutable_error_symbol, - wrong_number_of_args_symbol, read_error_symbol, string_read_error_symbol, syntax_error_symbol, division_by_zero_symbol, bad_result_symbol, - io_error_symbol, invalid_escape_function_symbol, wrong_type_arg_symbol, out_of_range_symbol, out_of_memory_symbol, - missing_method_symbol, unbound_variable_symbol, if_keyword, symbol_table_symbol, profile_in_symbol, trace_in_symbol; - - /* signatures of sequences used as applicable objects: ("hi" 1) */ - s7_pointer string_signature, vector_signature, float_vector_signature, int_vector_signature, byte_vector_signature, - c_object_signature, let_signature, hash_table_signature, pair_signature; - /* common signatures */ - s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, pcl_e, pcl_f, pcl_i, pcl_n, pcl_r, pcl_s, pcl_v, pl_bc, pl_bn, pl_bt, pl_p, pl_sf, pl_tl, pl_nn; - - /* optimizer s7_functions */ - s7_pointer add_2, add_3, add_1x, add_x1, subtract_1, subtract_2, subtract_3, subtract_x1, subtract_2f, subtract_f2, simple_char_eq, - char_equal_2, char_greater_2, char_less_2, char_position_csi, string_equal_2, substring_uncopied, display_2, display_f, - string_greater_2, string_less_2, symbol_to_string_uncopied, get_output_string_uncopied, string_equal_2c, string_c1, string_append_2, - vector_ref_2, vector_ref_3, vector_set_3, vector_set_4, read_char_1, dynamic_wind_unchecked, dynamic_wind_body, dynamic_wind_init, append_2, - fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, iv_ref_2, iv_ref_3, iv_set_3, bv_ref_2, bv_ref_3, bv_set_3, vector_2, vector_3, - list_0, list_1, list_2, list_3, list_4, list_set_i, hash_table_ref_2, hash_table_2, list_ref_at_0, list_ref_at_1, list_ref_at_2, - format_f, format_no_column, format_just_control_string, format_as_objstr, values_uncopied, int_log2, - memq_2, memq_3, memq_4, memq_any, tree_set_memq_syms, simple_inlet, sublet_curlet, profile_out, simple_list_values, - lint_let_ref, lint_let_set, geq_2, add_i_random, is_defined_in_rootlet; - - s7_pointer multiply_2, invert_1, invert_x, divide_2, divide_by_2, max_2, min_2, max_3, min_3, - num_eq_2, num_eq_xi, num_eq_ix, less_xi, less_xf, less_x0, less_2, greater_xi, greater_xf, greater_2, - leq_xi, leq_2, leq_ixx, geq_xi, geq_xf, random_i, random_f, random_1, - mul_2_ff, mul_2_ii, mul_2_if, mul_2_fi, mul_2_xi, mul_2_ix, mul_2_fx, mul_2_xf, - add_2_ff, add_2_ii, add_2_if, add_2_fi, add_2_xi, add_2_ix, add_2_fx, add_2_xf; - s7_pointer seed_symbol, carry_symbol; - - /* object->let symbols */ - s7_pointer active_symbol, goto_symbol, data_symbol, weak_symbol, dimensions_symbol, info_symbol, c_type_symbol, source_symbol, c_object_ref_symbol, - at_end_symbol, sequence_symbol, position_symbol, entries_symbol, function_symbol, open_symbol, alias_symbol, port_type_symbol, - file_symbol, file_info_symbol, line_symbol, c_object_let_symbol, class_symbol, current_value_symbol, closed_symbol, - mutable_symbol, size_symbol, original_vector_symbol, pointer_symbol; - -#if WITH_SYSTEM_EXTRAS - s7_pointer is_directory_symbol, file_exists_symbol, delete_file_symbol, getenv_symbol, system_symbol, directory_to_list_symbol, file_mtime_symbol; -#endif - s7_pointer open_input_function_choices[S7_NUM_READ_CHOICES]; - s7_pointer closed_input_function, closed_output_function; - s7_pointer vector_set_function, string_set_function, list_set_function, hash_table_set_function, let_set_function, c_object_set_function, last_function; - s7_pointer wrong_type_arg_info, out_of_range_info, sole_arg_wrong_type_info, sole_arg_out_of_range_info; - - #define NUM_SAFE_PRELISTS 8 - #define NUM_SAFE_LISTS 64 /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test */ - s7_pointer safe_lists[NUM_SAFE_LISTS]; - int32_t current_safe_list; - - s7_pointer autoload_table, s7_starlet, s7_starlet_symbol, let_temp_hook; - const char ***autoload_names; - s7_int *autoload_names_sizes; - bool **autoloaded_already; - s7_int autoload_names_loc, autoload_names_top; - int32_t format_depth; - bool undefined_identifier_warnings, undefined_constant_warnings, stop_at_error; - - opt_funcs_t *alloc_opt_func_cells; - int32_t alloc_opt_func_k; - - int32_t pc; - #define OPTS_SIZE 256 /* pqw-vox needs 178 */ - opt_info *opts[OPTS_SIZE + 1]; /* this form is a lot faster than opt_info**! */ - - #define INITIAL_SAVED_POINTERS_SIZE 256 - void **saved_pointers; - s7_int saved_pointers_loc, saved_pointers_size; - - s7_pointer type_names[NUM_TYPES]; - -#if S7_DEBUGGING - int32_t *tc_rec_calls; - int32_t last_gc_line; - bool printing_gc_info; -#endif -}; - -#if S7_DEBUGGING - static void gdb_break(void) {}; -#endif -#if S7_DEBUGGING || POINTER_32 || WITH_WARNINGS -static s7_scheme *cur_sc = NULL; /* intended for gdb (see gdbinit), but also used if S7_DEBUGGING unfortunately */ -#endif - -static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info); - -#if POINTER_32 -static void *Malloc(size_t bytes) -{ - void *p = malloc(bytes); - if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil); - return(p); -} - -static void *Calloc(size_t nmemb, size_t size) -{ - void *p = calloc(nmemb, size); - if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil); - return(p); -} - -static void *Realloc(void *ptr, size_t size) -{ - void *p = realloc(ptr, size); - if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, cur_sc->nil); - return(p); -} -#else -#define Malloc malloc -#define Calloc calloc -#define Realloc realloc -#endif - - -/* -------------------------------- mallocate -------------------------------- */ -static void add_saved_pointer(s7_scheme *sc, void *p) -{ - if (sc->saved_pointers_loc == sc->saved_pointers_size) - { - sc->saved_pointers_size *= 2; - sc->saved_pointers = (void **)Realloc(sc->saved_pointers, sc->saved_pointers_size * sizeof(void *)); - } - sc->saved_pointers[sc->saved_pointers_loc++] = p; -} - -static const int32_t intlen_bits[256] = - {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, - 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, - 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8}; - -static void memclr(void *s, size_t n) -{ - uint8_t *s2; -#if S7_ALIGNED - s2 = (uint8_t *)s; -#else -#if (defined(__x86_64__) || defined(__i386__)) - if (n >= 8) - { - int64_t *s1 = (int64_t *)s; - size_t n8 = n >> 3; - do {*s1++ = 0;} while (--n8 > 0); /* LOOP_4 here is slower */ - n &= 7; - s2 = (uint8_t *)s1; - } - else s2 = (uint8_t *)s; -#else - s2 = (uint8_t *)s; -#endif -#endif - while (n > 0) - { - *s2++ = 0; - n--; - } -} - -#define LOOP_4(Code) do {Code; Code; Code; Code;} while (0) -#define LOOP_8(Code) do {Code; Code; Code; Code; Code; Code; Code; Code;} while (0) -#define STEP_8(Var) (((Var) & 0x7) == 0) -#define STEP_64(Var) (((Var) & 0x3f) == 0) - -#if POINTER_32 -#define memclr64 memclr -#else -static Vectorized void memclr64(void *p, size_t bytes) -{ - size_t n = bytes >> 3; - int64_t *vals = (int64_t *)p; - for (size_t i = 0; i < n; ) - LOOP_8(vals[i++] = 0); -} -#endif - -static void init_block_lists(s7_scheme *sc) -{ - for (int32_t i = 0; i < NUM_BLOCK_LISTS; i++) - sc->block_lists[i] = NULL; -} - -static inline void liberate(s7_scheme *sc, block_t *p) -{ - if (block_index(p) != TOP_BLOCK_LIST) - { - block_next(p) = (struct block_t *)sc->block_lists[block_index(p)]; - sc->block_lists[block_index(p)] = p; - } - else - { - if (block_data(p)) - { - free(block_data(p)); - block_data(p) = NULL; - } - block_next(p) = (struct block_t *)sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = p; - } -} - -static inline void liberate_block(s7_scheme *sc, block_t *p) -{ - block_next(p) = (struct block_t *)sc->block_lists[BLOCK_LIST]; /* BLOCK_LIST=0 */ - sc->block_lists[BLOCK_LIST] = p; -} - -static void fill_block_list(s7_scheme *sc) -{ - #define BLOCK_MALLOC_SIZE 256 - block_t *b = (block_t *)Malloc(BLOCK_MALLOC_SIZE * sizeof(block_t)); /* batch alloc means blocks in this batch can't be freed, only returned to the list */ - add_saved_pointer(sc, b); - sc->block_lists[BLOCK_LIST] = b; - for (int32_t i = 0; i < BLOCK_MALLOC_SIZE - 1; b++, i++) - block_next(b) = (block_t *)(b + 1); - block_next(b) = NULL; -} - -static inline block_t *mallocate_block(s7_scheme *sc) -{ - block_t *p; - if (!sc->block_lists[BLOCK_LIST]) - fill_block_list(sc); /* this is much faster than allocating blocks as needed */ - p = sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = (block_t *)(block_next(p)); - block_set_index(p, BLOCK_LIST); - return(p); -} - -static inline char *permalloc(s7_scheme *sc, size_t len) -{ - #define ALLOC_STRING_SIZE (65536 * 8) /* going up to 16 made no difference in timings */ - #define ALLOC_MAX_STRING (512 * 8) /* was 256 -- sets max size of block space lost at the end, but smaller = more direct malloc calls */ - char *result; - size_t next_k; - - len = (len + 7) & (~7); /* 8-byte aligned -- more than half the time, len is already 8-byte aligned */ - next_k = sc->alloc_string_k + len; - if (next_k > ALLOC_STRING_SIZE) - { - if (len >= ALLOC_MAX_STRING) - { - result = (char *)Malloc(len); - add_saved_pointer(sc, result); - return(result); - } - sc->alloc_string_cells = (char *)Malloc(ALLOC_STRING_SIZE); /* get a new block */ - add_saved_pointer(sc, sc->alloc_string_cells); - sc->alloc_string_k = 0; - next_k = len; - } - result = &(sc->alloc_string_cells[sc->alloc_string_k]); - sc->alloc_string_k = next_k; - return(result); -} - -static Inline block_t *inline_mallocate(s7_scheme *sc, size_t bytes) -{ - block_t *p; - if (bytes > 0) - { - int32_t index; - if (bytes <= 8) /* presetting a version of intlen_bits with 3's gave only a small speed-up */ - index = 3; - else - { - if (bytes <= 256) - index = intlen_bits[bytes - 1]; - else index = (bytes <= 65536) ? (8 + intlen_bits[(bytes - 1) >> 8]) : TOP_BLOCK_LIST; /* expansion to (1 << 17) made no difference */ - } - p = sc->block_lists[index]; - if (p) - sc->block_lists[index] = (block_t *)block_next(p); - else - { - if (index < (TOP_BLOCK_LIST - 1)) - { - p = sc->block_lists[index + 1]; - if (p) - { - /* we are "borrowing" a block from the next larger bin -- this saves space but costs a bit of time. - * in a tauto run repeating every call 1000 times, the old form ends up at 129M and 31.1 secs, - * whereas the borrowing form ends at 116M and 31.5 secs, but most of my tests show a slight - * speed-up, probably because grabbing a block here is faster than making a new one. - * Worst case is tlet: 8 slower in callgrind. - */ - sc->block_lists[index + 1] = (block_t *)block_next(p); - block_set_size(p, bytes); - return(p); - }} - p = mallocate_block(sc); - block_data(p) = (index < TOP_BLOCK_LIST) ? (void *)permalloc(sc, (size_t)(1 << index)) : Malloc(bytes); - block_set_index(p, index); - }} - else p = mallocate_block(sc); - block_set_size(p, bytes); - return(p); -} - -static block_t *mallocate(s7_scheme *sc, size_t bytes) {return(inline_mallocate(sc, bytes));} - -static block_t *callocate(s7_scheme *sc, size_t bytes) -{ - block_t *p = inline_mallocate(sc, bytes); - if ((block_data(p)) && (block_index(p) != BLOCK_LIST)) - { - if ((bytes & (~0x3f)) > 0) - memclr64((void *)block_data(p), bytes & (~0x3f)); - if ((bytes & 0x3f) > 0) - memclr((void *)((uint8_t *)block_data(p) + (bytes & (~0x3f))), bytes & 0x3f); - } - return(p); -} - -static block_t *reallocate(s7_scheme *sc, block_t *op, size_t bytes) -{ - block_t *np = inline_mallocate(sc, bytes); - if (block_data(op)) /* presumably block_data(np) is not null */ - memcpy((uint8_t *)(block_data(np)), (uint8_t *)(block_data(op)), block_size(op)); - liberate(sc, op); - return(np); -} - -/* we can't export mallocate et al without also exporting block_t or accessors for it - * that is, the block_t* pointer returned can't be used as if it were the void* pointer returned by malloc - * ideally we'd have a way to release excessive mallocate bins, but they are permalloc'd individually - */ - - -/* -------------------------------------------------------------------------------- */ -typedef enum {P_DISPLAY, P_WRITE, P_READABLE, P_KEY, P_CODE} use_write_t; - -static s7_pointer too_many_arguments_string, not_enough_arguments_string, cant_bind_immutable_string, - a_boolean_string, a_byte_vector_string, a_format_port_string, a_let_string, a_list_string, a_non_constant_symbol_string, - a_non_negative_integer_string, a_normal_procedure_string, a_normal_real_string, a_number_string, a_procedure_string, a_procedure_or_a_macro_string, - a_proper_list_string, a_random_state_object_string, a_rational_string, a_sequence_string, a_symbol_string, a_thunk_string, a_valid_radix_string, - an_association_list_string, an_eq_func_string, an_input_file_port_string, an_input_port_string, an_input_string_port_string, an_open_input_port_string, - an_open_output_port_string, an_output_port_or_f_string, an_output_file_port_string, an_output_port_string, an_output_string_port_string, - an_unsigned_byte_string, caaar_a_list_string, caadr_a_list_string, caar_a_list_string, cadar_a_list_string, caddr_a_list_string, - cadr_a_list_string, car_a_list_string, cdaar_a_list_string, cdadr_a_list_string, cdar_a_list_string, cddar_a_list_string, - cdddr_a_list_string, cddr_a_list_string, cdr_a_list_string, immutable_error_string, it_is_infinite_string, it_is_nan_string, - it_is_negative_string, it_is_too_large_string, it_is_too_small_string, parameter_set_twice_string, result_is_too_large_string, - something_applicable_string, too_many_indices_string, intermediate_too_large_string, - format_string_1, format_string_2, format_string_3, format_string_4, keyword_value_missing_string; - -static bool t_number_p[NUM_TYPES], t_small_real_p[NUM_TYPES], t_rational_p[NUM_TYPES], t_real_p[NUM_TYPES], t_big_number_p[NUM_TYPES]; -static bool t_simple_p[NUM_TYPES], t_structure_p[NUM_TYPES]; -static bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES], t_has_closure_let[NUM_TYPES]; -static bool t_mappable_p[NUM_TYPES], t_sequence_p[NUM_TYPES], t_vector_p[NUM_TYPES]; -static bool t_procedure_p[NUM_TYPES], t_applicable_p[NUM_TYPES], t_macro_setter_p[NUM_TYPES]; -#if S7_DEBUGGING -static bool t_freeze_p[NUM_TYPES]; /* free_cell sanity check */ -static bool t_ext_p[NUM_TYPES]; /* make sure internal types don't leak out */ -#endif - -static void init_types(void) -{ - for (int32_t i = 0; i < NUM_TYPES; i++) - { - t_number_p[i] = false; - t_small_real_p[i] = false; - t_real_p[i] = false; - t_rational_p[i] = false; - t_simple_p[i] = false; - t_structure_p[i] = false; - t_any_macro_p[i] = false; - t_any_closure_p[i] = false; - t_has_closure_let[i] = false; - t_sequence_p[i] = false; - t_mappable_p[i] = false; - t_vector_p[i] = false; - t_applicable_p[i] = false; - t_procedure_p[i] = false; - t_macro_setter_p[i] = false; -#if S7_DEBUGGING - t_freeze_p[i] = false; - t_ext_p[i] = false; -#endif - } - t_number_p[T_INTEGER] = true; - t_number_p[T_RATIO] = true; - t_number_p[T_REAL] = true; - t_number_p[T_COMPLEX] = true; - t_number_p[T_BIG_INTEGER] = true; - t_number_p[T_BIG_RATIO] = true; - t_number_p[T_BIG_REAL] = true; - t_number_p[T_BIG_COMPLEX] = true; - - t_rational_p[T_INTEGER] = true; - t_rational_p[T_RATIO] = true; - t_rational_p[T_BIG_INTEGER] = true; - t_rational_p[T_BIG_RATIO] = true; - - t_small_real_p[T_INTEGER] = true; - t_small_real_p[T_RATIO] = true; - t_small_real_p[T_REAL] = true; - - t_real_p[T_INTEGER] = true; - t_real_p[T_RATIO] = true; - t_real_p[T_REAL] = true; - t_real_p[T_BIG_INTEGER] = true; - t_real_p[T_BIG_RATIO] = true; - t_real_p[T_BIG_REAL] = true; - - t_big_number_p[T_BIG_INTEGER] = true; - t_big_number_p[T_BIG_RATIO] = true; - t_big_number_p[T_BIG_REAL] = true; - t_big_number_p[T_BIG_COMPLEX] = true; - - t_structure_p[T_PAIR] = true; - t_structure_p[T_VECTOR] = true; - t_structure_p[T_HASH_TABLE] = true; - t_structure_p[T_SLOT] = true; - t_structure_p[T_LET] = true; - t_structure_p[T_ITERATOR] = true; - t_structure_p[T_C_POINTER] = true; - t_structure_p[T_C_OBJECT] = true; - - t_sequence_p[T_NIL] = true; - t_sequence_p[T_PAIR] = true; - t_sequence_p[T_STRING] = true; - t_sequence_p[T_VECTOR] = true; - t_sequence_p[T_INT_VECTOR] = true; - t_sequence_p[T_FLOAT_VECTOR] = true; - t_sequence_p[T_BYTE_VECTOR] = true; - t_sequence_p[T_HASH_TABLE] = true; - t_sequence_p[T_LET] = true; - t_sequence_p[T_C_OBJECT] = true; /* this assumes the object has a length method? */ - - t_mappable_p[T_PAIR] = true; - t_mappable_p[T_STRING] = true; - t_mappable_p[T_VECTOR] = true; - t_mappable_p[T_INT_VECTOR] = true; - t_mappable_p[T_FLOAT_VECTOR] = true; - t_mappable_p[T_BYTE_VECTOR] = true; - t_mappable_p[T_HASH_TABLE] = true; - t_mappable_p[T_LET] = true; - t_mappable_p[T_C_OBJECT] = true; - t_mappable_p[T_ITERATOR] = true; - t_mappable_p[T_C_MACRO] = true; - t_mappable_p[T_MACRO] = true; - t_mappable_p[T_BACRO] = true; - t_mappable_p[T_MACRO_STAR] = true; - t_mappable_p[T_BACRO_STAR] = true; - t_mappable_p[T_CLOSURE] = true; - t_mappable_p[T_CLOSURE_STAR] = true; - - t_vector_p[T_VECTOR] = true; - t_vector_p[T_INT_VECTOR] = true; - t_vector_p[T_FLOAT_VECTOR] = true; - t_vector_p[T_BYTE_VECTOR] = true; - - t_applicable_p[T_PAIR] = true; - t_applicable_p[T_STRING] = true; - t_applicable_p[T_VECTOR] = true; - t_applicable_p[T_INT_VECTOR] = true; - t_applicable_p[T_FLOAT_VECTOR] = true; - t_applicable_p[T_BYTE_VECTOR] = true; - t_applicable_p[T_HASH_TABLE] = true; - t_applicable_p[T_ITERATOR] = true; - t_applicable_p[T_LET] = true; - t_applicable_p[T_C_OBJECT] = true; - t_applicable_p[T_C_MACRO] = true; - t_applicable_p[T_MACRO] = true; - t_applicable_p[T_BACRO] = true; - t_applicable_p[T_MACRO_STAR] = true; - t_applicable_p[T_BACRO_STAR] = true; - t_applicable_p[T_SYNTAX] = true; - t_applicable_p[T_C_FUNCTION] = true; - t_applicable_p[T_C_FUNCTION_STAR] = true; - t_applicable_p[T_C_RST_NO_REQ_FUNCTION] = true; - t_applicable_p[T_CLOSURE] = true; - t_applicable_p[T_CLOSURE_STAR] = true; - t_applicable_p[T_GOTO] = true; - t_applicable_p[T_CONTINUATION] = true; - - /* t_procedure_p[T_C_OBJECT] = true; */ - t_procedure_p[T_C_FUNCTION] = true; - t_procedure_p[T_C_FUNCTION_STAR] = true; - t_procedure_p[T_C_RST_NO_REQ_FUNCTION] = true; - t_procedure_p[T_CLOSURE] = true; - t_procedure_p[T_CLOSURE_STAR] = true; - t_procedure_p[T_GOTO] = true; - t_procedure_p[T_CONTINUATION] = true; - - for (int32_t i = T_CLOSURE; i < NUM_TYPES; i++) t_macro_setter_p[i] = true; - t_macro_setter_p[T_SYMBOL] = true; /* (slot setter); apparently T_LET and T_C_OBJECT are not possible here */ - - t_any_macro_p[T_C_MACRO] = true; - t_any_macro_p[T_MACRO] = true; - t_any_macro_p[T_BACRO] = true; - t_any_macro_p[T_MACRO_STAR] = true; - t_any_macro_p[T_BACRO_STAR] = true; - - t_any_closure_p[T_CLOSURE] = true; - t_any_closure_p[T_CLOSURE_STAR] = true; - - t_has_closure_let[T_MACRO] = true; - t_has_closure_let[T_BACRO] = true; - t_has_closure_let[T_MACRO_STAR] = true; - t_has_closure_let[T_BACRO_STAR] = true; - t_has_closure_let[T_CLOSURE] = true; - t_has_closure_let[T_CLOSURE_STAR] = true; - - t_simple_p[T_NIL] = true; - /* t_simple_p[T_UNDEFINED] = true; */ /* only # itself will work with eq? */ - t_simple_p[T_EOF] = true; - t_simple_p[T_BOOLEAN] = true; - t_simple_p[T_CHARACTER] = true; - t_simple_p[T_SYMBOL] = true; - t_simple_p[T_SYNTAX] = true; - t_simple_p[T_C_MACRO] = true; - t_simple_p[T_C_FUNCTION] = true; - t_simple_p[T_C_FUNCTION_STAR] = true; - t_simple_p[T_C_RST_NO_REQ_FUNCTION] = true; - /* not completely sure about the next ones */ - /* t_simple_p[T_LET] = true; */ /* this needs let_equal in member et al, 29-Nov-22 */ - t_simple_p[T_INPUT_PORT] = true; - t_simple_p[T_OUTPUT_PORT] = true; - -#if S7_DEBUGGING - t_freeze_p[T_STRING] = true; - t_freeze_p[T_BYTE_VECTOR] = true; - t_freeze_p[T_VECTOR] = true; - t_freeze_p[T_FLOAT_VECTOR] = true; - t_freeze_p[T_INT_VECTOR] = true; - t_freeze_p[T_UNDEFINED] = true; - t_freeze_p[T_C_OBJECT] = true; - t_freeze_p[T_HASH_TABLE] = true; - t_freeze_p[T_C_FUNCTION] = true; - t_freeze_p[T_CONTINUATION] = true; - t_freeze_p[T_INPUT_PORT] = true; - t_freeze_p[T_OUTPUT_PORT] = true; -#if WITH_GMP - t_freeze_p[T_BIG_INTEGER] = true; - t_freeze_p[T_BIG_RATIO] = true; - t_freeze_p[T_BIG_REAL] = true; - t_freeze_p[T_BIG_COMPLEX] = true; - t_freeze_p[T_RANDOM_STATE] = true; -#endif - t_ext_p[T_UNUSED] = true; - t_ext_p[T_STACK] = true; - t_ext_p[T_SLOT] = true; - t_ext_p[T_DYNAMIC_WIND] = true; - t_ext_p[T_CATCH] = true; - t_ext_p[T_COUNTER] = true; -#if (!WITH_GMP) - t_ext_p[T_BIG_INTEGER] = true; - t_ext_p[T_BIG_RATIO] = true; - t_ext_p[T_BIG_REAL] = true; - t_ext_p[T_BIG_COMPLEX] = true; -#endif -#endif -} - -#if WITH_HISTORY -#define current_code(Sc) car(Sc->cur_code) -#define set_current_code(Sc, Code) do {Sc->cur_code = cdr(Sc->cur_code); set_car(Sc->cur_code, T_Ext(Code));} while (0) -#define replace_current_code(Sc, Code) set_car(Sc->cur_code, T_Ext(Code)) -#define mark_current_code(Sc) do {int32_t i; s7_pointer p; for (p = Sc->cur_code, i = 0; i < Sc->history_size; i++, p = cdr(p)) gc_mark(car(p));} while (0) -#else -#define current_code(Sc) Sc->cur_code -#define set_current_code(Sc, Code) Sc->cur_code = T_Ext(Code) -#define replace_current_code(Sc, Code) Sc->cur_code = T_Ext(Code) -#define mark_current_code(Sc) gc_mark(Sc->cur_code) -#endif - -#define full_type(p) ((p)->tf.flag) -#define typesflag(p) ((p)->tf.sflag) -#define TYPE_MASK 0xff - -#if S7_DEBUGGING - static void print_gc_info(s7_scheme *sc, s7_pointer obj, int32_t line); - static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2); - static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref11(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref16(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_ref19(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line); - static s7_pointer check_let_ref(s7_pointer p, uint64_t role, const char *func, int32_t line); - - #define unchecked_type(p) ((p)->tf.type_field) -#if WITH_GCC - #define type(p) ({uint8_t _t_; _t_ = (p)->tf.type_field; if ((!cur_sc->printing_gc_info) && ((_t_ == T_FREE) || (_t_ >= NUM_TYPES))) print_gc_info(cur_sc, p, __LINE__); _t_;}) -#else - #define type(p) (p)->tf.type_field -#endif - #define set_full_type(p, f) set_type_1(p, f, __func__, __LINE__) - /* these check most s7_cell field references (and many type bits) for consistency */ - #define T_App(P) check_ref11(P, __func__, __LINE__) /* applicable or #f */ - #define T_Arg(P) check_ref10(P, __func__, __LINE__) /* closure arg (list, symbol) */ - #define T_BVc(P) check_ref(P, T_BYTE_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Bgf(P) check_ref(P, T_BIG_RATIO, __func__, __LINE__, "sweep", NULL) - #define T_Bgi(P) check_ref(P, T_BIG_INTEGER, __func__, __LINE__, "sweep", NULL) - #define T_Bgr(P) check_ref(P, T_BIG_REAL, __func__, __LINE__, "sweep", NULL) - #define T_Bgz(P) check_ref(P, T_BIG_COMPLEX, __func__, __LINE__, "sweep", NULL) - #define T_CMac(P) check_ref(P, T_C_MACRO, __func__, __LINE__, NULL, NULL) - #define T_Cat(P) check_ref(P, T_CATCH, __func__, __LINE__, NULL, NULL) - #define T_Chr(P) check_ref(P, T_CHARACTER, __func__, __LINE__, NULL, NULL) - #define T_Clo(P) check_ref5(P, __func__, __LINE__) /* has closure let */ - #define T_Cmp(P) check_ref(P, T_COMPLEX, __func__, __LINE__, NULL, NULL) - #define T_Con(P) check_ref(P, T_CONTINUATION, __func__, __LINE__, "sweep", "process_continuation") - #define T_Ctr(P) check_ref(P, T_COUNTER, __func__, __LINE__, NULL, NULL) - #define T_Dyn(P) check_ref(P, T_DYNAMIC_WIND, __func__, __LINE__, NULL, NULL) - #define T_Eof(P) check_ref(P, T_EOF, __func__, __LINE__, "sweep", NULL) - #define T_Ext(P) check_ref19(P, __func__, __LINE__) - #define T_Fnc(P) check_ref6(P, __func__, __LINE__) /* any c_function|c_macro */ - #define T_Frc(P) check_ref2(P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL) - #define T_Fst(P) check_ref(P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL) - #define T_Fvc(P) check_ref(P, T_FLOAT_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Got(P) check_ref(P, T_GOTO, __func__, __LINE__, NULL, NULL) - #define T_Hsh(P) check_ref(P, T_HASH_TABLE, __func__, __LINE__, "sweep", "free_hash_table") - #define T_Int(P) check_ref(P, T_INTEGER, __func__, __LINE__, NULL, NULL) - #define T_Itr(P) check_ref(P, T_ITERATOR, __func__, __LINE__, "sweep", "process_iterator") - #define T_Ivc(P) check_ref(P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Key(P) check_ref18(P, __func__, __LINE__) /* keyword */ - #define T_Let(P) check_ref(P, T_LET, __func__, __LINE__, NULL, NULL) - #define T_Lid(P) check_ref16(P, __func__, __LINE__) /* let/nil */ - #define T_Lst(P) check_ref2(P, T_PAIR, T_NIL, __func__, __LINE__, "gc", NULL) - #define T_Mac(P) check_ref17(P, __func__, __LINE__) /* a non-C macro */ - #define T_Met(P) check_ref9(P, __func__, __LINE__) /* anything that might contain a method */ - #define T_Nmv(P) check_ref15(P, __func__, __LINE__) /* not multiple-value, not free */ - #define T_Num(P) check_ref7(P, __func__, __LINE__) /* any number (not bignums) */ - #define T_Nvc(P) check_ref(P, T_VECTOR, __func__, __LINE__, "sweep", NULL) - #define T_Obj(P) check_ref(P, T_C_OBJECT, __func__, __LINE__, "sweep", "s7_c_object_value") - #define T_Pair(P) check_ref(P, T_PAIR, __func__, __LINE__, NULL, NULL) - #define T_Pcs(P) check_ref2(P, T_PAIR, T_CLOSURE_STAR, __func__, __LINE__, NULL, NULL) - #define T_Pos(P) check_nref(P, __func__, __LINE__) /* not free */ - #define T_Prc(P) check_ref14(P, __func__, __LINE__) /* any procedure (3-arg setters) or #f|#t */ - #define T_Prt(P) check_ref3(P, __func__, __LINE__) /* input|output_port */ - #define T_Ptr(P) check_ref(P, T_C_POINTER, __func__, __LINE__, NULL, NULL) - #define T_Ran(P) check_ref(P, T_RANDOM_STATE, __func__, __LINE__, NULL, NULL) - #define T_Rel(P) check_ref(P, T_REAL, __func__, __LINE__, NULL, NULL) - #define T_SVec(P) check_ref13(P, __func__, __LINE__) /* subvector */ - #define T_Seq(P) check_ref8(P, __func__, __LINE__) /* any sequence or structure */ - #define T_Sld(P) check_ref2(P, T_SLOT, T_UNDEFINED,__func__, __LINE__, NULL, NULL) - #define T_Sln(P) check_ref12(P, __func__, __LINE__) /* slot or nil */ - #define T_Slt(P) check_ref(P, T_SLOT, __func__, __LINE__, NULL, NULL) - #define T_Stk(P) check_ref(P, T_STACK, __func__, __LINE__, NULL, NULL) - #define T_Str(P) check_ref(P, T_STRING, __func__, __LINE__, "sweep", NULL) - #define T_Sym(P) check_ref(P, T_SYMBOL, __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table") - #define T_Syn(P) check_ref(P, T_SYNTAX, __func__, __LINE__, NULL, NULL) - #define T_Undf(P) check_ref(P, T_UNDEFINED, __func__, __LINE__, "sweep", NULL) - #define T_Vec(P) check_ref4(P, __func__, __LINE__) /* any vector */ -#else - /* if not debugging, all those checks go away */ - #define T_App(P) P - #define T_Arg(P) P - #define T_BVc(P) P - #define T_Bgf(P) P - #define T_Bgi(P) P - #define T_Bgr(P) P - #define T_Bgz(P) P - #define T_CMac(P) P - #define T_Cat(P) P - #define T_Chr(P) P - #define T_Clo(P) P - #define T_Cmp(P) P - #define T_Con(P) P - #define T_Ctr(P) P - #define T_Dyn(P) P - #define T_Eof(P) P - #define T_Ext(P) P - #define T_Fnc(P) P - #define T_Frc(P) P - #define T_Fst(P) P - #define T_Fvc(P) P - #define T_Got(P) P - #define T_Hsh(P) P - #define T_Int(P) P - #define T_Itr(P) P - #define T_Ivc(P) P - #define T_Key(P) P - #define T_Let(P) P - #define T_Lid(P) P - #define T_Lst(P) P - #define T_Mac(P) P - #define T_Met(P) P - #define T_Nmv(P) P - #define T_Num(P) P - #define T_Nvc(P) P - #define T_Obj(P) P - #define T_Pair(P) P - #define T_Pcs(P) P - #define T_Pos(P) P - #define T_Prc(P) P - #define T_Prt(P) P - #define T_Ptr(P) P - #define T_Ran(P) P - #define T_Rel(P) P - #define T_SVec(P) P - #define T_Seq(P) P - #define T_Sld(P) P - #define T_Sln(P) P - #define T_Slt(P) P - #define T_Stk(P) P - #define T_Str(P) P - #define T_Sym(P) P - #define T_Syn(P) P - #define T_Undf(P) P - #define T_Vec(P) P - - #define unchecked_type(p) ((p)->tf.type_field) - #define type(p) ((p)->tf.type_field) - #define set_full_type(p, f) full_type(p) = f -#endif -#define signed_type(p) (p)->tf.signed_flag - -#define is_number(P) t_number_p[type(P)] -#define is_small_real(P) t_small_real_p[type(P)] -#define is_real(P) t_real_p[type(P)] -#define is_rational(P) t_rational_p[type(P)] -#define is_big_number(p) t_big_number_p[type(p)] -#define is_t_integer(p) (type(p) == T_INTEGER) -#define is_t_ratio(p) (type(p) == T_RATIO) -#define is_t_real(p) (type(p) == T_REAL) -#define is_t_complex(p) (type(p) == T_COMPLEX) -#define is_t_big_integer(p) (type(p) == T_BIG_INTEGER) -#define is_t_big_ratio(p) (type(p) == T_BIG_RATIO) -#define is_t_big_real(p) (type(p) == T_BIG_REAL) -#define is_t_big_complex(p) (type(p) == T_BIG_COMPLEX) - -#define is_boolean(p) (type(p) == T_BOOLEAN) - -#define is_free(p) (type(p) == T_FREE) -#define is_free_and_clear(p) (full_type(p) == T_FREE) -#define is_simple(P) t_simple_p[type(P)] /* eq? */ -#define has_structure(P) ((t_structure_p[type(P)]) && ((!is_normal_vector(P)) || (!has_simple_elements(P)))) - -#define is_any_macro(P) t_any_macro_p[type(P)] -#define is_any_closure(P) t_any_closure_p[type(P)] -#define is_any_procedure(P) (type(P) >= T_CLOSURE) -#define has_closure_let(P) t_has_closure_let[type(P)] - -#define is_simple_sequence(P) (t_sequence_p[type(P)]) -#define is_sequence(P) ((t_sequence_p[type(P)]) || (has_methods(P))) -#define is_mutable_sequence(P) (((t_sequence_p[type(P)]) || (has_methods(P))) && (!is_immutable(P))) -#define is_mappable(P) (t_mappable_p[type(P)]) -#define is_applicable(P) (t_applicable_p[type(P)]) -/* this misses #() which is not applicable to anything, and "", and inapplicable c-objects like random-state */ -#define is_procedure(p) ((t_procedure_p[type(p)]) || ((is_c_object(p)) && (is_safe_procedure(p)))) -#define is_t_procedure(p) (t_procedure_p[type(p)]) - -/* the layout of these bits does matter in several cases -- don't shadow SYNTACTIC_PAIR and OPTIMIZED_PAIR */ -#define TYPE_BITS 8 - -#define set_type_bit(p, b) full_type(p) |= (b) -#define clear_type_bit(p, b) full_type(p) &= (~(b)) -#define has_type_bit(p, b) ((full_type(p) & (b)) != 0) - -#define set_type0_bit(p, b) typesflag(p) |= (b) /* I don't think these type0's matter -- *_type_bit is the same speed */ -#define clear_type0_bit(p, b) typesflag(p) &= (~(b)) -#define has_type0_bit(p, b) ((typesflag(p) & (b)) != 0) - -#define set_type1_bit(p, b) (p)->tf.opts.high_flag |= (b) -#define clear_type1_bit(p, b) (p)->tf.opts.high_flag &= (~(b)) -#define has_type1_bit(p, b) (((p)->tf.opts.high_flag & (b)) != 0) - -#define T_SYNTACTIC (1 << (TYPE_BITS + 1)) -#define is_symbol_and_syntactic(p) (typesflag(T_Ext(p)) == (uint16_t)(T_SYMBOL | T_SYNTACTIC)) -#define is_syntactic_symbol(p) has_type0_bit(T_Sym(p), T_SYNTACTIC) -#define is_syntactic_pair(p) has_type0_bit(T_Pair(p), T_SYNTACTIC) -#define clear_syntactic(p) clear_type0_bit(T_Pair(p), T_SYNTACTIC) -#define set_syntactic_pair(p) full_type(T_Pair(p)) = (T_PAIR | T_SYNTACTIC | (full_type(p) & (0xffffffffffff0000 & ~T_OPTIMIZED))) /* used only in pair_set_syntax_op */ -/* this marks symbols that represent syntax objects, it should be in the second byte */ - -#define T_SIMPLE_ARG_DEFAULTS (1 << (TYPE_BITS + 2)) -#define lambda_has_simple_defaults(p) has_type0_bit(T_Pair(closure_body(p)), T_SIMPLE_ARG_DEFAULTS) -#define lambda_set_simple_defaults(p) set_type0_bit(T_Pair(p), T_SIMPLE_ARG_DEFAULTS) -/* are all lambda* default values simple? This is set on closure_body, so it doesn't mess up closure_is_ok_1 */ - -#define T_LIST_IN_USE T_SIMPLE_ARG_DEFAULTS -#define list_is_in_use(p) has_type0_bit(T_Pair(p), T_LIST_IN_USE) -#define set_list_in_use(p) set_type0_bit(T_Pair(p), T_LIST_IN_USE) -#define clear_list_in_use(p) do {clear_type0_bit(T_Pair(p), T_LIST_IN_USE); sc->current_safe_list = 0;} while (0) -/* since the safe lists are not in the heap, if the list_in_use bit is off, the list won't be GC-protected even if - * it is gc_marked explicitly. This happens, for example, in copy_proper_list where we try to protect the original list - * by sc->temp5 = lst; then in the GC, gc_mark(sc->temp5); but the safe_list probably is already marked, so its contents are not protected. - */ - -#define T_ONE_FORM T_SIMPLE_ARG_DEFAULTS -#define set_closure_has_one_form(p) set_type0_bit(T_Clo(p), T_ONE_FORM) -#define T_MULTIFORM (1 << (TYPE_BITS + 0)) -#define set_closure_has_multiform(p) set_type0_bit(T_Clo(p), T_MULTIFORM) -#define T_ONE_FORM_FX_ARG (T_ONE_FORM | T_MULTIFORM) -#define set_closure_one_form_fx_arg(p) set_type0_bit(T_Clo(p), T_ONE_FORM_FX_ARG) -/* can't use T_HAS_FX here because closure_is_ok wants to examine typesflag */ - -#define T_OPTIMIZED (1 << (TYPE_BITS + 3)) -#define set_optimized(p) set_type0_bit(T_Pair(p), T_OPTIMIZED) -#define clear_optimized(p) clear_type0_bit(T_Pair(p), T_OPTIMIZED | T_SYNTACTIC | T_HAS_FX | T_HAS_FN) -#define is_optimized(p) (typesflag(T_Ext(p)) == (uint16_t)(T_PAIR | T_OPTIMIZED)) -/* optimizer flag for an expression that has optimization info, it should be in the second byte */ - -#define T_SCOPE_SAFE T_OPTIMIZED -#define is_scope_safe(p) has_type0_bit(T_Fnc(p), T_SCOPE_SAFE) -#define set_scope_safe(p) set_type0_bit(T_Fnc(p), T_SCOPE_SAFE) - -#define T_SAFE_CLOSURE (1 << (TYPE_BITS + 4)) -#define is_safe_closure(p) has_type0_bit(T_Clo(p), T_SAFE_CLOSURE) -#define set_safe_closure(p) set_type0_bit(T_Clo(p), T_SAFE_CLOSURE) -#define is_safe_closure_body(p) has_type0_bit(T_Pair(p), T_SAFE_CLOSURE) -#define set_safe_closure_body(p) set_type0_bit(T_Pair(p), T_SAFE_CLOSURE) -#define clear_safe_closure_body(p) clear_type0_bit(T_Pair(p), T_SAFE_CLOSURE) - -/* optimizer flag for a closure body that is completely simple (every expression is safe) - * set_safe_closure happens in define_funchcecked letrec_setup_closures etc, clear only in procedure_source, bits only here - * this has to be separate from T_SAFE_PROCEDURE, and should be in the second byte (closure_is_ok_1 checks typesflag). - * define -> optimize_lambda sets safe -> define_funchecked -> make_funclet for the let - * similarly, named let -> optimize_lambda, then let creates the let if safe - * thereafter, optimizer uses OP_SAFE_CLOSURE* which calls update_let* - */ - -#define T_DONT_EVAL_ARGS (1 << (TYPE_BITS + 5)) -#define dont_eval_args(p) has_type0_bit(T_Ext(p), T_DONT_EVAL_ARGS) -/* this marks things that don't evaluate their arguments */ - -#define T_EXPANSION (1 << (TYPE_BITS + 6)) -#define is_expansion(p) has_type0_bit(T_Pos(p), T_EXPANSION) -#define clear_expansion(p) clear_type0_bit(T_Sym(p), T_EXPANSION) -/* this marks the symbol and its run-time macro value, distinguishing it from an ordinary macro */ - -#define T_MULTIPLE_VALUE (1 << (TYPE_BITS + 7)) -#define is_multiple_value(p) has_type0_bit(T_Pos(p), T_MULTIPLE_VALUE) /* not T_Ext -- can be a slot */ -#if S7_DEBUGGING -#define set_multiple_value(p) do {if (!in_heap(p)) {fprintf(stderr, "%s[%d]: mv\n", __func__, __LINE__); abort();} set_type0_bit(T_Pair(p), T_MULTIPLE_VALUE);} while (0) -#else -#define set_multiple_value(p) set_type0_bit(T_Pair(p), T_MULTIPLE_VALUE) -#endif -#define clear_multiple_value(p) clear_type0_bit(T_Pair(p), T_MULTIPLE_VALUE) -#define multiple_value(p) p -/* this bit marks a list (from "values") that is waiting for a chance to be spliced into its caller's argument list */ - -#define T_MATCHED T_MULTIPLE_VALUE -#define is_matched_pair(p) has_type0_bit(T_Pair(p), T_MATCHED) -#define clear_match_pair(p) clear_type0_bit(T_Pair(p), T_MATCHED) -#define set_match_pair(p) set_type0_bit(T_Pair(p), T_MATCHED) -#define set_match_symbol(p) set_type0_bit(T_Sym(p), T_MATCHED) -#define is_matched_symbol(p) has_type0_bit(T_Sym(p), T_MATCHED) -#define clear_match_symbol(p) clear_type0_bit(T_Sym(p), T_MATCHED) - -#define T_GLOBAL (1 << (TYPE_BITS + 8)) -#define T_LOCAL (1 << (TYPE_BITS + 12)) -#define is_global(p) has_type_bit(T_Sym(p), T_GLOBAL) -#define set_global(p) do {if ((full_type(T_Sym(p)) & T_LOCAL) == 0) full_type(p) |= T_GLOBAL;} while (0) -/* T_LOCAL marks a symbol that has been used locally */ -/* T_GLOBAL marks something defined (bound) at the top-level, and never defined locally */ - -#define REPORT_ROOTLET_REDEF 0 -#if REPORT_ROOTLET_REDEF - /* to find who is stomping on our symbols: */ - static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line); - #define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__) -#else - #define set_local(p) full_type(T_Sym(p)) = ((full_type(p) | T_LOCAL) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC)) -#endif - -#define T_LOW_COUNT T_LOCAL -#define has_low_count(p) has_type_bit(T_Pair(p), T_LOW_COUNT) -#define set_has_low_count(p) set_type_bit(T_Pair(p), T_LOW_COUNT) - -#define T_TC T_LOCAL -#define has_tc(p) has_type_bit(T_Pair(p), T_TC) -#define set_has_tc(p) set_type_bit(T_Pair(p), T_TC) - -#define T_UNSAFE_DO T_GLOBAL -#define is_unsafe_do(p) has_type_bit(T_Pair(p), T_UNSAFE_DO) -#define set_unsafe_do(p) set_type_bit(T_Pair(p), T_UNSAFE_DO) -/* marks do-loops that resist optimization */ - -#define T_DOX_SLOT1 T_GLOBAL -#define has_dox_slot1(p) has_type_bit(T_Let(p), T_DOX_SLOT1) -#define set_has_dox_slot1(p) set_type_bit(T_Let(p), T_DOX_SLOT1) -/* marks a let that includes the dox_slot1 */ - -#define T_COLLECTED (1 << (TYPE_BITS + 9)) -#define is_collected(p) has_type_bit(T_Seq(p), T_COLLECTED) -#define is_collected_unchecked(p) has_type_bit(p, T_COLLECTED) -#define set_collected(p) set_type_bit(T_Seq(p), T_COLLECTED) -/* #define clear_collected(p) clear_type_bit(T_Seq(p), T_COLLECTED) */ -/* this is a transient flag used by the printer to catch cycles. It affects only objects that have structure. - * We can't use a low bit (bit 7 for example), because collect_shared_info inspects the object's type. - */ - -#define T_LOCATION (1 << (TYPE_BITS + 10)) -#define has_location(p) has_type_bit(T_Pair(p), T_LOCATION) -#define set_has_location(p) set_type_bit(T_Pair(p), T_LOCATION) -/* pair in question has line/file/position info added during read, or the environment has function placement info - * this bit should not be in the first byte -- SYNTACTIC_PAIR ignores it. - */ - -#define T_LOADER_PORT T_LOCATION -#define is_loader_port(p) has_type_bit(T_Prt(p), T_LOADER_PORT) -#define set_loader_port(p) set_type_bit(T_Prt(p), T_LOADER_PORT) -#define clear_loader_port(p) clear_type_bit(T_Prt(p), T_LOADER_PORT) -/* this bit marks a port used by the loader so that random load-time reads do not screw up the load process */ - -#define T_HAS_SETTER T_LOCATION -#define slot_has_setter(p) has_type_bit(T_Slt(p), T_HAS_SETTER) -#define slot_set_has_setter(p) set_type_bit(T_Slt(p), T_HAS_SETTER) -/* marks a slot that has a setter or symbol that might have a setter */ - -#define T_WITH_LET_LET T_LOCATION -#define is_with_let_let(p) has_type_bit(T_Let(p), T_WITH_LET_LET) -#define set_with_let_let(p) set_type_bit(T_Let(p), T_WITH_LET_LET) -/* marks a let that is the argument to with-let */ - -#define T_SIMPLE_DEFAULTS T_LOCATION -#define c_func_has_simple_defaults(p) has_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) -#define c_func_set_simple_defaults(p) set_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) -#define c_func_clear_simple_defaults(p) clear_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS) -/* flag c_func_star arg defaults that need GC protection */ - -#define T_NO_SETTER T_LOCATION -#define closure_no_setter(p) has_type_bit(T_Clo(p), T_NO_SETTER) -#define closure_set_no_setter(p) set_type_bit(T_Clo(p), T_NO_SETTER) - -#define T_SHARED (1 << (TYPE_BITS + 11)) -#define is_shared(p) has_type_bit(T_Seq(p), T_SHARED) -#define set_shared(p) set_type_bit(T_Seq(p), T_SHARED) -#define is_collected_or_shared(p) has_type_bit(p, T_COLLECTED | T_SHARED) -#define clear_collected_and_shared(p) clear_type_bit(p, T_COLLECTED | T_SHARED) /* this can clear free cells = calloc */ -/* T_LOCAL is bit 12 */ - -#define T_SAFE_PROCEDURE (1 << (TYPE_BITS + 13)) -#define is_safe_procedure(p) has_type_bit(T_App(p), T_SAFE_PROCEDURE) /* was T_Pos 19-Apr-21 */ -#define is_safe_or_scope_safe_procedure(p) ((full_type(T_Fnc(p)) & (T_SCOPE_SAFE | T_SAFE_PROCEDURE)) != 0) -/* applicable objects that do not return or modify their arg list directly (no :rest arg in particular), - * and that can't call themselves either directly or via s7_call, and that don't mess with the stack. - */ - -#define T_CHECKED (1 << (TYPE_BITS + 14)) -#define set_checked(p) set_type_bit(T_Pair(p), T_CHECKED) -#define is_checked(p) has_type_bit(T_Pair(p), T_CHECKED) -#define clear_checked(p) clear_type_bit(T_Pair(p), T_CHECKED) -#define set_checked_slot(p) set_type_bit(T_Slt(p), T_CHECKED) -#define is_checked_slot(p) has_type_bit(T_Slt(p), T_CHECKED) -#define clear_checked_slot(p) clear_type_bit(T_Slt(p), T_CHECKED) - -#define T_ALL_INTEGER T_CHECKED -#define is_all_integer(p) has_type_bit(T_Sym(p), T_ALL_INTEGER) -#define set_all_integer(p) set_type_bit(T_Sym(p), T_ALL_INTEGER) - -#define T_UNSAFE (1 << (TYPE_BITS + 15)) -#define set_unsafe(p) set_type_bit(T_Pair(p), T_UNSAFE) -#define set_unsafely_optimized(p) full_type(T_Pair(p)) = (full_type(p) | T_UNSAFE | T_OPTIMIZED) -#define is_unsafe(p) has_type_bit(T_Pair(p), T_UNSAFE) -#define clear_unsafe(p) clear_type_bit(T_Pair(p), T_UNSAFE) -#define is_safely_optimized(p) ((full_type(T_Pair(p)) & (T_OPTIMIZED | T_UNSAFE)) == T_OPTIMIZED) /* was T_Pos 30-Jan-21 */ -/* optimizer flag saying "this expression is not completely self-contained. It might involve the stack, etc" */ - -#define T_CLEAN_SYMBOL T_UNSAFE -#define is_clean_symbol(p) has_type_bit(T_Sym(p), T_CLEAN_SYMBOL) -#define set_clean_symbol(p) set_type_bit(T_Sym(p), T_CLEAN_SYMBOL) -/* set if we know the symbol name can be printed without quotes (slashification) */ - -#define T_HAS_STEPPER T_UNSAFE -#define has_stepper(p) has_type_bit(T_Slt(p), T_HAS_STEPPER) -#define set_has_stepper(p) set_type_bit(T_Slt(p), T_HAS_STEPPER) - -#define T_DOX_SLOT2 T_UNSAFE -#define has_dox_slot2(p) has_type_bit(T_Let(p), T_DOX_SLOT2) -#define set_has_dox_slot2(p) set_type_bit(T_Let(p), T_DOX_SLOT2) -/* marks a let that includes the dox_slot2 */ - -#define T_IMMUTABLE (1 << (TYPE_BITS + 16)) -#define is_immutable(p) has_type_bit(T_Pos(p), T_IMMUTABLE) -#define set_immutable(p) set_type_bit(T_Pos(p), T_IMMUTABLE) -#define set_immutable_let(p) set_type_bit(T_Lid(p), T_IMMUTABLE) -#define set_immutable_slot(p) set_type_bit(T_Slt(p), T_IMMUTABLE) -#define is_immutable_port(p) has_type_bit(T_Prt(p), T_IMMUTABLE) -#define is_immutable_symbol(p) has_type_bit(T_Sym(p), T_IMMUTABLE) -#define is_immutable_slot(p) has_type_bit(T_Slt(p), T_IMMUTABLE) -#define is_immutable_pair(p) has_type_bit(T_Pair(p), T_IMMUTABLE) -#define is_immutable_vector(p) has_type_bit(T_Vec(p), T_IMMUTABLE) -#define is_immutable_string(p) has_type_bit(T_Str(p), T_IMMUTABLE) -/* T_IMMUTABLE is compatible with T_MUTABLE -- the latter is an internal bit for locally mutable numbers */ - -#define T_SETTER (1 << (TYPE_BITS + 17)) -#define set_is_setter(p) set_type_bit(T_Sym(p), T_SETTER) -#define is_setter(p) has_type_bit(T_Sym(p), T_SETTER) -/* optimizer flag for a procedure that sets some variable (set-car! for example) */ - -#define T_ALLOW_OTHER_KEYS T_SETTER -#define set_allow_other_keys(p) set_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS) -#define allows_other_keys(p) has_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS) -#define c_function_set_allow_other_keys(p) set_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS) -#define c_function_allows_other_keys(p) has_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS) -/* marks arglist (or c_function*) that allows keyword args other than those in the parameter list; - * we can't allow (define* (f :allow-other-keys)...) because there's only one nil, and besides, it does say "other". - */ - -#define T_LET_REMOVED T_SETTER -#define let_set_removed(p) set_type_bit(T_Let(p), T_LET_REMOVED) -#define let_removed(p) has_type_bit(T_Let(p), T_LET_REMOVED) -/* mark lets that have been removed from the heap or checked for that possibility */ - -#define T_HAS_EXPRESSION T_SETTER -#define slot_set_has_expression(p) set_type_bit(T_Slt(p), T_HAS_EXPRESSION) -#define slot_has_expression(p) has_type_bit(T_Slt(p), T_HAS_EXPRESSION) - -#define T_MUTABLE (1 << (TYPE_BITS + 18)) -#define is_mutable_number(p) has_type_bit(T_Num(p), T_MUTABLE) -#define is_mutable_integer(p) has_type_bit(T_Int(p), T_MUTABLE) -#define clear_mutable_number(p) clear_type_bit(T_Num(p), T_MUTABLE) -#define clear_mutable_integer(p) clear_type_bit(T_Int(p), T_MUTABLE) -/* used for mutable numbers, can occur with T_IMMUTABLE (outside view vs inside) */ - -#define T_HAS_KEYWORD T_MUTABLE -#define has_keyword(p) has_type_bit(T_Sym(p), T_HAS_KEYWORD) -#define set_has_keyword(p) set_type_bit(T_Sym(p), T_HAS_KEYWORD) - -#define T_MARK_SEQ T_MUTABLE -#define is_mark_seq(p) has_type_bit(T_Itr(p), T_MARK_SEQ) -#define set_mark_seq(p) set_type_bit(T_Itr(p), T_MARK_SEQ) -/* used in iterators for GC mark of sequence */ - -#define T_STEP_END T_MUTABLE -#define is_step_end(p) has_type_bit(T_Slt(p), T_STEP_END) -#define step_end_fits(Slot, Len) ((is_step_end(Slot)) && (denominator(slot_value(Slot)) <= Len)) -#define set_step_end(p) set_type_bit(T_Slt(p), T_STEP_END) -/* marks a slot that holds a do-loop's step-or-end variable, numerator=current, denominator=end */ - -#define T_NO_CELL_OPT T_MUTABLE -#define set_no_cell_opt(p) set_type_bit(T_Pair(p), T_NO_CELL_OPT) -#define no_cell_opt(p) has_type_bit(T_Pair(p), T_NO_CELL_OPT) - -#define T_IS_ELIST T_MUTABLE -#define set_is_elist(p) set_type_bit(T_Lst(p), T_IS_ELIST) -#define is_elist(p) has_type_bit(T_Lst(p), T_IS_ELIST) - -#define T_NO_INT_OPT T_SETTER -#define set_no_int_opt(p) set_type_bit(T_Pair(p), T_NO_INT_OPT) -#define no_int_opt(p) has_type_bit(T_Pair(p), T_NO_INT_OPT) - -#define T_NO_FLOAT_OPT T_UNSAFE -#define set_no_float_opt(p) set_type_bit(T_Pair(p), T_NO_FLOAT_OPT) -#define no_float_opt(p) has_type_bit(T_Pair(p), T_NO_FLOAT_OPT) - -#define T_NO_BOOL_OPT T_SAFE_STEPPER -#define set_no_bool_opt(p) set_type_bit(T_Pair(p), T_NO_BOOL_OPT) -#define no_bool_opt(p) has_type_bit(T_Pair(p), T_NO_BOOL_OPT) - -#define T_INTEGER_KEYS T_SETTER -#define set_has_integer_keys(p) set_type_bit(T_Pair(p), T_INTEGER_KEYS) -#define has_integer_keys(p) has_type_bit(T_Pair(p), T_INTEGER_KEYS) - -#define T_SAFE_STEPPER (1 << (TYPE_BITS + 19)) -#define is_safe_stepper(p) has_type_bit(T_Slt(p), T_SAFE_STEPPER) -#define set_safe_stepper(p) set_type_bit(T_Slt(p), T_SAFE_STEPPER) -#define clear_safe_stepper(p) clear_type_bit(T_Slt(p), T_SAFE_STEPPER) -#define is_safe_stepper_expr(p) has_type_bit(T_Pair(p), T_SAFE_STEPPER) -#define set_safe_stepper_expr(p) set_type_bit(T_Pair(p), T_SAFE_STEPPER) - -#define T_NUMBER_NAME T_SAFE_STEPPER -#define has_number_name(p) has_type_bit(T_Num(p), T_NUMBER_NAME) -#define set_has_number_name(p) set_type_bit(T_Num(p), T_NUMBER_NAME) -/* marks numbers that have a saved version of their string representation; this only matters in teq.scm, maybe tread.scm */ - -#define T_MAYBE_SAFE T_SAFE_STEPPER -#define is_maybe_safe(p) has_type_bit(T_Fnc(p), T_MAYBE_SAFE) -#define set_maybe_safe(p) set_type_bit(T_Fnc(p), T_MAYBE_SAFE) - -#define T_PAIR_MACRO T_SAFE_STEPPER -#define has_pair_macro(p) has_type_bit(T_Mac(p), T_PAIR_MACRO) -#define set_has_pair_macro(p) set_type_bit(T_Mac(p), T_PAIR_MACRO) - -#define T_HAS_LET_SET_FALLBACK T_SAFE_STEPPER -#define T_HAS_LET_REF_FALLBACK T_MUTABLE -#define has_let_ref_fallback(p) ((full_type(T_Lid(p)) & (T_HAS_LET_REF_FALLBACK | T_HAS_METHODS)) == (T_HAS_LET_REF_FALLBACK | T_HAS_METHODS)) -#define has_let_set_fallback(p) ((full_type(T_Lid(p)) & (T_HAS_LET_SET_FALLBACK | T_HAS_METHODS)) == (T_HAS_LET_SET_FALLBACK | T_HAS_METHODS)) -#define set_has_let_ref_fallback(p) set_type_bit(T_Let(p), T_HAS_LET_REF_FALLBACK) -#define set_has_let_set_fallback(p) set_type_bit(T_Let(p), T_HAS_LET_SET_FALLBACK) -#define has_let_fallback(p) has_type_bit(T_Lid(p), (T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK)) -#define set_all_methods(p, e) full_type(T_Let(p)) |= (full_type(e) & (T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK)) - -#define T_WEAK_HASH T_SAFE_STEPPER -#define set_weak_hash_table(p) set_type_bit(T_Hsh(p), T_WEAK_HASH) -#define is_weak_hash_table(p) has_type_bit(T_Hsh(p), T_WEAK_HASH) - -#define T_ALL_FLOAT T_SAFE_STEPPER -#define is_all_float(p) has_type_bit(T_Sym(p), T_ALL_FLOAT) -#define set_all_float(p) set_type_bit(T_Sym(p), T_ALL_FLOAT) -#define set_all_integer_and_float(p) set_type_bit(T_Sym(p), (T_ALL_INTEGER | T_ALL_FLOAT)) - -#define T_COPY_ARGS (1 << (TYPE_BITS + 20)) -#define needs_copied_args(p) has_type_bit(T_Ext(p), T_COPY_ARGS) /* set via explicit T_COPY_ARGS, on T_Pos see s7_apply_function */ -#define set_needs_copied_args(p) set_type_bit(T_Pair(p), T_COPY_ARGS) -#define clear_needs_copied_args(p) clear_type_bit(T_Pair(p), T_COPY_ARGS) -/* this marks something that might mess with its argument list, it should not be in the second byte */ - -#define T_GENSYM (1 << (TYPE_BITS + 21)) -#define is_gensym(p) has_type_bit(T_Sym(p), T_GENSYM) -/* symbol is from gensym (GC-able etc) */ - -#define T_FUNCLET T_GENSYM -#define is_funclet(p) has_type_bit(T_Let(p), T_FUNCLET) -#define set_funclet(p) set_type_bit(T_Let(p), T_FUNCLET) -/* this marks a funclet */ - -#define T_HASH_CHOSEN T_GENSYM -#define hash_chosen(p) has_type_bit(T_Hsh(p), T_HASH_CHOSEN) -#define hash_set_chosen(p) set_type_bit(T_Hsh(p), T_HASH_CHOSEN) -#define hash_clear_chosen(p) clear_type_bit(T_Hsh(p), T_HASH_CHOSEN) - -#define T_DOCUMENTED T_GENSYM -#define is_documented(p) has_type_bit(T_Str(p), T_DOCUMENTED) -#define set_documented(p) set_type_bit(T_Str(p), T_DOCUMENTED) -/* this marks a symbol that has documentation (bit is set on name cell) */ - -#define T_FX_TREED T_GENSYM -#define is_fx_treed(p) has_type_bit(T_Pair(p), T_FX_TREED) -#define set_fx_treed(p) set_type_bit(T_Pair(p), T_FX_TREED) - -#define T_SUBVECTOR T_GENSYM -#define is_subvector(p) has_type_bit(T_Vec(p), T_SUBVECTOR) - -#define T_HAS_PENDING_VALUE T_GENSYM -#define slot_set_has_pending_value(p) set_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) -#define slot_has_pending_value(p) has_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) -#define slot_clear_has_pending_value(p) clear_type_bit(T_Slt(p), T_HAS_PENDING_VALUE) - -#define T_HAS_METHODS (1 << (TYPE_BITS + 22)) -#define has_methods(p) has_type_bit(T_Pos(p), T_HAS_METHODS) /* display slot hits T_Ext here */ -#define is_openlet(p) has_type_bit(T_Let(p), T_HAS_METHODS) -#define has_active_methods(sc, p) ((has_type_bit(T_Ext(p), T_HAS_METHODS)) && (sc->has_openlets)) /* g_char # */ -#define set_has_methods(p) set_type_bit(T_Met(p), T_HAS_METHODS) -#define clear_has_methods(p) clear_type_bit(T_Met(p), T_HAS_METHODS) -/* this marks an environment or closure that is "open" for generic functions etc, don't reuse this bit */ - -#define T_ITER_OK (1LL << (TYPE_BITS + 23)) -#define iter_ok(p) has_type_bit(T_Itr(p), T_ITER_OK) /* was T_Pos 15-Apr-21 */ -#define clear_iter_ok(p) clear_type_bit(T_Itr(p), T_ITER_OK) - -#define T_STEP_END_OK T_ITER_OK -#define step_end_ok(p) has_type_bit(T_Pair(p), T_STEP_END_OK) -#define set_step_end_ok(p) set_type_bit(T_Pair(p), T_STEP_END_OK) - -#define T_IN_ROOTLET T_ITER_OK -#define in_rootlet(p) has_type_bit(T_Slt(p), T_IN_ROOTLET) -#define set_in_rootlet(p) set_type_bit(T_Slt(p), T_IN_ROOTLET) - -#define T_BOOL_FUNCTION T_ITER_OK -#define is_bool_function(p) has_type_bit(T_Prc(p), T_BOOL_FUNCTION) -#define set_is_bool_function(p) set_type_bit(T_Fnc(p), T_BOOL_FUNCTION) - -#define T_SYMBOL_FROM_SYMBOL T_ITER_OK -#define is_symbol_from_symbol(p) has_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) -#define set_is_symbol_from_symbol(p) set_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) -#define clear_symbol_from_symbol(p) clear_type1_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) - -/* it's faster here to use the high_flag bits rather than typeflag bits */ -#define BIT_ROOM 16 -#define T_FULL_SYMCONS (1LL << (TYPE_BITS + BIT_ROOM + 24)) -#define T_SYMCONS (1 << 0) -#define is_possibly_constant(p) has_type1_bit(T_Sym(p), T_SYMCONS) -#define set_possibly_constant(p) set_type1_bit(T_Sym(p), T_SYMCONS) -#define is_probably_constant(p) has_type_bit(T_Sym(p), (T_FULL_SYMCONS | T_IMMUTABLE)) - -#define T_HAS_LET_ARG T_SYMCONS -#define has_let_arg(p) has_type1_bit(T_Prc(p), T_HAS_LET_ARG) -#define set_has_let_arg(p) set_type1_bit(T_Prc(p), T_HAS_LET_ARG) -/* p is a setter procedure, "let arg" refers to the setter's optional third (let) argument */ - -#define T_HASH_VALUE_TYPE T_SYMCONS -#define has_hash_value_type(p) has_type1_bit(T_Hsh(p), T_HASH_VALUE_TYPE) -#define set_has_hash_value_type(p) set_type1_bit(T_Hsh(p), T_HASH_VALUE_TYPE) - -#define T_INT_OPTABLE T_SYMCONS -#define is_int_optable(p) has_type1_bit(T_Pair(p), T_INT_OPTABLE) -#define set_is_int_optable(p) set_type1_bit(T_Pair(p), T_INT_OPTABLE) - -/* symbol free here */ -#define T_FULL_HAS_LET_FILE (1LL << (TYPE_BITS + BIT_ROOM + 25)) -#define T_HAS_LET_FILE (1 << 1) -#define has_let_file(p) has_type1_bit(T_Let(p), T_HAS_LET_FILE) -#define set_has_let_file(p) set_type1_bit(T_Let(p), T_HAS_LET_FILE) -#define clear_has_let_file(p) clear_type1_bit(T_Let(p), T_HAS_LET_FILE) - -#define T_TYPED_VECTOR T_HAS_LET_FILE -#define is_typed_vector(p) has_type1_bit(T_Vec(p), T_TYPED_VECTOR) -#define set_typed_vector(p) set_type1_bit(T_Vec(p), T_TYPED_VECTOR) -#define clear_typed_vector(p) clear_type1_bit(T_Vec(p), T_TYPED_VECTOR) - -#define T_TYPED_HASH_TABLE T_HAS_LET_FILE -#define is_typed_hash_table(p) has_type1_bit(T_Hsh(p), T_TYPED_HASH_TABLE) -#define set_is_typed_hash_table(p) set_type1_bit(T_Hsh(p), T_TYPED_HASH_TABLE) - -#define T_BOOL_SETTER T_HAS_LET_FILE -#define c_function_has_bool_setter(p) has_type1_bit(T_Fnc(p), T_BOOL_SETTER) -#define c_function_set_has_bool_setter(p) set_type1_bit(T_Fnc(p), T_BOOL_SETTER) - -#define T_REST_SLOT T_HAS_LET_FILE -#define is_rest_slot(p) has_type1_bit(T_Slt(p), T_REST_SLOT) -#define set_is_rest_slot(p) set_type1_bit(T_Slt(p), T_REST_SLOT) - -#define T_NO_DEFAULTS T_HAS_LET_FILE -#define T_FULL_NO_DEFAULTS T_FULL_HAS_LET_FILE -#define has_no_defaults(p) has_type1_bit(T_Pcs(p), T_NO_DEFAULTS) -#define set_has_no_defaults(p) set_type1_bit(T_Pcs(p), T_NO_DEFAULTS) -/* pair=closure* body, transferred to closure* */ - -#define T_FULL_DEFINER (1LL << (TYPE_BITS + BIT_ROOM + 26)) -#define T_DEFINER (1 << 2) -#define is_definer(p) has_type1_bit(T_Sym(p), T_DEFINER) -#define set_is_definer(p) set_type1_bit(T_Sym(p), T_DEFINER) -#define is_func_definer(p) has_type1_bit(T_Fnc(p), T_DEFINER) -#define set_func_is_definer(p) do {set_type1_bit(T_Fnc(initial_value(p)), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0) -#define is_syntax_definer(p) has_type1_bit(T_Syn(p), T_DEFINER) -#define set_syntax_is_definer(p) do {set_type1_bit(T_Syn(initial_value(p)), T_DEFINER); set_type1_bit(T_Sym(p), T_DEFINER);} while (0) -/* this marks "definers" like define and define-macro */ - -#define T_MACLET T_DEFINER -#define is_maclet(p) has_type1_bit(T_Let(p), T_MACLET) -#define set_maclet(p) set_type1_bit(T_Let(p), T_MACLET) -/* this marks a maclet */ - -#define T_HAS_FX T_DEFINER -#define set_has_fx(p) set_type1_bit(T_Pair(p), T_HAS_FX) -#define has_fx(p) has_type1_bit(T_Pair(p), T_HAS_FX) -#define clear_has_fx(p) clear_type1_bit(T_Pair(p), T_HAS_FX) - -#define T_SLOT_DEFAULTS T_DEFINER -#define slot_defaults(p) has_type1_bit(T_Slt(p), T_SLOT_DEFAULTS) -#define set_slot_defaults(p) set_type1_bit(T_Slt(p), T_SLOT_DEFAULTS) - -#define T_WEAK_HASH_ITERATOR T_DEFINER -#define is_weak_hash_iterator(p) has_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) -#define set_weak_hash_iterator(p) set_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) -#define clear_weak_hash_iterator(p) clear_type1_bit(T_Itr(p), T_WEAK_HASH_ITERATOR) - -#define T_HASH_KEY_TYPE T_DEFINER -#define has_hash_key_type(p) has_type1_bit(T_Hsh(p), T_HASH_KEY_TYPE) -#define set_has_hash_key_type(p) set_type1_bit(T_Hsh(p), T_HASH_KEY_TYPE) - -#define T_FULL_BINDER (1LL << (TYPE_BITS + BIT_ROOM + 27)) -#define T_BINDER (1 << 3) -#define set_syntax_is_binder(p) do {set_type1_bit(T_Syn(initial_value(p)), T_BINDER); set_type1_bit(T_Sym(p), T_BINDER);} while (0) -#define is_definer_or_binder(p) has_type1_bit(T_Sym(p), T_DEFINER | T_BINDER) -/* this marks "binders" like let */ - -#define T_SEMISAFE T_BINDER -#define is_semisafe(p) has_type1_bit(T_Fnc(p), T_SEMISAFE) -#define set_is_semisafe(p) set_type1_bit(T_Fnc(p), T_SEMISAFE) - -/* #define T_TREE_COLLECTED T_FULL_BINDER */ -#define T_SHORT_TREE_COLLECTED T_BINDER -#define tree_is_collected(p) has_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) -#define tree_set_collected(p) set_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) -#define tree_clear_collected(p) clear_type1_bit(T_Pair(p), T_SHORT_TREE_COLLECTED) - -#define T_SIMPLE_VALUES T_BINDER -#define has_simple_values(p) has_type1_bit(T_Hsh(p), T_SIMPLE_VALUES) -#define set_has_simple_values(p) set_type1_bit(T_Hsh(p), T_SIMPLE_VALUES) -#define clear_has_simple_values(p) clear_type1_bit(T_Hsh(p), T_SIMPLE_VALUES) - -#define T_VERY_SAFE_CLOSURE (1LL << (TYPE_BITS + BIT_ROOM + 28)) -#define T_SHORT_VERY_SAFE_CLOSURE (1 << 4) -#define is_very_safe_closure(p) has_type1_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE) -#define set_very_safe_closure(p) set_type1_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE) -#define closure_bits(p) (full_type(T_Pair(p)) & (T_SAFE_CLOSURE | T_VERY_SAFE_CLOSURE | T_FULL_NO_DEFAULTS)) -#define is_very_safe_closure_body(p) has_type1_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE) -#define set_very_safe_closure_body(p) set_type1_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE) - -#define T_BAFFLE_LET T_SHORT_VERY_SAFE_CLOSURE -#define is_baffle_let(p) has_type1_bit(T_Let(p), T_BAFFLE_LET) -#define set_baffle_let(p) set_type1_bit(T_Let(p), T_BAFFLE_LET) - -#define T_CYCLIC (1LL << (TYPE_BITS + BIT_ROOM + 29)) -#define T_SHORT_CYCLIC (1 << 5) -#define is_cyclic(p) has_type1_bit(T_Seq(p), T_SHORT_CYCLIC) -#define set_cyclic(p) set_type1_bit(T_Seq(p), T_SHORT_CYCLIC) - -#define T_CYCLIC_SET (1LL << (TYPE_BITS + BIT_ROOM + 30)) -#define T_SHORT_CYCLIC_SET (1 << 6) -#define is_cyclic_set(p) has_type1_bit(T_Seq(p), T_SHORT_CYCLIC_SET) /* was T_Pos 30-Jan-21 */ -#define set_cyclic_set(p) set_type1_bit(T_Seq(p), T_SHORT_CYCLIC_SET) -#define clear_cyclic_bits(p) clear_type_bit(p, T_COLLECTED | T_SHARED | T_CYCLIC | T_CYCLIC_SET) - -#define T_KEYWORD (1LL << (TYPE_BITS + BIT_ROOM + 31)) -#define T_SHORT_KEYWORD (1 << 7) -#define is_keyword(p) has_type1_bit(T_Sym(p), T_SHORT_KEYWORD) -#define is_symbol_and_keyword(p) ((is_symbol(p)) && (is_keyword(p))) -/* this bit distinguishes a symbol from a symbol that is also a keyword */ - -#define T_FX_TREEABLE T_SHORT_KEYWORD -#define is_fx_treeable(p) has_type1_bit(T_Pair(p), T_FX_TREEABLE) -#define set_is_fx_treeable(p) set_type1_bit(T_Pair(p), T_FX_TREEABLE) - -#define T_FULL_SIMPLE_ELEMENTS (1LL << (TYPE_BITS + BIT_ROOM + 32)) -#define T_SIMPLE_ELEMENTS (1 << 8) -#define has_simple_elements(p) has_type1_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) -#define set_has_simple_elements(p) set_type1_bit(T_Nvc(p), T_SIMPLE_ELEMENTS) -#define c_function_has_simple_elements(p) has_type1_bit(T_Fnc(p), T_SIMPLE_ELEMENTS) -#define c_function_set_has_simple_elements(p) set_type1_bit(T_Fnc(p), T_SIMPLE_ELEMENTS) -/* c_func case here refers to boolean? et al -- structure element type declaration that ensures a simple object */ - -#define T_SIMPLE_KEYS T_SIMPLE_ELEMENTS -#define has_simple_keys(p) has_type1_bit(T_Hsh(p), T_SIMPLE_KEYS) -#define set_has_simple_keys(p) set_type1_bit(T_Hsh(p), T_SIMPLE_KEYS) -#define clear_has_simple_keys(p) clear_type1_bit(T_Hsh(p), T_SIMPLE_KEYS) - -#define T_SAFE_SETTER T_SIMPLE_ELEMENTS -#define is_safe_setter(p) has_type1_bit(T_Sym(p), T_SAFE_SETTER) -#define set_is_safe_setter(p) set_type1_bit(T_Sym(p), T_SAFE_SETTER) - -#define T_FLOAT_OPTABLE T_SIMPLE_ELEMENTS -#define is_float_optable(p) has_type1_bit(T_Pair(p), T_FLOAT_OPTABLE) -#define set_is_float_optable(p) set_type1_bit(T_Pair(p), T_FLOAT_OPTABLE) - -#define T_FULL_CASE_KEY (1LL << (TYPE_BITS + BIT_ROOM + 33)) -#define T_CASE_KEY (1 << 9) -#define is_case_key(p) has_type1_bit(T_Ext(p), T_CASE_KEY) -#define set_case_key(p) set_type1_bit(T_Sym(p), T_CASE_KEY) - -#define T_OPT1_FUNC_LISTED T_CASE_KEY -#define opt1_func_listed(p) has_type1_bit(T_Pair(p), T_OPT1_FUNC_LISTED) -#define set_opt1_func_listed(p) set_type1_bit(T_Pair(p), T_OPT1_FUNC_LISTED) - -#define T_FULL_HAS_GX (1LL << (TYPE_BITS + BIT_ROOM + 34)) -#define T_HAS_GX (1 << 10) -#define has_gx(p) has_type1_bit(T_Pair(p), T_HAS_GX) -#define set_has_gx(p) set_type1_bit(T_Pair(p), T_HAS_GX) - -#define T_FULL_UNKNOPT (1LL << (TYPE_BITS + BIT_ROOM + 35)) -#define T_UNKNOPT (1 << 11) -#define is_unknopt(p) has_type1_bit(T_Pair(p), T_UNKNOPT) -#define set_is_unknopt(p) set_type1_bit(T_Pair(p), T_UNKNOPT) - -#define T_MAC_OK T_UNKNOPT -#define mac_is_ok(p) has_type1_bit(T_Pair(p), T_MAC_OK) -#define set_mac_is_ok(p) set_type1_bit(T_Pair(p), T_MAC_OK) -/* marks a macro (via (macro...)) that has been checked -- easier (and slower) than making 4 or 5 more ops, op_macro_unchecked and so on */ - -#define T_FULL_SAFETY_CHECKED (1LL << (TYPE_BITS + BIT_ROOM + 36)) -#define T_SAFETY_CHECKED (1 << 12) -#define is_safety_checked(p) has_type1_bit(T_Pair(p), T_SAFETY_CHECKED) -#define set_safety_checked(p) do {if (in_heap(p)) set_type1_bit(T_Pair(p), T_SAFETY_CHECKED);} while (0) - -#define T_FULL_HAS_FN (1LL << (TYPE_BITS + BIT_ROOM + 37)) -#define T_HAS_FN (1 << 13) -#define set_has_fn(p) set_type1_bit(T_Pair(p), T_HAS_FN) -#define has_fn(p) has_type1_bit(T_Pair(p), T_HAS_FN) - -#define T_GC_MARK 0x8000000000000000 -#define is_marked(p) has_type_bit(p, T_GC_MARK) -#define set_mark(p) set_type_bit(T_Pos(p), T_GC_MARK) -#define clear_mark(p) clear_type_bit(p, T_GC_MARK) -/* using the sign bit, bit 23 (or 55) == 31 (or 63) for this makes a big difference in the GC */ - -#define T_UNHEAP 0x4000000000000000 -#define T_SHORT_UNHEAP (1 << 14) -#define in_heap(p) (((T_Pos(p))->tf.opts.high_flag & T_SHORT_UNHEAP) == 0) -#define unheap(sc, p) set_type1_bit(T_Pos(p), T_SHORT_UNHEAP) - -#define is_eof(p) ((T_Ext(p)) == eof_object) -#define is_true(Sc, p) ((T_Ext(p)) != Sc->F) -#define is_false(Sc, p) ((T_Ext(p)) == Sc->F) - -#ifdef _MSC_VER - static s7_pointer make_boolean(s7_scheme *sc, bool val) {if (val) return(sc->T); return(sc->F);} -#else - #define make_boolean(sc, Val) ((Val) ? sc->T : sc->F) -#endif - -#define is_pair(p) (type(p) == T_PAIR) -#define is_mutable_pair(p) ((is_pair(p)) && (!is_immutable(p))) /* same speed: ((full_type(T_Pos(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_PAIR) */ -#define is_null(p) ((T_Pos(p)) == sc->nil) /* can be a slot */ -#define is_not_null(p) ((T_Pos(p)) != sc->nil) -#define is_list(p) ((is_pair(p)) || (type(p) == T_NIL)) -#define is_quoted_pair(p) ((is_pair(p)) && (car(p) == sc->quote_symbol)) -#define is_unquoted_pair(p) ((is_pair(p)) && (car(p) != sc->quote_symbol)) -#define is_quoted_symbol(p) ((is_pair(p)) && (car(p) == sc->quote_symbol) && (is_symbol(cadr(p)))) - - -/* pair line/file/position */ -#define PAIR_LINE_BITS 24 -#define PAIR_FILE_BITS 12 -#define PAIR_POSITION_BITS 28 -#define PAIR_LINE_OFFSET 0 -#define PAIR_FILE_OFFSET PAIR_LINE_BITS -#define PAIR_POSITION_OFFSET (PAIR_LINE_BITS + PAIR_FILE_BITS) -#define PAIR_LINE_MASK ((1 << PAIR_LINE_BITS) - 1) -#define PAIR_FILE_MASK ((1 << PAIR_FILE_BITS) - 1) -#define PAIR_POSITION_MASK ((1 << PAIR_POSITION_BITS) - 1) - -#define port_location(Pt) (((port_line_number(Pt) & PAIR_LINE_MASK) << PAIR_LINE_OFFSET) | \ - ((port_file_number(Pt) & PAIR_FILE_MASK) << PAIR_FILE_OFFSET) | \ - ((port_position(Pt) & PAIR_POSITION_MASK) << PAIR_POSITION_OFFSET)) - -#define location_to_line(Loc) ((Loc >> PAIR_LINE_OFFSET) & PAIR_LINE_MASK) -#define location_to_file(Loc) ((Loc >> PAIR_FILE_OFFSET) & PAIR_FILE_MASK) -#define location_to_position(Loc) ((Loc >> PAIR_POSITION_OFFSET) & PAIR_POSITION_MASK) - -#define pair_line_number(p) location_to_line(pair_location(p)) -#define pair_file_number(p) location_to_file(pair_location(p)) -#define pair_position(p) location_to_position(pair_location(p)) - -#if (!S7_DEBUGGING) -#define pair_location(p) (p)->object.sym_cons.location -#define pair_set_location(p, X) (p)->object.sym_cons.location = X -#define pair_raw_hash(p) (p)->object.sym_cons.hash -#define pair_set_raw_hash(p, X) (p)->object.sym_cons.hash = X -#define pair_raw_len(p) (p)->object.sym_cons.location -#define pair_set_raw_len(p, X) (p)->object.sym_cons.location = X -#define pair_raw_name(p) (p)->object.sym_cons.fstr -#define pair_set_raw_name(p, X) (p)->object.sym_cons.fstr = X -/* opt1 == raw_hash, opt2 == raw_name, opt3 == line|ctr + len, but hash/name/len only apply to the symbol table so there's no collision */ - -#define opt1(p, r) ((p)->object.cons.opt1) -#define set_opt1(p, x, r) (p)->object.cons.opt1 = x -#define opt2(p, r) ((p)->object.cons.o2.opt2) -#define set_opt2(p, x, r) (p)->object.cons.o2.opt2 = (s7_pointer)(x) -#define opt2_n(p, r) ((p)->object.cons.o2.n) -#define set_opt2_n(p, x, r) (p)->object.cons.o2.n = x -#define opt3(p, r) ((p)->object.cons.o3.opt3) -#define set_opt3(p, x, r) do {(p)->object.cons.o3.opt3 = x; clear_type_bit(p, T_LOCATION);} while (0) -#define opt3_n(p, r) ((p)->object.cons.o3.n) -#define set_opt3_n(p, x, r) do {(p)->object.cons.o3.n = x; clear_type_bit(p, T_LOCATION);} while (0) - -#else - -/* the 3 opt fields hold most of the varigated optimizer info, so they are used in many conflicting ways. - * the bits and funcs here try to track each such use, and report any cross-talk or collisions. - * all of this machinery vanishes if debugging is turned off. - */ -#define OPT1_SET (1 << 0) -#define OPT2_SET (1 << 1) -#define OPT3_SET (1 << 2) - -#define OPT1_FAST (1 << 3) /* fast list in member/assoc circular list check */ -#define OPT1_CFUNC (1 << 4) /* c-function */ -#define OPT1_CLAUSE (1 << 5) /* case clause */ -#define OPT1_LAMBDA (1 << 6) /* lambda(*) */ -#define OPT1_SYM (1 << 7) /* symbol */ -#define OPT1_PAIR (1 << 8) /* pair */ -#define OPT1_CON (1 << 9) /* constant from eval's point of view */ /* 10 was opt1_goto, unused */ -#define OPT1_ANY (1 << 11) /* anything -- deliberate unchecked case */ -#define OPT1_HASH (1 << 12) /* hash code used in the symbol table (pair_raw_hash) */ -#define OPT1_MASK (OPT1_FAST | OPT1_CFUNC | OPT1_CLAUSE | OPT1_LAMBDA | OPT1_SYM | OPT1_PAIR | OPT1_CON | OPT1_ANY | OPT1_HASH) - -#define opt1_is_set(p) (((T_Pair(p))->debugger_bits & OPT1_SET) != 0) -#define set_opt1_is_set(p) (T_Pair(p))->debugger_bits |= OPT1_SET -#define opt1_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT1_MASK) == Role) -#define set_opt1_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT1_MASK)) -#define opt1(p, Role) opt1_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt1(p, x, Role) set_opt1_1(T_Pair(p), x, Role, __func__, __LINE__) - -#define OPT2_KEY (1 << 13) /* case key */ -#define OPT2_SLOW (1 << 14) /* slow list in member/assoc circular list check */ -#define OPT2_SYM (1 << 15) /* symbol */ -#define OPT2_PAIR (1 << 16) /* pair */ -#define OPT2_CON (1 << 17) /* constant as above */ -#define OPT2_FX (1 << 18) /* fx (fx_*) func (sc, form) */ -#define OPT2_FN (1 << 19) /* fn (s7_function) func (sc, arglist) */ -#define OPT2_LAMBDA (1 << 20) /* lambda form */ -#define OPT2_NAME (1 << 21) /* named used by symbol table (pair_raw_name) */ -#define OPT2_DIRECT (1LL << 32) -#define OPT2_INT (1LL << 33) -#define OPT2_MASK (OPT2_KEY | OPT2_SLOW | OPT2_SYM | OPT2_PAIR | OPT2_CON | OPT2_FX | \ - OPT2_FN | OPT2_LAMBDA | OPT2_DIRECT | OPT2_NAME | OPT2_INT) - -#define opt2_is_set(p) (((T_Pair(p))->debugger_bits & OPT2_SET) != 0) -#define set_opt2_is_set(p) (T_Pair(p))->debugger_bits |= OPT2_SET -#define opt2_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT2_MASK) == Role) -#define set_opt2_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT2_MASK)) -#define opt2(p, Role) opt2_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt2(p, x, Role) set_opt2_1(sc, T_Pair(p), (s7_pointer)(x), Role, __func__, __LINE__) -#define opt2_n(p, Role) opt2_n_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt2_n(p, x, Role) set_opt2_n_1(sc, T_Pair(p), x, Role, __func__, __LINE__) - -#define OPT3_ARGLEN (1 << 22) /* arglist length */ -#define OPT3_SYM (1 << 23) /* expression symbol access */ -#define OPT3_AND (1 << 24) /* and second clause */ -#define OPT3_DIRECT (1 << 25) /* direct call info */ -#define OPT3_ANY (1 << 26) -#define OPT3_LET (1 << 27) /* let or #f */ -#define OPT3_CON (1 << 28) -#define OPT3_LOCATION (1 << 29) -#define OPT3_LEN (1 << 30) -#define OPT3_BYTE (1LL << 31) -#define OPT3_INT (1LL << 34) -#define OPT3_MASK (OPT3_ARGLEN | OPT3_SYM | OPT3_AND | OPT3_ANY | OPT3_LET | OPT3_BYTE | \ - OPT3_LOCATION | OPT3_LEN | OPT3_DIRECT | OPT3_CON | OPT3_INT) - -#define opt3_is_set(p) (((T_Pair(p))->debugger_bits & OPT3_SET) != 0) -#define set_opt3_is_set(p) (T_Pair(p))->debugger_bits |= OPT3_SET -#define opt3_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT3_MASK) == Role) -#define set_opt3_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT3_MASK)) -#define opt3(p, Role) opt3_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt3(p, x, Role) set_opt3_1(T_Pair(p), x, Role) -#define opt3_n(p, Role) opt3_n_1(sc, T_Pair(p), Role, __func__, __LINE__) -#define set_opt3_n(p, x, Role) set_opt3_n_1(T_Pair(p), x, Role) - -#define pair_location(p) opt3_location_1(sc, T_Pair(p), __func__, __LINE__) -#define pair_set_location(p, X) set_opt3_location_1(T_Pair(p), X) -#define pair_raw_hash(p) opt1_hash_1(sc, T_Pair(p), __func__, __LINE__) -#define pair_set_raw_hash(p, X) set_opt1_hash_1(T_Pair(p), X) -#define pair_raw_len(p) opt3_len_1(sc, T_Pair(p), __func__, __LINE__) -#define pair_set_raw_len(p, X) set_opt3_len_1(T_Pair(p), X) -#define pair_raw_name(p) opt2_name_1(sc, T_Pair(p), __func__, __LINE__) -#define pair_set_raw_name(p, X) set_opt2_name_1(T_Pair(p), X) - -#define L_HIT (1LL << 40) /* "L_SET" is taken */ -#define L_FUNC (1LL << 41) -#define L_DOX (1LL << 42) -#define L_MASK (L_FUNC | L_DOX) -#endif - -#define opt1_fast(P) T_Lst(opt1(P, OPT1_FAST)) -#define set_opt1_fast(P, X) set_opt1(P, T_Pair(X), OPT1_FAST) -#define opt1_cfunc(P) T_Pos(opt1(P, OPT1_CFUNC)) -#define set_opt1_cfunc(P, X) set_opt1(P, T_Fnc(X), OPT1_CFUNC) -#define opt1_lambda_unchecked(P) opt1(P, OPT1_LAMBDA) /* can be free/null? from s7_call? */ -#define opt1_lambda(P) T_Clo(opt1(P, OPT1_LAMBDA)) -#define set_opt1_lambda(P, X) set_opt1(P, T_Clo(X), OPT1_LAMBDA) -#define set_opt1_lambda_add(P, X) do {set_opt1(P, T_Clo(X), OPT1_LAMBDA); add_opt1_func(sc, P);} while (0) -#define opt1_clause(P) T_Pos(opt1(P, OPT1_CLAUSE)) -#define set_opt1_clause(P, X) set_opt1(P, T_Pos(X), OPT1_CLAUSE) -#define opt1_sym(P) T_Sym(opt1(P, OPT1_SYM)) -#define set_opt1_sym(P, X) set_opt1(P, T_Sym(X), OPT1_SYM) -#define opt1_pair(P) T_Lst(opt1(P, OPT1_PAIR)) -#define set_opt1_pair(P, X) set_opt1(P, T_Lst(X), OPT1_PAIR) -#define opt1_con(P) T_Pos(opt1(P, OPT1_CON)) -#define set_opt1_con(P, X) set_opt1(P, T_Pos(X), OPT1_CON) /* can be # */ -#define opt1_any(P) opt1(P, OPT1_ANY) /* can be free in closure_is_ok */ -#define set_opt1_any(P, X) set_opt1(P, X, OPT1_ANY) - -#define opt2_any(P) opt2(P, OPT2_KEY) -#define set_opt2_any(P, X) set_opt2(P, X, OPT2_KEY) -#define opt2_int(P) opt2_n(P, OPT2_INT) -#define set_opt2_int(P, X) set_opt2_n(P, X, OPT2_INT) -#define opt2_slow(P) T_Lst(opt2(P, OPT2_SLOW)) -#define set_opt2_slow(P, X) set_opt2(P, T_Pair(X), OPT2_SLOW) -#define opt2_sym(P) T_Sym(opt2(P, OPT2_SYM)) -#define set_opt2_sym(P, X) set_opt2(P, T_Sym(X), OPT2_SYM) -#define opt2_pair(P) T_Lst(opt2(P, OPT2_PAIR)) -#define set_opt2_pair(P, X) set_opt2(P, T_Lst(X), OPT2_PAIR) -#define opt2_con(P) T_Pos(opt2(P, OPT2_CON)) -#define set_opt2_con(P, X) set_opt2(P, T_Pos(X), OPT2_CON) -#define opt2_lambda(P) T_Pair(opt2(P, OPT2_LAMBDA)) -#define set_opt2_lambda(P, X) set_opt2(P, T_Pair(X), OPT2_LAMBDA) -#define opt2_direct(P) opt2(P, OPT2_DIRECT) -#define set_opt2_direct(P, X) set_opt2(P, (s7_pointer)(X), OPT2_DIRECT) - -#define opt3_arglen(P) opt3_n(P, OPT3_ARGLEN) -#define set_opt3_arglen(P, X) set_opt3_n(P, X, OPT3_ARGLEN) -#define opt3_int(P) opt3_n(P, OPT3_INT) -#define set_opt3_int(P, X) set_opt3_n(P, X, OPT3_INT) -#define opt3_sym(P) T_Sym(opt3(P, OPT3_SYM)) -#define set_opt3_sym(P, X) set_opt3(P, T_Sym(X), OPT3_SYM) -#define opt3_con(P) T_Pos(opt3(P, OPT3_CON)) -#define set_opt3_con(P, X) set_opt3(P, T_Pos(X), OPT3_CON) -#define opt3_pair(P) T_Pair(opt3(P, OPT3_AND)) -#define set_opt3_pair(P, X) set_opt3(P, T_Pair(X), OPT3_AND) -#define opt3_any(P) opt3(P, OPT3_ANY) -#define set_opt3_any(P, X) set_opt3(P, X, OPT3_ANY) -#define opt3_let(P) T_Lid(opt3(P, OPT3_LET)) -#define set_opt3_let(P, X) set_opt3(P, T_Lid(X), OPT3_LET) -#define opt3_direct(P) opt3(P, OPT3_DIRECT) -#define set_opt3_direct(P, X) set_opt3(P, (s7_pointer)(X), OPT3_DIRECT) - -#if S7_DEBUGGING -#define opt3_byte(p) opt3_byte_1(sc, T_Pair(p), OPT3_BYTE, __func__, __LINE__) -#define set_opt3_byte(p, x) set_opt3_byte_1(T_Pair(p), x, OPT3_BYTE, __func__, __LINE__) -#else -#define opt3_byte(P) T_Pair(P)->object.cons.o3.opt_type /* op_if_is_type, opt_type == opt3 in cons */ -#define set_opt3_byte(P, X) do {T_Pair(P)->object.cons.o3.opt_type = X; clear_type_bit(P, T_LOCATION);} while (0) -#endif - -#define pair_macro(P) opt2_sym(P) -#define set_pair_macro(P, Name) set_opt2_sym(P, Name) - -#define fn_proc(f) ((s7_function)(opt2(f, OPT2_FN))) -#define fx_proc(f) ((s7_function)(opt2(f, OPT2_FX))) -#define fn_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.o2.opt2)) -#define fx_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.o2.opt2)) /* unused */ - -#define set_fx(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FX); if (X) set_has_fx(f); else clear_has_fx(f);} while (0) -#define set_fx_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FX); set_has_fx(f);} while (0) -#define set_fn(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FN); if (X) set_has_fn(f); else clear_has_fx(f);} while (0) -#define set_fn_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FN); set_has_fn(f);} while (0) - -#if WITH_GCC -#define fx_call(Sc, F) ({s7_pointer _P_; _P_ = F; fx_proc(_P_)(Sc, car(_P_));}) -#define fc_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));}) -#define fn_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));}) -#else -#define fx_call(Sc, F) fx_proc(F)(Sc, car(F)) -#define fc_call(Sc, F) fn_proc(F)(Sc, cdr(F)) -#define fn_call(Sc, F) fn_proc(F)(Sc, cdr(F)) -#endif -/* fx_call can affect the stack and sc->value */ - -#define car(p) (T_Pair(p))->object.cons.car -#define set_car(p, Val) car(p) = T_Pos(Val) /* can be a slot or # */ -#define cdr(p) (T_Pair(p))->object.cons.cdr -#define set_cdr(p, Val) cdr(p) = T_Pos(Val) -#define unchecked_car(p) (T_Pos(p))->object.cons.car -#define unchecked_cdr(p) (T_Pos(p))->object.cons.cdr - -#define caar(p) car(car(p)) -#define cadr(p) car(cdr(p)) -#define set_cadr(p, Val) car(cdr(p)) = T_Pos(Val) -#define cdar(p) cdr(car(p)) -#define set_cdar(p, Val) cdr(car(p)) = T_Pos(Val) -#define cddr(p) cdr(cdr(p)) - -#define caaar(p) car(car(car(p))) -#define cadar(p) car(cdr(car(p))) -#define cdadr(p) cdr(car(cdr(p))) -#define caddr(p) car(cdr(cdr(p))) -#define set_caddr(p, Val) car(cdr(cdr(p))) = T_Pos(Val) -#define caadr(p) car(car(cdr(p))) -#define cdaar(p) cdr(car(car(p))) -#define cdddr(p) cdr(cdr(cdr(p))) -#define set_cdddr(p, Val) cdr(cdr(cdr(p))) = T_Pos(Val) -#define cddar(p) cdr(cdr(car(p))) - -#define caaadr(p) car(car(car(cdr(p)))) -#define caadar(p) car(car(cdr(car(p)))) -#define cadaar(p) car(cdr(car(car(p)))) -#define cadddr(p) car(cdr(cdr(cdr(p)))) -#define caaddr(p) car(car(cdr(cdr(p)))) -#define cddddr(p) cdr(cdr(cdr(cdr(p)))) -#define caddar(p) car(cdr(cdr(car(p)))) -#define cdadar(p) cdr(car(cdr(car(p)))) -#define cdaddr(p) cdr(car(cdr(cdr(p)))) -#define caaaar(p) car(car(car(car(p)))) -#define cadadr(p) car(cdr(car(cdr(p)))) -#define cdaadr(p) cdr(car(car(cdr(p)))) -#define cdaaar(p) cdr(car(car(car(p)))) -#define cdddar(p) cdr(cdr(cdr(car(p)))) -#define cddadr(p) cdr(cdr(car(cdr(p)))) -#define cddaar(p) cdr(cdr(car(car(p)))) - -#define cadaddr(p) cadr(caddr(p)) -#define caddadr(p) caddr(cadr(p)) -#define caddaddr(p) caddr(caddr(p)) - -#if WITH_GCC - /* slightly tricky because cons can be called recursively, macro here is faster than inline function */ - #define cons(Sc, A, B) ({s7_pointer _X_, _A_, _B_; _A_ = A; _B_ = B; new_cell(Sc, _X_, T_PAIR | T_SAFE_PROCEDURE); set_car(_X_, _A_); set_cdr(_X_, _B_); _X_;}) -#else - #define cons(Sc, A, B) s7_cons(Sc, A, B) -#endif - -#define list_1(Sc, A) cons(Sc, A, Sc->nil) -#define list_1_unchecked(Sc, A) cons_unchecked(Sc, A, Sc->nil) -#define list_2(Sc, A, B) cons_unchecked(Sc, A, cons(Sc, B, Sc->nil)) -#define list_2_unchecked(Sc, A, B) cons_unchecked(Sc, A, cons_unchecked(Sc, B, Sc->nil)) -#define list_3(Sc, A, B, C) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons(Sc, C, Sc->nil))) -#define list_4(Sc, A, B, C, D) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons_unchecked(Sc, C, cons(Sc, D, Sc->nil)))) -#define with_list_t1(A) (set_car(sc->t1_1, A), sc->t1_1) /* this is slower than explicit code, esp t3, procedures are same as this */ -#define with_list_t2(A, B) (set_car(sc->t2_1, A), set_car(sc->t2_2, B), sc->t2_1) -#define with_list_t3(A, B, C) (set_car(sc->t3_1, A), set_car(sc->t3_2, B), set_car(sc->t3_3, C), sc->t3_1) -#define with_list_t4(A, B, C, D) (set_car(sc->t4_1, A), set_car(sc->t3_1, B), set_car(sc->t3_2, C), set_car(sc->t3_3, D), sc->t4_1) - -#define is_string(p) (type(p) == T_STRING) -#define is_mutable_string(p) ((full_type(T_Ext(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_STRING) -#define string_value(p) (T_Str(p))->object.string.svalue -#define string_length(p) (T_Str(p))->object.string.length -#define string_hash(p) (T_Str(p))->object.string.hash -#define string_block(p) (T_Str(p))->object.string.block -#define unchecked_string_block(p) p->object.string.block - -#define character(p) (T_Chr(p))->object.chr.c -#define is_character(p) (type(p) == T_CHARACTER) -#define upper_character(p) (T_Chr(p))->object.chr.up_c -#define is_char_alphabetic(p) (T_Chr(p))->object.chr.alpha_c -#define is_char_numeric(p) (T_Chr(p))->object.chr.digit_c -#define is_char_whitespace(p) (T_Chr(p))->object.chr.space_c -#define is_char_uppercase(p) (T_Chr(p))->object.chr.upper_c -#define is_char_lowercase(p) (T_Chr(p))->object.chr.lower_c -#define character_name(p) (T_Chr(p))->object.chr.c_name -#define character_name_length(p) (T_Chr(p))->object.chr.length - -#define optimize_op(P) (T_Ext(P))->tf.opts.opt_choice -#define set_optimize_op(P, Op) (T_Ext(P))->tf.opts.opt_choice = (Op) /* not T_Pair -- needs legit cur_sc in init_chars|strings */ -#define OP_HOP_MASK 0xfffe -#define optimize_op_match(P, Q) ((is_optimized(P)) && ((optimize_op(P) & OP_HOP_MASK) == (Q))) -#define op_no_hop(P) (optimize_op(P) & OP_HOP_MASK) -#define op_has_hop(P) ((optimize_op(P) & 1) != 0) -#define clear_optimize_op(P) set_optimize_op(P, OP_UNOPT) -#define set_safe_optimize_op(P, Q) do {set_optimized(P); set_optimize_op(P, Q);} while (0) -#define set_unsafe_optimize_op(P, Q) do {set_unsafely_optimized(P); set_optimize_op(P, Q);} while (0) - -#define is_symbol(p) (type(p) == T_SYMBOL) -#define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p))) -#define is_safe_symbol(p) ((is_symbol(p)) && (is_slot(lookup_slot_from(p, sc->curlet)))) -#define symbol_name_cell(p) T_Str((T_Sym(p))->object.sym.name) -#define symbol_set_name_cell(p, S) (T_Sym(p))->object.sym.name = T_Str(S) -#define symbol_name(p) string_value(symbol_name_cell(p)) -#define symbol_name_length(p) string_length(symbol_name_cell(p)) -#define gensym_block(p) symbol_name_cell(p)->object.string.gensym_block -#define pointer_map(p) (s7_int)((intptr_t)(p) >> 8) -#define symbol_id(p) (T_Sym(p))->object.sym.id -#define symbol_set_id_unchecked(p, X) (T_Sym(p))->object.sym.id = X -#if S7_DEBUGGING -static void symbol_set_id(s7_pointer p, s7_int id) -{ - if (id < symbol_id(p)) - { - fprintf(stderr, "%s[%d]: id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n", __func__, __LINE__, symbol_name(p), symbol_id(p), id); - abort(); - } - (T_Sym(p))->object.sym.id = id; -} -#else -#define symbol_set_id(p, X) (T_Sym(p))->object.sym.id = X -#endif -/* we need 64-bits here, since we don't want this thing to wrap around, and lets are created at a great rate - * callgrind says this is faster than a uint32_t! - */ -#define symbol_info(p) (symbol_name_cell(p))->object.string.block -#define symbol_type(p) (block_size(symbol_info(p)) & 0xff) /* boolean function bool type */ -#define symbol_set_type(p, Type) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff) | ((Type) & 0xff)) -#define symbol_clear_type(p) block_size(symbol_info(p)) = 0 -#define s7_starlet_symbol(p) ((uint8_t)((block_size(symbol_info(p)) >> 8) & 0xff)) /* *s7* id */ -#define s7_starlet_symbol_set(p, F) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff00) | (((F) & 0xff) << 8)) - -#define initial_slot(p) T_Sld(symbol_info(p)->ex.ex_ptr) -#define set_initial_slot(p, Val) symbol_info(p)->ex.ex_ptr = T_Sld(Val) -#define global_slot(p) T_Sld((T_Sym(p))->object.sym.global_slot) -#define set_global_slot(p, Val) (T_Sym(p))->object.sym.global_slot = T_Sld(Val) -#define local_slot(p) T_Sln((T_Sym(p))->object.sym.local_slot) -#define set_local_slot(p, Val) (T_Sym(p))->object.sym.local_slot = T_Slt(Val) - -#define initial_value(p) slot_value(initial_slot(T_Sym(p))) -#define local_value(p) slot_value(local_slot(T_Sym(p))) -#define unchecked_local_value(p) local_slot(p)->object.slt.val -#define global_value(p) slot_value(global_slot(T_Sym(p))) - -#define keyword_symbol(p) symbol_info(T_Key(p))->nx.ksym /* keyword only, so does not collide with documentation */ -#define keyword_symbol_unchecked(p) symbol_info(p)->nx.ksym -#define keyword_set_symbol(p, Val) symbol_info(T_Key(p))->nx.ksym = T_Sym(Val) -#define symbol_help(p) symbol_info(p)->nx.documentation -#define symbol_set_help(p, Doc) symbol_info(p)->nx.documentation = Doc -#define symbol_tag(p) (T_Sym(p))->object.sym.tag -#define symbol_set_tag(p, Val) (T_Sym(p))->object.sym.tag = Val -#define symbol_ctr(p) (T_Sym(p))->object.sym.ctr /* needs to be in the symbol object (not symbol_info) for speed */ -#define symbol_clear_ctr(p) (T_Sym(p))->object.sym.ctr = 0 -#define symbol_increment_ctr(p) (T_Sym(p))->object.sym.ctr++ -#define symbol_tag2(p) symbol_info(p)->ln.tag -#define symbol_set_tag2(p, Val) symbol_info(p)->ln.tag = Val -#define symbol_has_help(p) (is_documented(symbol_name_cell(p))) -#define symbol_set_has_help(p) set_documented(symbol_name_cell(p)) -/* symbol_info->dx is free */ - -#define symbol_set_local_slot_unchecked(Symbol, Id, Slot) \ - do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) -#define symbol_set_local_slot_unchecked_and_unincremented(Symbol, Id, Slot) \ - do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id);} while (0) -#define symbol_set_local_slot(Symbol, Id, Slot) \ - do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id); symbol_increment_ctr(Symbol);} while (0) -#define symbol_set_local_slot_unincremented(Symbol, Id, Slot) \ - do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id);} while (0) -/* set slot before id in case Slot is an expression that tries to find the current Symbol slot (using its old Id obviously) */ - -#define is_slot(p) (type(p) == T_SLOT) -#define slot_symbol(p) T_Sym((T_Slt(p))->object.slt.sym) -#define slot_set_symbol(p, Sym) (T_Slt(p))->object.slt.sym = T_Sym(Sym) -#define slot_value(p) T_Nmv((T_Slt(p))->object.slt.val) -#define slot_set_value(p, Val) (T_Slt(p))->object.slt.val = T_Nmv(Val) -#define slot_set_symbol_and_value(Slot, Symbol, Value) do {slot_set_symbol(Slot, Symbol); slot_set_value(Slot, Value);} while (0) -#define slot_set_value_with_hook(Slot, Value) \ - do {if (hook_has_functions(sc->rootlet_redefinition_hook)) slot_set_value_with_hook_1(sc, Slot, T_Nmv(Value)); else slot_set_value(Slot, T_Nmv(Value));} while (0) -#define next_slot(p) T_Sln((T_Slt(p))->object.slt.nxt) -#define slot_set_next(p, Val) (T_Slt(p))->object.slt.nxt = T_Sln(Val) -#define slot_set_pending_value(p, Val) do {(T_Slt(p))->object.slt.pending_value = T_Nmv(Val); slot_set_has_pending_value(p);} while (0) -#define slot_simply_set_pending_value(p, Val) (T_Slt(p))->object.slt.pending_value = T_Nmv(Val) -#if S7_DEBUGGING -static s7_pointer slot_pending_value(s7_pointer p) \ - {if (slot_has_pending_value(p)) return(p->object.slt.pending_value); fprintf(stderr, "%s[%d]: slot: no pending value\n", __func__, __LINE__); abort(); return(NULL);} -static s7_pointer slot_expression(s7_pointer p) \ - {if (slot_has_expression(p)) return(p->object.slt.expr); fprintf(stderr, "%s[%d]: slot: no expression\n", __func__, __LINE__); abort(); return(NULL);} -#else -#define slot_pending_value(p) (T_Slt(p))->object.slt.pending_value -#define slot_expression(p) (T_Slt(p))->object.slt.expr -#endif -#define slot_set_expression(p, Val) do {(T_Slt(p))->object.slt.expr = T_Ext(Val); slot_set_has_expression(p);} while (0) -#define slot_just_set_expression(p, Val) (T_Slt(p))->object.slt.expr = T_Ext(Val) -#define slot_setter(p) T_Prc(T_Slt(p)->object.slt.pending_value) -#define slot_set_setter_1(p, Val) (T_Slt(p))->object.slt.pending_value = T_Prc(Val) -#if S7_DEBUGGING -#define tis_slot(p) ((p) && (T_Slt(p))) -#else -#define tis_slot(p) (p) /* used for loop through let slots which end in nil, not for general slot recognition */ -#endif -#define slot_end(sc) NULL -#define is_slot_end(p) (!(p)) - -#define is_syntax(p) (type(p) == T_SYNTAX) -#define syntax_symbol(p) T_Sym((T_Syn(p))->object.syn.symbol) -#define syntax_set_symbol(p, Sym) (T_Syn(p))->object.syn.symbol = T_Sym(Sym) -#define syntax_opcode(p) (T_Syn(p))->object.syn.op -#define syntax_min_args(p) (T_Syn(p))->object.syn.min_args -#define syntax_max_args(p) (T_Syn(p))->object.syn.max_args -#define syntax_documentation(p) (T_Syn(p))->object.syn.documentation -#define pair_set_syntax_op(p, X) do {set_optimize_op(p, X); set_syntactic_pair(p);} while (0) -#define symbol_syntax_op_checked(p) ((is_syntactic_pair(p)) ? optimize_op(p) : symbol_syntax_op(car(p))) -#define symbol_syntax_op(p) syntax_opcode(global_value(p)) -#define is_syntax_or_qq(p) ((is_syntax(p)) || ((p) == initial_value(sc->quasiquote_symbol))) - -#define INITIAL_ROOTLET_SIZE 512 -#define let_id(p) (T_Lid(p))->object.envr.id -#define let_set_id(p, Id) (T_Lid(p))->object.envr.id = Id -#define is_let(p) (type(p) == T_LET) -#define is_let_unchecked(p) (unchecked_type(p) == T_LET) -#define let_slots(p) T_Sln((T_Let(p))->object.envr.slots) -#define let_outlet(p) T_Lid((T_Let(p))->object.envr.nxt) -#define let_set_outlet(p, ol) (T_Let(p))->object.envr.nxt = T_Lid(ol) -#if S7_DEBUGGING - #define let_set_slots(p, Slot) do {if ((!in_heap(p)) && (Slot) && (in_heap(Slot))) fprintf(stderr, "%s[%d]: let+slot mismatch\n", __func__, __LINE__); \ - T_Let(p)->object.envr.slots = T_Sln(Slot);} while (0) - #define C_Let(p, role) check_let_ref(p, role, __func__, __LINE__) - #define S_Let(p, role) check_let_set(p, role, __func__, __LINE__) -#else - #define let_set_slots(p, Slot) (T_Let(p))->object.envr.slots = T_Sln(Slot) - #define C_Let(p, role) p - #define S_Let(p, role) p -#endif -#define funclet_function(p) T_Sym((C_Let(p, L_FUNC))->object.envr.edat.efnc.function) -#define funclet_set_function(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.function = T_Sym(F) -#define set_curlet(Sc, P) Sc->curlet = T_Lid(P) - -#define let_baffle_key(p) (T_Let(p))->object.envr.edat.key -#define set_let_baffle_key(p, K) (T_Let(p))->object.envr.edat.key = K - -#define let_line(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.line -#define let_set_line(p, L) (S_Let(p, L_FUNC))->object.envr.edat.efnc.line = L -#define let_file(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.file -#define let_set_file(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.file = F - -#define let_dox_slot1(p) T_Slt((C_Let(p, L_DOX))->object.envr.edat.dox.dox1) -#define let_set_dox_slot1(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox1 = T_Slt(S); set_has_dox_slot1(p);} while (0) -#define let_dox_slot2(p) T_Sld((C_Let(p, L_DOX))->object.envr.edat.dox.dox2) -#define let_set_dox_slot2(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox2 = T_Slt(S); set_has_dox_slot2(p);} while (0) -#define let_dox_slot2_unchecked(p) T_Sld(C_Let(p, L_DOX)->object.envr.edat.dox.dox2) -#define let_set_dox_slot2_unchecked(p, S) do {S_Let(p, L_DOX)->object.envr.edat.dox.dox2 = T_Sld(S); set_has_dox_slot2(p);} while (0) -#define let_dox1_value(p) slot_value(let_dox_slot1(p)) -#define let_dox2_value(p) slot_value(let_dox_slot2(p)) - -#define unique_name(p) (p)->object.unq.name /* not T_Uniq(p) here -- see make_unique */ -#define unique_name_length(p) (p)->object.unq.len -#define is_unspecified(p) (type(p) == T_UNSPECIFIED) -#define unique_car(p) (p)->object.unq.car -#define unique_cdr(p) (p)->object.unq.cdr - -#define is_undefined(p) (type(p) == T_UNDEFINED) -#define undefined_name(p) (T_Undf(p))->object.undef.name -#define undefined_name_length(p) (T_Undf(p))->object.undef.len -#define undefined_set_name_length(p, L) (T_Undf(p))->object.undef.len = L -#define eof_name(p) (T_Eof(p))->object.eof.name -#define eof_name_length(p) (T_Eof(p))->object.eof.len - -#define is_any_vector(p) t_vector_p[type(p)] -#define is_normal_vector(p) (type(p) == T_VECTOR) -#define vector_length(p) (p)->object.vector.length -#define unchecked_vector_elements(p) (p)->object.vector.elements.objects -#define unchecked_vector_element(p, i) ((p)->object.vector.elements.objects[i]) -#define vector_element(p, i) ((T_Nvc(p))->object.vector.elements.objects[i]) -#define vector_elements(p) (T_Nvc(p))->object.vector.elements.objects -#define any_vector_elements(p) (T_Vec(p))->object.vector.elements.objects -#define vector_getter(p) (T_Vec(p))->object.vector.vget -#define vector_setter(p) (T_Vec(p))->object.vector.setv.vset -#define vector_block(p) (T_Vec(p))->object.vector.block -#define unchecked_vector_block(p) p->object.vector.block - -#define typed_vector_typer(p) T_Prc((T_Vec(p))->object.vector.setv.fset) -#define typed_vector_set_typer(p, Fnc) (T_Vec(p))->object.vector.setv.fset = T_Prc(Fnc) -#define typed_vector_gc_mark(p) ((is_c_function(typed_vector_typer(p))) ? c_function_marker(typed_vector_typer(p)) : mark_typed_vector_1) -#define typed_vector_typer_call(sc, p, Args) \ - ((is_c_function(typed_vector_typer(p))) ? c_function_call(typed_vector_typer(p))(sc, Args) : s7_apply_function(sc, typed_vector_typer(p), Args)) - -#define is_int_vector(p) (type(p) == T_INT_VECTOR) -#define int_vector(p, i) ((T_Ivc(p))->object.vector.elements.ints[i]) -#define int_vector_ints(p) (T_Ivc(p))->object.vector.elements.ints - -#define is_float_vector(p) (type(p) == T_FLOAT_VECTOR) -#define float_vector(p, i) ((T_Fvc(p))->object.vector.elements.floats[i]) -#define float_vector_floats(p) (T_Fvc(p))->object.vector.elements.floats - -#define is_byte_vector(p) (type(p) == T_BYTE_VECTOR) -#define byte_vector_length(p) (T_BVc(p))->object.vector.length -#define byte_vector_bytes(p) (T_BVc(p))->object.vector.elements.bytes -#define byte_vector(p, i) ((T_BVc(p))->object.vector.elements.bytes[i]) -#define is_string_or_byte_vector(p) ((type(p) == T_STRING) || (type(p) == T_BYTE_VECTOR)) - -#define vector_dimension_info(p) ((vdims_t *)(T_Vec(p))->object.vector.block->ex.ex_info) -#define vector_set_dimension_info(p, d) (T_Vec(p))->object.vector.block->ex.ex_info = (void *)d -#define vector_ndims(p) vdims_rank(vector_dimension_info(p)) -#define vector_dimension(p, i) vdims_dims(vector_dimension_info(p))[i] -#define vector_dimensions(p) vdims_dims(vector_dimension_info(p)) -#define vector_offset(p, i) vdims_offsets(vector_dimension_info(p))[i] -#define vector_offsets(p) vdims_offsets(vector_dimension_info(p)) -#define vector_rank(p) ((vector_dimension_info(p)) ? vector_ndims(p) : 1) -#define vector_has_dimension_info(p) (vector_dimension_info(p)) - -#define subvector_vector(p) T_Vec(((vector_dimension_info(T_SVec(p))) ? vdims_original(vector_dimension_info(p)) : (p)->object.vector.block->nx.ksym)) -#define subvector_set_vector(p, vect) (T_SVec(p))->object.vector.block->nx.ksym = T_Vec(vect) - -#define rootlet_element(p, i) unchecked_vector_element(p, i) -#define rootlet_elements(p) unchecked_vector_elements(p) -#define rootlet_block(p) unchecked_vector_block(p) - -#define stack_element(p, i) unchecked_vector_element(T_Stk(p), i) -#define stack_elements(p) unchecked_vector_elements(T_Stk(p)) -#define stack_block(p) unchecked_vector_block(T_Stk(p)) -#define current_stack_top(Sc) ((Sc)->stack_end - (Sc)->stack_start) -#define temp_stack_top(p) (T_Stk(p))->object.stk.top -/* #define stack_flags(p) (T_Stk(p))->object.stk.flags */ -#define stack_clear_flags(p) (T_Stk(p))->object.stk.flags = 0 -#define stack_has_pairs(p) (((T_Stk(p))->object.stk.flags & 1) != 0) -#define stack_set_has_pairs(p) (T_Stk(p))->object.stk.flags |= 1 -#define stack_has_counters(p) (((T_Stk(p))->object.stk.flags & 2) != 0) -#define stack_set_has_counters(p) (T_Stk(p))->object.stk.flags |= 2 - -#define is_hash_table(p) (type(p) == T_HASH_TABLE) -#define is_mutable_hash_table(p) ((full_type(T_Ext(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_HASH_TABLE) -#define hash_table_mask(p) (T_Hsh(p))->object.hasher.mask -#define hash_table_block(p) (T_Hsh(p))->object.hasher.block -#define unchecked_hash_table_block(p) p->object.hasher.block -#define hash_table_set_block(p, b) (T_Hsh(p))->object.hasher.block = b -#define hash_table_element(p, i) (T_Hsh(p))->object.hasher.elements[i] -#define hash_table_elements(p) (T_Hsh(p))->object.hasher.elements /* block data (dx) */ -#define hash_table_entries(p) hash_table_block(p)->nx.nx_int -#define hash_table_checker(p) (T_Hsh(p))->object.hasher.hash_func -#define hash_table_mapper(p) (T_Hsh(p))->object.hasher.loc -#define hash_table_procedures(p) T_Lst(hash_table_block(p)->ex.ex_ptr) -#define hash_table_set_procedures(p, Lst) hash_table_block(p)->ex.ex_ptr = T_Lst(Lst) /* both the checker/mapper: car/cdr, and the two typers (opt/opt2) */ -#define hash_table_procedures_checker(p) car(hash_table_procedures(p)) -#define hash_table_procedures_mapper(p) cdr(hash_table_procedures(p)) -#define hash_table_set_procedures_checker(p, f) set_car(hash_table_procedures(p), f) -#define hash_table_set_procedures_mapper(p, f) set_cdr(hash_table_procedures(p), f) -#define hash_table_key_typer(p) T_Prc(opt1_any(hash_table_procedures(p))) -#define hash_table_key_typer_unchecked(p) hash_table_block(p)->ex.ex_ptr->object.cons.opt1 -#define hash_table_set_key_typer(p, Fnc) set_opt1_any(hash_table_procedures(T_Hsh(p)), T_Prc(Fnc)) -#define hash_table_value_typer(p) T_Prc(opt2_any(hash_table_procedures(p))) -#define hash_table_value_typer_unchecked(p) hash_table_block(p)->ex.ex_ptr->object.cons.o2.opt2 -#define hash_table_set_value_typer(p, Fnc) set_opt2_any(hash_table_procedures(T_Hsh(p)), T_Prc(Fnc)) -#define weak_hash_iters(p) hash_table_block(p)->ln.tag - -#if S7_DEBUGGING -#define T_Itr_Pos(p) titr_pos(sc, T_Itr(p), __func__, __LINE__) -#define T_Itr_Len(p) titr_len(sc, T_Itr(p), __func__, __LINE__) -#define T_Itr_Hash(p) titr_hash(sc, T_Itr(p), __func__, __LINE__) -#define T_Itr_Let(p) titr_let(sc, T_Itr(p), __func__, __LINE__) -#define T_Itr_Pair(p) titr_pair(sc, T_Itr(p), __func__, __LINE__) -#else -#define T_Itr_Pos(p) p -#define T_Itr_Len(p) p -#define T_Itr_Hash(p) p -#define T_Itr_Let(p) p -#define T_Itr_Pair(p) p -#endif - -#define is_iterator(p) (type(p) == T_ITERATOR) -#define iterator_sequence(p) (T_Itr(p))->object.iter.obj -#define iterator_position(p) (T_Itr_Pos(p))->object.iter.lc.loc -#define iterator_length(p) (T_Itr_Len(p))->object.iter.lw.len -#define iterator_next(p) (T_Itr(p))->object.iter.next -#define iterator_is_at_end(p) (!iter_ok(p)) /* ((full_type(T_Itr(p)) & T_ITER_OK) == 0) */ -#define iterator_slow(p) T_Lst((T_Itr_Pair(p))->object.iter.lw.slow) -#define iterator_set_slow(p, Val) (T_Itr_Pair(p))->object.iter.lw.slow = T_Lst(Val) -#define iterator_hash_current(p) (T_Itr_Hash(p))->object.iter.lw.hcur -#define iterator_current(p) (T_Itr(p))->object.iter.cur -#define iterator_current_slot(p) T_Sln((T_Itr_Let(p))->object.iter.lc.lcur) -#define iterator_set_current_slot(p, Val) (T_Itr_Let(p))->object.iter.lc.lcur = T_Sln(Val) -#define iterator_let_cons(p) (T_Itr_Let(p))->object.iter.cur - -#define ITERATOR_END eof_object -#define ITERATOR_END_NAME "#" - -#define is_input_port(p) (type(p) == T_INPUT_PORT) -#define is_output_port(p) (type(p) == T_OUTPUT_PORT) -#define port_port(p) (T_Prt(p))->object.prt.port -#define is_string_port(p) (port_type(p) == STRING_PORT) -#define is_file_port(p) (port_type(p) == FILE_PORT) -#define is_function_port(p) (port_type(p) == FUNCTION_PORT) -#define port_filename_block(p) port_port(p)->filename_block -#define port_filename(p) port_port(p)->filename -#define port_filename_length(p) port_port(p)->filename_length -#define port_file(p) port_port(p)->file -#define port_data_block(p) port_port(p)->block -#define unchecked_port_data_block(p) p->object.prt.port->block -#define port_line_number(p) port_port(p)->line_number -#define port_file_number(p) port_port(p)->file_number -#define port_data(p) (T_Prt(p))->object.prt.data -#define port_data_size(p) (T_Prt(p))->object.prt.size -#define port_position(p) (T_Prt(p))->object.prt.point -#define port_block(p) (T_Prt(p))->object.prt.block -#define port_type(p) port_port(p)->ptype -#define port_is_closed(p) port_port(p)->is_closed -#define port_set_closed(p, Val) port_port(p)->is_closed = Val /* this can't be a type bit because sweep checks it after the type has been cleared */ -#define port_needs_free(p) port_port(p)->needs_free -#define port_next(p) port_block(p)->nx.next -#define port_output_function(p) port_port(p)->output_function /* these two are for function ports */ -#define port_input_function(p) port_port(p)->input_function -#define port_string_or_function(p) port_port(p)->orig_str -#define port_set_string_or_function(p, S) port_port(p)->orig_str = S - -#define current_input_port(Sc) Sc->input_port -#define set_current_input_port(Sc, P) Sc->input_port = P -#define current_output_port(Sc) Sc->output_port -#define set_current_output_port(Sc, P) Sc->output_port = P - -#define port_read_character(p) port_port(p)->pf->read_character -#define port_read_line(p) port_port(p)->pf->read_line -#define port_display(p) port_port(p)->pf->displayer -#define port_write_character(p) port_port(p)->pf->write_character -#define port_write_string(p) port_port(p)->pf->write_string -#define port_read_semicolon(p) port_port(p)->pf->read_semicolon -#define port_read_white_space(p) port_port(p)->pf->read_white_space -#define port_read_name(p) port_port(p)->pf->read_name -#define port_read_sharp(p) port_port(p)->pf->read_sharp -#define port_close(p) port_port(p)->pf->close_port - -#define is_c_function(f) (type(f) >= T_C_FUNCTION) -#define is_c_function_star(f) (type(f) == T_C_FUNCTION_STAR) -#define is_any_c_function(f) (type(f) >= T_C_FUNCTION_STAR) -#define is_safe_c_function(f) ((is_c_function(f)) && (is_safe_procedure(f))) -#define c_function_data(f) (T_Fnc(f))->object.fnc.c_proc -#define c_function_call(f) (T_Fnc(f))->object.fnc.ff -#define c_function_min_args(f) (T_Fnc(f))->object.fnc.required_args -#define c_function_optional_args(f) (T_Fnc(f))->object.fnc.optional_args -#define c_function_max_args(f) (T_Fnc(f))->object.fnc.all_args -#define c_function_is_aritable(f, N) ((c_function_min_args(f) <= N) && (c_function_max_args(f) >= N)) -#define c_function_name(f) c_function_data(f)->name -#define c_function_name_length(f) c_function_data(f)->name_length -#define c_function_documentation(f) c_function_data(f)->doc -#define c_function_signature(f) c_function_data(f)->signature -#define c_function_setter(f) T_Prc(c_function_data(f)->setter) -#define c_function_set_setter(f, Val) c_function_data(f)->setter = T_Prc(Val) -#define c_function_class(f) c_function_data(f)->id -#define c_function_chooser(f) c_function_data(f)->chooser -#define c_function_base(f) T_Fnc(c_function_data(f)->generic_ff) -#define c_function_set_base(f, Val) c_function_data(f)->generic_ff = T_Fnc(Val) -#define c_function_marker(f) c_function_data(f)->cam.marker /* the mark function for the vector (mark_vector_1 etc) */ -#define c_function_set_marker(f, Val) c_function_data(f)->cam.marker = Val -#define c_function_symbol(f) c_function_data(f)->sam.c_sym - -#define c_function_bool_setter(f) c_function_data(f)->dam.bool_setter -#define c_function_set_bool_setter(f, Val) c_function_data(f)->dam.bool_setter = Val - -#define c_function_arg_defaults(f) c_function_data(T_Fst(f))->dam.arg_defaults -#define c_function_call_args(f) c_function_data(T_Fst(f))->cam.call_args -#define c_function_arg_names(f) c_function_data(T_Fst(f))->sam.arg_names - -#define set_c_function(X, f) do {set_opt1_cfunc(X, f); set_fn_direct(X, c_function_call(f));} while (0) -#define c_function_opt_data(f) c_function_data(f)->opt_data - -#define is_c_macro(p) (type(p) == T_C_MACRO) -#define c_macro_data(f) (T_CMac(f))->object.fnc.c_proc -#define c_macro_call(f) (T_CMac(f))->object.fnc.ff -#define c_macro_name(f) c_macro_data(f)->name -#define c_macro_name_length(f) c_macro_data(f)->name_length -#define c_macro_min_args(f) (T_CMac(f))->object.fnc.required_args -#define c_macro_max_args(f) (T_CMac(f))->object.fnc.all_args -#define c_macro_setter(f) T_Prc(c_macro_data(f)->setter) -#define c_macro_set_setter(f, Val) c_macro_data(f)->setter = T_Prc(Val) -#define could_be_macro_setter(Obj) t_macro_setter_p[type(Obj)] - -#define is_random_state(p) (type(p) == T_RANDOM_STATE) -#define random_gmp_state(p) (p)->object.rng.state /* sweep sees free cell in big_random_state gc_list and needs to call gmprandclear on its value */ -#define random_seed(p) (T_Ran(p))->object.rng.seed -#define random_carry(p) (T_Ran(p))->object.rng.carry - -#define continuation_block(p) (T_Con(p))->object.cwcc.block -#define continuation_stack(p) T_Stk(T_Con(p)->object.cwcc.stack) -#define continuation_set_stack(p, Val) (T_Con(p))->object.cwcc.stack = T_Stk(Val) -#define continuation_stack_end(p) (T_Con(p))->object.cwcc.stack_end -#define continuation_stack_start(p) (T_Con(p))->object.cwcc.stack_start -#define continuation_stack_top(p) (continuation_stack_end(p) - continuation_stack_start(p)) -#define continuation_op_stack(p) (T_Con(p))->object.cwcc.op_stack -#define continuation_stack_size(p) continuation_block(p)->nx.ix.i1 -#define continuation_op_loc(p) continuation_block(p)->nx.ix.i2 -#define continuation_op_size(p) continuation_block(p)->ln.tag -#define continuation_key(p) continuation_block(p)->ex.ckey -/* this can overflow int32_t -- baffle_key is s7_int, so ckey should be also */ -#define continuation_name(p) continuation_block(p)->dx.d_ptr - -#define call_exit_goto_loc(p) (T_Got(p))->object.rexit.goto_loc -#define call_exit_op_loc(p) (T_Got(p))->object.rexit.op_stack_loc -#define call_exit_active(p) (T_Got(p))->object.rexit.active -#define call_exit_name(p) (T_Got(p))->object.rexit.name - -#define is_continuation(p) (type(p) == T_CONTINUATION) -#define is_goto(p) (type(p) == T_GOTO) -#define is_macro(p) (type(p) == T_MACRO) -#define is_macro_star(p) (type(p) == T_MACRO_STAR) -#define is_bacro(p) (type(p) == T_BACRO) -#define is_bacro_star(p) (type(p) == T_BACRO_STAR) -#define is_either_macro(p) ((is_macro(p)) || (is_macro_star(p))) -#define is_either_bacro(p) ((type(p) == T_BACRO) || (type(p) == T_BACRO_STAR)) - -#define is_closure(p) (type(p) == T_CLOSURE) -#define is_closure_star(p) (type(p) == T_CLOSURE_STAR) -#define closure_args(p) T_Arg((T_Clo(p))->object.func.args) -#define closure_set_args(p, Val) (T_Clo(p))->object.func.args = T_Arg(Val) -#define closure_body(p) (T_Pair((T_Clo(p))->object.func.body)) -#define closure_set_body(p, Val) (T_Clo(p))->object.func.body = T_Pair(Val) -#define closure_let(p) T_Lid((T_Clo(p))->object.func.env) -#define closure_set_let(p, L) (T_Clo(p))->object.func.env = T_Lid(L) -#define closure_arity(p) (T_Clo(p))->object.func.arity -#define closure_set_arity(p, A) (T_Clo(p))->object.func.arity = A - -#define closure_setter(p) (T_Prc((T_Clo(p))->object.func.setter)) -#define closure_set_setter(p, Val) (T_Clo(p))->object.func.setter = T_Prc(Val) -#define closure_map_list(p) (T_Pair((T_Clo(p))->object.func.setter)) -#define closure_set_map_list(p, Val) (T_Clo(p))->object.func.setter = T_Pair(Val) -#define closure_setter_or_map_list(p) (T_Clo(p)->object.func.setter) -/* closure_map_list refers to a cyclic list detector in map; since in this case map makes a new closure for its own use, - * closure_map_list doesn't collide with closure_setter. - */ - -#define CLOSURE_ARITY_NOT_SET 0x40000000 -#define MAX_ARITY 0x20000000 -#define closure_arity_unknown(p) (closure_arity(p) == CLOSURE_ARITY_NOT_SET) -#define is_thunk(Sc, Fnc) ((type(Fnc) >= T_GOTO) && (s7_is_aritable(Sc, Fnc, 0))) - -#define hook_has_functions(p) (is_pair(s7_hook_functions(sc, T_Clo(p)))) - -#define catch_tag(p) (T_Cat(p))->object.rcatch.tag -#define catch_goto_loc(p) (T_Cat(p))->object.rcatch.goto_loc -#define catch_op_loc(p) (T_Cat(p))->object.rcatch.op_stack_loc -#define catch_cstack(p) (T_Cat(p))->object.rcatch.cstack -#define catch_handler(p) T_Ext((T_Cat(p))->object.rcatch.handler) -#define catch_set_handler(p, val) (T_Cat(p))->object.rcatch.handler = T_Ext(val) - -#define dynamic_wind_state(p) (T_Dyn(p))->object.winder.state -#define dynamic_wind_in(p) (T_Dyn(p))->object.winder.in -#define dynamic_wind_out(p) (T_Dyn(p))->object.winder.out -#define dynamic_wind_body(p) (T_Dyn(p))->object.winder.body - -#define is_c_object(p) (type(p) == T_C_OBJECT) -#define c_object_value(p) (T_Obj(p))->object.c_obj.value -#define c_object_type(p) (T_Obj(p))->object.c_obj.type -#define c_object_let(p) T_Lid((T_Obj(p))->object.c_obj.e) -#define c_object_set_let(p, L) (T_Obj(p))->object.c_obj.e = T_Lid(L) -#define c_object_s7(p) (T_Obj(p))->object.c_obj.sc - -#define c_object_info(Sc, p) Sc->c_object_types[c_object_type(T_Obj(p))] -#define c_object_free(Sc, p) c_object_info(Sc, p)->free -#define c_object_mark(Sc, p) c_object_info(Sc, p)->mark -#define c_object_gc_mark(Sc, p) c_object_info(Sc, p)->gc_mark -#define c_object_gc_free(Sc, p) c_object_info(Sc, p)->gc_free -#define c_object_ref(Sc, p) c_object_info(Sc, p)->ref -#define c_object_getf(Sc, p) c_object_info(Sc, p)->getter -#define c_object_set(Sc, p) c_object_info(Sc, p)->set -#define c_object_setf(Sc, p) c_object_info(Sc, p)->setter -#if (!DISABLE_DEPRECATED) - #define c_object_print(Sc, p) c_object_info(Sc, p)->print -#endif -#define c_object_len(Sc, p) c_object_info(Sc, p)->length -#define c_object_eql(Sc, p) c_object_info(Sc, p)->eql -#define c_object_equal(Sc, p) c_object_info(Sc, p)->equal -#define c_object_equivalent(Sc, p) c_object_info(Sc, p)->equivalent -#define c_object_fill(Sc, p) c_object_info(Sc, p)->fill -#define c_object_copy(Sc, p) c_object_info(Sc, p)->copy -#define c_object_reverse(Sc, p) c_object_info(Sc, p)->reverse -#define c_object_to_list(Sc, p) c_object_info(Sc, p)->to_list -#define c_object_to_string(Sc, p) c_object_info(Sc, p)->to_string -#define c_object_scheme_name(Sc, p) T_Str(c_object_info(Sc, p)->scheme_name) - -#define c_pointer(p) (T_Ptr(p))->object.cptr.c_pointer -#define c_pointer_type(p) (T_Ptr(p))->object.cptr.c_type -#define c_pointer_info(p) (T_Ptr(p))->object.cptr.info -#define c_pointer_weak1(p) (T_Ptr(p))->object.cptr.weak1 -#define c_pointer_weak2(p) (T_Ptr(p))->object.cptr.weak2 -#define c_pointer_set_weak1(p, q) (T_Ptr(p))->object.cptr.weak1 = T_Ext(q) -#define c_pointer_set_weak2(p, q) (T_Ptr(p))->object.cptr.weak2 = T_Ext(q) -#define is_c_pointer(p) (type(p) == T_C_POINTER) - -#define is_counter(p) (type(p) == T_COUNTER) -#define counter_result(p) (T_Ctr(p))->object.ctr.result -#define counter_set_result(p, Val) (T_Ctr(p))->object.ctr.result = T_Ext(Val) -#define counter_list(p) (T_Ctr(p))->object.ctr.list -#define counter_set_list(p, Val) (T_Ctr(p))->object.ctr.list = T_Ext(Val) -#define counter_capture(p) (T_Ctr(p))->object.ctr.cap -#define counter_set_capture(p, Val) (T_Ctr(p))->object.ctr.cap = Val -#define counter_let(p) T_Lid((T_Ctr(p))->object.ctr.env) -#define counter_set_let(p, L) (T_Ctr(p))->object.ctr.env = T_Lid(L) -#define counter_slots(p) T_Sln(T_Ctr(p)->object.ctr.slots) -#define counter_set_slots(p, Val) (T_Ctr(p))->object.ctr.slots = T_Sln(Val) - -#if S7_DEBUGGING -#define init_temp(p, Val) do {if (p != sc->unused) fprintf(stderr, "%s[%d]: temp %s\n", __func__, __LINE__, display(p)); p = T_Ext(Val);} while (0) -#else -#define init_temp(p, Val) p = Val -#endif - -#if __cplusplus && HAVE_COMPLEX_NUMBERS - using namespace std; /* the code has to work in C as well as C++, so we can't scatter std:: all over the place */ - typedef complex s7_complex; - static s7_double Real(complex x) {return(real(x));} /* protect the C++ name */ - static s7_double Imag(complex x) {return(imag(x));} -#endif - -#define integer(p) (T_Int(p))->object.number.integer_value -#define set_integer(p, x) integer(p) = x -#define real(p) (T_Rel(p))->object.number.real_value -#define set_real(p, x) real(p) = x -#define numerator(p) (T_Frc(p))->object.number.fraction_value.numerator -#define denominator(p) (T_Frc(p))->object.number.fraction_value.denominator -#define fraction(p) (((long_double)numerator(p)) / ((long_double)denominator(p))) -#define inverted_fraction(p) (((long_double)denominator(p)) / ((long_double)numerator(p))) -#define real_part(p) (T_Cmp(p))->object.number.complex_value.rl -#define set_real_part(p, x) real_part(p) = x -#define imag_part(p) (T_Cmp(p))->object.number.complex_value.im -#define set_imag_part(p, x) imag_part(p) = x -#if HAVE_COMPLEX_NUMBERS - #define to_c_complex(p) CMPLX(real_part(p), imag_part(p)) -#endif - -#if WITH_GMP -#define big_integer(p) ((T_Bgi(p))->object.number.bgi->n) -#define big_integer_nxt(p) (p)->object.number.bgi->nxt -#define big_integer_bgi(p) (p)->object.number.bgi -#define big_ratio(p) ((T_Bgf(p))->object.number.bgr->q) -#define big_ratio_nxt(p) (p)->object.number.bgr->nxt -#define big_ratio_bgr(p) (p)->object.number.bgr -#define big_real(p) ((T_Bgr(p))->object.number.bgf->x) -#define big_real_nxt(p) (p)->object.number.bgf->nxt -#define big_real_bgf(p) (p)->object.number.bgf -#define big_complex(p) ((T_Bgz(p))->object.number.bgc->z) -#define big_complex_nxt(p) (p)->object.number.bgc->nxt -#define big_complex_bgc(p) (p)->object.number.bgc -#endif - -#if S7_DEBUGGING -const char *display(s7_pointer obj) -{ - const char *res; - if (!has_methods(obj)) - return(string_value(s7_object_to_string(cur_sc, obj, false))); - clear_type_bit(obj, T_HAS_METHODS); /* clear_has_methods calls T_Met -> check_ref9 */ - res = string_value(s7_object_to_string(cur_sc, obj, false)); - set_type_bit(obj, T_HAS_METHODS); /* same for set_has_methods */ - return(res); -} -#else -#define display(Obj) string_value(s7_object_to_string(sc, Obj, false)) -#endif -#define display_80(Obj) string_value(object_to_truncated_string(sc, Obj, 80)) - -#if S7_DEBUGGING -static void set_type_1(s7_pointer p, uint64_t f, const char *func, int32_t line) -{ - p->alloc_line = line; - p->alloc_func = func; - p->alloc_type = f; - p->explicit_free_line = 0; - p->uses++; - if (((f) & TYPE_MASK) == T_FREE) - fprintf(stderr, "%d: set free, %p type to %" PRIx64 "\n", __LINE__, p, (int64_t)(f)); - else - if (((f) & TYPE_MASK) >= NUM_TYPES) - fprintf(stderr, "%d: set invalid type, %p type to %" PRIx64 "\n", __LINE__, p, (int64_t)(f)); - else - { - if (((full_type(p) & T_IMMUTABLE) != 0) && ((full_type(p) != (uint64_t)(f)))) - { - fprintf(stderr, "%s[%d]: set immutable %p type %d to %" ld64 "\n", __func__, __LINE__, p, unchecked_type(p), (int64_t)(f)); - abort(); - } - if (((full_type(p) & T_UNHEAP) != 0) && (((f) & T_UNHEAP) == 0)) - fprintf(stderr, "%s[%d]: clearing unheap in set type!\n", __func__, __LINE__); - } - full_type(p) = f; -} -#endif - -#define number_name(p) (char *)((T_Num(p))->object.number_name.name + 1) -#define number_name_length(p) (T_Num(p))->object.number_name.name[0] - -static void set_number_name(s7_pointer p, const char *name, int32_t len) -{ - /* if no number name: teq +110 tread +30 tform +90 */ - if ((len >= 0) && (len < NUMBER_NAME_SIZE) && (!is_mutable_number(p))) - { - set_has_number_name(p); - number_name_length(p) = (uint8_t)len; - memcpy((void *)number_name(p), (void *)name, len); - (number_name(p))[len] = 0; - } -} - -static s7_int s7_int_min = 0; -static int32_t s7_int_digits_by_radix[17]; - -#define S7_INT_BITS 63 - -#define S7_INT64_MAX 9223372036854775807LL -#define S7_INT64_MIN (int64_t)(-S7_INT64_MAX - 1LL) - -#define S7_INT32_MAX 2147483647LL -#define S7_INT32_MIN (-S7_INT32_MAX - 1LL) - -static void init_int_limits(void) -{ -#if WITH_GMP - #define S7_LOG_INT64_MAX 36.736800 -#else - /* actually not safe = (log (- (expt 2 63) 1)) and (log (- (expt 2 31) 1)) (using 63 and 31 bits) */ - #define S7_LOG_INT64_MAX 43.668274 -#endif - s7_int_min = S7_INT64_MIN; /* see comment in s7_make_ratio -- we're trying to hack around a gcc bug (9.2.1 Ubuntu) */ - s7_int_digits_by_radix[0] = 0; - s7_int_digits_by_radix[1] = 0; - for (int32_t i = 2; i < 17; i++) - s7_int_digits_by_radix[i] = (int32_t)(floor(S7_LOG_INT64_MAX / log((double)i))); -} - -static s7_pointer make_permanent_integer(s7_int i) -{ - s7_pointer p = (s7_pointer)Calloc(1, sizeof(s7_cell)); /* Calloc to clear name */ - full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP; - integer(p) = i; - return(p); -} - -#define NUM_CHARS 256 -#ifndef NUM_SMALL_INTS - #define NUM_SMALL_INTS 8192 - /* 65536: tshoot -6, tvect -50, dup -26, trclo -27, tmap -48, tsort -14, tlet -16, trec -58, thash -40 */ -#else -#if (NUM_SMALL_INTS < NUM_CHARS) /* g_char_to_integer assumes this is at least NUM_CHARS, as does the byte_vector stuff (256) */ - #error NUM_SMALL_INTS is less than NUM_CHARS which will not work -#endif -#endif - -static bool t_number_separator_p[NUM_CHARS]; -static s7_pointer *small_ints = NULL; -#define small_int(Val) small_ints[Val] -#define is_small_int(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */ - -static s7_pointer real_zero, real_NaN, complex_NaN, real_pi, real_one, arity_not_set, max_arity, real_infinity, real_minus_infinity; -static s7_pointer int_zero, int_one, int_two, int_three, minus_one, minus_two, mostfix, leastfix; - -static void init_small_ints(void) -{ - const char *ones[10] = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9"}; - s7_cell *cells = (s7_cell *)Malloc(NUM_SMALL_INTS * sizeof(s7_cell)); /* was calloc 14-Apr-22 */ - small_ints = (s7_pointer *)Malloc(NUM_SMALL_INTS * sizeof(s7_pointer)); - for (int32_t i = 0; i < NUM_SMALL_INTS; i++) - { - s7_pointer p; - small_ints[i] = &cells[i]; - p = small_ints[i]; - full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP; - integer(p) = i; - } - for (int32_t i = 0; i < 10; i++) - set_number_name(small_ints[i], ones[i], 1); - - /* setup a few other numbers while we're here */ - #define EXTRA_NUMBERS 11 - cells = (s7_cell *)Calloc(EXTRA_NUMBERS, sizeof(s7_cell)); - - #define init_integer(Ptr, Num, Name, Name_Len) \ - do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0) - #define init_integer_no_name(Ptr, Num) \ - do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num);} while (0) - - #define init_real(Ptr, Num, Name, Name_Len) \ - do {set_full_type(Ptr, T_REAL | T_IMMUTABLE | T_UNHEAP); set_real(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0) - #define init_real_no_name(Ptr, Num) \ - do {set_full_type(Ptr, T_REAL | T_IMMUTABLE | T_UNHEAP); set_real(Ptr, Num);} while (0) - - #define init_complex(Ptr, Real, Imag, Name, Name_Len) \ - do {set_full_type(Ptr, T_COMPLEX | T_IMMUTABLE | T_UNHEAP); set_real_part(Ptr, Real); set_imag_part(Ptr, Imag); set_number_name(Ptr, Name, Name_Len);} while (0) - - real_zero = &cells[0]; init_real(real_zero, 0.0, "0.0", 3); - real_one = &cells[1]; init_real(real_one, 1.0, "1.0", 3); - real_NaN = &cells[2]; init_real(real_NaN, NAN, "+nan.0", 6); - complex_NaN = &cells[10]; init_complex(complex_NaN, NAN, NAN, "+nan.0+nan.0i", 13); - real_infinity = &cells[3]; init_real(real_infinity, INFINITY, "+inf.0", 6); - real_minus_infinity = &cells[4]; init_real(real_minus_infinity, -INFINITY, "-inf.0", 6); - real_pi = &cells[5]; init_real_no_name(real_pi, 3.1415926535897932384626433832795029L); - - arity_not_set = &cells[6]; init_integer_no_name(arity_not_set, CLOSURE_ARITY_NOT_SET); - max_arity = &cells[7]; init_integer_no_name(max_arity, MAX_ARITY); - minus_one = &cells[8]; init_integer(minus_one, -1, "-1", 2); - minus_two = &cells[9]; init_integer(minus_two, -2, "-2", 2); - int_zero = small_ints[0]; - int_one = small_ints[1]; - int_two = small_ints[2]; - int_three = small_ints[3]; - - mostfix = make_permanent_integer(S7_INT64_MAX); - leastfix = make_permanent_integer(s7_int_min); - set_number_name(mostfix, "9223372036854775807", 19); - set_number_name(leastfix, "-9223372036854775808", 20); - - for (int32_t i = 0; i < NUM_CHARS; i++) t_number_separator_p[i] = true; - t_number_separator_p[(uint8_t)'i'] = false; - t_number_separator_p[(uint8_t)'+'] = false; - t_number_separator_p[(uint8_t)'-'] = false; - t_number_separator_p[(uint8_t)'/'] = false; - t_number_separator_p[(uint8_t)'@'] = false; - t_number_separator_p[(uint8_t)'.'] = false; - t_number_separator_p[(uint8_t)'e'] = false; - t_number_separator_p[(uint8_t)'E'] = false; -} - -#define clamp_length(NLen, Len) (((NLen) < (Len)) ? (NLen) : (Len)) - - -/* -------------------------------------------------------------------------------- */ -#if (defined(__FreeBSD__)) || ((defined(__linux__)) && (__GLIBC__ >= 2) && (__GLIBC_MINOR__ > 17)) || (defined(__OpenBSD__)) || (defined(__NetBSD__)) - static inline s7_int my_clock(void) - { - struct timespec ts; - clock_gettime(CLOCK_MONOTONIC, &ts); - /* coarse: 0.057u 0.007s, monotonic: 0.083u 0.007s, clock(): 0.624u 0.372s -- coarse since Linux 2.6.32, glibc > 2.17 - * FreeBSD has CLOCK_MONOTONIC_FAST in place of COARSE, OpenBSD and netBSD have neither - * clock_getres places 1 in tv_nsec in linux, so I assume I divide billion/tv_nsec - * MacOSX has clock_get_time, and after Sierra 10.12 has clock_gettime - * apparently we include /usr/include/AvailabilityMacros.h, then #if MAC_OS_X_VERSION_MIN_REQUIRED >= MAC_OS_X_VERSION_10_12 - * Windows has QueryPerformanceCounter or something - * maybe just check for POSIX compatibility? - */ - return(ts.tv_sec * 1000000000 + ts.tv_nsec); /* accumulated into s7_int so this should be ok: s7.h gives it 64 bits */ - } - - static s7_int ticks_per_second(void) - { - struct timespec ts; - clock_getres(CLOCK_MONOTONIC, &ts); - return((ts.tv_nsec == 0) ? 1000000000 : (1000000000 / ts.tv_nsec)); - } -#else - #define my_clock clock /* but this is cpu time? */ - #define ticks_per_second() CLOCKS_PER_SEC -#endif - -#ifndef GC_TRIGGER_SIZE - #define GC_TRIGGER_SIZE 64 -#endif - -#if S7_DEBUGGING -static void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line); -#define try_to_call_gc(Sc) try_to_call_gc_1(Sc, __func__, __LINE__) -#else -static void try_to_call_gc(s7_scheme *sc); -#endif - -#define GC_STATS 1 -#define HEAP_STATS 2 -#define STACK_STATS 4 -#define PROTECTED_OBJECTS_STATS 8 - -#define show_gc_stats(Sc) ((Sc->gc_stats & GC_STATS) != 0) -#define show_stack_stats(Sc) ((Sc->gc_stats & STACK_STATS) != 0) -#define show_heap_stats(Sc) ((Sc->gc_stats & HEAP_STATS) != 0) -#define show_protected_objects_stats(Sc) ((Sc->gc_stats & PROTECTED_OBJECTS_STATS) != 0) - - -/* new_cell has to include the new cell's type. In the free list, it is 0 (T_FREE). If we remove it here, - * but then hit some error before setting the type, the GC sweep thinks it is a free cell already and - * does not return it to the free list: a memory leak. - */ -#if (!S7_DEBUGGING) -#define new_cell(Sc, Obj, Type) \ - do { \ - if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \ - Obj = (*(--(Sc->free_heap_top))); \ - set_full_type(Obj, Type); \ - } while (0) - -#define new_cell_no_check(Sc, Obj, Type) do {Obj = (*(--(Sc->free_heap_top))); set_full_type(Obj, Type);} while (0) - /* since sc->free_heap_trigger is GC_TRIGGER_SIZE above the free heap base, we don't need - * to check it repeatedly after the first such check. - */ -#else - -#define new_cell(Sc, Obj, Type) \ - do { \ - if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \ - Obj = (*(--(Sc->free_heap_top))); \ - Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \ - set_full_type(Obj, Type); \ - } while (0) - -#define new_cell_no_check(Sc, Obj, Type) \ - do { \ - Obj = (*(--(Sc->free_heap_top))); \ - if (Sc->free_heap_top < Sc->free_heap) {fprintf(stderr, "%s[%d]: free heap exhausted\n", __func__, __LINE__); abort();}\ - Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \ - set_full_type(Obj, Type); \ - } while (0) -#endif - -/* #define gc_if_at_trigger(Sc) if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc) */ - -#if WITH_GCC -#define make_integer(Sc, N) \ - ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) -#define make_integer_unchecked(Sc, N) \ - ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell_no_check(Sc, _I_, T_INTEGER); integer(_I_) = _N_; _I_;}) ); }) - -#define make_real(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) -#define make_real_unchecked(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell_no_check(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;}) - -#define make_complex_not_0i(Sc, R, I) ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, I); _C_;}) -#define make_complex(Sc, R, I) \ - ({ s7_double _im_; _im_ = (I); ((_im_ == 0.0) ? make_real(Sc, R) : \ - ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}) ); }) - -#define real_to_double(Sc, X, Caller) ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_REAL) ? real(_x_) : s7_number_to_real_with_caller(Sc, _x_, Caller)); }) -#define rational_to_double(Sc, X) ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_INTEGER) ? (s7_double)integer(_x_) : fraction(_x_)); }) - -#else - -#define make_integer(Sc, N) s7_make_integer(Sc, N) -#define make_integer_unchecked(Sc, N) s7_make_integer(Sc, N) -#define make_real(Sc, X) s7_make_real(Sc, X) -#define make_real_unchecked(Sc, X) s7_make_real(Sc, X) -#define make_complex(Sc, R, I) s7_make_complex(Sc, R, I) -#define make_complex_not_0i(Sc, R, I) s7_make_complex(Sc, R, I) -#define real_to_double(Sc, X, Caller) s7_number_to_real_with_caller(Sc, X, Caller) -#define rational_to_double(Sc, X) s7_number_to_real(Sc, X) -#endif - -static s7_pointer wrap_integer(s7_scheme *sc, s7_int x) -{ - s7_pointer p; - if (is_small_int(x)) return(small_int(x)); - p = car(sc->integer_wrappers); - integer(p) = x; - sc->integer_wrappers = cdr(sc->integer_wrappers); - return(p); -} - -static s7_pointer wrap_real(s7_scheme *sc, s7_double x) -{ - s7_pointer p = car(sc->real_wrappers); - real(p) = x; - sc->real_wrappers = cdr(sc->real_wrappers); - return(p); -} - - -/* -------------------------------------------------------------------------------- - * local versions of some standard C library functions - * timing tests involving these are very hard to interpret, local_memset is faster using int64_t than int32_t - */ - -static void local_memset(void *s, uint8_t val, size_t n) -{ - uint8_t *s2; -#if S7_ALIGNED - s2 = (uint8_t *)s; -#else -#if (defined(__x86_64__) || defined(__i386__)) - if (n >= 8) - { - int64_t *s1 = (int64_t *)s; - size_t n8 = n >> 3; - int64_t ival = val | (val << 8) | (val << 16) | (((uint64_t)val) << 24); /* uint64_t casts make gcc/clang/fsanitize happy */ - ival = (((uint64_t)ival) << 32) | ival; - if ((n8 & 0x3) == 0) - while (n8 > 0) {LOOP_4(*s1++ = ival); n8 -= 4;} - else do {*s1++ = ival;} while (--n8 > 0); - n &= 7; - s2 = (uint8_t *)s1; - } - else s2 = (uint8_t *)s; -#else - s2 = (uint8_t *)s; -#endif -#endif - while (n > 0) - { - *s2++ = val; - n--; - } -} - -static inline s7_int safe_strlen(const char *str) /* this is safer than strlen, and slightly faster */ -{ - const char *tmp = str; - if ((!tmp) || (!(*tmp))) return(0); - for (; *tmp; ++tmp); - return(tmp - str); -} - -static char *copy_string_with_length(const char *str, s7_int len) -{ - char *newstr; - if ((S7_DEBUGGING) && ((len <= 0) || (!str))) fprintf(stderr, "%s[%d]: len: %" ld64 ", str: %s\n", __func__, __LINE__, len, str); - if (len > (1LL << 48)) return(NULL); /* squelch an idiotic warning */ - newstr = (char *)Malloc(len + 1); - memcpy((void *)newstr, (void *)str, len); /* we check len != 0 above -- 24-Jan-22 */ - newstr[len] = '\0'; - return(newstr); -} - -static char *copy_string(const char *str) {return(copy_string_with_length(str, safe_strlen(str)));} - -#if 0 -static bool local_strcmp(const char *s1, const char *s2) -{ - while (true) - { - if (*s1 != *s2++) return(false); - if (*s1++ == 0) return(true); - } - return(true); -} -#else -#define local_strcmp(S1, S2) (strcmp(S1, S2) == 0) -/* I think libc strcmp is much faster than it used to be, and beats the code above */ -#endif - -#define c_strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2)) -/* scheme strings can have embedded nulls */ - -static bool safe_strcmp(const char *s1, const char *s2) -{ - if ((!s1) || (!s2)) return(s1 == s2); - return(local_strcmp(s1, s2)); -} - -static bool local_strncmp(const char *s1, const char *s2, size_t n) /* not strncmp because scheme strings can have embedded nulls */ -{ -#if ((!S7_ALIGNED) && (defined(__x86_64__) || defined(__i386__))) /* unaligned accesses are safe on i386 hardware, sez everyone */ - if (n >= 8) - { - size_t n8 = n >> 3; - int64_t *is1 = (int64_t *)s1, *is2 = (int64_t *)s2; - do {if (*is1++ != *is2++) return(false);} while (--n8 > 0); /* in tbig LOOP_4 is slower? */ - s1 = (const char *)is1; - s2 = (const char *)is2; - n &= 7; - } -#endif - while (n > 0) - { - if (*s1++ != *s2++) return(false); - n--; - } - return(true); -} - -#define strings_are_equal_with_length(Str1, Str2, Len) (local_strncmp(Str1, Str2, Len)) - -static Sentinel size_t catstrs(char *dst, size_t len, ...) /* NULL-terminated arg list */ -{ - const char *dend = (const char *)(dst + len - 1); /* -1 for null at end? */ - char *d = dst; - va_list ap; - while ((*d) && (d < dend)) d++; /* stop at NULL or end-of-buffer */ - va_start(ap, len); - for (const char *s = va_arg(ap, const char *); s != NULL; s = va_arg(ap, const char *)) - while ((*s) && (d < dend)) {*d++ = *s++;} - *d = '\0'; - va_end (ap); - return(d - dst); -} - -static Sentinel size_t catstrs_direct(char *dst, const char *s1, ...) -{ /* NULL-terminated arg list, dst is destination only (assumed empty), all args known to fit in dst */ - char *d = dst; - va_list ap; - va_start(ap, s1); - for (const char *s = s1; s != NULL; s = va_arg(ap, const char *)) - while (*s) {*d++ = *s++;} - *d = '\0'; - va_end (ap); - return(d - dst); -} - -static char *pos_int_to_str(s7_scheme *sc, s7_int num, s7_int *len, char endc) -{ - char *p = (char *)(sc->int_to_str3 + INT_TO_STR_SIZE - 1); - char *op = p; - *p-- = '\0'; - if (endc != '\0') *p-- = endc; - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - (*len) = op - p; /* this includes the trailing #\null */ - return((char *)(p + 1)); -} - -static char *pos_int_to_str_direct(s7_scheme *sc, s7_int num) -{ - char *p = (char *)(sc->int_to_str4 + INT_TO_STR_SIZE - 1); - *p-- = '\0'; - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - return((char *)(p + 1)); -} - -static char *pos_int_to_str_direct_1(s7_scheme *sc, s7_int num) -{ - char *p = (char *)(sc->int_to_str5 + INT_TO_STR_SIZE - 1); - *p-- = '\0'; - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - return((char *)(p + 1)); -} - -#if WITH_GCC - #if S7_DEBUGGING - static s7_pointer lookup_1(s7_scheme *sc, s7_pointer symbol); - #define lookup(Sc, Sym) check_null_sym(Sc, lookup_1(Sc, Sym), Sym, __LINE__, __func__) - static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int32_t line, const char *func); - #define lookup_unexamined(Sc, Sym) lookup_1(Sc, Sym) - #define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup_1(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));}) - #else - static inline s7_pointer lookup(s7_scheme *sc, s7_pointer symbol); - #define lookup_unexamined(Sc, Sym) lookup(Sc, Sym) - #define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));}) - #endif -#else - #define lookup_unexamined(Sc, Sym) s7_symbol_value(Sc, Sym) /* changed 3-Nov-22 -- we're using lookup_unexamined below to avoid the unbound_variable check */ - #define lookup_checked(Sc, Sym) lookup(Sc, Sym) -#endif - - -/* ---------------- evaluator ops ---------------- */ -/* C=constant, S=symbol, A=fx-callable, Q=quote, N=any number of next >= 1, FX=list of A's, P=parlous?, O=one form, M=multiform */ -enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_protect used below as lower boundary marker */ - - OP_SAFE_C_NC, HOP_SAFE_C_NC, OP_SAFE_C_S, HOP_SAFE_C_S, - OP_SAFE_C_SS, HOP_SAFE_C_SS, OP_SAFE_C_SC, HOP_SAFE_C_SC, OP_SAFE_C_CS, HOP_SAFE_C_CS, OP_SAFE_C_CQ, HOP_SAFE_C_CQ, - OP_SAFE_C_SSS, HOP_SAFE_C_SSS, OP_SAFE_C_SCS, HOP_SAFE_C_SCS, OP_SAFE_C_SSC, HOP_SAFE_C_SSC, OP_SAFE_C_CSS, HOP_SAFE_C_CSS, - OP_SAFE_C_SCC, HOP_SAFE_C_SCC, OP_SAFE_C_CSC, HOP_SAFE_C_CSC, OP_SAFE_C_CCS, HOP_SAFE_C_CCS, - OP_SAFE_C_NS, HOP_SAFE_C_NS, OP_SAFE_C_opNCq, HOP_SAFE_C_opNCq, OP_SAFE_C_opSq, HOP_SAFE_C_opSq, - OP_SAFE_C_opSSq, HOP_SAFE_C_opSSq, OP_SAFE_C_opSCq, HOP_SAFE_C_opSCq, - OP_SAFE_C_opCSq, HOP_SAFE_C_opCSq, OP_SAFE_C_S_opSq, HOP_SAFE_C_S_opSq, - OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq, OP_SAFE_C_S_opSCq, HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq, - OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S, OP_SAFE_C_opSq_C, HOP_SAFE_C_opSq_C, - OP_SAFE_C_opSq_opSq, HOP_SAFE_C_opSq_opSq, OP_SAFE_C_S_opSSq, HOP_SAFE_C_S_opSSq, OP_SAFE_C_C_opSq, HOP_SAFE_C_C_opSq, - OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C, OP_SAFE_C_opSSq_C, HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq, - OP_SAFE_C_opSSq_opSSq, HOP_SAFE_C_opSSq_opSSq, OP_SAFE_C_opSSq_opSq, HOP_SAFE_C_opSSq_opSq, OP_SAFE_C_opSq_opSSq, HOP_SAFE_C_opSq_opSSq, - OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S, OP_SAFE_C_opCSq_S, HOP_SAFE_C_opCSq_S, OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C, - OP_SAFE_C_op_opSSqq_S, HOP_SAFE_C_op_opSSqq_S, OP_SAFE_C_op_opSqq, HOP_SAFE_C_op_opSqq, - OP_SAFE_C_op_S_opSqq, HOP_SAFE_C_op_S_opSqq, OP_SAFE_C_op_opSq_Sq, HOP_SAFE_C_op_opSq_Sq, OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS, - - OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, OP_SAFE_C_SA, HOP_SAFE_C_SA, OP_SAFE_C_AS, HOP_SAFE_C_AS, - OP_SAFE_C_CA, HOP_SAFE_C_CA, OP_SAFE_C_AC, HOP_SAFE_C_AC, OP_SAFE_C_AAA, HOP_SAFE_C_AAA, OP_SAFE_C_4A, HOP_SAFE_C_4A, - OP_SAFE_C_NA, HOP_SAFE_C_NA, OP_SAFE_C_ALL_CA, HOP_SAFE_C_ALL_CA, - OP_SAFE_C_SSA, HOP_SAFE_C_SSA, OP_SAFE_C_SAS, HOP_SAFE_C_SAS, OP_SAFE_C_SAA, HOP_SAFE_C_SAA, - OP_SAFE_C_CSA, HOP_SAFE_C_CSA, OP_SAFE_C_SCA, HOP_SAFE_C_SCA, OP_SAFE_C_ASS, HOP_SAFE_C_ASS, - OP_SAFE_C_CAC, HOP_SAFE_C_CAC, OP_SAFE_C_AGG, HOP_SAFE_C_AGG, - OP_SAFE_C_opAq, HOP_SAFE_C_opAq, OP_SAFE_C_opAAq, HOP_SAFE_C_opAAq, OP_SAFE_C_opAAAq, HOP_SAFE_C_opAAAq, - OP_SAFE_C_S_opAq, HOP_SAFE_C_S_opAq, OP_SAFE_C_opAq_S, HOP_SAFE_C_opAq_S, OP_SAFE_C_S_opAAq, HOP_SAFE_C_S_opAAq, - OP_SAFE_C_STAR, HOP_SAFE_C_STAR, OP_SAFE_C_STAR_A, HOP_SAFE_C_STAR_A, - OP_SAFE_C_STAR_AA, HOP_SAFE_C_STAR_AA, OP_SAFE_C_STAR_NA, HOP_SAFE_C_STAR_NA, - - OP_SAFE_C_P, HOP_SAFE_C_P, OP_SAFE_C_PP, HOP_SAFE_C_PP, OP_SAFE_C_FF, HOP_SAFE_C_FF, OP_SAFE_C_SP, HOP_SAFE_C_SP, - OP_SAFE_C_CP, HOP_SAFE_C_CP, OP_SAFE_C_AP, HOP_SAFE_C_AP, OP_SAFE_C_PA, HOP_SAFE_C_PA, OP_SAFE_C_PS, HOP_SAFE_C_PS, - OP_SAFE_C_PC, HOP_SAFE_C_PC, OP_SAFE_C_SSP, HOP_SAFE_C_SSP, OP_ANY_C_NP, HOP_ANY_C_NP, OP_SAFE_C_3P, HOP_SAFE_C_3P, - - OP_THUNK, HOP_THUNK, OP_THUNK_O, HOP_THUNK_O, OP_THUNK_ANY, HOP_THUNK_ANY, - OP_SAFE_THUNK, HOP_SAFE_THUNK, OP_SAFE_THUNK_A, HOP_SAFE_THUNK_A, OP_SAFE_THUNK_ANY, HOP_SAFE_THUNK_ANY, - - OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_S_O, HOP_CLOSURE_S_O, - OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_A_O, HOP_CLOSURE_A_O, OP_CLOSURE_P, HOP_CLOSURE_P, - OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA, OP_CLOSURE_PP, HOP_CLOSURE_PP, - OP_CLOSURE_FA, HOP_CLOSURE_FA, OP_CLOSURE_SS, HOP_CLOSURE_SS, OP_CLOSURE_SS_O, HOP_CLOSURE_SS_O, - OP_CLOSURE_SC, HOP_CLOSURE_SC, OP_CLOSURE_SC_O, HOP_CLOSURE_SC_O, - OP_CLOSURE_3S, HOP_CLOSURE_3S, OP_CLOSURE_3S_O, HOP_CLOSURE_3S_O, OP_CLOSURE_4S, HOP_CLOSURE_4S, OP_CLOSURE_4S_O, HOP_CLOSURE_4S_O, - OP_CLOSURE_AA, HOP_CLOSURE_AA, OP_CLOSURE_AA_O, HOP_CLOSURE_AA_O, OP_CLOSURE_3A, HOP_CLOSURE_3A, OP_CLOSURE_4A, HOP_CLOSURE_4A, - OP_CLOSURE_NA, HOP_CLOSURE_NA, OP_CLOSURE_ASS, HOP_CLOSURE_ASS, OP_CLOSURE_SAS, HOP_CLOSURE_SAS ,OP_CLOSURE_AAS, HOP_CLOSURE_AAS, - OP_CLOSURE_SAA, HOP_CLOSURE_SAA, OP_CLOSURE_ASA, HOP_CLOSURE_ASA, OP_CLOSURE_NS, HOP_CLOSURE_NS, - - OP_SAFE_CLOSURE_S, HOP_SAFE_CLOSURE_S, OP_SAFE_CLOSURE_S_O, HOP_SAFE_CLOSURE_S_O, - OP_SAFE_CLOSURE_S_A, HOP_SAFE_CLOSURE_S_A, OP_SAFE_CLOSURE_S_TO_S, HOP_SAFE_CLOSURE_S_TO_S, OP_SAFE_CLOSURE_S_TO_SC, HOP_SAFE_CLOSURE_S_TO_SC, - OP_SAFE_CLOSURE_P, HOP_SAFE_CLOSURE_P, OP_SAFE_CLOSURE_P_A, HOP_SAFE_CLOSURE_P_A, - OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA, HOP_SAFE_CLOSURE_PA, OP_SAFE_CLOSURE_PP, HOP_SAFE_CLOSURE_PP, - OP_SAFE_CLOSURE_A, HOP_SAFE_CLOSURE_A, OP_SAFE_CLOSURE_A_O, HOP_SAFE_CLOSURE_A_O, OP_SAFE_CLOSURE_A_A, HOP_SAFE_CLOSURE_A_A, - OP_SAFE_CLOSURE_A_TO_SC, HOP_SAFE_CLOSURE_A_TO_SC, - OP_SAFE_CLOSURE_SS, HOP_SAFE_CLOSURE_SS, OP_SAFE_CLOSURE_SS_O, HOP_SAFE_CLOSURE_SS_O, OP_SAFE_CLOSURE_SS_A, HOP_SAFE_CLOSURE_SS_A, - OP_SAFE_CLOSURE_SC, HOP_SAFE_CLOSURE_SC, OP_SAFE_CLOSURE_SC_O, HOP_SAFE_CLOSURE_SC_O, - OP_SAFE_CLOSURE_AA, HOP_SAFE_CLOSURE_AA, OP_SAFE_CLOSURE_AA_O, HOP_SAFE_CLOSURE_AA_O, OP_SAFE_CLOSURE_AA_A, HOP_SAFE_CLOSURE_AA_A, - OP_SAFE_CLOSURE_SAA, HOP_SAFE_CLOSURE_SAA, OP_SAFE_CLOSURE_SSA, HOP_SAFE_CLOSURE_SSA, - OP_SAFE_CLOSURE_AGG, HOP_SAFE_CLOSURE_AGG, OP_SAFE_CLOSURE_3A, HOP_SAFE_CLOSURE_3A, OP_SAFE_CLOSURE_NA, HOP_SAFE_CLOSURE_NA, - OP_SAFE_CLOSURE_3S, HOP_SAFE_CLOSURE_3S, OP_SAFE_CLOSURE_NS, HOP_SAFE_CLOSURE_NS, /* safe_closure_4s gained very little */ - OP_SAFE_CLOSURE_3S_A, HOP_SAFE_CLOSURE_3S_A, - /* ssa|saa|ns|na|3s|agg|3a|sc|ap|pa|pp_a ? thunk_o? op_closure_ns? */ - - OP_ANY_CLOSURE_3P, HOP_ANY_CLOSURE_3P, OP_ANY_CLOSURE_4P, HOP_ANY_CLOSURE_4P, OP_ANY_CLOSURE_NP, HOP_ANY_CLOSURE_NP, - OP_ANY_CLOSURE_SYM, HOP_ANY_CLOSURE_SYM, OP_ANY_CLOSURE_A_SYM, HOP_ANY_CLOSURE_A_SYM, - - OP_CLOSURE_STAR_A, HOP_CLOSURE_STAR_A, OP_CLOSURE_STAR_NA, HOP_CLOSURE_STAR_NA, - OP_SAFE_CLOSURE_STAR_A, HOP_SAFE_CLOSURE_STAR_A, OP_SAFE_CLOSURE_STAR_AA, HOP_SAFE_CLOSURE_STAR_AA, - OP_SAFE_CLOSURE_STAR_AA_O, HOP_SAFE_CLOSURE_STAR_AA_O, OP_SAFE_CLOSURE_STAR_A1, HOP_SAFE_CLOSURE_STAR_A1, - OP_SAFE_CLOSURE_STAR_KA, HOP_SAFE_CLOSURE_STAR_KA, OP_CLOSURE_STAR_KA, HOP_CLOSURE_STAR_KA, OP_SAFE_CLOSURE_STAR_3A, HOP_SAFE_CLOSURE_STAR_3A, - OP_SAFE_CLOSURE_STAR_NA, HOP_SAFE_CLOSURE_STAR_NA, OP_SAFE_CLOSURE_STAR_NA_0, HOP_SAFE_CLOSURE_STAR_NA_0, - OP_SAFE_CLOSURE_STAR_NA_1, HOP_SAFE_CLOSURE_STAR_NA_1, OP_SAFE_CLOSURE_STAR_NA_2, HOP_SAFE_CLOSURE_STAR_NA_2, - - OP_C_SS, HOP_C_SS, OP_C_S, HOP_C_S, OP_READ_S, HOP_READ_S, OP_C_P, HOP_C_P, OP_C_AP, HOP_C_AP, - OP_C_A, HOP_C_A, OP_C_AA, HOP_C_AA, OP_C, HOP_C, OP_C_NA, HOP_C_NA, - - OP_CL_S, HOP_CL_S, OP_CL_SS, HOP_CL_SS, OP_CL_A, HOP_CL_A, OP_CL_AA, HOP_CL_AA, - OP_CL_NA, HOP_CL_NA, OP_CL_FA, HOP_CL_FA, OP_CL_SAS, HOP_CL_SAS, - /* end of h_opts */ - - OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL, OP_MACRO_D, OP_MACRO_STAR_D, - OP_WITH_IO, OP_WITH_IO_1, OP_WITH_OUTPUT_TO_STRING, OP_WITH_IO_C, OP_CALL_WITH_OUTPUT_STRING, - OP_S, OP_S_G, OP_S_A, OP_S_AA, OP_A_A, OP_A_AA, OP_P_S, OP_P_S_1, OP_MAP_FOR_EACH_FA, OP_MAP_FOR_EACH_FAA, - OP_F, OP_F_A, OP_F_AA, OP_F_NP, OP_F_NP_1, - - OP_IMPLICIT_GOTO, OP_IMPLICIT_GOTO_A, OP_IMPLICIT_CONTINUATION_A, OP_IMPLICIT_ITERATE, - OP_IMPLICIT_VECTOR_REF_A, OP_IMPLICIT_VECTOR_REF_AA, OP_IMPLICIT_VECTOR_SET_3, OP_IMPLICIT_VECTOR_SET_4, - OP_IMPLICIT_STRING_REF_A, OP_IMPLICIT_C_OBJECT_REF_A, OP_IMPLICIT_PAIR_REF_A, OP_IMPLICIT_PAIR_REF_AA, - OP_IMPLICIT_HASH_TABLE_REF_A, OP_IMPLICIT_HASH_TABLE_REF_AA, - OP_IMPLICIT_LET_REF_C, OP_IMPLICIT_LET_REF_A, OP_IMPLICIT_S7_STARLET_REF_S, OP_IMPLICIT_S7_STARLET_SET, - OP_UNKNOWN, OP_UNKNOWN_NS, OP_UNKNOWN_NA, OP_UNKNOWN_S, OP_UNKNOWN_GG, OP_UNKNOWN_A, OP_UNKNOWN_AA, OP_UNKNOWN_NP, - - OP_SYMBOL, OP_CONSTANT, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, HOP_HASH_TABLE_INCREMENT, OP_CLEAR_OPTS, - - OP_READ_INTERNAL, OP_EVAL, OP_EVAL_ARGS, OP_EVAL_ARGS1, OP_EVAL_ARGS2, OP_EVAL_ARGS3, OP_EVAL_ARGS4, OP_EVAL_ARGS5, - OP_APPLY, OP_EVAL_MACRO, OP_LAMBDA, OP_QUOTE, OP_QUOTE_UNCHECKED, OP_MACROEXPAND, OP_CALL_CC, OP_CALL_WITH_EXIT, OP_CALL_WITH_EXIT_O, - OP_C_CATCH, OP_C_CATCH_ALL, OP_C_CATCH_ALL_O, OP_C_CATCH_ALL_A, - - OP_DEFINE, OP_DEFINE1, OP_BEGIN, OP_BEGIN_HOOK, OP_BEGIN_NO_HOOK, OP_BEGIN_UNCHECKED, OP_BEGIN_2_UNCHECKED, OP_BEGIN_NA, OP_BEGIN_AA, - OP_IF, OP_IF1, OP_WHEN, OP_UNLESS, OP_SET, OP_SET1, OP_SET2, - OP_LET, OP_LET1, OP_LET_STAR, OP_LET_STAR1, OP_LET_STAR2, OP_LET_STAR_SHADOWED, - OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1, - OP_LET_TEMPORARILY, OP_LET_TEMP_UNCHECKED, OP_LET_TEMP_INIT1, OP_LET_TEMP_INIT2, OP_LET_TEMP_DONE, OP_LET_TEMP_DONE1, - OP_LET_TEMP_S7, OP_LET_TEMP_NA, OP_LET_TEMP_A, OP_LET_TEMP_SETTER, OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND, OP_LET_TEMP_SETTER_UNWIND, - OP_LET_TEMP_A_A, OP_LET_TEMP_S7_DIRECT, OP_LET_TEMP_S7_DIRECT_UNWIND, - OP_COND, OP_COND1, OP_FEED_TO_1, OP_COND_SIMPLE, OP_COND1_SIMPLE, OP_COND_SIMPLE_O, OP_COND1_SIMPLE_O, - OP_AND, OP_OR, - OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION, OP_DEFINE_EXPANSION_STAR, OP_MACRO, OP_MACRO_STAR, - OP_CASE, - OP_READ_LIST, OP_READ_NEXT, OP_READ_DOT, OP_READ_QUOTE, - OP_READ_QUASIQUOTE, OP_READ_UNQUOTE, OP_READ_APPLY_VALUES, - OP_READ_VECTOR, OP_READ_BYTE_VECTOR, OP_READ_INT_VECTOR, OP_READ_FLOAT_VECTOR, OP_READ_DONE, - OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_DONE, OP_SPLICE_VALUES, OP_NO_VALUES, - OP_CATCH, OP_DYNAMIC_WIND, OP_DYNAMIC_UNWIND, OP_DYNAMIC_UNWIND_PROFILE, OP_PROFILE_IN, - OP_DEFINE_CONSTANT, OP_DEFINE_CONSTANT1, - OP_DO, OP_DO_END, OP_DO_END1, OP_DO_STEP, OP_DO_STEP2, OP_DO_INIT, - OP_DEFINE_STAR, OP_LAMBDA_STAR, OP_LAMBDA_STAR_DEFAULT, OP_ERROR_QUIT, OP_UNWIND_INPUT, OP_UNWIND_OUTPUT, OP_ERROR_HOOK_QUIT, - OP_WITH_LET, OP_WITH_LET1, OP_WITH_LET_UNCHECKED, OP_WITH_LET_S, - OP_WITH_BAFFLE, OP_WITH_BAFFLE_UNCHECKED, OP_EXPANSION, - OP_FOR_EACH, OP_FOR_EACH_1, OP_FOR_EACH_2, OP_FOR_EACH_3, - OP_MAP, OP_MAP_1, OP_MAP_2, OP_MAP_GATHER, OP_MAP_GATHER_1, OP_MAP_GATHER_2, OP_MAP_GATHER_3, OP_MAP_UNWIND, - OP_BARRIER, OP_DEACTIVATE_GOTO, - OP_DEFINE_BACRO, OP_DEFINE_BACRO_STAR, OP_BACRO, OP_BACRO_STAR, - OP_GET_OUTPUT_STRING, - OP_SORT, OP_SORT1, OP_SORT2, OP_SORT3, OP_SORT_PAIR_END, OP_SORT_VECTOR_END, OP_SORT_STRING_END, - OP_EVAL_STRING, - OP_MEMBER_IF, OP_ASSOC_IF, OP_MEMBER_IF1, OP_ASSOC_IF1, - OP_LAMBDA_UNCHECKED, OP_LET_UNCHECKED, OP_CATCH_1, OP_CATCH_2, OP_CATCH_ALL, - - OP_SET_UNCHECKED, OP_SET_S_C, OP_SET_S_S, OP_SET_S_P, OP_SET_S_A, - OP_SET_NORMAL, OP_SET_opSq_A, OP_SET_opSAq_A, OP_SET_opSAq_P, OP_SET_opSAq_P_1, OP_SET_opSAAq_A, OP_SET_opSAAq_P, OP_SET_opSAAq_P_1, - OP_SET_FROM_SETTER, OP_SET_FROM_LET_TEMP, OP_SET_SAFE, - OP_INCREMENT_BY_1, OP_DECREMENT_BY_1, OP_INCREMENT_SA, OP_INCREMENT_SAA, OP_SET_CONS, - - OP_LETREC_UNCHECKED, OP_LETREC_STAR_UNCHECKED, OP_COND_UNCHECKED, - OP_LAMBDA_STAR_UNCHECKED, OP_DO_UNCHECKED, OP_DEFINE_UNCHECKED, OP_DEFINE_STAR_UNCHECKED, OP_DEFINE_FUNCHECKED, OP_DEFINE_CONSTANT_UNCHECKED, - OP_DEFINE_WITH_SETTER, - - OP_LET_NO_VARS, OP_NAMED_LET, OP_NAMED_LET_NO_VARS, OP_NAMED_LET_A, OP_NAMED_LET_AA, OP_NAMED_LET_NA, OP_NAMED_LET_STAR, - OP_LET_NA_OLD, OP_LET_NA_NEW, OP_LET_2A_OLD, OP_LET_2A_NEW, OP_LET_3A_OLD, OP_LET_3A_NEW, - OP_LET_opaSSq_OLD, OP_LET_opaSSq_NEW, OP_LET_ONE_OLD, OP_LET_ONE_NEW, OP_LET_ONE_P_OLD, OP_LET_ONE_P_NEW, - OP_LET_ONE_OLD_1, OP_LET_ONE_NEW_1, OP_LET_ONE_P_OLD_1, OP_LET_ONE_P_NEW_1, - OP_LET_A_OLD, OP_LET_A_NEW, OP_LET_A_P_OLD, OP_LET_A_P_NEW, - OP_LET_A_A_OLD, OP_LET_A_A_NEW, OP_LET_A_NA_OLD, OP_LET_A_NA_NEW, OP_LET_A_OLD_2, OP_LET_A_NEW_2, - OP_LET_STAR_NA, OP_LET_STAR_NA_A, - - OP_CASE_A_E_S, OP_CASE_A_I_S, OP_CASE_A_G_S, OP_CASE_A_E_G, OP_CASE_A_G_G, OP_CASE_A_S_G, - OP_CASE_P_E_S, OP_CASE_P_I_S, OP_CASE_P_G_S, OP_CASE_P_E_G, OP_CASE_P_G_G, - OP_CASE_E_S, OP_CASE_I_S, OP_CASE_G_S, OP_CASE_E_G, OP_CASE_G_G, - OP_CASE_A_I_S_A, OP_CASE_A_E_S_A, OP_CASE_A_G_S_A, OP_CASE_A_S_G_A, - - OP_IF_UNCHECKED, OP_AND_P, OP_AND_P1, OP_AND_AP, OP_AND_PAIR_P, - OP_AND_SAFE_P1, OP_AND_SAFE_P2, OP_AND_SAFE_P3, OP_AND_SAFE_P_REST, OP_AND_2A, OP_AND_3A, OP_AND_N, OP_AND_S_2, - OP_OR_P, OP_OR_P1, OP_OR_AP, OP_OR_2A, OP_OR_3A, OP_OR_N, OP_OR_S_2, OP_OR_S_TYPE_2, - OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_WHEN_AND_2A, OP_WHEN_AND_3A, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P, - - OP_IF_A_C_C, OP_IF_A_A, OP_IF_A_A_A, OP_IF_S_A_A, OP_IF_AND2_S_A, OP_IF_NOT_A_A, OP_IF_NOT_A_A_A, - OP_IF_B_A, OP_IF_B_P, OP_IF_B_R, OP_IF_B_A_P, OP_IF_B_P_A, OP_IF_B_P_P, OP_IF_B_N_N, - OP_IF_A_A_P, OP_IF_A_P_A, OP_IF_S_P_A, OP_IF_S_A_P, OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N, - OP_IF_opSq_P, OP_IF_opSq_P_P, OP_IF_opSq_R, OP_IF_opSq_N, OP_IF_opSq_N_N, - OP_IF_IS_TYPE_S_P, OP_IF_IS_TYPE_S_P_P, OP_IF_IS_TYPE_S_R, OP_IF_IS_TYPE_S_N, OP_IF_IS_TYPE_S_N_N, OP_IF_IS_TYPE_S_P_A, OP_IF_IS_TYPE_S_A_A, OP_IF_IS_TYPE_S_A_P, - OP_IF_A_P, OP_IF_A_P_P, OP_IF_A_R, OP_IF_A_N, OP_IF_A_N_N, - OP_IF_AND2_P, OP_IF_AND2_P_P, OP_IF_AND2_R, OP_IF_AND2_N, OP_IF_AND2_N_N, - OP_IF_AND3_P, OP_IF_AND3_P_P, OP_IF_AND3_R, OP_IF_AND3_N, OP_IF_AND3_N_N, /* or3 got few hits */ - OP_IF_P_P, OP_IF_P_P_P, OP_IF_P_R, OP_IF_P_N, OP_IF_P_N_N, - OP_IF_ANDP_P, OP_IF_ANDP_P_P, OP_IF_ANDP_R, OP_IF_ANDP_N, OP_IF_ANDP_N_N, - OP_IF_ORP_P, OP_IF_ORP_P_P, OP_IF_ORP_R, OP_IF_ORP_N, OP_IF_ORP_N_N, - OP_IF_OR2_P, OP_IF_OR2_P_P, OP_IF_OR2_R, OP_IF_OR2_N, OP_IF_OR2_N_N, - OP_IF_PP, OP_IF_PPP, OP_IF_PN, OP_IF_PR, OP_IF_PRR, OP_WHEN_PP, OP_UNLESS_PP, - - OP_COND_NA_NA, OP_COND_NA_NP, OP_COND_NA_NP_1, OP_COND_NA_2E, OP_COND_NA_3E, OP_COND_NA_NP_O, - OP_COND_FEED, OP_COND_FEED_1, - - OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP, OP_SAFE_DOTIMES_STEP_O, - OP_SAFE_DO, OP_SAFE_DO_STEP, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_O, OP_DOX_NO_BODY, OP_DOX_PENDING_NO_BODY, OP_DOX_INIT, - OP_DOTIMES_P, OP_DOTIMES_STEP_O, - OP_DO_NO_VARS, OP_DO_NO_VARS_NO_OPT, OP_DO_NO_VARS_NO_OPT_1, - OP_DO_NO_BODY_NA_VARS, OP_DO_NO_BODY_NA_VARS_STEP, OP_DO_NO_BODY_NA_VARS_STEP_1, - - OP_SAFE_C_P_1, OP_SAFE_C_PP_1, OP_SAFE_C_PP_3_MV, OP_SAFE_C_PP_5, OP_SAFE_C_PP_6_MV, - OP_SAFE_C_3P_1, OP_SAFE_C_3P_2, OP_SAFE_C_3P_3, OP_SAFE_C_3P_1_MV, OP_SAFE_C_3P_2_MV, OP_SAFE_C_3P_3_MV, - OP_SAFE_C_SP_1, OP_SAFE_C_SP_MV, OP_SAFE_CONS_SP_1, OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1, - OP_SAFE_C_PS_1, OP_SAFE_C_PC_1, OP_SAFE_C_PS_MV, OP_SAFE_C_PC_MV, - OP_EVAL_MACRO_MV, OP_MACROEXPAND_1, OP_APPLY_LAMBDA, - OP_ANY_C_NP_1, OP_ANY_C_NP_MV, OP_SAFE_C_SSP_1, OP_SAFE_C_SSP_MV, - OP_C_P_1, OP_C_P_MV, OP_C_AP_1, OP_C_AP_MV, OP_ANY_C_NP_2, OP_SAFE_C_PA_1, OP_SAFE_C_PA_MV, - OP_SET_WITH_LET_1, OP_SET_WITH_LET_2, - - OP_CLOSURE_AP_1, OP_CLOSURE_PA_1, OP_CLOSURE_PP_1, OP_CLOSURE_P_1, - OP_SAFE_CLOSURE_P_1, OP_SAFE_CLOSURE_P_A_1, OP_SAFE_CLOSURE_AP_1, OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_PP_1, - OP_ANY_CLOSURE_3P_1, OP_ANY_CLOSURE_3P_2, OP_ANY_CLOSURE_3P_3, OP_ANY_CLOSURE_NP_1, OP_ANY_CLOSURE_NP_MV, - OP_ANY_CLOSURE_4P_1, OP_ANY_CLOSURE_4P_2, OP_ANY_CLOSURE_4P_3, OP_ANY_CLOSURE_4P_4, OP_ANY_CLOSURE_NP_2, - - OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA, OP_TC_OR_A_AND_A_LAA, OP_TC_AND_A_OR_A_L3A, OP_TC_OR_A_AND_A_L3A, - OP_TC_OR_A_A_AND_A_A_LA, OP_TC_OR_A_AND_A_A_L3A, OP_TC_AND_A_OR_A_A_LA, OP_TC_OR_A_AND_A_A_LA, - OP_TC_WHEN_LA, OP_TC_WHEN_LAA, OP_TC_WHEN_L3A, OP_TC_LET_WHEN_LAA, OP_TC_LET_UNLESS_LAA, - OP_TC_COND_A_Z_A_Z_LAA, OP_TC_COND_A_Z_A_LAA_Z, OP_TC_COND_A_Z_A_LAA_LAA, OP_TC_LET_COND, - OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_Z_L3A, OP_TC_IF_A_L3A_Z, OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z, - OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_IF_A_Z_IF_A_LAA_Z, OP_TC_IF_A_Z_IF_A_L3A_L3A, - OP_TC_COND_A_Z_A_Z_LA, OP_TC_COND_A_Z_A_LA_Z, OP_TC_COND_A_Z_LA, OP_TC_COND_A_LA_Z, OP_TC_COND_A_Z_LAA, OP_TC_COND_A_LAA_Z, - OP_TC_LET_IF_A_Z_LA, OP_TC_LET_IF_A_Z_LAA, OP_TC_IF_A_Z_LET_IF_A_Z_LAA, - OP_TC_CASE_LA, OP_TC_AND_A_IF_A_Z_LA, OP_TC_AND_A_IF_A_LA_Z, - - OP_RECUR_IF_A_A_opA_LAq, OP_RECUR_IF_A_opA_LAq_A, OP_RECUR_IF_A_A_opLA_Aq, OP_RECUR_IF_A_opLA_Aq_A, - OP_RECUR_IF_A_A_opLA_LAq, OP_RECUR_IF_A_opLA_LAq_A, - OP_RECUR_IF_A_A_opA_LA_LAq, OP_RECUR_IF_A_opA_LA_LAq_A, - OP_RECUR_IF_A_A_opLA_LA_LAq, OP_RECUR_IF_A_A_IF_A_A_opLA_LAq, OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq, - OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A, OP_RECUR_IF_A_A_opA_L3Aq, - OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq, OP_RECUR_IF_A_A_AND_A_LAA_LAA, - OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq, /* same as cond case below */ - OP_RECUR_COND_A_A_opA_LAq, OP_RECUR_COND_A_A_opA_LAAq, - OP_RECUR_COND_A_A_A_A_opLA_LAq, OP_RECUR_COND_A_A_A_A_opLAA_LAAq, OP_RECUR_COND_A_A_A_A_opA_LAAq, - OP_RECUR_COND_A_A_A_LAA_LopA_LAAq, OP_RECUR_COND_A_A_A_LAA_opA_LAAq, - OP_RECUR_AND_A_OR_A_LAA_LAA, - - NUM_OPS}; - -#define is_tc_op(Op) ((Op >= OP_TC_AND_A_OR_A_LA) && (Op <= OP_TC_CASE_LA)) - -typedef enum{E_C_P, E_C_PP, E_C_CP, E_C_SP, E_C_PC, E_C_PS} combine_op_t; - -static const char* op_names[NUM_OPS] = - { - "unopt", "gc_protect", - - "safe_c_nc", "h_safe_c_nc", "safe_c_s", "h_safe_c_s", - "safe_c_ss", "h_safe_c_ss", "safe_c_sc", "h_safe_c_sc", "safe_c_cs", "h_safe_c_cs", "safe_c_cq", "h_safe_c_cq", - "safe_c_sss", "h_safe_c_sss", "safe_c_scs", "h_safe_c_scs", "safe_c_ssc", "h_safe_c_ssc", "safe_c_css", "h_safe_c_css", - "safe_c_scc", "h_safe_c_scc", "safe_c_csc", "h_safe_c_csc", "safe_c_ccs", "h_safe_c_ccs", - "safe_c_ns", "h_safe_c_ns", "safe_c_opncq", "h_safe_c_opncq", "safe_c_opsq", "h_safe_c_opsq", - "safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq", - "safe_c_opcsq", "h_safe_c_opcsq", "safe_c_s_opsq", "h_safe_c_s_opsq", - "safe_c_c_opscq", "h_safe_c_c_opscq", "safe_c_s_opscq", "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq", - "safe_c_opsq_s", "h_safe_c_opsq_s", "safe_c_opsq_c", "h_safe_c_opsq_c", - "safe_c_opsq_opsq", "h_safe_c_opsq_opsq", "safe_c_s_opssq", "h_safe_c_s_opssq", "safe_c_c_opsq", "h_safe_c_c_opsq", - "safe_c_opcsq_c", "h_safe_c_opcsq_c", "safe_c_opssq_c", "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq", - "safe_c_opssq_opssq", "h_safe_c_opssq_opssq", "safe_c_opssq_opsq", "h_safe_c_opssq_opsq", "safe_c_opsq_opssq", "h_safe_c_opsq_opssq", - "safe_c_opssq_s", "h_safe_c_opssq_s", "safe_c_opcsq_s", "h_safe_c_opcsq_s", "safe_c_opscq_c", "h_safe_c_opscq_c", - "safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s", "safe_c_op_opsqq", "h_safe_c_op_opsqq", - "safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq", "h_safe_c_op_opsq_sq", "safe_c_opsq_cs", "h_safe_c_opsq_cs", - - "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_sa", "h_safe_c_sa", "safe_c_as", "h_safe_c_as", - "safe_c_ca", "h_safe_c_ca", "safe_c_ac", "h_safe_c_ac", "safe_c_aaa", "h_safe_c_aaa", "safe_c_4a", "h_safe_c_4a", - "safe_c_na", "h_safe_c_na", "safe_c_all_ca", "h_safe_c_all_ca", - "safe_c_ssa", "h_safe_c_ssa", "safe_c_sas", "h_safe_c_sas", "safe_c_saa", "h_safe_c_saa", - "safe_c_csa", "h_safe_c_csa", "safe_c_sca", "h_safe_c_sca", "safe_c_ass", "h_safe_c_ass", - "safe_c_cac", "h_safe_c_cac", "safe_c_agg", "h_safe_c_agg", - "safe_c_opaq", "h_safe_c_opaq", "safe_c_opaaq", "h_safe_c_opaaq", "safe_c_opaaaq", "h_safe_c_opaaaq", - "safe_c_s_opaq", "h_safe_c_s_opaq", "safe_c_opaq_s", "h_safe_c_opaq_s", "safe_c_s_opaaq", "h_safe_c_s_opaaq", - "safe_c*", "h_safe_c*", "safe_c*_a", "h_safe_c*_a", "safe_c*_aa", "h_safe_c*_aa", "safe_c*_na", "h_safe_c*_na", - - "safe_c_p", "h_safe_c_p", "safe_c_pp", "h_safe_c_pp", "safe_c_ff", "h_safe_c_ff", "safe_c_sp", "h_safe_c_sp", - "safe_c_cp", "h_safe_c_cp", "safe_c_ap", "h_safe_c_ap", "safe_c_pa", "h_safe_c_pa", "safe_c_ps", "h_safe_c_ps", - "safe_c_pc", "h_safe_c_pc", "safe_c_ssp", "h_safe_c_ssp", "any_c_np", "h_any_c_np", "safe_c_3p", "h_safe_c_3p", - - "thunk", "h_thunk", "thunk_o", "h_thunk_o", "thunk_any", "h_thunk_any", - "safe_thunk", "h_safe_thunk", "safe_thunk_a", "h_safe_thunk_a", "safe_thunk_any", "h_safe_thunk_any", - - "closure_s", "h_closure_s", "closure_s_o", "h_closure_s_o", - "closure_a", "h_closure_a", "closure_a_o", "h_closure_a_o", "closure_p", "h_closure_p", - "closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa", "closure_pp", "h_closure_pp", - "closure_fa", "h_closure_fa", "closure_ss", "h_closure_ss", "closure_ss_o", "h_closure_ss_o", - "closure_sc", "h_closure_sc", "closure_sc_o", "h_closure_sc_o", - "closure_3s", "h_closure_3s", "closure_3s_o", "h_closure_3s_o", "closure_4s", "h_closure_4s", "closure_4s_o", "h_closure_4s_o", - "closure_aa", "h_closure_aa", "closure_aa_o", "h_closure_aa_o", "closure_3a", "h_closure_3a", "closure_4a", "h_closure_4a", - "closure_na", "h_closure_na", "closure_ass", "h_closure_ass", "closure_sas", "h_closure_sas ","closure_aas", "h_closure_aas", - "closure_saa", "h_closure_saa", "closure_asa", "h_closure_asa", "closure_ns", "h_closure_ns", - - "safe_closure_s", "h_safe_closure_s", "safe_closure_s_o", "h_safe_closure_s_o", - "safe_closure_s_a", "h_safe_closure_s_a", "safe_closure_s_to_s", "h_safe_closure_s_to_s", "safe_closure_s_to_sc", "h_safe_closure_s_to_sc", - "safe_closure_p", "h_safe_closure_p", "safe_closure_p_a", "h_safe_closure_p_a", - "safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", "h_safe_closure_pa", "safe_closure_pp", "h_safe_closure_pp", - "safe_closure_a", "h_safe_closure_a", "safe_closure_a_o", "h_safe_closure_a_o", "safe_closure_a_a", "h_safe_closure_a_a", - "safe_closure_a_to_sc", "h_safe_closure_a_to_sc", - "safe_closure_ss", "h_safe_closure_ss", "safe_closure_ss_o", "h_safe_closure_ss_o", "safe_closure_ss_a", "h_safe_closure_ss_a", - "safe_closure_sc", "h_safe_closure_sc", "safe_closure_sc_o", "h_safe_closure_sc_o", - "safe_closure_aa", "h_safe_closure_aa", "safe_closure_aa_o", "h_safe_closure_aa_o", "safe_closure_aa_a", "h_safe_closure_aa_a", - "safe_closure_saa", "h_safe_closure_saa", "safe_closure_ssa", "h_safe_closure_ssa", - "safe_closure_agg", "h_safe_closure_agg", "safe_closure_3a", "h_safe_closure_3a", "safe_closure_na", "h_safe_closure_na", - "safe_closure_3s", "h_safe_closure_3s", "safe_closure_ns", "h_safe_closure_ns", - "safe_closure_3s_a", "h_safe_closure_3s_a", - - "any_closure_3p", "h_any_closure_3p", "any_closure_4p", "h_any_closure_4p", "any_closure_np", "h_any_closure_np", - "any_closure_sym", "h_any_closure_sym", "any_closure_a_sym", "h_any_closure_a_sym", - - "closure*_a", "h_closure*_a", "closure*_na", "h_closure*_na", - "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", "h_safe_closure*_aa", - "safe_closure*_aa_o", "h_safe_closure*_aa_o", "safe_closure*_a1", "h_safe_closure*_a1", - "safe_closure*_ka", "h_safe_closure*_ka", "closure*_ka", "h_closure*_ka", "safe_closure*_3a", "h_safe_closure*_3a", - "safe_closure*_na", "h_safe_closure*_na", "safe_closure*_na_0", "h_safe_closure*_na_0", - "safe_closure*_na_1", "h_safe_closure*_na_1", "safe_closure*_na_2", "h_safe_closure*_na_2", - - "c_ss", "h_c_ss", "c_s", "h_c_s", "read_s", "h_read_s", "c_p", "h_c_p", "c_ap", "h_c_ap", - "c_a", "h_c_a", "c_aa", "h_c_aa", "c", "h_c", "c_na", "h_c_na", - - "cl_s", "h_cl_s", "cl_ss", "h_cl_ss", "cl_a", "h_cl_a", "cl_aa", "h_cl_aa", - "cl_na", "h_cl_na", "cl_fa", "h_cl_fa", "cl_sas", "h_cl_sas", - - "apply_ss", "apply_sa", "apply_sl", "macro_d", "macro*_d", - "with_input_from_string", "with_input_from_string_1", "with_output_to_string", "with_input_from_string_c", "call_with_output_string", - "s", "s_g", "s_a", "s_aa", "a_a", "a_aa", "p_s", "p_s_1", "map_for_each_fa", "map_for_each_faa", - "f", "f_a", "f_aa", "f_np", "f_np_1", - - "implicit_goto", "implicit_goto_a", "implicit_continuation_a","implicit_iterate", - "implicit_vector_ref_a", "implicit_vector_ref_aa", "implicit_vector_set_3", "implicit_vector_set_4", - "implicit_string_ref_a", "implicit_c_object_ref_a", "implicit_pair_ref_a", "implicit_pair_ref_aa", - "implicit_hash_table_ref_a", "implicit_hash_table_ref_aa", - "implicit_let_ref_c", "implicit_let_ref_a", "implicit_*s7*_ref_s", "implicit_*s7*_set", - "unknown_thunk", "unknown_ns", "unknown_na", "unknown_s", "unknown_gg", "unknown_a", "unknown_aa", "unknown_np", - - "symbol", "constant", "pair_sym", "pair_pair", "pair_any", "h_hash_table_increment", "clear_opts", - - "read_internal", "eval", "eval_args", "eval_args1", "eval_args2", "eval_args3", "eval_args4", "eval_args5", - "apply", "eval_macro", "lambda", "quote", "quote_unchecked", "macroexpand", "call/cc", "call_with_exit", "call_with_exit_o", - "c_catch", "c_catch_all", "c_catch_all_o", "c_catch_all_a", - - "define", "define1", "begin", "begin_hook", "begin_no_hook", "begin_unchecked", "begin_2_unchecked", "begin_na", "begin_aa", - "if", "if1", "when", "unless", "set", "set1", "set2", - "let", "let1", "let*", "let*1", "let*2", "let*-shadowed", - "letrec", "letrec1", "letrec*", "letrec*1", - "let_temporarily", "let_temp_unchecked", "let_temp_init1", "let_temp_init2", "let_temp_done", "let_temp_done1", - "let_temp_s7", "let_temp_na", "let_temp_a", "let_temp_setter", "let_temp_unwind", "let_temp_s7_unwind", "let_temp_setter_unwind", - "let_temp_a_a", "let_temp_s7_direct", "let_temp_s7_direct_unwind", - "cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple", "cond_simple_o", "cond1_simple_o", - "and", "or", - "define_macro", "define_macro*", "define_expansion", "define_expansion*", "macro", "macro*", - "case", "read_list", "read_next", "read_dot", "read_quote", - "read_quasiquote", "read_unquote", "read_apply_values", - "read_vector", "read_byte_vector", "read_int_vector", "read_float_vector", "read_done", - "load_return_if_eof", "load_close_and_pop_if_eof", "eval_done", "splice_values", "no_values", - "catch", "dynamic_wind", "dynamic_unwind", "dynamic_unwind_profile", "profile_in", - "define_constant", "define_constant1", - "do", "do_end", "do_end1", "do_step", "do_step2", "do_init", - "define*", "lambda*", "lambda*_default", "error_quit", "unwind_input", "unwind_output", "error_hook_quit", - "with_let", "with_let1", "with_let_unchecked", "with_let_s", - "with_baffle", "with_baffle_unchecked", "expansion", - "for_each", "for_each_1", "for_each_2", "for_each_3", - "map", "map_1", "map_2", "map_gather", "map_gather_1", "map_gather_2", "map_gather_3", "map_unwind", - "barrier", "deactivate_goto", - "define_bacro", "define_bacro*", "bacro", "bacro*", - "get_output_string", - "sort", "sort1", "sort2", "sort3", "sort_pair_end", "sort_vector_end", "sort_string_end", - "eval_string", - "member_if", "assoc_if", "member_if1", "assoc_if1", - "lambda_unchecked", "let_unchecked", "catch_1", "catch_2", "catch_all", - "set_unchecked", "set_s_c", "set_s_s", "set_s_p", "set_a", - "set_normal", "set_opsq_a", "set_opsaq_a", "set_opsaq_p", "set_opsaq_p_1", "set_opsaaq_a", "set_opsaaq_p", "set_opsaaq_p_1", - "set_from_setter", "set_from_let_temp", "set_safe", - "increment_1", "decrement_1", "increment_sa", "increment_saa", "set_cons", - "letrec_unchecked", "letrec*_unchecked", "cond_unchecked", - "lambda*_unchecked", "do_unchecked", "define_unchecked", "define*_unchecked", "define_funchecked", "define_constant_unchecked", - "define_with_setter", - - "let_no_vars", "named_let", "named_let_no_vars", "named_let_a", "named_let_aa", "named_let_na", "named_let*", - "let_na_old", "let_na_new", "let_2a_old", "let_2a_new", "let_3a_old", "let_3a_new", - "let_opassq_old", "let_opassq_new", "let_one_old", "let_one_new", "let_one_p_old", "let_one_p_new", - "let_one_old_1", "let_one_new_1", "let_one_p_old_1", "let_one_p_new_1", - "let_a_old", "let_a_new", "let_a_p_old", "let_a_p_new", - "let_a_a_old", "let_a_a_new", "let_a_na_old", "let_a_na_new", "let_a_old_2", "let_a_new_2", - "let*_na", "let*_na_a", - - "case_a_e_s", "case_a_i_s", "case_a_g_s", "case_a_e_g", "case_a_g_g", "case_a_s_g", - "case_p_e_s", "case_p_i_s", "case_p_g_s", "case_p_e_g", "case_p_g_g", - "case_e_s", "case_i_s", "case_g_s", "case_e_g", "case_g_g", - "case_a_i_s_a", "case_a_e_s_a", "case_a_g_s_a", "case_a_s_g_a", - - "if_unchecked", "and_p", "and_p1", "and_ap", "and_pair_p", - "and_safe_p1", "op_and_safe_p2", "and_safe_p3", "and_safe_p_rest", "and_2a", "and_3a", "and_n", "and_s_2", - "or_p", "or_p1", "or_ap", "or_2a", "or_3a", "or_n", "or_s_2", "or_s_type_2", - "when_s", "when_a", "when_p", "when_and_ap", "when_and_2a", "when_and_3a", "unless_s", "unless_a", "unless_p", - - "if_a_c_c", "if_a_a", "if_a_a_a", "if_s_a_a", "if_and2_s_a", "if_not_a_a", "if_not_a_a_a", - "if_b_a", "if_b_p", "if_b_r", "if_b_a_p", "if_b_p_a", "if_b_p_p", "if_b_n_n", - "if_a_a_p", "if_a_p_a", "if_s_p_a", "if_s_a_p", "if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n", - "if_opsq_p", "if_opsq_p_p", "if_opsq_r", "if_opsq_n", "if_opsq_n_n", - "if_is_type_s_p", "if_is_type_s_p_p", "if_is_type_s_r", "if_is_type_s_n", "if_is_type_s_n_n", "if_is_type_s_p_a", "if_is_type_s_a_a", "if_is_type_s_a_p", - "if_a_p", "if_a_p_p", "if_a_r", "if_a_n", "if_a_n_n", - "if_and2_p", "if_and2_p_p", "if_and2_r", "if_and2_n", "if_and2_n_n", - "if_and3_p", "if_and3_p_p", "if_and3_r", "if_and3_n", "if_and3_n_n", - "if_p_p", "if_p_p_p", "if_p_r", "if_p_n", "if_p_n_n", - "if_andp_p", "if_andp_p_p", "if_andp_r", "if_andp_n", "if_andp_n_n", - "if_orp_p", "if_orp_p_p", "if_orp_r", "if_orp_n", "if_orp_n_n", - "if_or2_p", "if_or2_p_p", "if_or2_r", "if_or2_n", "if_or2_n_n", - "if_pp", "if_ppp", "if_pn", "if_pr", "if_prr", "when_pp", "unless_pp", - - "cond_na_na", "cond_na_np", "cond_na_np_1", "cond_na_2e", "cond_na_3e", "cond_na_np_o", - "cond_feed", "cond_feed_1", - - "simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", "safe_dotimes_step_o", - "safe_do", "safe_do_step", "dox", "dox_step", "dox_step_o", "dox_no_body", "dox_pending_no_body", "dox_init", - "dotimes_p", "dotimes_step_o", - "do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1", - "do_no_body_na_vars", "do_no_body_na_vars_step", "do_no_body_na_vars_step_1", - - "safe_c_p_1", "safe_c_pp_1", "safe_c_pp_3_mv", "safe_c_pp_5", "safe_c_pp_6_mv", - "safe_c_3p_1", "safe_c_3p_2", "safe_c_3p_3", "safe_c_3p_1_mv", "safe_c_3p_2_mv", "safe_c_3p_3_mv", - "safe_c_sp_1", "safe_c_sp_mv", "safe_cons_sp_1", "safe_add_sp_1", "safe_multiply_sp_1", - "safe_c_ps_1", "safe_c_pc_1", "safe_c_ps_mv", "safe_c_pc_mv", - "eval_macro_mv", "macroexpand_1", "apply_lambda", - "any_c_np_1", "any_c_np_mv", "safe_c_ssp_1", "safe_c_ssp_mv", - "c_p_1", "c_p_mv", "c_ap_1", "c_ap_mv", "any_c_np_2", "safe_c_pa_1", "safe_c_pa_mv", - "set_with_let_1", "set_with_let_2", - - "closure_ap_1", "closure_pa_1", "closure_pp_1", "closure_p_1", - "safe_closure_p_1", "safe_closure_p_a_1", "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_pp_1", - "any_closure_3p_1", "any_closure_3p_2", "any_closure_3p_3", "any_closure_np_1", "any_closure_np_mv", - "any_closure_4p_1", "any_closure_4p_2", "any_closure_4p_3", "any_closure_4p_4", "any_closure_np_2", - - "tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_laa", "tc_or_a_and_a_laa", "tc_and_a_or_a_l3a", "tc_or_a_and_a_l3a", - "tc_or_a_a_and_a_a_la", "tc_or_a_and_a_a_l3a", "tc_and_a_or_a_a_la", "tc_or_a_and_a_a_la", - "tc_when_la", "tc_when_laa", "tc_when_l3a", "tc_let_when_laa", "tc_let_unless_laa", - "tc_cond_a_z_a_z_laa", "tc_cond_a_z_a_laa_z", "tc_cond_a_z_a_laa_laa", "tc_let_cond", - "tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_z_l3a", "tc_if_a_l3a_z", "tc_if_a_la_z", "tc_if_a_laa_z", - "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa", "tc_if_a_z_if_a_laa_z", "tc_if_a_z_if_a_l3a_l3a", - "tc_cond_a_z_a_z_la", "tc_cond_a_z_a_la_z", "tc_cond_a_z_la", "tc_cond_a_la_z", "tc_cond_a_z_laa", "tc_cond_a_laa_z", - "tc_let_if_a_z_la", "tc_let_if_a_z_laa", "if_a_z_let_if_a_z_laa", - "tc_case_la", "tc_and_a_if_a_z_la", "tc_and_a_if_a_la_z", - - "recur_if_a_a_opa_laq", "recur_if_a_opa_laq_a", "recur_if_a_a_opla_aq", "recur_if_a_opla_aq_a", - "recur_if_a_a_opla_laq", "recur_if_a_opla_laq_a", - "recur_if_a_a_opa_la_laq", "recur_if_a_opa_la_laq_a", - "recur_if_a_a_opla_la_laq", "recur_if_a_a_if_a_a_opla_laq", "recur_if_a_a_if_a_a_oplaa_laaq", - "recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a", "recur_if_a_a_opa_l3aq", - "recur_if_a_a_lopl3a_l3a_l3aq", "recur_if_a_a_and_a_laa_laa", - "recur_if_a_a_if_a_laa_opa_laaq", - "recur_cond_a_a_op_a_laq", "recur_cond_a_a_op_a_laaq", - "recur_cond_a_a_a_a_opla_laq", "recur_cond_a_a_a_a_oplaa_laaq", "recur_cond_a_a_a_a_opa_laaq", - "recur_cond_a_a_a_laa_lopa_laaq", "recur_cond_a_a_a_laa_opa_laaq", - "recur_and_a_or_a_laa_laa", -}; - -#define is_safe_c_op(op) ((op >= OP_SAFE_C_NC) && (op < OP_THUNK)) -#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_NP)) -#define is_h_safe_c_nc(P) (optimize_op(P) == HOP_SAFE_C_NC) -#define is_safe_c_s(P) ((optimize_op(P) == OP_SAFE_C_S) || (optimize_op(P) == HOP_SAFE_C_S)) -#define is_h_safe_c_s(P) (optimize_op(P) == HOP_SAFE_C_S) -#define FIRST_UNHOPPABLE_OP OP_APPLY_SS - -static bool is_h_optimized(s7_pointer p) -{ - return((is_optimized(p)) && - (op_has_hop(p)) && - (optimize_op(p) < FIRST_UNHOPPABLE_OP) && /* was OP_S? */ - (optimize_op(p) > OP_GC_PROTECT)); -} - -static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e); -static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int len); -static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b); -static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym); -static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article); - -/* if this changes, remember to change lint.scm */ -typedef enum {SL_NO_FIELD=0, SL_STACK_TOP, SL_STACK_SIZE, SL_STACKTRACE_DEFAULTS, SL_HEAP_SIZE, SL_FREE_HEAP_SIZE, - SL_GC_FREED, SL_GC_PROTECTED_OBJECTS, SL_GC_TOTAL_FREED, SL_GC_INFO, SL_FILE_NAMES, SL_FILENAMES, SL_ROOTLET_SIZE, SL_C_TYPES, - SL_SAFETY, SL_UNDEFINED_IDENTIFIER_WARNINGS, SL_UNDEFINED_CONSTANT_WARNINGS, SL_GC_STATS, SL_MAX_HEAP_SIZE, - SL_MAX_PORT_DATA_SIZE, SL_MAX_STACK_SIZE, SL_CPU_TIME, SL_CATCHES, SL_STACK, SL_MAJOR_VERSION, SL_MINOR_VERSION, - SL_MAX_STRING_LENGTH, SL_MAX_FORMAT_LENGTH, SL_MAX_LIST_LENGTH, SL_MAX_VECTOR_LENGTH, SL_MAX_VECTOR_DIMENSIONS, - SL_DEFAULT_HASH_TABLE_LENGTH, SL_INITIAL_STRING_PORT_LENGTH, SL_DEFAULT_RATIONALIZE_ERROR, - SL_DEFAULT_RANDOM_STATE, SL_EQUIVALENT_FLOAT_EPSILON, SL_HASH_TABLE_FLOAT_EPSILON, SL_PRINT_LENGTH, - SL_BIGNUM_PRECISION, SL_MEMORY_USAGE, SL_FLOAT_FORMAT_PRECISION, SL_HISTORY, SL_HISTORY_ENABLED, - SL_HISTORY_SIZE, SL_PROFILE, SL_PROFILE_INFO, SL_PROFILE_PREFIX, SL_AUTOLOADING, SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, - SL_MUFFLE_WARNINGS, SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM, SL_OUTPUT_PORT_DATA_SIZE, SL_DEBUG, SL_VERSION, - SL_GC_TEMPS_SIZE, SL_GC_RESIZE_HEAP_FRACTION, SL_GC_RESIZE_HEAP_BY_4_FRACTION, SL_OPENLETS, SL_EXPANSIONS, - SL_NUMBER_SEPARATOR, SL_NUM_FIELDS} s7_starlet_t; - -static const char *s7_starlet_names[SL_NUM_FIELDS] = - {"no-field", "stack-top", "stack-size", "stacktrace-defaults", "heap-size", "free-heap-size", - "gc-freed", "gc-protected-objects", "gc-total-freed", "gc-info", "file-names", "filenames", "rootlet-size", "c-types", - "safety", "undefined-identifier-warnings", "undefined-constant-warnings", "gc-stats", "max-heap-size", - "max-port-data-size", "max-stack-size", "cpu-time", "catches", "stack", "major-version", "minor-version", - "max-string-length", "max-format-length", "max-list-length", "max-vector-length", "max-vector-dimensions", - "default-hash-table-length", "initial-string-port-length", "default-rationalize-error", - "default-random-state", "equivalent-float-epsilon", "hash-table-float-epsilon", "print-length", - "bignum-precision", "memory-usage", "float-format-precision", "history", "history-enabled", - "history-size", "profile", "profile-info", "profile-prefix", "autoloading?", "accept-all-keyword-arguments", - "muffle-warnings?", "most-positive-fixnum", "most-negative-fixnum", "output-port-data-size", "debug", "version", - "gc-temps-size", "gc-resize-heap-fraction", "gc-resize-heap-by-4-fraction", "openlets", "expansions?", - "number-separator"}; - - -/* -------------------------------- internal debugging apparatus -------------------------------- */ -static int64_t heap_location(s7_scheme *sc, s7_pointer p) -{ - for (heap_block_t *hp = sc->heap_blocks; hp; hp = hp->next) - if (((intptr_t)p >= hp->start) && ((intptr_t)p < hp->end)) - return(hp->offset + (((intptr_t)p - hp->start) / sizeof(s7_cell))); - return(((s7_big_pointer)p)->big_hloc); -} - -#if TRAP_SEGFAULT -#include -static Jmp_Buf senv; /* global here is not a problem -- it is used only to protect s7_is_valid */ -static volatile sig_atomic_t can_jump = 0; -static void segv(int32_t unused) {if (can_jump) LongJmp(senv, 1);} -#endif - -bool s7_is_valid(s7_scheme *sc, s7_pointer arg) -{ - bool result = false; - if (!arg) return(false); - { - s7_pointer heap0 = *(sc->heap); - s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); - if ((arg >= heap0) && (arg < heap1)) return(true); - } -#if TRAP_SEGFAULT - if (SetJmp(senv, 1) == 0) - { - void (*old_segv)(int32_t sig); - can_jump = 1; - old_segv = signal(SIGSEGV, segv); -#endif - if ((unchecked_type(arg) > T_FREE) && - (unchecked_type(arg) < NUM_TYPES)) - { - if (!in_heap(arg)) - result = true; - else - { - int64_t loc = heap_location(sc, arg); - if ((loc >= 0) && (loc < sc->heap_size)) - result = (sc->heap[loc] == arg); - }} -#if TRAP_SEGFAULT - signal(SIGSEGV, old_segv); - } - else result = false; - can_jump = 0; -#endif - return(result); -} - -#define safe_print(Code) \ - do { \ - bool old_open = sc->has_openlets, old_stop = sc->stop_at_error; \ - sc->has_openlets = false; \ - sc->stop_at_error = false; \ - Code; \ - sc->stop_at_error = old_stop; \ - sc->has_openlets = old_open; \ - } while (0) - -void s7_show_history(s7_scheme *sc) -{ -#if WITH_HISTORY - if (sc->cur_code == sc->history_sink) - fprintf(stderr, "history diabled\n"); - else - { - int32_t size = sc->history_size; - s7_pointer p = cdr(sc->cur_code); - fprintf(stderr, "history:\n"); - for (int32_t i = 0; i < size; i++, p = cdr(p)) /* stepper "i" is not redundant */ - safe_print(fprintf(stderr, "%d: %s\n", i, display_80(car(p)))); - fprintf(stderr, "\n"); - } -#else - fprintf(stderr, "%s\n", display(sc->cur_code)); -#endif -} - -#define stack_code(Stack, Loc) stack_element(Stack, Loc - 3) -#define stack_let(Stack, Loc) stack_element(Stack, Loc - 2) -#define stack_args(Stack, Loc) stack_element(Stack, Loc - 1) -#define stack_op(Stack, Loc) ((opcode_t)(stack_element(Stack, Loc))) - -void s7_show_stack(s7_scheme *sc) -{ - fprintf(stderr, "stack:\n"); - for (int64_t i = current_stack_top(sc) - 1; i >= 3; i -= 4) - fprintf(stderr, " %s\n", op_names[stack_op(sc->stack, i)]); -} - -#if S7_DEBUGGING -#define UNUSED_BITS 0xfc00000000c0 /* high 6 bits of optimizer code + high 2 bits of type */ - -static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) /* used outside S7_DEBUGGING in display_fallback (for display_functions) */ -{ - uint64_t full_typ = full_type(obj); - uint8_t typ = unchecked_type(obj); - char *buf; - char str[900]; - - str[0] = '\0'; - catstrs(str, 900, /* if debugging, all of these bits are being watched, so we need to access them directly */ - /* bit 8 (the first 8 bits (after the 8 type bits) are easy...) */ - ((full_typ & T_MULTIFORM) != 0) ? ((is_any_closure(obj)) ? - (((full_typ & T_ONE_FORM) != 0) ? " closure-one-form-has-fx" : " closure-multiform") : - " ?0?") : "", - /* bit 9 */ - ((full_typ & T_SYNTACTIC) != 0) ? (((is_pair(obj)) || (is_syntax(obj)) || (is_normal_symbol(obj))) ? - " syntactic" : - " ?1?") : "", - /* bit 10 */ - ((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) ? ((is_pair(obj)) ? " simple-args|in-use" : - ((is_any_closure(obj)) ? " closure-one-form" : - " ?2?")) : "", - /* bit 11 */ - ((full_typ & T_OPTIMIZED) != 0) ? ((is_c_function(obj)) ? " scope-safe" : - ((is_pair(obj)) ? " optimized" : - " ?3?")) : "", - /* bit 12 */ - ((full_typ & T_SAFE_CLOSURE) != 0) ? (((has_closure_let(obj)) || (is_pair(obj))) ? " safe-closure" : " ?4?") : "", - /* bit 13 */ - ((full_typ & T_DONT_EVAL_ARGS) != 0) ? (((is_any_macro(obj)) || (is_syntax(obj))) ? " dont-eval-args" : " ?5?") : "", - /* bit 14 */ - ((full_typ & T_EXPANSION) != 0) ? (((is_normal_symbol(obj)) || (is_either_macro(obj))) ? " expansion" : " ?6?") : "", - /* bit 15 */ - ((full_typ & T_MULTIPLE_VALUE) != 0) ? ((is_symbol(obj)) ? " matched" : - ((is_pair(obj)) ? " values|matched" : - " ?7?")) : "", - /* bit 16 */ - ((full_typ & T_GLOBAL) != 0) ? ((is_pair(obj)) ? " unsafe-do" : - (((is_symbol(obj)) || (is_syntax(obj))) ? " global" : - ((is_let(obj)) ? " dox_slot1" : - " ?8?"))) : "", - /* bit 17 */ - ((full_typ & T_COLLECTED) != 0) ? " collected" : "", - /* bit 18 */ - ((full_typ & T_LOCATION) != 0) ? ((is_pair(obj)) ? " line-number" : - ((is_input_port(obj)) ? " loader-port" : - ((is_let(obj)) ? " with-let" : - ((is_any_procedure(obj)) ? " simple-defaults" : - ((is_slot(obj)) ? " has-setter" : - " ?10?"))))) : "", - /* bit 19 */ - ((full_typ & T_SHARED) != 0) ? ((is_sequence(obj)) ? " shared" : " ?11?") : "", - /* bit 20 */ - ((full_typ & T_LOCAL) != 0) ? ((is_normal_symbol(obj)) ? " local" : - ((is_pair(obj)) ? " high-c" : - " ?12?")) : "", - /* bit 21 */ - ((full_typ & T_SAFE_PROCEDURE) != 0) ? ((is_applicable(obj)) ? " safe-procedure" : " ?13?") : "", - /* bit 22 */ - ((full_typ & T_CHECKED) != 0) ? (((is_pair(obj)) || (is_slot(obj))) ? " checked" : - ((is_symbol(obj)) ? " all-integer" : - " ?14?")) : "", - /* bit 23 */ - ((full_typ & T_UNSAFE) != 0) ? ((is_symbol(obj)) ? " clean-symbol" : - ((is_slot(obj)) ? " has-stepper" : - ((is_pair(obj)) ? " unsafely-opt|no-float-opt" : - ((is_let(obj)) ? " dox-slot2" : - " ?15?")))) : "", - /* bit 24 */ - ((full_typ & T_IMMUTABLE) != 0) ? " immutable" : "", - /* bit 25 */ - ((full_typ & T_SETTER) != 0) ? ((is_normal_symbol(obj)) ? " setter" : - ((is_pair(obj)) ? " allow-other-keys|no-int-opt" : - ((is_slot(obj)) ? " has-expression" : - ((is_c_function_star(obj)) ? " allow-other-keys" : - " ?17?")))) : "", - /* bit 26 */ - ((full_typ & T_MUTABLE) != 0) ? ((is_number(obj)) ? " mutable" : - ((is_symbol(obj)) ? " has-keyword" : - ((is_let(obj)) ? " ref-fallback" : - ((is_iterator(obj)) ? " mark-sequence" : - ((is_slot(obj)) ? " step-end" : - ((is_pair(obj)) ? " no-opt" : - " ?18?")))))) : "", - /* bit 27 */ - ((full_typ & T_SAFE_STEPPER) != 0) ? ((is_let(obj)) ? " set-fallback" : - ((is_slot(obj)) ? " safe-stepper" : - ((is_c_function(obj)) ? " maybe-safe" : - ((is_number(obj)) ? " print-name" : - ((is_pair(obj)) ? " direct-opt" : - ((is_hash_table(obj)) ? " weak-hash" : - ((is_any_macro(obj)) ? " pair-macro-set" : - ((is_symbol(obj)) ? " all-float" : - " ?19?")))))))) : "", - /* bit 28, for c_function case see sc->apply */ - ((full_typ & T_COPY_ARGS) != 0) ? (((is_pair(obj)) || (is_any_macro(obj)) || (is_syntax(obj)) || - (is_any_closure(obj)) || (is_c_function(obj))) ? " copy-args" : - " ?20?") : "", - /* bit 29 */ - ((full_typ & T_GENSYM) != 0) ? ((is_let(obj)) ? " funclet" : - ((is_normal_symbol(obj)) ? " gensym" : - ((is_string(obj)) ? " documented-symbol" : - ((is_hash_table(obj)) ? " hash-chosen" : - ((is_pair(obj)) ? " fx-treed" : - ((is_any_vector(obj)) ? " subvector" : - ((is_slot(obj)) ? " has-pending-value" : - ((is_any_closure(obj)) ? " unknopt" : - " ?21?")))))))) : "", - /* bit 30 */ - ((full_typ & T_HAS_METHODS) != 0) ? (((is_let(obj)) || (is_c_object(obj)) || (is_any_closure(obj)) || - (is_any_macro(obj)) || (is_c_pointer(obj))) ? " has-methods" : " ?22?") : "", - /* bit 31 */ - ((full_typ & T_ITER_OK) != 0) ? ((is_iterator(obj)) ? " iter-ok" : - ((is_pair(obj)) ? " step-end-ok" : - ((is_slot(obj)) ? " in-rootlet" : - ((is_c_function(obj)) ? " bool-function" : - ((is_symbol(obj)) ? " symbol-from-symbol" : - " ?23?"))))) : "", - /* bit 24+24 */ - ((full_typ & T_FULL_SYMCONS) != 0) ? ((is_symbol(obj)) ? " possibly-constant" : - ((is_any_procedure(obj)) ? " has-let-arg" : - ((is_hash_table(obj)) ? " has-value-type" : - ((is_pair(obj)) ? " int-optable" : - " ?24?")))) : "", - /* bit 25+24 */ - ((full_typ & T_FULL_HAS_LET_FILE) != 0) ? ((is_let(obj)) ? " has-let-file" : - ((is_any_vector(obj)) ? " typed-vector" : - ((is_hash_table(obj)) ? " typed-hash-table" : - ((is_c_function(obj)) ? " has-bool-setter" : - ((is_slot(obj)) ? " rest-slot" : - (((is_pair(obj)) || (is_closure_star(obj))) ? " no-defaults" : - " ?25?")))))) : "", - /* bit 26+24 */ - ((full_typ & T_FULL_DEFINER) != 0) ? ((is_normal_symbol(obj)) ? " definer" : - ((is_pair(obj)) ? " has-fx" : - ((is_slot(obj)) ? " slot-defaults" : - ((is_iterator(obj)) ? " weak-hash-iterator" : - ((is_hash_table(obj)) ? " has-key-type" : - ((is_let(obj)) ? " maclet" : - ((is_c_function(obj)) ? " func-definer" : - ((is_syntax(obj)) ? " syntax-definer" : - " ?26?")))))))) : "", - /* bit 27+24 */ - ((full_typ & T_FULL_BINDER) != 0) ? ((is_pair(obj)) ? " tree-collected" : - ((is_hash_table(obj)) ? " simple-values" : - ((is_normal_symbol(obj)) ? " binder" : - ((is_c_function(obj)) ? " safe-args" : - ((is_syntax(obj)) ? " syntax-binder" : - " ?27?"))))) : "", - /* bit 28+24 */ - ((full_typ & T_VERY_SAFE_CLOSURE) != 0) ? (((is_pair(obj)) || (is_any_closure(obj))) ? " very-safe-closure" : - ((is_let(obj)) ? " baffle-let" : - " ?28?")) : "", - /* bit 29+24 */ - ((full_typ & T_CYCLIC) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || - (is_any_closure(obj))) ? " cyclic" : " ?29?") : "", - /* bit 30+24 */ - ((full_typ & T_CYCLIC_SET) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || - (is_any_closure(obj))) ? " cyclic-set" : " ?30?") : "", - /* bit 31+24 */ - ((full_typ & T_KEYWORD) != 0) ? ((is_symbol(obj)) ? " keyword" : - ((is_pair(obj)) ? " fx-treeable" : - " ?31?")) : "", - /* bit 32+24 */ - ((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) ? ((is_normal_vector(obj)) ? " simple-elements" : - ((is_hash_table(obj)) ? " simple-keys" : - ((is_normal_symbol(obj)) ? " safe-setter" : - ((is_pair(obj)) ? " float-optable" : - ((typ >= T_C_MACRO) ? " function-simple-elements" : - " 32?"))))) : "", - /* bit 33+24 */ - ((full_typ & T_FULL_CASE_KEY) != 0) ? ((is_symbol(obj)) ? " case-key" : - ((is_pair(obj)) ? " opt1-func-listed" : - " ?33?")) : "", - /* bit 34+24 */ - ((full_typ & T_FULL_HAS_GX) != 0) ? ((is_pair(obj)) ? " has-gx" : " ?34?") : "", - /* bit 35+24 */ - ((full_typ & T_FULL_UNKNOPT) != 0) ? ((is_pair(obj)) ? " unknopt" : " ?35?") : "", - /* bit 36+24 */ - ((full_typ & T_FULL_SAFETY_CHECKED) != 0) ? ((is_pair(obj)) ? " safety-checked" : " ?36?") : "", - /* bit 37+24 */ - ((full_typ & T_FULL_HAS_FN) != 0) ? ((is_pair(obj)) ? " has-fn" : " ?37") : "", - /* bit 62 */ - ((full_typ & T_UNHEAP) != 0) ? " unheap" : "", - /* bit 63 */ - ((full_typ & T_GC_MARK) != 0) ? " gc-marked" : "", - - ((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "", - ((is_symbol(obj)) && (((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) || ((symbol_type(obj) & ~0xffff) != 0))) ? " bad-symbol-type" : "", - NULL); - - buf = (char *)Malloc(1024); - snprintf(buf, 1024, "type: %s? (%d), opt_op: %d %s, flags: #x%" PRIx64 "%s", - type_name(sc, obj, NO_ARTICLE), typ, optimize_op(obj), (optimize_op(obj) < NUM_OPS) ? op_names[optimize_op(obj)] : "", full_typ, str); - return(buf); -} - -/* snprintf returns the number of bytes that would have been written: (display (c-pointer 123123123 (symbol (make-string 130 #\a)))) */ - -static bool has_odd_bits(s7_pointer obj) -{ - uint64_t full_typ = full_type(obj); - if ((full_typ & UNUSED_BITS) != 0) return(true); - if (((full_typ & T_MULTIFORM) != 0) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_KEYWORD) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_SYNTACTIC) != 0) && (!is_syntax(obj)) && (!is_pair(obj)) && (!is_normal_symbol(obj))) return(true); - if (((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) && (!is_pair(obj)) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_OPTIMIZED) != 0) && (!is_c_function(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_SAFE_CLOSURE) != 0) && (!is_any_closure(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_SAFE_PROCEDURE) != 0) && (!is_applicable(obj))) return(true); - if (((full_typ & T_EXPANSION) != 0) && (!is_normal_symbol(obj)) && (!is_either_macro(obj))) return(true); - if (((full_typ & T_MULTIPLE_VALUE) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_GLOBAL) != 0) && (!is_pair(obj)) && (!is_symbol(obj)) && (!is_let(obj)) && (!is_syntax(obj))) return(true); - if (((full_typ & T_ITER_OK) != 0) && (!is_iterator(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_c_function(obj)) && (!is_symbol(obj))) return(true); - if (((full_typ & T_LOCAL) != 0) && (!is_normal_symbol(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_UNSAFE) != 0) && (!is_symbol(obj)) && (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_VERY_SAFE_CLOSURE) != 0) && (!is_pair(obj)) && (!is_any_closure(obj)) && (!is_let(obj))) return(true); - if (((full_typ & T_FULL_CASE_KEY) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); - if (((full_typ & T_FULL_UNKNOPT) != 0) && (!is_pair(obj))) return(true); - if (((full_typ & T_FULL_SAFETY_CHECKED) != 0) && (!is_pair(obj))) return(true); - if (((full_typ & T_FULL_HAS_GX) != 0) && (!is_pair(obj))) return(true); - if (((full_typ & T_DONT_EVAL_ARGS) != 0) && (!is_any_macro(obj)) && (!is_syntax(obj))) return(true); - if (((full_typ & T_CHECKED) != 0) && (!is_slot(obj)) && (!is_pair(obj)) && (!is_symbol(obj))) return(true); - if (((full_typ & T_SHARED) != 0) && (!t_sequence_p[type(obj)]) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_COPY_ARGS) != 0) && (!is_pair(obj)) && - (!is_any_macro(obj)) && (!is_any_closure(obj)) && (!is_c_function(obj)) && (!is_syntax(obj))) - return(true); - if (((full_typ & T_FULL_SYMCONS) != 0) && - (!is_symbol(obj)) && (!is_any_procedure(obj)) && (!is_hash_table(obj)) && (!is_pair(obj))) - return(true); - if (((full_typ & T_FULL_BINDER) != 0) && - ((!is_pair(obj)) && (!is_hash_table(obj)) && (!is_normal_symbol(obj)) && (!is_c_function(obj)) && (!is_syntax(obj)))) - return(true); - if (((full_typ & T_FULL_DEFINER) != 0) && - (!is_normal_symbol(obj)) && (!is_c_function(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj)) && - (!is_hash_table(obj)) && (!is_let(obj)) && (!is_syntax(obj))) - return(true); - if (((full_typ & T_FULL_HAS_LET_FILE) != 0) && - (!is_let(obj)) && (!is_any_vector(obj)) && (!is_hash_table(obj)) && (!is_c_function(obj)) && - (!is_slot(obj)) && (!is_pair(obj)) && (!is_closure_star(obj))) - return(true); - if (((full_typ & T_SAFE_STEPPER) != 0) && - (!is_let(obj)) && (!is_slot(obj)) && (!is_c_function(obj)) && (!is_number(obj)) && - (!is_pair(obj)) && (!is_hash_table(obj)) && (!is_any_macro(obj)) && (!is_symbol(obj))) - return(true); - if (((full_typ & T_SETTER) != 0) && - (!is_slot(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj)) && (!is_let(obj)) && (!is_c_function_star(obj))) - return(true); - if (((full_typ & T_LOCATION) != 0) && - (!is_pair(obj)) && (!is_input_port(obj)) && (!is_let(obj)) && (!is_any_procedure(obj)) && (!is_slot(obj))) - return(true); - if (((full_typ & T_MUTABLE) != 0) && - (!is_number(obj)) && (!is_symbol(obj)) && (!is_let(obj)) && (!is_iterator(obj)) && (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj))) - return(true); - if (((full_typ & T_GENSYM) != 0) && (!is_slot(obj)) && (!is_any_closure(obj)) && - (!is_let(obj)) && (!is_symbol(obj)) && (!is_string(obj)) && (!is_hash_table(obj)) && (!is_pair(obj)) && (!is_any_vector(obj))) - return(true); - if (((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) && - ((!is_normal_vector(obj)) && (!is_hash_table(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj)) && (unchecked_type(obj) < T_C_MACRO))) - return(true); - if (((full_typ & T_CYCLIC) != 0) && (!is_simple_sequence(obj)) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_CYCLIC_SET) != 0) && (!is_simple_sequence(obj)) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true); - if (((full_typ & T_FULL_HAS_FN) != 0) && (!is_pair(obj))) return(true); - if (is_symbol(obj)) - { - if ((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) - return(true); - if ((symbol_type(obj) & ~0xffff) != 0) /* boolean function bool type and *s7*_let field id */ - return(true); - } - if ((signed_type(obj) == 0) && ((full_typ & T_GC_MARK) != 0)) return(true); - /* if ((in_heap(obj)) && ((type(obj) == T_C_FUNCTION) || (type(obj) == T_C_FUNCTION_STAR) || (type(obj) == T_C_MACRO))) return(true); */ - /* this is currently impossible -- s7_make_function et al use semipermanent pointers, but is that a bug? */ - return(false); -} - -void s7_show_let(s7_scheme *sc) /* debugging convenience */ -{ - for (s7_pointer olet = sc->curlet; is_let(T_Lid(olet)); olet = let_outlet(olet)) - { - if (olet == sc->owlet) - fprintf(stderr, "(owlet): "); - else - if (is_funclet(olet)) - fprintf(stderr, "(%s funclet): ", display(funclet_function(olet))); - else - if (olet == sc->shadow_rootlet) - fprintf(stderr, "(shadow rootlet): "); - fprintf(stderr, "%s\n", display(olet)); - } -} - -static const char *check_name(s7_scheme *sc, int32_t typ) -{ - if ((typ >= 0) && (typ < NUM_TYPES)) - { - s7_pointer p = sc->type_names[typ]; - if (is_string(p)) return(string_value(p)); - } - return("unknown type!"); -} - -#if REPORT_ROOTLET_REDEF -static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line) -{ - if (is_global(symbol)) - fprintf(stderr, "%s[%d]: %s%s%s in %s\n", - func, line, - BOLD_TEXT, display(symbol), UNBOLD_TEXT, - display_80(sc->cur_code)); - full_type(symbol) = (full_type(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC)); -} -#endif - -static char *safe_object_to_string(s7_pointer p) -{ - char *buf = (char *)Malloc(128); - snprintf(buf, 128, "type: %d", unchecked_type(p)); - return(buf); -} - -static void complain(const char* complaint, s7_pointer p, const char *func, int32_t line, uint8_t typ) -{ - fprintf(stderr, complaint, BOLD_TEXT, func, line, check_name(cur_sc, typ), safe_object_to_string(p), UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); -} - -static char* show_debugger_bits(s7_pointer p) -{ - char *bits_str = (char *)Malloc(512); - int64_t bits = p->debugger_bits; - snprintf(bits_str, 512, " %s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s", - ((bits & OPT1_SET) != 0) ? " opt1_set" : "", - ((bits & OPT1_FAST) != 0) ? " opt1_fast" : "", - ((bits & OPT1_CFUNC) != 0) ? " opt1_cfunc" : "", - ((bits & OPT1_CLAUSE) != 0) ? " opt1_clause" : "", - ((bits & OPT1_LAMBDA) != 0) ? " opt1_lambda" : "", - ((bits & OPT1_SYM) != 0) ? " opt1_sym" : "", - ((bits & OPT1_PAIR) != 0) ? " opt1_pair" : "", - ((bits & OPT1_CON) != 0) ? " opt1_con" : "", - ((bits & OPT1_ANY) != 0) ? " opt1_any" : "", - ((bits & OPT1_HASH) != 0) ? " opt1_hash" : "", - - ((bits & OPT2_SET) != 0) ? " opt2_set" : "", - ((bits & OPT2_KEY) != 0) ? " opt2_any" : "", - ((bits & OPT2_SLOW) != 0) ? " opt2_slow" : "", - ((bits & OPT2_SYM) != 0) ? " opt2_sym" : "", - ((bits & OPT2_PAIR) != 0) ? " opt2_pair" : "", - ((bits & OPT2_CON) != 0) ? " opt2_con" : "", - ((bits & OPT2_FX) != 0) ? " opt2_fx" : "", - ((bits & OPT2_FN) != 0) ? " opt2_fn" : "", - ((bits & OPT2_LAMBDA) != 0) ? " opt2_lambda" : "", - ((bits & OPT2_DIRECT) != 0) ? " opt2_direct" : "", - ((bits & OPT2_NAME) != 0) ? " opt2_raw_name" : "", - ((bits & OPT2_INT) != 0) ? " opt2_int" : "", - - ((bits & OPT3_SET) != 0) ? " opt3_set" : "", - ((bits & OPT3_ARGLEN) != 0) ? " opt3_arglen" : "", - ((bits & OPT3_SYM) != 0) ? " opt3_sym" : "", - ((bits & OPT3_CON) != 0) ? " opt3_con" : "", - ((bits & OPT3_AND) != 0) ? " opt3_pair " : "", - ((bits & OPT3_ANY) != 0) ? " opt3_any " : "", - ((bits & OPT3_LET) != 0) ? " opt3_let " : "", - ((bits & OPT3_BYTE) != 0) ? " opt3_byte " : "", - ((bits & OPT3_DIRECT) != 0) ? " opt3_direct" : "", - ((bits & OPT3_LOCATION) != 0) ? " opt3_location" : "", - ((bits & OPT3_LEN) != 0) ? " opt3_len" : "", - ((bits & OPT3_INT) != 0) ? " opt3_int" : "", - - ((bits & L_HIT) != 0) ? " let_set" : "", - ((bits & L_FUNC) != 0) ? " let_func" : "", - ((bits & L_DOX) != 0) ? " let_dox" : ""); - return(bits_str); -} - -static s7_pointer check_ref(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2) -{ - if (!p) - fprintf(stderr, "%s%s[%d]: null pointer passed to check_ref%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - else - { - uint8_t typ = unchecked_type(p); - if (typ != expected_type) - { - if ((!func1) || (typ != T_FREE)) - { - fprintf(stderr, "%s%s[%d]: not %s, but %s (%s)%s\n", - BOLD_TEXT, - func, line, check_name(cur_sc, expected_type), check_name(cur_sc, typ), safe_object_to_string(p), - UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); - } - else - if ((strcmp(func, func1) != 0) && - ((!func2) || (strcmp(func, func2) != 0))) - { - fprintf(stderr, "%s%s[%d]: free cell, not %s%s\n", BOLD_TEXT, func, line, check_name(cur_sc, expected_type), UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); - }}} - return(p); -} - -static s7_pointer check_let_ref(s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_ref(p, T_LET, func, line, NULL, NULL); - if ((p->debugger_bits & L_HIT) == 0) fprintf(stderr, "%s[%d]: let not set\n", func, line); - if ((p->debugger_bits & L_MASK) != role) fprintf(stderr, "%s[%d]: let bad role\n", func, line); - return(p); -} - -static s7_pointer check_let_set(s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_ref(p, T_LET, func, line, NULL, NULL); - p->debugger_bits &= (~L_MASK); - p->debugger_bits |= (L_HIT | role); - return(p); -} - -static s7_pointer check_ref2(s7_pointer p, uint8_t expected_type, int32_t other_type, const char *func, int32_t line, const char *func1, const char *func2) -{ - if (!p) - fprintf(stderr, "%s[%d]: null pointer passed to check_ref2\n", func, line); - else - { - uint8_t typ = unchecked_type(p); - if ((typ != expected_type) && (typ != other_type)) - return(check_ref(p, expected_type, func, line, func1, func2)); - } - return(p); -} - -static s7_pointer check_ref3(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((typ != T_INPUT_PORT) && (typ != T_OUTPUT_PORT) && (typ != T_FREE)) - complain("%s%s[%d]: not a port, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref4(s7_pointer p, const char *func, int32_t line) -{ - if ((strcmp(func, "sweep") != 0) && - (strcmp(func, "process_multivector") != 0)) - { - uint8_t typ = unchecked_type(p); - if (!t_vector_p[typ]) complain("%s%s[%d]: not a vector, but %s (%s)%s\n", p, func, line, typ); - } - return(p); -} - -static s7_pointer check_ref5(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if (!t_has_closure_let[typ]) complain("%s%s[%d]: not a closure, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref6(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if (typ < T_C_MACRO) complain("%s%s[%d]: not a c function or macro, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref7(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((typ < T_INTEGER) || (typ > T_COMPLEX)) - complain("%s%s[%d]: not a number, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref8(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((!t_sequence_p[typ]) && (!t_structure_p[typ]) && (!is_any_closure(p))) /* closure as iterator -- see s7test */ - complain("%s%s[%d]: not a sequence or structure, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref9(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((typ != T_LET) && (typ != T_C_OBJECT) && (!is_any_closure(p)) && (!is_any_macro(p)) && (typ != T_C_POINTER)) - complain("%s%s[%d]: not a possible method holder, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref10(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((typ != T_PAIR) && (typ != T_NIL) && (typ != T_SYMBOL)) - complain("%s%s[%d]: arglist is %s (%s)%s?\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref11(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - if ((!t_applicable_p[typ]) && (p != cur_sc->F)) - complain("%s%s[%d]: applicable object is %s (%s)%s?\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref12(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ; - if (is_slot_end(p)) return(p); - typ = unchecked_type(p); - if ((typ != T_SLOT) && (typ != T_NIL)) /* unset slots are nil */ - complain("%s%s[%d]: slot is %s (%s)%s?\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref13(s7_pointer p, const char *func, int32_t line) -{ - if (!is_any_vector(p)) complain("%s%s[%d]: subvector is %s (%s)%s?\n", p, func, line, unchecked_type(p)); - if (!is_subvector(p)) complain("%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p, func, line, unchecked_type(p)); - return(p); -} - -static s7_pointer check_ref14(s7_pointer p, const char *func, int32_t line) -{ - if ((!is_any_procedure(p)) && (!is_boolean(p))) - complain("%s%s[%d]: setter is %s (%s)%s?\n", p, func, line, unchecked_type(p)); - return(p); -} - -static void print_gc_info(s7_scheme *sc, s7_pointer obj, int32_t line) -{ - if (!obj) - fprintf(stderr, "[%d]: obj is %p\n", line, obj); - else - if (unchecked_type(obj) != T_FREE) - fprintf(stderr, "[%d]: %p type is %d?\n", line, obj, unchecked_type(obj)); - else - { - s7_int free_type = full_type(obj); - char *bits; - char fline[128]; - full_type(obj) = obj->alloc_type; - sc->printing_gc_info = true; - bits = describe_type_bits(sc, obj); /* this func called in type macro */ - sc->printing_gc_info = false; - full_type(obj) = free_type; - if (obj->explicit_free_line > 0) - snprintf(fline, 128, ", freed at %d, ", obj->explicit_free_line); - fprintf(stderr, "%s%p is free (line %d, alloc type: %s %" ld64 " #x%" PRIx64 " (%s)), alloc: %s[%d], %sgc: %s[%d]%s", - BOLD_TEXT, obj, line, s7_type_names[obj->alloc_type & 0xff], obj->alloc_type, obj->alloc_type, - bits, obj->alloc_func, obj->alloc_line, - (obj->explicit_free_line > 0) ? fline : "", obj->gc_func, obj->gc_line, UNBOLD_TEXT); - if (S7_DEBUGGING) fprintf(stderr, "%s, last gc line: %d%s", BOLD_TEXT, sc->last_gc_line, UNBOLD_TEXT); - fprintf(stderr, "\n"); - free(bits); - } - if (sc->stop_at_error) abort(); -} - -static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line) -{ - if (!p) - { - fprintf(stderr, "%s%s[%d]: null pointer!%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); - } - else - if (unchecked_type(p) >= NUM_TYPES) - { - fprintf(stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", BOLD_TEXT, func, line, unchecked_type(p), UNBOLD_TEXT); - if (cur_sc->stop_at_error) abort(); - } - if (unchecked_type(p) == T_FREE) - { - fprintf(stderr, "%s%s[%d]: attempt to use free cell%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - print_gc_info(cur_sc, p, line); - } - return(p); -} - -static s7_pointer check_ref15(s7_pointer p, const char *func, int32_t line) /* called in mark_let so s7_scheme* for cur_sc is difficult */ -{ - uint8_t typ = unchecked_type(p); - check_nref(p, func, line); - if ((is_multiple_value(p)) && - (!safe_strcmp(func, "mark_slot"))) /* match == multiple-values which causes false error messages */ - complain("%s%s[%d]: slot value is a multiple-value, %s (%s)%s?\n", p, func, line, typ); - if (has_odd_bits(p)) - {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(cur_sc, p)); free(s);} - return(p); -} - -static s7_pointer check_ref16(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - check_nref(p, func, line); - if ((typ != T_LET) && (typ != T_NIL)) complain("%s%s[%d]: not a let or nil, but %s (%s)%s\n", p, func, line, typ); - return(p); -} - -static s7_pointer check_ref17(s7_pointer p, const char *func, int32_t line) -{ - if ((!is_any_macro(p)) || (is_c_macro(p))) complain("%s%s[%d]: macro is %s (%s)%s?\n", p, func, line, unchecked_type(p)); - return(p); -} - -static s7_pointer check_ref18(s7_pointer p, const char *func, int32_t line) -{ - if (!is_symbol_and_keyword(p)) complain("%s%s[%d]: not a keyword: %s (%s)%s?\n", p, func, line, unchecked_type(p)); - if (strcmp(func, "new_symbol") != 0) - { - if (global_value(p) != p) - fprintf(stderr, "%s%s[%d]: keyword %s value is not itself (type: %s)%s\n", BOLD_TEXT, func, line, display(p), s7_type_names[unchecked_type(global_value(p))], UNBOLD_TEXT); - if (in_heap(keyword_symbol_unchecked(p))) - fprintf(stderr, "%s%s[%d]: keyword %s symbol is in the heap%s\n", BOLD_TEXT, func, line, display(p), UNBOLD_TEXT); - if (has_odd_bits(p)) - {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(cur_sc, p)); free(s);} - } - return(p); -} - -static s7_pointer check_ref19(s7_pointer p, const char *func, int32_t line) -{ - uint8_t typ = unchecked_type(p); - check_nref(p, func, line); - if (t_ext_p[typ]) fprintf(stderr, "%s%s[%d]: attempt to use (internal) %s cell%s\n", BOLD_TEXT, func, line, s7_type_names[typ], UNBOLD_TEXT); - return(p); -} - -static const char *opt1_role_name(uint64_t role) -{ - if (role == OPT1_FAST) return("opt1_fast"); - if (role == OPT1_CFUNC) return("opt1_cfunc"); - if (role == OPT1_LAMBDA) return("opt1_lambda"); - if (role == OPT1_CLAUSE) return("opt1_clause"); - if (role == OPT1_SYM) return("opt1_sym"); - if (role == OPT1_PAIR) return("opt1_pair"); - if (role == OPT1_CON) return("opt1_con"); - if (role == OPT1_ANY) return("opt1_any"); - return((role == OPT1_HASH) ? "opt1_hash" : "opt1_unknown"); -} - -static const char *opt2_role_name(uint64_t role) -{ - if (role == OPT2_FX) return("opt2_fx"); - if (role == OPT2_FN) return("opt2_fn"); - if (role == OPT2_KEY) return("opt2_any"); - if (role == OPT2_SLOW) return("opt2_slow"); - if (role == OPT2_SYM) return("opt2_sym"); - if (role == OPT2_PAIR) return("opt2_pair"); - if (role == OPT2_CON) return("opt2_con"); - if (role == OPT2_LAMBDA) return("opt2_lambda"); - if (role == OPT2_DIRECT) return("opt2_direct"); - if (role == OPT2_INT) return("opt2_int"); - return((role == OPT2_NAME) ? "opt2_raw_name" : "opt2_unknown"); -} - -static const char *opt3_role_name(uint64_t role) -{ - if (role == OPT3_ARGLEN) return("opt3_arglen"); - if (role == OPT3_SYM) return("opt3_sym"); - if (role == OPT3_CON) return("opt3_con"); - if (role == OPT3_AND) return("opt3_pair"); - if (role == OPT3_ANY) return("opt3_any"); - if (role == OPT3_LET) return("opt3_let"); - if (role == OPT3_BYTE) return("opt3_byte"); - if (role == OPT3_DIRECT) return("direct_opt3"); - if (role == OPT3_LEN) return("opt3_len"); - if (role == OPT3_INT) return("opt3_int"); - return((role == OPT3_LOCATION) ? "opt3_location" : "opt3_unknown"); -} - -static void show_opt1_bits(s7_pointer p, const char *func, int32_t line, uint64_t role) -{ - char *bits = show_debugger_bits(p); - fprintf(stderr, "%s%s[%d]%s: opt1: %p->%p wants %s, debugger bits are %" PRIx64 "%s but expects %" ld64, - BOLD_TEXT, func, line, UNBOLD_TEXT, - p, p->object.cons.opt1, - opt1_role_name(role), - p->debugger_bits, bits, (s7_int)role); - free(bits); -} - -static s7_pointer opt1_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - if ((!opt1_is_set(p)) || - ((!opt1_role_matches(p, role)) && - (role != OPT1_ANY))) - { - show_opt1_bits(p, func, line, role); - if (sc->stop_at_error) abort(); - } - return(p->object.cons.opt1); -} - -static void base_opt1(s7_pointer p, uint64_t role) -{ - set_opt1_role(p, role); - set_opt1_is_set(p); -} - -static s7_pointer set_opt1_1(s7_pointer p, s7_pointer x, uint64_t role, const char *func, int32_t line) -{ - if (((p->debugger_bits & OPT1_MASK) != role) && - ((p->debugger_bits & OPT1_MASK) == OPT1_LAMBDA) && - (role != OPT1_CFUNC)) - fprintf(stderr, "%s[%d]: opt1_lambda -> %s, op: %s, x: %s,\n %s\n", - func, line, opt1_role_name(role), - (is_optimized(x)) ? op_names[optimize_op(x)] : "unopt", - display(x), display(p)); - p->object.cons.opt1 = x; - base_opt1(p, role); - return(x); -} - -static uint64_t opt1_hash_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((!opt1_is_set(p)) || (!opt1_role_matches(p, OPT1_HASH))) - { - show_opt1_bits(p, func, line, (uint64_t)OPT1_HASH); - if (sc->stop_at_error) abort(); - } - return(p->object.sym_cons.hash); -} - -static void set_opt1_hash_1(s7_pointer p, uint64_t x) -{ - p->object.sym_cons.hash = x; - base_opt1(p, OPT1_HASH); -} - -static void show_opt2_bits(s7_pointer p, const char *func, int32_t line, uint64_t role) -{ - char *bits = show_debugger_bits(p); - fprintf(stderr, "%s%s[%d]%s: opt2: %p->%p wants %s, debugger bits are %" PRIx64 "%s but expects %" ld64 " %s", - BOLD_TEXT, func, line, UNBOLD_TEXT, - p, p->object.cons.o2.opt2, - opt2_role_name(role), - p->debugger_bits, bits, (s7_int)role, - opt2_role_name(role)); - free(bits); -} - -static bool f_call_func_mismatch(const char *func) -{ - return((!safe_strcmp(func, "check_and")) && /* these reflect set_fx|unchecked where the destination checks for null fx_proc */ - (!safe_strcmp(func, "check_or")) && - (!safe_strcmp(func, "eval")) && - (!safe_strcmp(func, "set_any_c_np")) && - (!safe_strcmp(func, "set_any_closure_np")) && - (!safe_strcmp(func, "optimize_func_two_args")) && - (!safe_strcmp(func, "optimize_func_many_args")) && - (!safe_strcmp(func, "optimize_func_three_args")) && - (!safe_strcmp(func, "fx_c_ff")) && - (!safe_strcmp(func, "op_map_for_each_fa")) && - (!safe_strcmp(func, "op_map_for_each_faa"))); -} - -static void check_opt2_bits(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - if (!p) - { - fprintf(stderr, "%s%s[%d]: opt2 null!\n%s", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - if ((!opt2_is_set(p)) || - (!opt2_role_matches(p, role))) - { - show_opt2_bits(p, func, line, role); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer opt2_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt2_bits(sc, p, role, func, line); - return(p->object.cons.o2.opt2); -} - -static s7_int opt2_n_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt2_bits(sc, p, role, func, line); - return(p->object.cons.o2.n); -} - -static void base_opt2(s7_pointer p, uint64_t role) -{ - set_opt2_role(p, role); - set_opt2_is_set(p); -} - -static void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, uint64_t role, const char *func, int32_t line) -{ - if ((role == OPT2_FX) && - (x == NULL) && - (f_call_func_mismatch(func))) - fprintf(stderr, "%s[%d]: set fx_proc for %s to null (%s%s%s)\n", func, line, - string_value(object_to_truncated_string(sc, p, 80)), - ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? BOLD_TEXT : "", - op_names[optimize_op(car(p))], - ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? UNBOLD_TEXT : ""); - if ((role != OPT2_FX) && (role != OPT2_DIRECT) && (has_fx(p))) /* sometimes opt2_direct just specializes fx */ - { - fprintf(stderr, "%s[%d]: overwrite has_fx: %s %s\n", func, line, opt2_role_name(role), display_80(p)); - if (sc->stop_at_error) abort(); - } - p->object.cons.o2.opt2 = x; - base_opt2(p, role); -} - -static void set_opt2_n_1(s7_scheme *unused_sc, s7_pointer p, s7_int x, uint64_t role, const char *unused_func, int32_t unused_line) -{ - p->object.cons.o2.n = x; - base_opt2(p, role); -} - -static const char *opt2_name_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((!opt2_is_set(p)) || - (!opt2_role_matches(p, OPT2_NAME))) - { - show_opt2_bits(p, func, line, (uint64_t)OPT2_NAME); - if (sc->stop_at_error) abort(); - } - return(p->object.sym_cons.fstr); -} - -static void set_opt2_name_1(s7_pointer p, const char *str) -{ - p->object.sym_cons.fstr = str; - base_opt2(p, OPT2_NAME); -} - -static void show_opt3_bits(s7_pointer p, const char *func, int32_t line, uint64_t role) -{ - char *bits = show_debugger_bits(p); - fprintf(stderr, "%s%s[%d]%s: opt3: %s %" PRIx64 "%s", BOLD_TEXT, func, line, UNBOLD_TEXT, opt3_role_name(role), p->debugger_bits, bits); - free(bits); -} - -static void check_opt3_bits(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - if (!p) - { - fprintf(stderr, "%s%s[%d]: opt3 null!\n%s", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - if ((!opt3_is_set(p)) || - (!opt3_role_matches(p, role))) - { - show_opt3_bits(p, func, line, role); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer opt3_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt3_bits(sc, p, role, func, line); - return(p->object.cons.o3.opt3); -} - -static s7_int opt3_n_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt3_bits(sc, p, role, func, line); - return(p->object.cons.o3.n); -} - -static void base_opt3(s7_pointer p, uint64_t role) -{ - set_opt3_role(p, role); - set_opt3_is_set(p); -} - -static void set_opt3_1(s7_pointer p, s7_pointer x, uint64_t role) -{ - clear_type_bit(p, T_LOCATION); - p->object.cons.o3.opt3 = x; - base_opt3(p, role); -} - -static void set_opt3_n_1(s7_pointer p, s7_int x, uint64_t role) -{ - clear_type_bit(p, T_LOCATION); - p->object.cons.o3.n = x; - base_opt3(p, role); -} - -static uint8_t opt3_byte_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) -{ - check_opt3_bits(sc, p, role, func, line); - return(p->object.cons.o3.opt_type); -} - -static void set_opt3_byte_1(s7_pointer p, uint8_t x, uint64_t role, const char *unused_func, int32_t unused_line) -{ - clear_type_bit(p, T_LOCATION); - p->object.cons.o3.opt_type = x; - base_opt3(p, role); -} - -static uint64_t opt3_location_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((!opt3_is_set(p)) || - ((p->debugger_bits & OPT3_LOCATION) == 0) || - (!has_location(p))) - { - show_opt3_bits(p, func, line, (uint64_t)OPT3_LOCATION); - if (sc->stop_at_error) abort(); - } - return(p->object.sym_cons.location); -} - -static void set_opt3_location_1(s7_pointer p, uint64_t x) -{ - p->object.sym_cons.location = x; - (p)->debugger_bits = (OPT3_LOCATION | (p->debugger_bits & ~OPT3_LEN)); /* turn on line, cancel len */ - set_opt3_is_set(p); -} - -static uint64_t opt3_len_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((!opt3_is_set(p)) || - ((p->debugger_bits & OPT3_LEN) == 0) || - (has_location(p))) - { - show_opt3_bits(p, func, line, (uint64_t)OPT3_LEN); - if (sc->stop_at_error) abort(); - } - return(p->object.sym_cons.location); -} - -static void set_opt3_len_1(s7_pointer p, uint64_t x) -{ - clear_type_bit(p, T_LOCATION); - p->object.sym_cons.location = x; - (p)->debugger_bits = (OPT3_LEN | (p->debugger_bits & ~(OPT3_LOCATION))); - set_opt3_is_set(p); -} - -static void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - /* show current state, current allocated state */ - char *allocated_bits, *str; - int64_t save_full_type = full_type(obj); - s7_int len, nlen; - const char *excl_name = (is_free(obj)) ? "free cell!" : "unknown object!"; - block_t *b; - char *current_bits = describe_type_bits(sc, obj); - - full_type(obj) = obj->alloc_type; - allocated_bits = describe_type_bits(sc, obj); - full_type(obj) = save_full_type; - - len = safe_strlen(excl_name) + safe_strlen(current_bits) + safe_strlen(allocated_bits) + safe_strlen(obj->alloc_func) + 512; - b = mallocate(sc, len); - str = (char *)block_data(b); - nlen = snprintf(str, len, - "\n<%s %s,\n alloc: %s[%d] %s, %d uses>", excl_name, current_bits, - obj->alloc_func, obj->alloc_line, allocated_bits, obj->uses); - free(current_bits); - free(allocated_bits); - if (is_null(port)) - fprintf(stderr, "%p: %s\n", obj, str); - else port_write_string(port)(sc, str, clamp_length(nlen, len), port); - liberate(sc, b); -} - -static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer e); -static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int32_t line, const char *func) -{ - if (!p) - { - s7_pointer slot = symbol_to_local_slot(sc, sym, sc->curlet); - char *s = describe_type_bits(sc, sym); - fprintf(stderr, "%s%s[%d]: %s unbound%s\n", BOLD_TEXT, func, line, symbol_name(sym), UNBOLD_TEXT); - fprintf(stderr, " symbol_id: %" ld64 ", let_id: %" ld64 ", bits: %s", symbol_id(sym), let_id(sc->curlet), s); - free(s); - if (is_slot(slot)) fprintf(stderr, ", slot: %s", display(slot)); - fprintf(stderr, "\n"); - if (sc->stop_at_error) abort(); - } - return(p); -} -#endif /* S7_DEBUGGING */ -/* -------------------------------- end internal debugging apparatus -------------------------------- */ - - -static s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1) -{ - set_car(sc->elist_1, x1); - return(sc->elist_1); -} - -static s7_pointer set_elist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) -{ - set_car(sc->elist_2, x1); - set_cadr(sc->elist_2, x2); - return(sc->elist_2); -} - -static s7_pointer set_elist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) -{ - s7_pointer p = sc->elist_3; - set_car(p, x1); p = cdr(p); - set_car(p, x2); p = cdr(p); - set_car(p, x3); - return(sc->elist_3); -} - -static s7_pointer set_elist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) -{ - s7_pointer p = sc->elist_4; - set_car(p, x1); p = cdr(p); - set_car(p, x2); p = cdr(p); - set_car(p, x3); p = cdr(p); - set_car(p, x4); - return(sc->elist_4); -} - -static s7_pointer set_elist_5(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5) -{ - set_car(sc->elist_5, x1); - set_elist_4(sc, x2, x3, x4, x5); - return(sc->elist_5); -} - -static s7_pointer set_elist_6(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6) -{ - set_car(sc->elist_6, x1); - set_elist_5(sc, x2, x3, x4, x5, x6); - return(sc->elist_6); -} - -static s7_pointer set_elist_7(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6, s7_pointer x7) -{ - set_car(sc->elist_7, x1); - set_elist_6(sc, x2, x3, x4, x5, x6, x7); - return(sc->elist_7); -} - -static s7_pointer set_wlist_3(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3) -{ - s7_pointer p = lst; - set_car(p, x1); p = cdr(p); - set_car(p, x2); p = cdr(p); - set_car(p, x3); - return(lst); -} - -static s7_pointer set_wlist_4(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) -{ - s7_pointer p = lst; - set_car(p, x1); p = cdr(p); - set_car(p, x2); p = cdr(p); - set_car(p, x3); p = cdr(p); - set_car(p, x4); - return(lst); -} - -static s7_pointer set_mlist_1(s7_scheme *sc, s7_pointer x1) -{ - set_car(sc->mlist_1, x1); - return(sc->mlist_1); -} - -static s7_pointer set_mlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* mlist_3 saves 3 in tmock -- see ~/old/s7-mlist_3.c */ -{ - set_car(sc->mlist_2, x1); - set_cadr(sc->mlist_2, x2); - return(sc->mlist_2); -} - -static s7_pointer set_plist_1(s7_scheme *sc, s7_pointer x1) -{ - set_car(sc->plist_1, x1); - return(sc->plist_1); -} - -static s7_pointer set_plist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) -{ - set_car(sc->plist_2, x1); - set_car(sc->plist_2_2, x2); - return(sc->plist_2); -} - -static s7_pointer set_plist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) -{ - return(set_wlist_3(sc->plist_3, x1, x2, x3)); -} - -static s7_pointer set_qlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* let_ref_fallback */ -{ - set_car(sc->qlist_2, x1); - set_cadr(sc->qlist_2, x2); - return(sc->qlist_2); -} - -static s7_pointer set_qlist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) /* let_set_fallback */ -{ - return(set_wlist_3(sc->qlist_3, x1, x2, x3)); -} - -static s7_pointer set_clist_1(s7_scheme *sc, s7_pointer x1) /* for c_object length method etc, a "weak" list */ -{ - set_car(sc->clist_1, x1); - return(sc->clist_1); -} - -static s7_pointer set_clist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* for c_object equal method etc, a "weak" list */ -{ - set_car(sc->clist_2, x1); - set_cadr(sc->clist_2, x2); - return(sc->clist_2); -} - -static s7_pointer set_dlist_1(s7_scheme *sc, s7_pointer x1) /* another like clist: temp usage, "weak" (not gc_marked), but semipermanent list */ -{ - set_car(sc->dlist_1, x1); - return(sc->dlist_1); -} - -static s7_pointer set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2) -{ - set_car(sc->u1_1, x1); - set_cdr(sc->u1_1, x2); - return(sc->u1_1); -} - - -/* ---------------- error handlers ---------------- */ -static const char *make_type_name(s7_scheme *sc, const char *name, article_t article) -{ - s7_int i, slen = safe_strlen(name); - s7_int len = slen + 8; - if (len > sc->typnam_len) - { - if (sc->typnam) free(sc->typnam); - sc->typnam = (char *)Malloc(len); - sc->typnam_len = len; - } - if (article == INDEFINITE_ARTICLE) - { - i = 1; - sc->typnam[0] = 'a'; - if ((name[0] == 'a') || (name[0] == 'e') || (name[0] == 'i') || (name[0] == 'o') || (name[0] == 'u')) - sc->typnam[i++] = 'n'; - sc->typnam[i++] = ' '; - } - else i = 0; - memcpy((void *)(sc->typnam + i), (void *)name, slen); - sc->typnam[i + slen] = '\0'; - return(sc->typnam); -} - -static const char *type_name_from_type(int32_t typ, article_t article) -{ - switch (typ) - { - case T_FREE: return((article == NO_ARTICLE) ? "free-cell" : "a free cell"); - case T_NIL: return("nil"); - case T_UNUSED: return((article == NO_ARTICLE) ? "#" : "the unused object"); - case T_EOF: return((article == NO_ARTICLE) ? "#" : "the end-of-file object"); - case T_UNSPECIFIED: return((article == NO_ARTICLE) ? "#" : "the unspecified object"); - case T_UNDEFINED: return((article == NO_ARTICLE) ? "undefined" : "an undefined object"); - case T_BOOLEAN: return("boolean"); - case T_STRING: return((article == NO_ARTICLE) ? "string" : "a string"); - case T_BYTE_VECTOR: return((article == NO_ARTICLE) ? "byte-vector" : "a byte-vector"); - case T_SYMBOL: return((article == NO_ARTICLE) ? "symbol" : "a symbol"); - case T_SYNTAX: return((article == NO_ARTICLE) ? "syntax" : "syntactic"); - case T_PAIR: return((article == NO_ARTICLE) ? "pair" : "a pair"); - case T_GOTO: return((article == NO_ARTICLE) ? "goto" : "a goto (from call-with-exit)"); - case T_CONTINUATION: return((article == NO_ARTICLE) ? "continuation" : "a continuation"); - case T_C_RST_NO_REQ_FUNCTION: - case T_C_FUNCTION: return((article == NO_ARTICLE) ? "c-function" : "a c-function"); - case T_C_FUNCTION_STAR: return((article == NO_ARTICLE) ? "c-function*" : "a c-function*"); - case T_CLOSURE: return((article == NO_ARTICLE) ? "function" : "a function"); - case T_CLOSURE_STAR: return((article == NO_ARTICLE) ? "function*" : "a function*"); - case T_C_MACRO: return((article == NO_ARTICLE) ? "c-macro" : "a c-macro"); - case T_C_POINTER: return((article == NO_ARTICLE) ? "c-pointer" : "a c-pointer"); - case T_CHARACTER: return((article == NO_ARTICLE) ? "character" : "a character"); - case T_VECTOR: return((article == NO_ARTICLE) ? "vector" : "a vector"); - case T_INT_VECTOR: return((article == NO_ARTICLE) ? "int-vector" : "an int-vector"); - case T_FLOAT_VECTOR: return((article == NO_ARTICLE) ? "float-vector" : "a float-vector"); - case T_MACRO_STAR: return((article == NO_ARTICLE) ? "macro*" : "a macro*"); - case T_MACRO: return((article == NO_ARTICLE) ? "macro" : "a macro"); - case T_BACRO_STAR: return((article == NO_ARTICLE) ? "bacro*" : "a bacro*"); - case T_BACRO: return((article == NO_ARTICLE) ? "bacro" : "a bacro"); - case T_CATCH: return((article == NO_ARTICLE) ? "catch" : "a catch"); - case T_STACK: return((article == NO_ARTICLE) ? "stack" : "a stack"); - case T_DYNAMIC_WIND: return((article == NO_ARTICLE) ? "dynamic-wind" : "a dynamic-wind"); - case T_HASH_TABLE: return((article == NO_ARTICLE) ? "hash-table" : "a hash-table"); - case T_ITERATOR: return((article == NO_ARTICLE) ? "iterator" : "an iterator"); - case T_LET: return((article == NO_ARTICLE) ? "let" : "a let"); - case T_COUNTER: return((article == NO_ARTICLE) ? "internal-counter" : "an internal counter"); - case T_RANDOM_STATE: return((article == NO_ARTICLE) ? "random-state" : "a random-state"); - case T_SLOT: return((article == NO_ARTICLE) ? "slot" : "a slot (variable binding)"); - case T_INTEGER: return((article == NO_ARTICLE) ? "integer" : "an integer"); - case T_RATIO: return((article == NO_ARTICLE) ? "ratio" : "a ratio"); - case T_REAL: return((article == NO_ARTICLE) ? "real" : "a real"); - case T_COMPLEX: return((article == NO_ARTICLE) ? "complex-number" : "a complex number"); - case T_BIG_INTEGER: return((article == NO_ARTICLE) ? "big-integer" : "a big integer"); - case T_BIG_RATIO: return((article == NO_ARTICLE) ? "big-ratio" : "a big ratio"); - case T_BIG_REAL: return((article == NO_ARTICLE) ? "big-real" : "a big real"); - case T_BIG_COMPLEX: return((article == NO_ARTICLE) ? "big-complex-number": "a big complex number"); - case T_INPUT_PORT: return((article == NO_ARTICLE) ? "input-port" : "an input port"); - case T_OUTPUT_PORT: return((article == NO_ARTICLE) ? "output-port" : "an output port"); - case T_C_OBJECT: return((article == NO_ARTICLE) ? "c-object" : "a c_object"); - } - return(NULL); -} - -static s7_pointer find_let(s7_scheme *sc, s7_pointer obj) -{ - if (is_let(obj)) return(obj); - switch (type(obj)) - { - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - return(closure_let(obj)); - case T_C_OBJECT: - return(c_object_let(obj)); - case T_C_POINTER: - if ((is_let(c_pointer_info(obj))) && - (c_pointer_info(obj) != sc->rootlet)) - return(c_pointer_info(obj)); - } - return(sc->nil); -} - -static s7_pointer find_method(s7_scheme *sc, s7_pointer let, s7_pointer symbol) -{ - s7_pointer slot; - if (symbol_id(symbol) == 0) /* this means the symbol has never been used locally, so how can it be a method? */ - return(sc->undefined); - slot = lookup_slot_from(symbol, let); - if (slot != global_slot(symbol)) - return(slot_value(slot)); - return(sc->undefined); -} - -static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer let, s7_pointer symbol) -{ - return(find_method(sc, find_let(sc, let), symbol)); -} - -static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article) -{ - switch (unchecked_type(arg)) - { - case T_C_OBJECT: return(make_type_name(sc, string_value(c_object_scheme_name(sc, arg)), article)); - case T_INPUT_PORT: return(make_type_name(sc, (is_file_port(arg)) ? "input file port" : ((is_string_port(arg)) ? "input string port" : "input port"), article)); - case T_OUTPUT_PORT: return(make_type_name(sc, (is_file_port(arg)) ? "output file port" : ((is_string_port(arg)) ? "output string port" : "output port"), article)); - case T_LET: - if (has_active_methods(sc, arg)) - { - s7_pointer class_name = find_method(sc, arg, sc->class_name_symbol); - if (is_symbol(class_name)) - return(make_type_name(sc, symbol_name(class_name), article)); - } - default: - { - const char *str = type_name_from_type(unchecked_type(arg), article); - if (str) return(str); - }} - return("messed up object"); -} - -static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len); - -static s7_pointer object_type_name(s7_scheme *sc, s7_pointer x) -{ - uint8_t typ; - if (has_active_methods(sc, x)) - { - s7_pointer p = find_method_with_let(sc, x, sc->class_name_symbol); - if (is_symbol(p)) return(symbol_name_cell(p)); - } - typ = type(x); - if (typ < NUM_TYPES) - { - if (typ == T_C_OBJECT) return(c_object_scheme_name(sc, x)); - return(sc->type_names[typ]); - } - return(wrap_string(sc, "unknown type!", 13)); -} - -static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg) -{ - if (type(arg) < NUM_TYPES) - { - s7_pointer p = sc->type_names[type(arg)]; /* these use INDEFINITE_ARTICLE */ - if (is_string(p)) return(p); - } - return(s7_make_string_wrapper(sc, type_name(sc, arg, INDEFINITE_ARTICLE))); -} - - -static noreturn void sole_arg_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ) -{ - set_wlist_4(cdr(sc->sole_arg_wrong_type_info), caller, arg, object_type_name(sc, arg), typ); - error_nr(sc, sc->wrong_type_arg_symbol, sc->sole_arg_wrong_type_info); -} - -static /* Inline */ noreturn void wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ) -{ - s7_pointer p = cdr(sc->wrong_type_arg_info); /* info list is '(format_string caller arg_n arg type_name descr) */ - set_car(p, caller); p = cdr(p); - set_car(p, (is_small_int(arg_num)) ? small_int(arg_num) : wrap_integer(sc, arg_num)); p = cdr(p); - set_car(p, arg); p = cdr(p); - set_car(p, object_type_name(sc, arg)); p = cdr(p); - set_car(p, typ); - error_nr(sc, sc->wrong_type_arg_symbol, sc->wrong_type_arg_info); -} - -s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr) -{ - if (arg_n > 0) - wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg_n, arg, wrap_string(sc, descr, safe_strlen(descr))); - sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg, wrap_string(sc, descr, safe_strlen(descr))); - return(sc->wrong_type_arg_symbol); -} - -s7_pointer s7_wrong_type_error(s7_scheme *sc, s7_pointer caller, s7_int arg_n, s7_pointer arg, s7_pointer descr) -{ - if (arg_n > 0) wrong_type_error_nr(sc, caller, arg_n, arg, descr); - sole_arg_wrong_type_error_nr(sc, caller, arg, descr); - return(sc->wrong_type_arg_symbol); /* never happens */ -} - -static noreturn void sole_arg_out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr) -{ - set_wlist_3(cdr(sc->sole_arg_out_of_range_info), caller, arg, descr); - error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info); -} - -static noreturn void out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, s7_pointer descr) -{ - set_wlist_4(cdr(sc->out_of_range_info), caller, arg_n, arg, descr); - error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info); -} - -s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr) -{ - if (arg_n > 0) - { - set_wlist_4(cdr(sc->out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)), - wrap_integer(sc, arg_n), arg, wrap_string(sc, descr, safe_strlen(descr))); - error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info); - } - set_wlist_3(cdr(sc->sole_arg_out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)), - arg, wrap_string(sc, descr, safe_strlen(descr))); - error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info); - return(sc->out_of_range_symbol); -} - - -static noreturn void wrong_number_of_args_error_nr(s7_scheme *sc, const char *caller, s7_pointer args) -{ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_2(sc, s7_make_string_wrapper(sc, caller), args)); /* "caller" includes the format directives */ -} - -s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args) -{ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_2(sc, s7_make_string_wrapper(sc, caller), args)); /* "caller" includes the format directives */ - return(sc->wrong_number_of_args_symbol); -} - - -static noreturn void syntax_error_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer obj) -{ - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, errmsg, len), obj)); -} - -static noreturn void syntax_error_with_caller_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer obj) -{ - error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, errmsg, len), caller, obj)); -} - -static noreturn void syntax_error_with_caller2_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer name, s7_pointer obj) -{ - error_nr(sc, sc->syntax_error_symbol, set_elist_4(sc, wrap_string(sc, errmsg, len), caller, name, obj)); -} - -static noreturn void missing_method_error_nr(s7_scheme *sc, s7_pointer method, s7_pointer obj) -{ - error_nr(sc, sc->missing_method_symbol, - set_elist_3(sc, wrap_string(sc, "missing ~S method in ~A", 23), method, - (is_c_object(obj)) ? c_object_scheme_name(sc, obj) : obj)); -} - -static noreturn void immutable_object_error_nr(s7_scheme *sc, s7_pointer info) {error_nr(sc, sc->immutable_error_symbol, info);} - - -/* -------- method handlers -------- */ -s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) -{ - if (has_active_methods(sc, obj)) return(find_method_with_let(sc, obj, method)); - return(sc->undefined); -} - -/* if a method is shadowing a built-in like abs, it should expect the same args as abs and behave the same -- no multiple values etc */ -#define check_method(Sc, Obj, Method, Args) \ - { \ - s7_pointer func; \ - if ((has_active_methods(Sc, Obj)) && \ - ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ - return(s7_apply_function(Sc, func, Args)); \ - } - -static s7_pointer apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) -{ - s7_pointer func = find_method_with_let(sc, obj, method); - if (func == sc->undefined) return(sc->F); - return(s7_apply_function(sc, func, set_mlist_1(sc, obj))); /* plist here and below will probably not work (_pp case known bad) */ -} - -/* this is a macro mainly to simplify the Checker handling */ -#define check_boolean_method(Sc, Checker, Method, Args) \ - { \ - s7_pointer p = car(Args); \ - if (Checker(p)) return(Sc->T); \ - if (!has_active_methods(Sc, p)) return(Sc->F); \ - return(apply_boolean_method(Sc, p, Method)); \ - } - -static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args); -static s7_pointer find_and_apply_method(s7_scheme *sc, s7_pointer obj, s7_pointer sym, s7_pointer args) /* slower if inline */ -{ - s7_pointer func = find_method_with_let(sc, obj, sym); - if (is_closure(func)) return(apply_method_closure(sc, func, args)); - if (func == sc->undefined) missing_method_error_nr(sc, sym, obj); - return(s7_apply_function(sc, func, args)); -} - -static s7_pointer method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, args)); -} - -static s7_pointer mutable_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num) -{ - if (has_active_methods(sc, obj)) return(find_and_apply_method(sc, obj, method, args)); - if (sc->type_names[type(obj)] != typ) wrong_type_error_nr(sc, method, num, obj, typ); - if (!is_immutable(obj)) wrong_type_error_nr(sc, method, num, obj, typ); - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, method, obj)); - return(NULL); -} - -static s7_pointer mutable_method_or_bust_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer typ, int32_t num) -{ - return(mutable_method_or_bust(sc, obj, method, set_qlist_3(sc, x1, x2, x3), typ, num)); /* was list_3, plist_3 not safe */ -} - -static s7_pointer method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ) -{ - if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_1(sc, obj))); -} - -static s7_pointer method_or_bust_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2))); -} - -static s7_pointer method_or_bust_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, set_qlist_3(sc, x1, x2, x3))); /* was list_3, plist not safe */ -} - -static s7_pointer method_or_bust_with_type_and_loc_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) -{ - int32_t loc = sc->error_argnum + num; - sc->error_argnum = 0; - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, loc, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2))); -} - -static s7_pointer method_or_bust_with_type_pi(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_int x2, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, make_integer(sc, x2)))); -} - -static s7_pointer method_or_bust_with_type_pf(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_double x2, s7_pointer typ, int32_t num) -{ - if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, make_real(sc, x2)))); -} - -static s7_pointer sole_arg_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ) -{ - if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ); - return(find_and_apply_method(sc, obj, method, args)); -} - -static s7_pointer sole_arg_method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ) -{ - if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ); - return(find_and_apply_method(sc, obj, method, set_mlist_1(sc, obj))); -} - - -/* -------------------------------- constants -------------------------------- */ -/* #f and #t */ -s7_pointer s7_f(s7_scheme *sc) {return(sc->F);} -s7_pointer s7_t(s7_scheme *sc) {return(sc->T);} - - -/* () */ -s7_pointer s7_nil(s7_scheme *sc) {return(sc->nil);} -bool s7_is_null(s7_scheme *sc, s7_pointer p) {return(is_null(p));} -static bool is_null_b_p(s7_pointer p) {return(type(p) == T_NIL);} /* faster than b_7p because opt_b_p is faster */ - -static s7_pointer g_is_null(s7_scheme *sc, s7_pointer args) -{ - #define H_is_null "(null? obj) returns #t if obj is the empty list" - #define Q_is_null sc->pl_bt - check_boolean_method(sc, is_null, sc->is_null_symbol, args); -} - - -/* # and # */ -s7_pointer s7_undefined(s7_scheme *sc) {return(sc->undefined);} -s7_pointer s7_unspecified(s7_scheme *sc) {return(sc->unspecified);} - -bool s7_is_unspecified(s7_scheme *sc, s7_pointer val) {return(is_unspecified(val));} - -static s7_pointer g_is_undefined(s7_scheme *sc, s7_pointer args) -{ - #define H_is_undefined "(undefined? val) returns #t if val is # or its reader equivalent" - #define Q_is_undefined sc->pl_bt - check_boolean_method(sc, is_undefined, sc->is_undefined_symbol, args); -} - -static s7_pointer g_is_unspecified(s7_scheme *sc, s7_pointer args) -{ - #define H_is_unspecified "(unspecified? val) returns #t if val is #" - #define Q_is_unspecified sc->pl_bt - check_boolean_method(sc, is_unspecified, sc->is_unspecified_symbol, args); -} - - -/* -------------------------------- eof-object? -------------------------------- */ -s7_pointer eof_object = NULL; /* # is an entry in the chars array, so it's not a part of sc */ - -s7_pointer s7_eof_object(s7_scheme *sc) {return(eof_object);} - -static s7_pointer g_is_eof_object(s7_scheme *sc, s7_pointer args) -{ - #define H_is_eof_object "(eof-object? val) returns #t if val is the end-of-file object" - #define Q_is_eof_object sc->pl_bt - check_boolean_method(sc, is_eof, sc->is_eof_object_symbol, args); -} - -static bool is_eof_object_b_p(s7_pointer p) {return(p == eof_object);} - - -/* -------------------------------- not -------------------------------- */ -static bool not_b_7p(s7_scheme *sc, s7_pointer p) {return(p == sc->F);} - -static s7_pointer g_not(s7_scheme *sc, s7_pointer args) -{ - #define H_not "(not obj) returns #t if obj is #f, otherwise #t: (not ()) -> #f" - #define Q_not sc->pl_bt - return((car(args) == sc->F) ? sc->T : sc->F); -} - - -/* -------------------------------- boolean? -------------------------------- */ -bool s7_boolean(s7_scheme *sc, s7_pointer x) {return(x != sc->F);} -s7_pointer s7_make_boolean(s7_scheme *sc, bool x) {return(make_boolean(sc, x));} - -bool s7_is_boolean(s7_pointer x) {return(type(x) == T_BOOLEAN);} - -static s7_pointer g_is_boolean(s7_scheme *sc, s7_pointer args) -{ - #define H_is_boolean "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f" - #define Q_is_boolean sc->pl_bt - check_boolean_method(sc, is_boolean, sc->is_boolean_symbol, args); -} - - -/* -------------------------------- constant? -------------------------------- */ -static inline bool is_constant_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (is_immutable_symbol(sym)) /* for keywords */ - return(true); - if (is_possibly_constant(sym)) - { - s7_pointer slot = lookup_slot_from(sym, sc->curlet); - return((is_slot(slot)) && (is_immutable_slot(slot))); - } - return(false); -} - -#define is_constant(sc, p) ((type(p) != T_SYMBOL) || (is_constant_symbol(sc, p))) - -static s7_pointer g_is_constant(s7_scheme *sc, s7_pointer args) -{ - #define H_is_constant "(constant? obj) returns #t if obj either evaluates to itself, or is a symbol whose binding is constant" - #define Q_is_constant sc->pl_bt - return(make_boolean(sc, is_constant(sc, car(args)))); -} - -static bool is_constant_b_7p(s7_scheme *sc, s7_pointer p) {return(is_constant(sc, p));} -static s7_pointer is_constant_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_constant(sc, p)));} - - -/* -------------------------------- immutable? -------------------------------- */ -bool s7_is_immutable(s7_pointer p) {return(is_immutable(p));} - -static s7_pointer g_is_immutable(s7_scheme *sc, s7_pointer args) -{ - #define H_is_immutable "(immutable? sequence) returns #t if the sequence is immutable" - #define Q_is_immutable sc->pl_bt - s7_pointer p = car(args); - if (is_number(p)) return(sc->T); /* should these be marked immutable? should we use (type != SYMBOL) as above? */ - return(make_boolean(sc, is_immutable(p))); -} - - -/* -------------------------------- immutable! -------------------------------- */ -s7_pointer s7_immutable(s7_pointer p) -{ - set_immutable(p); - return(p); -} - -static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) -{ - #define H_immutable "(immutable! x) declares that the x can't be changed. x is returned." - #define Q_immutable s7_make_signature(sc, 2, sc->T, sc->T) - s7_pointer p = car(args); - if (is_symbol(p)) - { - s7_pointer slot = lookup_slot_from(p, sc->curlet); - if (is_slot(slot)) - { - set_immutable_slot(slot); - return(p); /* symbol is not set immutable ? */ - }} - set_immutable(p); /* could set_immutable save the current file/line? Then the immutable error checks for define-constant and this setting */ - return(p); -} - -/* there's no way to make a slot setter (as setter) immutable (t_multiform as bit) */ - - -/* -------------------------------- GC -------------------------------- */ -/* in most code, pairs, lets, and slots dominate the heap -- each about 25% to 40% of the - * total cell allocations. In snd-test, reals are 50%. slots need not be in the heap, - * but moving them out to their own free list was actually slower because we need (in that - * case) to manage them in the sweep process by tracking lets. - */ - -#if S7_DEBUGGING -static s7_int gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line) -{ - s7_int loc = s7_gc_protect(sc, x); - if (loc > 8192) - { - fprintf(stderr, "infinite loop or memory leak at line %d %s?\n", line, string_value(s7_object_to_string(sc, current_code(sc), false))); - abort(); - } - return(loc); -} -#define gc_protect_1(Sc, X) gc_protect_2(Sc, X, __LINE__) -#else -#define gc_protect_1(Sc, X) s7_gc_protect(Sc, X) -#endif - -static void resize_gc_protect(s7_scheme *sc) -{ - s7_int size = sc->protected_objects_size; - block_t *ob = vector_block(sc->protected_objects); - s7_int new_size = 2 * size; - block_t *nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); - block_info(nb) = NULL; - vector_block(sc->protected_objects) = nb; - vector_elements(sc->protected_objects) = (s7_pointer *)block_data(nb); - vector_length(sc->protected_objects) = new_size; - sc->protected_objects_size = new_size; - sc->protected_objects_free_list = (s7_int *)Realloc(sc->protected_objects_free_list, new_size * sizeof(s7_int)); - for (s7_int i = size; i < new_size; i++) - { - vector_element(sc->protected_objects, i) = sc->unused; - sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = i; - } -} - -s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x) -{ - s7_int loc; - if (sc->protected_objects_free_list_loc < 0) - resize_gc_protect(sc); - loc = sc->protected_objects_free_list[sc->protected_objects_free_list_loc--]; - vector_element(sc->protected_objects, loc) = x; - return(loc); -} - -void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc) -{ - if (loc < sc->protected_objects_size) - { - if (vector_element(sc->protected_objects, loc) != sc->unused) - sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = loc; - else if (S7_DEBUGGING) fprintf(stderr, "redundant gc_unprotect_at location %" ld64 "\n", loc); - vector_element(sc->protected_objects, loc) = sc->unused; - } -} - -s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc) -{ - s7_pointer obj = sc->unspecified; - if (loc < sc->protected_objects_size) - obj = vector_element(sc->protected_objects, loc); - if (obj == sc->unused) - return(sc->unspecified); - return(obj); -} - -#define gc_protected_at(Sc, Loc) vector_element(Sc->protected_objects, Loc) - -s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc) -{ - vector_element(sc->protected_objects, loc) = x; - return(x); -} - -s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc) -{ - vector_element(sc->protected_objects, loc) = sc->F; - return(sc->F); -} - - -/* these 3 are needed by sweep */ -static void (*mark_function[NUM_TYPES])(s7_pointer p); -void s7_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[unchecked_type(p)])(p);} -static void mark_noop(s7_pointer unused_p) {} - - -static void close_output_port(s7_scheme *sc, s7_pointer p); -static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym); -static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table); - -static void process_iterator(s7_scheme *unused_sc, s7_pointer s1) -{ - if (is_weak_hash_iterator(s1)) - { - s7_pointer h = iterator_sequence(s1); - clear_weak_hash_iterator(s1); - if (unchecked_type(h) == T_HASH_TABLE) - weak_hash_iters(h)--; - } -} - -static void process_multivector(s7_scheme *sc, s7_pointer s1) -{ - vdims_t *info = vector_dimension_info(s1); /* a multidimensional empty vector can have dimension info, wrapped vectors always have dimension info */ - if ((info) && - (info != sc->wrap_only)) - { - if (vector_elements_should_be_freed(info)) /* a kludge for foreign code convenience */ - { - free(any_vector_elements(s1)); - vector_elements_should_be_freed(info) = false; - } - liberate(sc, info); - vector_set_dimension_info(s1, NULL); - } - liberate(sc, vector_block(s1)); -} - -static void process_input_string_port(s7_scheme *sc, s7_pointer s1) -{ -#if S7_DEBUGGING - /* this set of ports is a subset of the ports that respond true to is_string_port -- - * the latter include file ports fully read into local memory; see read_file which uses add_input_port, not add_input_string_port - */ - if (port_filename(s1)) - fprintf(stderr, "string input port has a filename: %s\n", port_filename(s1)); - if (port_needs_free(s1)) - fprintf(stderr, "string input port needs data release\n"); -#endif - liberate(sc, port_block(s1)); -} - -static void free_port_data(s7_scheme *sc, s7_pointer s1) -{ - if (port_data(s1)) - { - liberate(sc, port_data_block(s1)); - port_data_block(s1) = NULL; - port_data(s1) = NULL; - port_data_size(s1) = 0; - } - port_needs_free(s1) = false; -} - -static void close_input_function(s7_scheme *sc, s7_pointer p); - -static void process_input_port(s7_scheme *sc, s7_pointer s1) -{ - if (!port_is_closed(s1)) - { - if (is_file_port(s1)) - { - if (port_file(s1)) - { - fclose(port_file(s1)); - port_file(s1) = NULL; - }} - else - if (is_function_port(s1)) - close_input_function(sc, s1); - } - if (port_needs_free(s1)) - free_port_data(sc, s1); - - if (port_filename(s1)) - { - liberate(sc, port_filename_block(s1)); - port_filename(s1) = NULL; - } - liberate(sc, port_block(s1)); -} - -static void process_output_port(s7_scheme *sc, s7_pointer s1) -{ - close_output_port(sc, s1); /* needed for free filename, etc */ - liberate(sc, port_block(s1)); - if (port_needs_free(s1)) - { - port_needs_free(s1) = false; - if (port_data_block(s1)) - { - liberate(sc, port_data_block(s1)); - port_data_block(s1) = NULL; - }} -} - -static void process_continuation(s7_scheme *sc, s7_pointer s1) -{ - continuation_op_stack(s1) = NULL; - liberate_block(sc, continuation_block(s1)); -} - - -#if WITH_GMP -#if ((__GNU_MP_VERSION < 6) || ((__GNU_MP_VERSION == 6) && (__GNU_MP_VERSION_MINOR == 0))) -static int32_t mpq_cmp_z(const mpq_t op1, const mpz_t op2) -{ - mpq_t z1; - int32_t result; - mpq_init(z1); - mpq_set_z(z1, op2); - result = mpq_cmp(op1, z1); - mpq_clear(z1); - return(result); -} -#endif - -static s7_int big_integer_to_s7_int(s7_scheme *sc, mpz_t n); - -static s7_int s7_integer_clamped_if_gmp(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) - return(integer(p)); - if (is_t_big_integer(p)) - return(big_integer_to_s7_int(sc, big_integer(p))); - return(0); -} - -static void free_big_integer(s7_scheme *sc, s7_pointer p) -{ - big_integer_nxt(p) = sc->bigints; - sc->bigints = big_integer_bgi(p); - big_integer_bgi(p) = NULL; -} - -static void free_big_ratio(s7_scheme *sc, s7_pointer p) -{ - big_ratio_nxt(p) = sc->bigrats; - sc->bigrats = big_ratio_bgr(p); - big_ratio_bgr(p) = NULL; -} - -static void free_big_real(s7_scheme *sc, s7_pointer p) -{ - big_real_nxt(p) = sc->bigflts; - sc->bigflts = big_real_bgf(p); - big_real_bgf(p) = NULL; -} - -static void free_big_complex(s7_scheme *sc, s7_pointer p) -{ - big_complex_nxt(p) = sc->bigcmps; - sc->bigcmps = big_complex_bgc(p); - big_complex_bgc(p) = NULL; -} -#else -#define s7_integer_clamped_if_gmp(Sc, P) integer(P) -#endif - - -static void free_hash_table(s7_scheme *sc, s7_pointer table); - -static void sweep(s7_scheme *sc) -{ - s7_int i, j; - gc_list_t *gp; - - #define process_gc_list(Code) \ - if (gp->loc > 0) \ - { \ - for (i = 0, j = 0; i < gp->loc; i++) \ - { \ - s7_pointer s1 = gp->list[i]; \ - if (is_free_and_clear(s1)) \ - { \ - Code; \ - } \ - else gp->list[j++] = s1; \ - } \ - gp->loc = j; \ - } \ - - gp = sc->strings; - process_gc_list(liberate(sc, string_block(s1))) - - gp = sc->gensyms; - process_gc_list(remove_gensym_from_symbol_table(sc, s1); liberate(sc, gensym_block(s1))) - if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop; - - gp = sc->undefineds; - process_gc_list(free(undefined_name(s1))) - - gp = sc->c_objects; - process_gc_list((c_object_gc_free(sc, s1)) ? (void)(*(c_object_gc_free(sc, s1)))(sc, s1) : (void)(*(c_object_free(sc, s1)))(c_object_value(s1))) - - gp = sc->vectors; - process_gc_list(liberate(sc, vector_block(s1))) - - gp = sc->multivectors; - process_gc_list(process_multivector(sc, s1)); - - gp = sc->hash_tables; - if (gp->loc > 0) - { - for (i = 0, j = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (is_free_and_clear(s1)) - free_hash_table(sc, s1); - else - { - if ((is_weak_hash_table(s1)) && - (weak_hash_iters(s1) == 0) && - (hash_table_entries(s1) > 0)) - cull_weak_hash_table(sc, s1); - gp->list[j++] = s1; - }} - gp->loc = j; - } - - gp = sc->weak_hash_iterators; - process_gc_list(process_iterator(sc, s1)); - - gp = sc->opt1_funcs; - if (gp->loc > 0) - { - for (i = 0, j = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (!is_free_and_clear(s1)) - gp->list[j++] = s1; - } - gp->loc = j; - } - - gp = sc->input_ports; - process_gc_list(process_input_port(sc, s1)); - - gp = sc->input_string_ports; - process_gc_list(process_input_string_port(sc, s1)); - - gp = sc->output_ports; - process_gc_list(process_output_port(sc, s1)); - - gp = sc->continuations; - process_gc_list(process_continuation(sc, s1)); - - gp = sc->weak_refs; - if (gp->loc > 0) - { - for (i = 0, j = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (!is_free_and_clear(s1)) - { - if (is_free_and_clear(c_pointer_weak1(s1))) - c_pointer_weak1(s1) = sc->F; - if (is_free_and_clear(c_pointer_weak2(s1))) - c_pointer_weak2(s1) = sc->F; - if ((c_pointer_weak1(s1) != sc->F) || - (c_pointer_weak2(s1) != sc->F)) - gp->list[j++] = s1; - }} - gp->loc = j; - } - -#if WITH_GMP - gp = sc->big_integers; - process_gc_list(free_big_integer(sc, s1)) - - gp = sc->big_ratios; - process_gc_list(free_big_ratio(sc ,s1)) - - gp = sc->big_reals; - process_gc_list(free_big_real(sc, s1)) - - gp = sc->big_complexes; - process_gc_list(free_big_complex(sc, s1)) - - gp = sc->big_random_states; - process_gc_list(gmp_randclear(random_gmp_state(s1))) -#endif -} - -static /* inline */ void add_to_gc_list(gc_list_t *gp, s7_pointer p) /* why inline here? (not tgc) */ -{ - if (gp->loc == gp->size) - { - gp->size *= 2; - gp->list = (s7_pointer *)Realloc(gp->list, gp->size * sizeof(s7_pointer)); - } - gp->list[gp->loc++] = p; -} - -static gc_list_t *make_gc_list(void) -{ - gc_list_t *gp = (gc_list_t *)Malloc(sizeof(gc_list_t)); - #define INIT_GC_CACHE_SIZE 4 - gp->size = INIT_GC_CACHE_SIZE; - gp->loc = 0; - gp->list = (s7_pointer *)Malloc(gp->size * sizeof(s7_pointer)); - return(gp); -} - -static void just_mark(s7_pointer p) {set_mark(p);} - -static void add_gensym(s7_scheme *sc, s7_pointer p) -{ - add_to_gc_list(sc->gensyms, p); - mark_function[T_SYMBOL] = just_mark; -} - -#define add_c_object(sc, p) add_to_gc_list(sc->c_objects, p) -#define add_hash_table(sc, p) add_to_gc_list(sc->hash_tables, p) -#define add_string(sc, p) add_to_gc_list(sc->strings, p) -#define add_input_port(sc, p) add_to_gc_list(sc->input_ports, p) -#define add_input_string_port(sc, p) add_to_gc_list(sc->input_string_ports, p) -#define add_output_port(sc, p) add_to_gc_list(sc->output_ports, p) -#define add_continuation(sc, p) add_to_gc_list(sc->continuations, p) -#define add_undefined(sc, p) add_to_gc_list(sc->undefineds, p) -#define add_vector(sc, p) add_to_gc_list(sc->vectors, p) -#define add_multivector(sc, p) add_to_gc_list(sc->multivectors, p) -#define add_weak_ref(sc, p) add_to_gc_list(sc->weak_refs, p) -#define add_weak_hash_iterator(sc, p) add_to_gc_list(sc->weak_hash_iterators, p) -#define add_opt1_func(sc, p) do {if (!opt1_func_listed(p)) add_to_gc_list(sc->opt1_funcs, p); set_opt1_func_listed(p);} while (0) - -#if WITH_GMP -#define add_big_integer(sc, p) add_to_gc_list(sc->big_integers, p) -#define add_big_ratio(sc, p) add_to_gc_list(sc->big_ratios, p) -#define add_big_real(sc, p) add_to_gc_list(sc->big_reals, p) -#define add_big_complex(sc, p) add_to_gc_list(sc->big_complexes, p) -#define add_big_random_state(sc, p) add_to_gc_list(sc->big_random_states, p) -#endif - -static void init_gc_caches(s7_scheme *sc) -{ - sc->strings = make_gc_list(); - sc->gensyms = make_gc_list(); - sc->undefineds = make_gc_list(); - sc->vectors = make_gc_list(); - sc->multivectors = make_gc_list(); - sc->hash_tables = make_gc_list(); - sc->input_ports = make_gc_list(); - sc->input_string_ports = make_gc_list(); - sc->output_ports = make_gc_list(); - sc->continuations = make_gc_list(); - sc->c_objects = make_gc_list(); - sc->weak_refs = make_gc_list(); - sc->weak_hash_iterators = make_gc_list(); - sc->opt1_funcs = make_gc_list(); -#if WITH_GMP - sc->big_integers = make_gc_list(); - sc->big_ratios = make_gc_list(); - sc->big_reals = make_gc_list(); - sc->big_complexes = make_gc_list(); - sc->big_random_states = make_gc_list(); - sc->ratloc = NULL; -#endif - /* slightly unrelated... */ - sc->setters_size = 4; - sc->setters_loc = 0; - sc->setters = (s7_pointer *)Malloc(sc->setters_size * sizeof(s7_pointer)); -} - -static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, uint64_t type); - -static void add_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter) -{ - /* setters GC-protected. The c_function_setter field can't be used because the built-in functions - * are often removed from the heap and never thereafter marked. Only closures and macros are protected here. - */ - for (s7_int i = 0; i < sc->setters_loc; i++) - { - s7_pointer x = sc->setters[i]; - if (car(x) == p) - { - set_cdr(x, setter); - return; - }} - if (sc->setters_loc == sc->setters_size) - { - sc->setters_size *= 2; - sc->setters = (s7_pointer *)Realloc(sc->setters, sc->setters_size * sizeof(s7_pointer)); - } - sc->setters[sc->setters_loc++] = semipermanent_cons(sc, p, setter, T_PAIR | T_IMMUTABLE); -} - - -static inline void gc_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[unchecked_type(p)])(p);} - -static void mark_symbol_vector(s7_pointer p, s7_int len) -{ - set_mark(p); - if (mark_function[T_SYMBOL] != mark_noop) /* else no gensyms */ - { - s7_pointer *e = vector_elements(p); - for (s7_int i = 0; i < len; i++) - if ((is_symbol(e[i])) && (is_gensym(e[i]))) /* need is_symbol: make-vector + set! vector-typer symbol? where init is not a symbol */ - set_mark(e[i]); - } -} - -static void mark_simple_vector(s7_pointer p, s7_int len) -{ - s7_pointer *e = vector_elements(p); - set_mark(p); - for (s7_int i = 0; i < len; i++) - set_mark(e[i]); -} - -static void just_mark_vector(s7_pointer p, s7_int unused_len) {set_mark(p);} - -static void mark_vector_1(s7_pointer p, s7_int top) -{ - s7_pointer *tp = (s7_pointer *)(vector_elements(p)); - s7_pointer *tend, *tend4; - set_mark(p); - if (!tp) return; - tend = (s7_pointer *)(tp + top); - tend4 = (s7_pointer *)(tend - 8); - while (tp <= tend4) - LOOP_8(gc_mark(*tp++)); - while (tp < tend) - gc_mark(*tp++); -} - -static void mark_typed_vector_1(s7_pointer p, s7_int top) /* for typed vectors with closure setters */ -{ - gc_mark(typed_vector_typer(p)); - mark_vector_1(p, top); -} - -static inline void mark_slot(s7_pointer p) -{ - set_mark(T_Slt(p)); - gc_mark(slot_value(p)); - if (slot_has_setter(p)) - gc_mark(slot_setter(p)); - if (slot_has_pending_value(p)) - gc_mark(slot_pending_value(p)); - set_mark(slot_symbol(p)); -} - -static void mark_let(s7_pointer let) -{ - for (s7_pointer x = let; is_let(x) && (!is_marked(x)); x = let_outlet(x)) /* let can be sc->nil, e.g. closure_let */ - { - set_mark(x); - if (has_dox_slot1(x)) mark_slot(let_dox_slot1(x)); - if ((has_dox_slot2(x)) && (is_slot(let_dox_slot2(x)))) mark_slot(let_dox_slot2(x)); - /* it can happen (call/cc related) that let_dox_slot2 is a slot but invalid, but in that case has_dox_slot2 will not be set(?) */ - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (!is_marked(y)) /* slot value might be the enclosing let */ - mark_slot(y); - } -} - -#if WITH_HISTORY -static void gc_owlet_mark(s7_pointer tp) -{ - /* gc_mark but if tp is a pair ignore the marked bit on unheaped entries */ - if (is_pair(tp)) - { - s7_pointer p = tp; - do { - set_mark(p); - gc_mark(car(p)); /* does this need to be gc_owlet_mark? I can't find a case */ - p = cdr(p); - } while ((is_pair(p)) && (p != tp) && ((!in_heap(p)) || (!is_marked(p)))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */ - gc_mark(p); - } - else - if (!is_marked(tp)) - (*mark_function[unchecked_type(tp)])(tp); -} -#endif - -static void mark_owlet(s7_scheme *sc) -{ -#if WITH_HISTORY - { - for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3)) - { - gc_owlet_mark(car(p1)); - gc_owlet_mark(car(p2)); - gc_owlet_mark(car(p3)); - p1 = cdr(p1); - if (p1 == sc->eval_history1) break; /* these are circular lists */ - }} -#endif - /* sc->error_type and friends are slots in owlet */ - mark_slot(sc->error_type); - slot_set_value(sc->error_data, sc->F); /* or maybe mark_tree(slot_value(sc->error_data)) ? */ - mark_slot(sc->error_data); - mark_slot(sc->error_code); - mark_slot(sc->error_line); - mark_slot(sc->error_file); - mark_slot(sc->error_position); -#if WITH_HISTORY - mark_slot(sc->error_history); -#endif - set_mark(sc->owlet); - mark_let(let_outlet(sc->owlet)); -} - -static void mark_c_pointer(s7_pointer p) -{ - set_mark(p); - gc_mark(c_pointer_type(p)); - gc_mark(c_pointer_info(p)); -} - -static void mark_c_proc_star(s7_pointer p) -{ - set_mark(p); - if ((!c_func_has_simple_defaults(p)) && - (c_function_call_args(p))) /* NULL if not a safe function */ - for (s7_pointer arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg)) - gc_mark(car(arg)); -} - -static void mark_pair(s7_pointer p) -{ - do { - set_mark(p); - gc_mark(car(p)); /* expanding this to avoid recursion is slower */ - p = cdr(p); - } while ((is_pair(p)) && (!is_marked(p))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */ - gc_mark(p); -} - -static void mark_counter(s7_pointer p) -{ - set_mark(p); - gc_mark(counter_result(p)); - gc_mark(counter_list(p)); - gc_mark(counter_let(p)); -} - -static void mark_closure(s7_pointer p) -{ - set_mark(p); - gc_mark(closure_args(p)); - gc_mark(closure_body(p)); - mark_let(closure_let(p)); - gc_mark(closure_setter_or_map_list(p)); -} - -static void mark_stack_1(s7_pointer p, s7_int top) -{ - s7_pointer *tp = (s7_pointer *)(stack_elements(p)), *tend; - set_mark(p); - if (!tp) return; - tend = (s7_pointer *)(tp + top); - while (tp < tend) - { - gc_mark(*tp++); - gc_mark(*tp++); - gc_mark(*tp++); - tp++; - } -} - -static void mark_stack(s7_pointer p) -{ - /* we can have a bare stack waiting for a continuation to hold it if the new_cell for the continuation triggers the GC! But we need a top-of-stack?? */ - mark_stack_1(p, temp_stack_top(p)); -} - -static void mark_continuation(s7_pointer p) -{ - set_mark(p); - if (!is_marked(continuation_stack(p))) /* can these be cyclic? */ - mark_stack_1(continuation_stack(p), continuation_stack_top(p)); - gc_mark(continuation_op_stack(p)); -} - -static void mark_vector(s7_pointer p) -{ - if (is_typed_vector(p)) - typed_vector_gc_mark(p)(p, vector_length(p)); - else mark_vector_1(p, vector_length(p)); -} - -static void mark_vector_possibly_shared(s7_pointer p) -{ - /* If a subvector (an inner dimension) of a vector is the only remaining reference - * to the main vector, we want to make sure the main vector is not GC'd until - * the subvector is also GC-able. The subvector field either points to the - * parent vector, or it is sc->F, so we need to check for a vector parent if - * the current is multidimensional (this will include 1-dim slices). We need - * to keep the parent case separate (i.e. sc->F means the current is the original) - * so that we only free once (or remove_from_heap once). - * - * If we have a subvector of a subvector, and the middle and original are not otherwise - * in use, we mark the middle one, but (since it itself is not in use anywhere else) - * we don't mark the original! So we need to follow the share-vector chain marking every one. - * - * To remove a cell from the heap, we need its current heap location so that we can replace it. - * The heap is allocated as needed in monolithic blocks of (say) 1/2M s7_cells. When a cell - * is replaced, the new cell (at heap[x] say) is no longer from the original block. Since the - * GC clears all type bits when it frees a cell, we can't use a type bit to distinguish the - * replacements from the originals, but we need that info because in the base case, we use - * the distance of the cell from the base cell to get "x", its location. In the replacement - * case, we add the location at the end of the s7_cell (s7_big_cell). We track the current - * heap blocks via the sc->heap_blocks list. To get the location of "p" above, we run through - * that list looking for a block it fits in. If none is found, we assume it is an s7_big_cell - * and use the saved location. - */ - if (is_subvector(p)) - mark_vector_possibly_shared(subvector_vector(p)); - - /* mark_vector_1 does not check the marked bit, so if subvector below is in a cycle involving - * the calling vector, we get infinite recursion unless we check the mark bit here. - */ - if (!is_marked(p)) - mark_vector_1(p, vector_length(p)); -} - -static void mark_int_or_float_vector(s7_pointer p) {set_mark(p);} - -static void mark_int_or_float_vector_possibly_shared(s7_pointer p) -{ - if (is_subvector(p)) - mark_int_or_float_vector_possibly_shared(subvector_vector(p)); - set_mark(p); -} - -static void mark_c_object(s7_pointer p) -{ - set_mark(p); - if (c_object_gc_mark(c_object_s7(p), p)) - (*(c_object_gc_mark(c_object_s7(p), p)))(c_object_s7(p), p); - else (*(c_object_mark(c_object_s7(p), p)))(c_object_value(p)); -} - -static void mark_catch(s7_pointer p) -{ - set_mark(p); - gc_mark(catch_tag(p)); - gc_mark(catch_handler(p)); -} - -static void mark_dynamic_wind(s7_pointer p) -{ - set_mark(p); - gc_mark(dynamic_wind_in(p)); - gc_mark(dynamic_wind_out(p)); - gc_mark(dynamic_wind_body(p)); -} - -static void mark_hash_table(s7_pointer p) -{ - set_mark(p); - gc_mark(hash_table_procedures(p)); - if (is_pair(hash_table_procedures(p))) - { - gc_mark(hash_table_key_typer_unchecked(p)); /* unchecked to avoid s7-debugger's reference to sc */ - gc_mark(hash_table_value_typer_unchecked(p)); - } - if (hash_table_entries(p) > 0) - { - s7_int len = hash_table_mask(p) + 1; - hash_entry_t **entries = hash_table_elements(p); - hash_entry_t **last = (hash_entry_t **)(entries + len); - - if ((is_weak_hash_table(p)) && - (weak_hash_iters(p) == 0)) - while (entries < last) - { - hash_entry_t *xp; - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - gc_mark(hash_entry_value(xp)); - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - gc_mark(hash_entry_value(xp)); - } - else - while (entries < last) /* counting entries here was slightly faster */ - { - hash_entry_t *xp; - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - { - gc_mark(hash_entry_key(xp)); - gc_mark(hash_entry_value(xp)); - } - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - { - gc_mark(hash_entry_key(xp)); - gc_mark(hash_entry_value(xp)); - }}} -} - -static void mark_iterator(s7_pointer p) -{ - set_mark(p); - gc_mark(iterator_sequence(p)); - if (is_mark_seq(p)) - gc_mark(iterator_current(p)); -} - -static void mark_input_port(s7_pointer p) -{ - set_mark(p); - gc_mark(port_string_or_function(p)); -} - -static void mark_output_port(s7_pointer p) -{ - set_mark(p); - if (is_function_port(p)) - gc_mark(port_string_or_function(p)); -} - -#define clear_type(p) full_type(p) = T_FREE - -static void init_mark_functions(void) -{ - mark_function[T_FREE] = mark_noop; - mark_function[T_UNDEFINED] = just_mark; - mark_function[T_EOF] = mark_noop; - mark_function[T_UNSPECIFIED] = mark_noop; - mark_function[T_NIL] = mark_noop; - mark_function[T_UNUSED] = mark_noop; - mark_function[T_BOOLEAN] = mark_noop; - mark_function[T_SYNTAX] = mark_noop; - mark_function[T_CHARACTER] = mark_noop; - mark_function[T_SYMBOL] = mark_noop; /* this changes to just_mark when gensyms are in the heap */ - mark_function[T_STRING] = just_mark; - mark_function[T_INTEGER] = just_mark; - mark_function[T_RATIO] = just_mark; - mark_function[T_REAL] = just_mark; - mark_function[T_COMPLEX] = just_mark; - mark_function[T_BIG_INTEGER] = just_mark; - mark_function[T_BIG_RATIO] = just_mark; - mark_function[T_BIG_REAL] = just_mark; - mark_function[T_BIG_COMPLEX] = just_mark; - mark_function[T_RANDOM_STATE] = just_mark; - mark_function[T_GOTO] = just_mark; - mark_function[T_OUTPUT_PORT] = just_mark; /* changed to mark_output_port if output function ports are active */ - mark_function[T_C_MACRO] = just_mark; - mark_function[T_C_POINTER] = mark_c_pointer; - mark_function[T_C_FUNCTION] = just_mark; - mark_function[T_C_FUNCTION_STAR] = just_mark; /* changes to mark_c_proc_star if defaults involve an expression */ - mark_function[T_C_RST_NO_REQ_FUNCTION] = just_mark; - mark_function[T_PAIR] = mark_pair; - mark_function[T_CLOSURE] = mark_closure; - mark_function[T_CLOSURE_STAR] = mark_closure; - mark_function[T_CONTINUATION] = mark_continuation; - mark_function[T_INPUT_PORT] = mark_input_port; - mark_function[T_VECTOR] = mark_vector; /* this changes if subvector created (similarly below) */ - mark_function[T_INT_VECTOR] = mark_int_or_float_vector; - mark_function[T_FLOAT_VECTOR] = mark_int_or_float_vector; - mark_function[T_BYTE_VECTOR] = just_mark; - mark_function[T_MACRO] = mark_closure; - mark_function[T_BACRO] = mark_closure; - mark_function[T_MACRO_STAR] = mark_closure; - mark_function[T_BACRO_STAR] = mark_closure; - mark_function[T_C_OBJECT] = mark_c_object; - mark_function[T_CATCH] = mark_catch; - mark_function[T_DYNAMIC_WIND] = mark_dynamic_wind; - mark_function[T_HASH_TABLE] = mark_hash_table; - mark_function[T_ITERATOR] = mark_iterator; - mark_function[T_LET] = mark_let; - mark_function[T_STACK] = mark_stack; - mark_function[T_COUNTER] = mark_counter; - mark_function[T_SLOT] = mark_slot; -} - -static void mark_op_stack(s7_scheme *sc) -{ - s7_pointer *p = sc->op_stack; - s7_pointer *tp = sc->op_stack_now; - while (p < tp) - gc_mark(*p++); -} - -static void mark_input_port_stack(s7_scheme *sc) -{ - s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc); - for (s7_pointer *p = sc->input_port_stack; p < tp; p++) - gc_mark(*p); -} - -static void mark_rootlet(s7_scheme *sc) -{ - s7_pointer ge = sc->rootlet; - s7_pointer *tmp = rootlet_elements(ge); - s7_pointer *top = (s7_pointer *)(tmp + sc->rootlet_entries); - set_mark(ge); - while (tmp < top) - gc_mark(slot_value(*tmp++)); - /* slot_setter is handled below with an explicit list -- more code than its worth probably */ - /* we're not marking slot_symbol above which makes me worry that a top-level gensym won't be protected - * (apply define (gensym) '(32)), then try to get the GC to clobber {gensym}-0, - * but I can't get it to break, so they must be protected somehow; apparently they are - * removed from the heap! At least: (define-macro (defit) (let ((n (gensym))) `(define (,n) (format #t "fun")))) (defit) - * removes the function from the heap (protecting the gensym). - */ -} - -/* mark_closure calls mark_let on closure_let(func) which marks slot values. - * if we move rootlet to end, unmarked closures at that point could mark let/slot but not slot value? - * or save safe-closure lets to handle all at end? or a gc_list of safe closure lets and only mark let if not safe? - */ - -static void mark_semipermanent_objects(s7_scheme *sc) -{ - for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) - gc_mark(g->p); - /* semipermanent_objects also has lets (removed from heap) -- should they be handled like semipermanent_lets? - * if unmarked should either be removed from the list and perhaps placed on a free list? - * if outlet is free can the let potentially be in use? - * there are many more semipermanent_lets(slots) than semipermanent objects - */ -} -/* do we mark funclet slot values from the function as root? Maybe treat them like semipermanent_lets here? */ - -static void unmark_semipermanent_objects(s7_scheme *sc) -{ - gc_obj_t *g; - for (g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) - clear_mark(g->p); - for (g = sc->semipermanent_lets; g; g = (gc_obj_t *)(g->nxt)) /* there are lets and slots in this list */ - clear_mark(g->p); -} - -#if (!MS_WINDOWS) - #include - #include -#endif - -static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len); /* calls new_symbol */ -#define make_symbol_with_strlen(Sc, Name) make_symbol(Sc, Name, safe_strlen(Name)) - -#if WITH_GCC -static __attribute__ ((format (printf, 3, 4))) void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...); -#else -static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...); -#endif - -#if S7_DEBUGGING -static int64_t gc(s7_scheme *sc, const char *func, int32_t line) -#else -static int64_t gc(s7_scheme *sc) -#endif -{ - s7_cell **old_free_heap_top; - s7_int i; - - if (sc->gc_in_progress) - error_nr(sc, sc->error_symbol, set_elist_1(sc, wrap_string(sc, "GC called recursively", 21))); - sc->gc_in_progress = true; - sc->gc_start = my_clock(); - sc->gc_calls++; -#if S7_DEBUGGING - sc->last_gc_line = line; -#endif - sc->continuation_counter = 0; - - mark_rootlet(sc); - mark_owlet(sc); - - gc_mark(sc->code); - if (sc->args) gc_mark(sc->args); - gc_mark(sc->curlet); /* not mark_let because op_any_closure_3p uses sc->curlet as a temp!! */ - mark_current_code(sc); /* probably redundant if with_history */ - gc_mark(sc->value); - - mark_stack_1(sc->stack, current_stack_top(sc)); - set_mark(current_input_port(sc)); - mark_input_port_stack(sc); - set_mark(current_output_port(sc)); - set_mark(sc->error_port); - gc_mark(sc->stacktrace_defaults); - gc_mark(sc->autoload_table); - gc_mark(sc->default_random_state); - if (sc->let_temp_hook) gc_mark(sc->let_temp_hook); - - gc_mark(sc->w); - gc_mark(sc->x); - gc_mark(sc->y); - gc_mark(sc->z); - gc_mark(sc->temp1); - gc_mark(sc->temp2); - gc_mark(sc->temp3); - gc_mark(sc->temp4); - gc_mark(sc->temp5); - gc_mark(sc->temp7); - gc_mark(sc->temp8); - gc_mark(sc->temp9); - gc_mark(sc->temp10); - - gc_mark(car(sc->t1_1)); - gc_mark(car(sc->t2_1)); gc_mark(car(sc->t2_2)); - gc_mark(car(sc->t3_1)); gc_mark(car(sc->t3_2)); gc_mark(car(sc->t3_3)); - gc_mark(car(sc->t4_1)); - gc_mark(car(sc->mlist_1)); - gc_mark(car(sc->mlist_2)); gc_mark(cadr(sc->mlist_2)); - gc_mark(car(sc->plist_1)); - gc_mark(car(sc->plist_2)); gc_mark(cadr(sc->plist_2)); - gc_mark(car(sc->plist_3)); gc_mark(cadr(sc->plist_3)); gc_mark(caddr(sc->plist_3)); - gc_mark(car(sc->qlist_2)); gc_mark(cadr(sc->qlist_2)); - gc_mark(car(sc->qlist_3)); - gc_mark(car(sc->u1_1)); - - gc_mark(sc->rec_p1); - gc_mark(sc->rec_p2); - - /* these probably don't need to be marked */ - for (s7_pointer p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - for (s7_pointer p = sc->sole_arg_wrong_type_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - for (s7_pointer p = sc->out_of_range_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - for (s7_pointer p = sc->sole_arg_out_of_range_info; is_pair(p); p = cdr(p)) gc_mark(car(p)); - - gc_mark(car(sc->elist_1)); - gc_mark(car(sc->elist_2)); gc_mark(cadr(sc->elist_2)); - gc_mark(car(sc->elist_3)); gc_mark(cadr(sc->elist_3)); gc_mark(caddr(sc->elist_3)); - gc_mark(car(sc->elist_4)); - gc_mark(car(sc->elist_5)); - gc_mark(car(sc->elist_6)); - gc_mark(car(sc->elist_7)); - - for (i = 1; i < NUM_SAFE_LISTS; i++) - if ((is_pair(sc->safe_lists[i])) && - (list_is_in_use(sc->safe_lists[i]))) - for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p)) - gc_mark(car(p)); - - for (i = 0; i < sc->setters_loc; i++) - gc_mark(cdr(sc->setters[i])); - - for (i = 0; i <= sc->format_depth; i++) /* sc->num_fdats is size of array */ - if (sc->fdats[i]) - gc_mark(sc->fdats[i]->curly_arg); - - if (sc->rec_stack) - { - just_mark(sc->rec_stack); - for (i = 0; i < sc->rec_loc; i++) - gc_mark(sc->rec_els[i]); - } - mark_vector(sc->protected_objects); - mark_vector(sc->protected_setters); - set_mark(sc->protected_setter_symbols); - if ((is_symbol(sc->profile_prefix)) && (is_gensym(sc->profile_prefix))) set_mark(sc->profile_prefix); - - /* protect recent allocations using the free_heap cells above the current free_heap_top (if any). - * cells above sc->free_heap_top might be malloc'd garbage (after heap reallocation), so we keep track of - * where the last actually freed cells were after the previous GC call. We're trying to - * GC protect the previous GC_TEMPS_SIZE allocated pointers so that the caller doesn't have - * to gc-protect every temporary cell. - */ - { - s7_pointer *tmps = sc->free_heap_top; - s7_pointer *tmps_top = tmps + sc->gc_temps_size; - if (tmps_top > sc->previous_free_heap_top) - tmps_top = sc->previous_free_heap_top; - while (tmps < tmps_top) - gc_mark(*tmps++); - } - mark_op_stack(sc); - mark_semipermanent_objects(sc); - - if (sc->profiling_gensyms) - { - profile_data_t *pd = sc->profile_data; - for (i = 0; i < pd->top; i++) - if ((pd->funcs[i]) && (is_gensym(pd->funcs[i]))) - set_mark(pd->funcs[i]); - } - - { - gc_list_t *gp = sc->opt1_funcs; - for (i = 0; i < gp->loc; i++) - { - s7_pointer s1 = T_Pair(gp->list[i]); - if ((is_marked(s1)) && (!is_marked(opt1_any(s1)))) /* opt1_lambda, but op_unknown* can change to opt1_cfunc etc */ - gc_mark(opt1_any(s1)); /* not set_mark -- need to protect let/body/args as well */ - }} - - /* free up all unmarked objects */ - old_free_heap_top = sc->free_heap_top; - { - s7_pointer *fp = sc->free_heap_top; - s7_pointer *tp = sc->heap; - s7_pointer *heap_top = (s7_pointer *)(sc->heap + sc->heap_size); - -#if S7_DEBUGGING - #define gc_object(Tp) \ - p = (*Tp++); \ - if (signed_type(p) > 0) \ - { \ - p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \ - if (has_odd_bits(p)) {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(sc, p)); free(s);} \ - signed_type(p) = 0; \ - (*fp++) = p; \ - } \ - else if (signed_type(p) < 0) clear_mark(p); -#else - #define gc_object(Tp) p = (*Tp++); if (signed_type(p) > 0) {signed_type(p) = 0; (*fp++) = p;} else if (signed_type(p) < 0) clear_mark(p); - /* this appears to be about 10% faster than the previous form - * if the sign bit is on, but no other bits, this version will take no action (it thinks the cell is on the free list), but - * it means we've marked a free cell as in-use: since types are set as soon as removed from the free list, this has to be a bug - * (this case is caught by has_odd_bits). If ignored, the type will be set, and later the bit cleared, so no problem? - * An alternate form that simply calls clear_mark (no check for < 0) appears to be the same speed even in cases with lots - * of long-lived objects. - */ -#endif - while (tp < heap_top) /* != here or ^ makes no difference, and going to 64 (from 32) doesn't matter */ - { - s7_pointer p; - LOOP_8(gc_object(tp)); - LOOP_8(gc_object(tp)); - LOOP_8(gc_object(tp)); - LOOP_8(gc_object(tp)); - } - /* I tried using pthreads here, since there is no need for a lock in this loop, but the *fp++ part needs to - * be local to each thread, then merged at the end. In my timing tests, the current version was faster. - * If NUM_THREADS=2, and all thread variables are local, surely there's no "false sharing"? - */ - sc->free_heap_top = fp; - sweep(sc); - } - - unmark_semipermanent_objects(sc); - sc->gc_freed = (int64_t)(sc->free_heap_top - old_free_heap_top); - sc->gc_total_freed += sc->gc_freed; - sc->gc_end = my_clock(); - sc->gc_total_time += (sc->gc_end - sc->gc_start); - - if (show_gc_stats(sc)) - { -#if (!MS_WINDOWS) -#if S7_DEBUGGING - s7_warn(sc, 512, "%s[%d]: gc freed %" ld64 "/%" ld64 " (free: %" p64 "), time: %f\n", func, line, - sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), (double)(sc->gc_end - sc->gc_start) / ticks_per_second()); -#else - s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 " (free: %" p64 "), time: %f\n", - sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), (double)(sc->gc_end - sc->gc_start) / ticks_per_second()); -#endif -#else - s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 "\n", sc->gc_freed, sc->heap_size); -#endif - } - if (show_protected_objects_stats(sc)) - { - s7_int num, len = vector_length(sc->protected_objects); /* allocated at startup */ - for (i = 0, num = 0; i < len; i++) - if (vector_element(sc->protected_objects, i) != sc->unused) - num++; - s7_warn(sc, 256, "gc-protected-objects: %" ld64 " in use of %" ld64 "\n", num, len); - } - sc->previous_free_heap_top = sc->free_heap_top; - sc->gc_in_progress = false; - return(sc->gc_freed); -} - - -#ifndef GC_RESIZE_HEAP_FRACTION - #define GC_RESIZE_HEAP_FRACTION 0.8 -/* 1/2 is ok, 3/4 speeds up some GC benchmarks, 7/8 is a bit faster, 95/100 comes to a halt (giant heap) - * in my tests, only tvect.scm ends up larger if 3/4 used - */ -#endif - -#define GC_RESIZE_HEAP_BY_4_FRACTION 0.67 -/* .5+.1: test -3?, dup +86, tmap +45, tsort -3, thash +305. .85+.7: dup -5 */ - - -#if S7_DEBUGGING -#define resize_heap_to(Sc, Size) resize_heap_to_1(Sc, Size, __func__, __LINE__) -static void resize_heap_to_1(s7_scheme *sc, int64_t size, const char *func, int line) -#else -static void resize_heap_to(s7_scheme *sc, int64_t size) -#endif -{ - int64_t old_size = sc->heap_size; - int64_t old_free = sc->free_heap_top - sc->free_heap; - s7_cell *cells; - s7_cell **cp; - heap_block_t *hp; - -#if (S7_DEBUGGING) && (!MS_WINDOWS) - if (show_gc_stats(sc)) - s7_warn(sc, 512, "%s from %s[%d]: old: %" ld64 " / %ld, new: %" ld64 ", fraction: %.3f -> %" ld64 "\n", - __func__, func, line, old_free, old_size, size, sc->gc_resize_heap_fraction, (int64_t)(floor(sc->heap_size * sc->gc_resize_heap_fraction))); -#endif - - if (size == 0) - { - if (old_free < old_size * sc->gc_resize_heap_by_4_fraction) - sc->heap_size *= 4; /* *8 if < 1M (or whatever) doesn't make much difference */ - else sc->heap_size *= 2; - if (sc->gc_resize_heap_fraction > .4) - sc->gc_resize_heap_fraction *= .95; - } - else - if (size > sc->heap_size) - while (sc->heap_size < size) sc->heap_size *= 2; - else return; - /* do not call new_cell here! */ -#if POINTER_32 - if (((2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell))) >= SIZE_MAX) - { /* can this happen in 64-bit land? SIZE_MAX is unsigned int in 32-bit, unsigned long in 64 bit = UINTPTR_MAX = 18446744073709551615UL */ - s7_warn(sc, 256, "heap size requested, %" ld64 " => %" ld64 " bytes, is greater than size_t: %u\n", - sc->heap_size, - (2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell)), - SIZE_MAX); - sc->heap_size = old_size + 64000; - } -#endif - cp = (s7_cell **)Realloc(sc->heap, sc->heap_size * sizeof(s7_cell *)); - if (cp) - sc->heap = cp; - else - { - s7_warn(sc, 256, "heap reallocation failed! tried to get %" ld64 " bytes (will retry with a smaller amount)\n", - (int64_t)(sc->heap_size * sizeof(s7_cell *))); - sc->heap_size = old_size + 64000; - sc->heap = (s7_cell **)Realloc(sc->heap, sc->heap_size * sizeof(s7_cell *)); - } - sc->free_heap = (s7_cell **)Realloc(sc->free_heap, sc->heap_size * sizeof(s7_cell *)); - sc->free_heap_trigger = (s7_cell **)(sc->free_heap + GC_TRIGGER_SIZE); - sc->free_heap_top = sc->free_heap + old_free; /* incremented below, added old_free 21-Aug-12?!? */ - - cells = (s7_cell *)Calloc(sc->heap_size - old_size, sizeof(s7_cell)); /* Malloc + clear_type below is much slower?! */ - add_saved_pointer(sc, (void *)cells); - { - s7_pointer p = cells; - for (int64_t k = old_size; k < sc->heap_size;) - { - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - }} - hp = (heap_block_t *)Malloc(sizeof(heap_block_t)); - hp->start = (intptr_t)cells; - hp->end = (intptr_t)cells + ((sc->heap_size - old_size) * sizeof(s7_cell)); - hp->offset = old_size; - hp->next = sc->heap_blocks; - sc->heap_blocks = hp; - sc->previous_free_heap_top = sc->free_heap_top; - - if (show_heap_stats(sc)) - { - const char *str = string_value(object_to_truncated_string(sc, current_code(sc), 80)); - if (size != 0) - s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", requested %" ld64 ") from %s\n", - sc->heap_size, old_free, old_size, size, str); - else s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ") from %s\n", - sc->heap_size, old_free, old_size, str); - } - if (sc->heap_size >= sc->max_heap_size) - error_nr(sc, make_symbol(sc, "heap-too-big", 12), - set_elist_3(sc, wrap_string(sc, "heap has grown past (*s7* 'max-heap-size): ~S > ~S", 50), - wrap_integer(sc, sc->max_heap_size), - wrap_integer(sc, sc->heap_size))); -} - - -#define resize_heap(Sc) resize_heap_to(Sc, 0) - -#if S7_DEBUGGING -#define call_gc(Sc) gc(Sc, __func__, __LINE__) -static void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line) -#else -#define call_gc(Sc) gc(Sc) -static void try_to_call_gc(s7_scheme *sc) -#endif -{ - /* called only from new_cell */ - if (sc->gc_off) /* we can't just return here! Someone needs a new cell, and once the heap free list is exhausted, segfault */ - resize_heap(sc); - else - { - if ((sc->gc_resize_heap_fraction > 0.5) && (sc->heap_size >= 4194304)) - sc->gc_resize_heap_fraction = 0.5; -#if S7_DEBUGGING - gc(sc, func, line); /* not call_gc! */ -#else - gc(sc); -#endif - if ((int64_t)(sc->free_heap_top - sc->free_heap) < (sc->heap_size * sc->gc_resize_heap_fraction)) /* changed 21-Jul-22 */ - resize_heap(sc); - } -} - /* originally I tried to mark each temporary value until I was done with it, but that way madness lies... By delaying - * GC of _every_ %$^#%@ pointer, I can dispense with hundreds of individual protections. So the free_heap's last - * GC_TEMPS_SIZE allocated pointers are protected during the mark sweep. - */ - -static s7_pointer g_gc(s7_scheme *sc, s7_pointer args) -{ - #define H_gc "(gc (on #t)) runs the garbage collector. If 'on' is supplied, it turns the GC on or off. \ -Evaluation produces a surprising amount of garbage, so don't leave the GC off for very long!" - #define Q_gc s7_make_signature(sc, 2, sc->T, sc->is_boolean_symbol) - - /* g_gc can't be called in a situation where these lists matter (I think...) */ - set_mlist_1(sc, sc->unused); - set_mlist_2(sc, sc->unused, sc->unused); - set_plist_1(sc, sc->unused); - set_plist_2(sc, sc->unused, sc->unused); - set_plist_3(sc, sc->unused, sc->unused, sc->unused); - set_qlist_2(sc, sc->unused, sc->unused); - set_car(sc->qlist_3, sc->unused); - set_elist_1(sc, sc->unused); - set_elist_2(sc, sc->unused, sc->unused); - set_elist_3(sc, sc->unused, sc->unused, sc->unused); - set_car(sc->elist_4, sc->unused); - set_car(sc->elist_5, sc->unused); - set_car(sc->elist_6, sc->unused); - set_car(sc->elist_7, sc->unused); /* clist and dlist are weak references */ - set_ulist_1(sc, sc->unused, sc->unused); - if (is_not_null(args)) - { - if (!is_boolean(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->gc_symbol, args, sc->type_names[T_BOOLEAN])); - sc->gc_off = (car(args) == sc->F); - if (sc->gc_off) - return(sc->F); - } - call_gc(sc); - return(sc->unspecified); -} - -s7_pointer s7_gc_on(s7_scheme *sc, bool on) -{ - sc->gc_off = !on; - return(s7_make_boolean(sc, on)); -} - -#if S7_DEBUGGING -static void check_free_heap_size_1(s7_scheme *sc, s7_int size, const char *func, int32_t line) -#define check_free_heap_size(Sc, Size) check_free_heap_size_1(Sc, Size, __func__, __LINE__) -#else -static void check_free_heap_size(s7_scheme *sc, s7_int size) -#endif -{ - s7_int free_cells = sc->free_heap_top - sc->free_heap; - if (free_cells < size) - { -#if S7_DEBUGGING - gc(sc, func, line); -#else - gc(sc); -#endif - while ((sc->free_heap_top - sc->free_heap) < (s7_int)(size * 1.5)) - resize_heap(sc); - } -} - -#define ALLOC_POINTER_SIZE 256 -static s7_cell *alloc_pointer(s7_scheme *sc) -{ - if (sc->alloc_pointer_k == ALLOC_POINTER_SIZE) /* if either no current block or the block is used up, make a new block */ - { - sc->semipermanent_cells += ALLOC_POINTER_SIZE; - sc->alloc_pointer_cells = (s7_cell *)Calloc(ALLOC_POINTER_SIZE, sizeof(s7_cell)); /* not Malloc here or below (maybe set full type to 0 if Malloc) */ - add_saved_pointer(sc, sc->alloc_pointer_cells); - sc->alloc_pointer_k = 0; - } - return(&(sc->alloc_pointer_cells[sc->alloc_pointer_k++])); -} - -#define ALLOC_BIG_POINTER_SIZE 256 -static s7_big_cell *alloc_big_pointer(s7_scheme *sc, int64_t loc) -{ - s7_big_pointer p; - if (sc->alloc_big_pointer_k == ALLOC_BIG_POINTER_SIZE) - { - sc->semipermanent_cells += ALLOC_BIG_POINTER_SIZE; - sc->alloc_big_pointer_cells = (s7_big_cell *)Calloc(ALLOC_BIG_POINTER_SIZE, sizeof(s7_big_cell)); - add_saved_pointer(sc, sc->alloc_big_pointer_cells); - sc->alloc_big_pointer_k = 0; - } - p = (&(sc->alloc_big_pointer_cells[sc->alloc_big_pointer_k++])); - p->big_hloc = loc; - /* needed if this new pointer is itself petrified later -- it's not from one of the heap blocks, - * but it's in the heap, and we'll need to know where it is in the heap to replace it - */ - return(p); -} - -static void add_semipermanent_object(s7_scheme *sc, s7_pointer obj) /* called by remove_from_heap */ -{ - gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t)); - g->p = obj; - g->nxt = sc->semipermanent_objects; - sc->semipermanent_objects = g; -} - -static void add_semipermanent_let_or_slot(s7_scheme *sc, s7_pointer obj) -{ - gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t)); - g->p = obj; - g->nxt = sc->semipermanent_lets; - sc->semipermanent_lets = g; -} - -#if S7_DEBUGGING -static const char *type_name_from_type(int32_t typ, article_t article); - -#define free_cell(Sc, P) free_cell_1(Sc, P, __LINE__) -static void free_cell_1(s7_scheme *sc, s7_pointer p, int32_t line) -#else -static void free_cell(s7_scheme *sc, s7_pointer p) -#endif -{ -#if S7_DEBUGGING - /* anything that needs gc_list attention should not be freed here */ - uint8_t typ = unchecked_type(p); - gc_list_t *gp = sc->opt1_funcs; - - if ((t_freeze_p[typ]) || ((typ == T_SYMBOL) && (is_gensym(p)))) - fprintf(stderr, "free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); - if ((t_any_closure_p[typ]) && (gp->loc > 0)) - for (s7_int i = 0; i < gp->loc; i++) - if (gp->list[i] == p) - fprintf(stderr, "opt1_funcs free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); - gp = sc->weak_refs; - if (gp->loc > 0) - for (s7_int i = 0; i < gp->loc; i++) - if (gp->list[i] == p) - fprintf(stderr, "weak refs free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); - - p->debugger_bits = 0; - p->explicit_free_line = line; -#endif - clear_type(p); - (*(sc->free_heap_top++)) = p; -} - -static inline s7_pointer petrify(s7_scheme *sc, s7_pointer x) -{ - int64_t loc = heap_location(sc, x); - s7_pointer p = (s7_pointer)alloc_big_pointer(sc, loc); - sc->heap[loc] = p; - free_cell(sc, p); - unheap(sc, x); /* set_immutable(x); */ /* if there are GC troubles, this might catch them? */ - return(x); -} - -#if S7_DEBUGGING -#define remove_gensym_from_heap(Sc, Gensym) remove_gensym_from_heap_1(Sc, Gensym, __func__, __LINE__) -static void remove_gensym_from_heap_1(s7_scheme *sc, s7_pointer x, const char *func, int line) -#else -static void remove_gensym_from_heap(s7_scheme *sc, s7_pointer x) /* x known to be a symbol and in the heap */ -#endif -{ - int64_t loc = heap_location(sc, x); - sc->heap[loc] = (s7_pointer)alloc_big_pointer(sc, loc); - free_cell(sc, sc->heap[loc]); -#if S7_DEBUGGING - x->gc_func = func; - x->gc_line = line; -#endif - unheap(sc, x); /* set UNHEAP bit in type(x) */ - { - gc_list_t *gp = sc->gensyms; - for (s7_int i = 0; i < gp->loc; i++) /* sc->gensyms reaches size 512 during s7test, but this search is called 3 times and costs nothing */ - if (gp->list[i] == x) - { - for (s7_int j = i + 1; i < gp->loc - 1; i++, j++) - gp->list[i] = gp->list[j]; - gp->list[i] = NULL; - gp->loc--; - if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop; - break; - }} -} - -static inline void remove_from_heap(s7_scheme *sc, s7_pointer x) -{ - /* global functions are very rarely redefined, so we can remove the function body from the heap when it is defined */ - if (!in_heap(x)) return; - if (is_pair(x)) /* all the compute time is here, might be faster to go down a level explicitly */ - { - s7_pointer p = x; - do { - petrify(sc, p); - remove_from_heap(sc, car(p)); - p = cdr(p); - } while (is_pair(p) && (in_heap(p))); - if (in_heap(p)) petrify(sc, p); - return; - } - switch (type(x)) - { - case T_LET: /* very rare */ - if (is_funclet(x)) set_immutable_let(x); - case T_HASH_TABLE: - case T_VECTOR: - /* not int|float_vector or string because none of their elements are GC-able (so unheap below is ok) - * but hash-table and let seem like they need protection? And let does happen via define-class. - */ - add_semipermanent_object(sc, x); - return; - case T_SYMBOL: - if (is_gensym(x)) - remove_gensym_from_heap(sc, x); - return; - case T_CLOSURE: case T_CLOSURE_STAR: - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - /* these need to be GC-protected! */ - add_semipermanent_object(sc, x); - return; - default: - break; - } - petrify(sc, x); -} - - -/* -------------------------------- stacks -------------------------------- */ -#define OP_STACK_INITIAL_SIZE 64 - -#if S7_DEBUGGING -static void push_op_stack(s7_scheme *sc, s7_pointer op) -{ - (*sc->op_stack_now++) = T_Ext(op); /* not T_App etc -- args can be pushed */ - if (sc->op_stack_now > (sc->op_stack + sc->op_stack_size)) - { - fprintf(stderr, "%sop_stack overflow%s\n", BOLD_TEXT, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer pop_op_stack(s7_scheme *sc) -{ - s7_pointer op = T_Ext(*(--(sc->op_stack_now))); - if (sc->op_stack_now < sc->op_stack) - { - fprintf(stderr, "%sop_stack underflow%s\n", BOLD_TEXT, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(T_Ext(op)); -} -#else -#define push_op_stack(Sc, Op) (*Sc->op_stack_now++) = Op -#define pop_op_stack(Sc) (*(--(Sc->op_stack_now))) -#endif - -static void initialize_op_stack(s7_scheme *sc) -{ - sc->op_stack = (s7_pointer *)Malloc(OP_STACK_INITIAL_SIZE * sizeof(s7_pointer)); - sc->op_stack_size = OP_STACK_INITIAL_SIZE; - sc->op_stack_now = sc->op_stack; - sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size); - for (int32_t i = 0; i < OP_STACK_INITIAL_SIZE; i++) sc->op_stack[i] = sc->unused; -} - -static void resize_op_stack(s7_scheme *sc) -{ - int32_t new_size = sc->op_stack_size * 2; - int32_t loc = (int32_t)(sc->op_stack_now - sc->op_stack); - sc->op_stack = (s7_pointer *)Realloc((void *)(sc->op_stack), new_size * sizeof(s7_pointer)); - for (int32_t i = sc->op_stack_size; i < new_size; i++) sc->op_stack[i] = sc->unused; - sc->op_stack_size = (uint32_t)new_size; - sc->op_stack_now = (s7_pointer *)(sc->op_stack + loc); - sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size); -} - -#if S7_DEBUGGING -#define pop_stack(Sc) pop_stack_1(Sc, __func__, __LINE__) -static void pop_stack_1(s7_scheme *sc, const char *func, int32_t line) -{ - sc->stack_end -= 4; - if (sc->stack_end < sc->stack_start) - { - fprintf(stderr, "%s%s[%d]: stack underflow%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - /* here and in push_stack, both code and args might be non-free only because they've been retyped - * inline (as in named let) -- they actually don't make sense in these cases, but are ignored, - * and are carried around as GC protection in other cases. - */ - sc->code = T_Pos(sc->stack_end[0]); - sc->curlet = sc->stack_end[1]; /* not T_Lid|Pos, see op_any_closure_3p_end et al (stack used to pass args, not curlet) */ - sc->args = sc->stack_end[2]; - sc->cur_op = (opcode_t)(sc->stack_end[3]); - if (sc->cur_op >= NUM_OPS) - { - fprintf(stderr, "%s%s[%d]: pop_stack invalid opcode: %" p64 " %s\n", BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - if ((sc->cur_op != OP_GC_PROTECT) && - (!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1])) && - (sc->cur_op != OP_ANY_CLOSURE_3P_3)) /* used as third GC protection field */ - fprintf(stderr, "%s[%d]: curlet not a let: %s\n", func, line, op_names[sc->cur_op]); -} - -#define pop_stack_no_op(Sc) pop_stack_no_op_1(Sc, __func__, __LINE__) -static void pop_stack_no_op_1(s7_scheme *sc, const char *func, int32_t line) -{ - sc->stack_end -= 4; - if (sc->stack_end < sc->stack_start) - { - fprintf(stderr, "%s%s[%d]: stack underflow%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - sc->code = T_Pos(sc->stack_end[0]); - if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(sc->stack_end[1])) && (!is_null(sc->stack_end[1]))) - fprintf(stderr, "%s[%d]: curlet not a let\n", func, line); - sc->curlet = sc->stack_end[1]; /* not T_Lid|Pos: gc_protect can set this directly (not through push_stack) to anything */ - sc->args = sc->stack_end[2]; -} - -#define push_stack(Sc, Op, Args, Code) \ - do {s7_pointer *_end_; _end_ = Sc->stack_end; push_stack_1(Sc, Op, Args, Code, _end_, __func__, __LINE__);} while (0) - -static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer code, s7_pointer *end, const char *func, int32_t line) -{ - if ((SHOW_EVAL_OPS) && (op == OP_EVAL_DONE)) fprintf(stderr, "%s[%d]: push eval_done\n", func, line); - if (sc->stack_end >= sc->stack_start + sc->stack_size) - { - fprintf(stderr, "%s%s[%d]: stack overflow, %" ld64 " > %u, trigger: %" ld64 " %s\n", - BOLD_TEXT, func, line, - (s7_int)((intptr_t)(sc->stack_end - sc->stack_start)), sc->stack_size, - (s7_int)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), - UNBOLD_TEXT); - s7_show_stack(sc); - /* make room for debugging */ - - abort(); - if (sc->stop_at_error) abort(); - } - if (sc->stack_end >= sc->stack_resize_trigger) - { - fprintf(stderr, "%s%s[%d]: stack resize skipped%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - if (sc->stop_at_error) - { - /* this is pointless if we can't look around in gdb, so give us some room */ - sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2))); - abort(); - }} - if (sc->stack_end != end) - fprintf(stderr, "%s[%d]: stack changed in push_stack\n", func, line); - if (op >= NUM_OPS) - { - fprintf(stderr, "%s%s[%d]: push_stack invalid opcode: %" p64 " %s\n", BOLD_TEXT, func, line, sc->cur_op, UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - if (code) sc->stack_end[0] = T_Pos(code); - sc->stack_end[1] = T_Lid(sc->curlet); - if ((args) && (unchecked_type(args) != T_FREE)) sc->stack_end[2] = T_Pos(args); - sc->stack_end[3] = (s7_pointer)op; - sc->stack_end += 4; -} - -#define push_stack_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) -#define push_stack_no_let_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) -#define push_stack_no_args(Sc, Op, Code) push_stack(Sc, Op, Sc->unused, Code) -#define push_stack_no_let(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code) -#define push_stack_op(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused) -#define push_stack_op_let(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused) -#define push_stack_direct(Sc, Op) push_stack(Sc, Op, Sc->args, Sc->code) -#define push_stack_no_args_direct(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->code) -/* in the non-debugging case, the sc->unused's here are not set, so we can (later) pop free cells */ - -#else - -#define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0) -#define pop_stack_no_op(Sc) {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0) - -#define push_stack(Sc, Op, Args, Code) \ - do { \ - Sc->stack_end[0] = Code; \ - Sc->stack_end[1] = Sc->curlet; \ - Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_direct(Sc, Op) \ - do { \ - Sc->cur_op = Op; \ - memcpy((void *)(Sc->stack_end), (void *)Sc, 4 * sizeof(s7_pointer)); \ - /* Sc->stack_end[3] = (s7_pointer)(Op); */ \ - Sc->stack_end += 4; \ - } while (0) -/* is this faster with cur_op because of the cast to s7_pointer, or is callgrind messing up memcpy stats? - * time's output is all over the map. I think the cur_op form should be slower, but callgrind disagrees. - */ - -#define push_stack_no_code(Sc, Op, Args) \ - do { \ - Sc->stack_end[1] = Sc->curlet; \ - Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_no_let_no_code(Sc, Op, Args) \ - do { \ - Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_no_args(Sc, Op, Code) \ - do { \ - Sc->stack_end[0] = Code; \ - Sc->stack_end[1] = Sc->curlet; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_no_args_direct(Sc, Op) \ - do { \ - memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer)); \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_no_let(Sc, Op, Args, Code) \ - do { \ - Sc->stack_end[0] = Code; \ - Sc->stack_end[2] = Args; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_op(Sc, Op) \ - do { \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) - -#define push_stack_op_let(Sc, Op) \ - do { \ - Sc->stack_end[1] = Sc->curlet; \ - Sc->stack_end[3] = (s7_pointer)(Op); \ - Sc->stack_end += 4; \ - } while (0) -#endif -/* since we don't GC mark the stack past the stack_top, push_stack_no_args and friends can cause pop_stack to set - * sc->code and sc->args to currently free objects. - */ - -#if S7_DEBUGGING -#define unstack(Sc) unstack_1(Sc, __func__, __LINE__) -static void unstack_1(s7_scheme *sc, const char *func, int32_t line) -{ - sc->stack_end -= 4; - if (((opcode_t)sc->stack_end[3]) != OP_GC_PROTECT) - { - fprintf(stderr, "%s%s[%d]: popped %s?%s\n", BOLD_TEXT, func, line, op_names[(opcode_t)sc->stack_end[3]], UNBOLD_TEXT); - /* "popped apply" means we called something that went to eval+apply when we thought it was a safe function */ - fprintf(stderr, " code: %s, args: %s\n", display(sc->code), display(sc->args)); - fprintf(stderr, " cur_code: %s, estr: %s\n", display(current_code(sc)), display(s7_name_to_value(sc, "estr"))); - if (sc->stop_at_error) abort(); - } -} -#define unstack_with(Sc, Op) unstack_2(Sc, Op, __func__, __LINE__) -static void unstack_2(s7_scheme *sc, opcode_t op, const char *func, int32_t line) -{ - sc->stack_end -= 4; - if (((opcode_t)sc->stack_end[3]) != op) - { - fprintf(stderr, "%s%s[%d]: popped %s? (expected %s)%s\n", BOLD_TEXT, func, line, op_names[(opcode_t)sc->stack_end[3]], op_names[op], UNBOLD_TEXT); - fprintf(stderr, " code: %s, args: %s\n", display(sc->code), display(sc->args)); - fprintf(stderr, " cur_code: %s, estr: %s\n", display(current_code(sc)), display(s7_name_to_value(sc, "estr"))); - if (sc->stop_at_error) abort(); - } -} -#else -#define unstack(sc) sc->stack_end -= 4 -#define unstack_with(sc, op) sc->stack_end -= 4 -#endif - -#define main_stack_op(Sc) ((opcode_t)(Sc->stack_end[-1])) -/* #define main_stack_args(Sc) (Sc->stack_end[-2]), #define main_stack_let(Sc) (Sc->stack_end[-3]), #define main_stack_code(Sc) (Sc->stack_end[-4]) */ -/* beware of main_stack_code! If a function has a tail-call, the main_stack_code that form sees - * if main_stack_op==op-begin1 can change from call to call -- the begin actually refers - * to the caller, which is dependent on where the current function was called, so we can't hard-wire - * any optimizations based on that sequence. - */ - -static void stack_reset(s7_scheme *sc) -{ - sc->stack_end = sc->stack_start; - push_stack_op(sc, OP_EVAL_DONE); -} - -static uint32_t resize_stack_unchecked(s7_scheme *sc) -{ - uint64_t loc = current_stack_top(sc); - uint32_t new_size = sc->stack_size * 2; - block_t *ob = stack_block(sc->stack); - block_t *nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); - block_info(nb) = NULL; - stack_block(sc->stack) = nb; - stack_elements(sc->stack) = (s7_pointer *)block_data(nb); - { - s7_pointer *orig = stack_elements(sc->stack); - s7_int i = sc->stack_size; - s7_int left = new_size - i - 8; - while (i <= left) - LOOP_8(orig[i++] = sc->unused); - for (; i < new_size; i++) - orig[i] = sc->unused; - } - vector_length(sc->stack) = new_size; - sc->stack_size = new_size; - sc->stack_start = stack_elements(sc->stack); - sc->stack_end = (s7_pointer *)(sc->stack_start + loc); - sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (new_size - STACK_RESIZE_TRIGGER)); - return(new_size); -} - -#if S7_DEBUGGING -#define resize_stack(Sc) resize_stack_1(Sc, __func__, __LINE__) -static void resize_stack_1(s7_scheme *sc, const char *func, int line) -{ - if ((sc->stack_size * 2) > sc->max_stack_size) - { - fprintf(stderr, "%s%s[%d]: stack too big, %" ld64 " > %u, trigger: %" ld64 " %s\n", - BOLD_TEXT, func, line, - (s7_int)((intptr_t)(sc->stack_end - sc->stack_start)), sc->stack_size, - (s7_int)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), - UNBOLD_TEXT); - /* s7_show_stack(sc); */ /* prints so much the error message is inaccessible */ - fprintf(stderr, "stack:\n"); - for (int64_t i = current_stack_top(sc) - 1; i >= current_stack_top(sc) - 100; i -= 4) - fprintf(stderr, " %s\n", op_names[stack_op(sc->stack, i)]); - resize_stack_unchecked(sc); /* give us some room while debugging! */ - abort(); - if (sc->stop_at_error) abort(); - } - resize_stack_unchecked(sc); -} -#else -static void resize_stack(s7_scheme *sc) -{ - uint32_t new_size = resize_stack_unchecked(sc); - if (show_stack_stats(sc)) - s7_warn(sc, 128, "stack grows to %u\n", new_size); - if (new_size > sc->max_stack_size) - error_nr(sc, make_symbol(sc, "stack-too-big", 13), - set_elist_1(sc, wrap_string(sc, "stack has grown past (*s7* 'max-stack-size)", 43))); - /* error needs to follow realloc, else error -> catchers in error_nr -> let_temp* -> eval_done -> stack_resize -> infinite loop */ -} -#endif - -#define check_stack_size(Sc) do {if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack(Sc);} while (0) - -s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x) -{ - push_stack_no_let_no_code(sc, OP_GC_PROTECT, x); - return(x); -} - -s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x) -{ - unstack(sc); - return(x); -} - -#define stack_protected1(Sc) Sc->stack_end[-2] /* args */ -#define stack_protected2(Sc) Sc->stack_end[-4] /* code */ -#define stack_protected3(Sc) Sc->stack_end[-3] /* curlet */ - -#if S7_DEBUGGING - #define set_stack_protected1(Sc, Val) do {if ((opcode_t)(Sc->stack_end[-1]) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-2] = Val;} while (0) - #define set_stack_protected2(Sc, Val) do {if ((opcode_t)(Sc->stack_end[-1]) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-4] = Val;} while (0) - #define set_stack_protected3(Sc, Val) do {if ((opcode_t)(Sc->stack_end[-1]) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-3] = Val;} while (0) - - #define set_stack_protected1_with(Sc, Val, Op) do {if ((opcode_t)(Sc->stack_end[-1]) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-2] = Val;} while (0) - #define set_stack_protected2_with(Sc, Val, Op) do {if ((opcode_t)(Sc->stack_end[-1]) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-4] = Val;} while (0) - #define set_stack_protected3_with(Sc, Val, Op) do {if ((opcode_t)(Sc->stack_end[-1]) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[(opcode_t)(Sc->stack_end[-1])]); Sc->stack_end[-3] = Val;} while (0) -#else - #define set_stack_protected1(Sc, Val) Sc->stack_end[-2] = Val - #define set_stack_protected2(Sc, Val) Sc->stack_end[-4] = Val - #define set_stack_protected3(Sc, Val) Sc->stack_end[-3] = Val - - #define set_stack_protected1_with(Sc, Val, Op) Sc->stack_end[-2] = Val - #define set_stack_protected2_with(Sc, Val, Op) Sc->stack_end[-4] = Val - #define set_stack_protected3_with(Sc, Val, Op) Sc->stack_end[-3] = Val -#endif - -#define gc_protect_via_stack(Sc, Obj) push_stack_no_let_no_code(Sc, OP_GC_PROTECT, Obj) -#define gc_protect_2_via_stack(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); stack_protected2(Sc) = Y;} while (0) -#define gc_protect_3_via_stack(Sc, X, Y, Z) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); stack_protected2(Sc) = Y; stack_protected3(sc) = Z;} while (0) -/* often X and Y are fx_calls, so push X, then set Y */ - - -/* -------------------------------- symbols -------------------------------- */ -static inline uint64_t raw_string_hash(const uint8_t *key, s7_int len) -{ - if (len <= 8) - { - uint64_t xs[1] = {0}; - memcpy((void *)xs, (void *)key, len); - return(xs[0]); - } - else - { - uint64_t xs[2] = {0, 0}; - memcpy((void *)xs, (void *)key, (len > 16) ? 16 : len); /* compiler complaint here is bogus */ - return(xs[0] + xs[1]); - } -} - -static uint8_t *alloc_symbol(s7_scheme *sc) -{ - #define SYMBOL_SIZE (3 * sizeof(s7_cell) + sizeof(block_t)) - #define ALLOC_SYMBOL_SIZE (64 * SYMBOL_SIZE) - uint8_t *result; - if (sc->alloc_symbol_k == ALLOC_SYMBOL_SIZE) - { - sc->alloc_symbol_cells = (uint8_t *)Malloc(ALLOC_SYMBOL_SIZE); - add_saved_pointer(sc, sc->alloc_symbol_cells); - sc->alloc_symbol_k = 0; - } - result = &(sc->alloc_symbol_cells[sc->alloc_symbol_k]); - sc->alloc_symbol_k += SYMBOL_SIZE; - return(result); -} - -static s7_pointer make_semipermanent_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot = alloc_pointer(sc); - set_full_type(slot, T_SLOT | T_UNHEAP); - slot_set_symbol_and_value(slot, symbol, value); - return(slot); -} - -static /* inline */ s7_pointer new_symbol(s7_scheme *sc, const char *name, s7_int len, uint64_t hash, uint32_t location) /* inline useless here 20-Oct-22 */ -{ - /* name might not be null-terminated, these are semipermanent symbols even in s7_gensym; g_gensym handles everything separately */ - uint8_t *base = alloc_symbol(sc); - s7_pointer x = (s7_pointer)base; - s7_pointer str = (s7_pointer)(base + sizeof(s7_cell)); - s7_pointer p = (s7_pointer)(base + 2 * sizeof(s7_cell)); - uint8_t *val = (uint8_t *)permalloc(sc, len + 1); - memcpy((void *)val, (void *)name, len); - val[len] = '\0'; - - full_type(str) = T_STRING | T_IMMUTABLE | T_UNHEAP; /* avoid debugging confusion involving set_type (also below) */ - string_length(str) = len; - string_value(str) = (char *)val; - string_hash(str) = hash; - - full_type(x) = T_SYMBOL | T_UNHEAP; - symbol_set_name_cell(x, str); - set_global_slot(x, sc->undefined); /* was sc->nil */ - symbol_info(x) = (block_t *)(base + 3 * sizeof(s7_cell)); - set_initial_slot(x, sc->undefined); - symbol_set_local_slot_unchecked_and_unincremented(x, 0LL, sc->nil); - symbol_set_tag(x, 0); - symbol_set_tag2(x, 0); - symbol_clear_ctr(x); /* alloc_symbol uses malloc */ - symbol_clear_type(x); - - if ((len > 1) && /* not 0, otherwise : is a keyword */ - ((name[0] == ':') || (name[len - 1] == ':'))) /* see s7test under keyword? for troubles if both colons are present */ - { - s7_pointer slot, ksym; - set_type_bit(x, T_IMMUTABLE | T_KEYWORD | T_GLOBAL); - set_optimize_op(str, OP_CONSTANT); - ksym = make_symbol(sc, (name[0] == ':') ? (char *)(name + 1) : name, len - 1); - keyword_set_symbol(x, ksym); - set_has_keyword(ksym); - /* the keyword symbol needs to be semipermanent (not a gensym) else we have to laboriously gc-protect it */ - if ((is_gensym(ksym)) && - (in_heap(ksym))) - remove_gensym_from_heap(sc, ksym); - slot = make_semipermanent_slot(sc, x, x); - set_global_slot(x, slot); - set_local_slot(x, slot); - } - full_type(p) = T_PAIR | T_IMMUTABLE | T_UNHEAP; /* add x to the symbol table */ - set_car(p, x); - set_cdr(p, vector_element(sc->symbol_table, location)); - vector_element(sc->symbol_table, location) = p; - pair_set_raw_hash(p, hash); - pair_set_raw_len(p, (uint64_t)len); /* symbol name length, so it ought to fit! */ - pair_set_raw_name(p, string_value(str)); - return(x); -} - -static Inline s7_pointer inline_make_symbol(s7_scheme *sc, const char *name, s7_int len) /* inline out: ca 40=2% in tload */ -{ /* name here might not be null-terminated */ - uint64_t hash = raw_string_hash((const uint8_t *)name, len); - uint32_t location = hash % SYMBOL_TABLE_SIZE; - - if (len <= 8) - { - for (s7_pointer x = vector_element(sc->symbol_table, location); is_pair(x); x = cdr(x)) - if ((hash == pair_raw_hash(x)) && - ((uint64_t)len == pair_raw_len(x))) - return(car(x)); - } - else /* checking name[len=='\0' and using strcmp if so was not a big win */ - for (s7_pointer x = vector_element(sc->symbol_table, location); is_pair(x); x = cdr(x)) - if ((hash == pair_raw_hash(x)) && - ((uint64_t)len == pair_raw_len(x)) && - (strings_are_equal_with_length(name, pair_raw_name(x), len))) /* length here because name might not be null-terminated */ - return(car(x)); - return(new_symbol(sc, name, len, hash, location)); -} - -static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len) {return(inline_make_symbol(sc, name, len));} - -s7_pointer s7_make_symbol(s7_scheme *sc, const char *name) {return(inline_make_symbol(sc, name, safe_strlen(name)));} - -static s7_pointer symbol_table_find_by_name(s7_scheme *sc, const char *name, uint64_t hash, uint32_t location, s7_int len) -{ - for (s7_pointer x = vector_element(sc->symbol_table, location); is_not_null(x); x = cdr(x)) - if ((hash == pair_raw_hash(x)) && - (strings_are_equal_with_length(name, pair_raw_name(x), len))) - return(car(x)); - return(sc->nil); -} - -s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name) -{ - s7_int len = safe_strlen(name); - uint64_t hash = raw_string_hash((const uint8_t *)name, len); - s7_pointer result = symbol_table_find_by_name(sc, name, hash, hash % SYMBOL_TABLE_SIZE, len); - return((is_null(result)) ? NULL : result); -} - - -/* -------------------------------- symbol-table -------------------------------- */ -static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len); - -static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_symbol_table "(symbol-table) returns a vector containing the current symbol-table symbols" - #define Q_symbol_table s7_make_signature(sc, 1, sc->is_vector_symbol) - - s7_pointer *els, *entries = vector_elements(sc->symbol_table); - int32_t syms = 0; - s7_pointer lst; - /* this can't be optimized by returning the actual symbol-table (a vector of lists), because - * gensyms can cause the table's lists and symbols to change at any time. This wreaks havoc - * on traversals like for-each. So, symbol-table returns a snap-shot of the table contents - * at the time it is called. - * (define (for-each-symbol func num) (for-each (lambda (sym) (if (> num 0) (for-each-symbol func (- num 1)) (func sym))) (symbol-table))) - * (for-each-symbol (lambda (sym) (gensym) 1)) - */ - for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = entries[i]; is_not_null(x); x = cdr(x)) - syms++; - sc->w = make_simple_vector(sc, syms); - els = vector_elements(sc->w); - for (int32_t i = 0, j = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = entries[i]; is_not_null(x); x = cdr(x)) - els[j++] = car(x); - lst = sc->w; - sc->w = sc->unused; - return(lst); -} - -bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data) -{ - /* this includes the special constants # and so on for simplicity -- are there any others? */ - for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) - if (symbol_func(symbol_name(car(x)), data)) - return(true); - return((symbol_func("#t", data)) || (symbol_func("#f", data)) || - (symbol_func("#", data)) || (symbol_func("#", data)) || - (symbol_func("#", data)) || - (symbol_func("#true", data)) || (symbol_func("#false", data))); -} - -bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data) -{ - for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) - if (symbol_func(symbol_name(car(x)), data)) - return(true); - return(false); -} - - -/* -------------------------------- gensym -------------------------------- */ -static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym) -{ - /* sym is a free cell at this point (we're called after the GC), but the name_cell is still intact */ - s7_pointer name = symbol_name_cell(sym); - uint32_t location = string_hash(name) % SYMBOL_TABLE_SIZE; - s7_pointer x = vector_element(sc->symbol_table, location); - if (car(x) == sym) - vector_element(sc->symbol_table, location) = cdr(x); - else - for (s7_pointer y = x, z = cdr(x); is_pair(z); y = z, z = cdr(z)) - if (car(z) == sym) - { - set_cdr(y, cdr(z)); - return; - } -} - -s7_pointer s7_gensym(s7_scheme *sc, const char *prefix) -{ - s7_int len = safe_strlen(prefix) + 32; - block_t *b = mallocate(sc, len); - char *name = (char *)block_data(b); - /* there's no point in heroic efforts here to avoid name collisions -- the user can screw up no matter what we do */ - name[0] = '\0'; - { - s7_int slen = catstrs(name, len, "{", (prefix) ? prefix : "", "}-", pos_int_to_str_direct(sc, sc->gensym_counter++), (char *)NULL); - uint64_t hash = raw_string_hash((const uint8_t *)name, slen); - int32_t location = hash % SYMBOL_TABLE_SIZE; - s7_pointer x = new_symbol(sc, name, slen, hash, location); /* not T_GENSYM -- might be called from outside */ - liberate(sc, b); - return(x); - } -} - -static bool is_gensym_b_p(s7_pointer g) {return((is_symbol(g)) && (is_gensym(g)));} - -static s7_pointer g_is_gensym(s7_scheme *sc, s7_pointer args) -{ - #define H_is_gensym "(gensym? sym) returns #t if sym is a gensym" - #define Q_is_gensym sc->pl_bt - check_boolean_method(sc, is_gensym_b_p, sc->is_gensym_symbol, args); -} - -static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args) -{ - #define H_gensym "(gensym (prefix \"gensym\")) returns a new, unused symbol" - #define Q_gensym s7_make_signature(sc, 2, sc->is_gensym_symbol, sc->is_string_symbol) - - const char *prefix; - char *name, *p, *base; - s7_int len, plen, nlen; - uint32_t location; - uint64_t hash; - s7_pointer x, str, stc; - block_t *b, *ib; - - /* get symbol name */ - if (is_not_null(args)) - { - s7_pointer gname = car(args); - if (!is_string(gname)) - return(sole_arg_method_or_bust(sc, gname, sc->gensym_symbol, args, sc->type_names[T_STRING])); - prefix = string_value(gname); - plen = string_length(gname); /* was safe_strlen(prefix): were we stopping at #\null deliberately? */ - } - else - { - prefix = "gensym"; - plen = 6; - } - len = plen + 32; /* why 32 -- we need room for the gensym_counter integer, but (length "9223372036854775807") = 19 */ - - b = mallocate(sc, len + sizeof(block_t) + 2 * sizeof(s7_cell)); - base = (char *)block_data(b); - str = (s7_cell *)base; - stc = (s7_cell *)(base + sizeof(s7_cell)); - ib = (block_t *)(base + 2 * sizeof(s7_cell)); - name = (char *)(base + sizeof(block_t) + 2 * sizeof(s7_cell)); - - name[0] = '{'; - memcpy((void *)(name + 1), prefix, plen); /* memcpy is ok with plen==0, I think */ - name[plen + 1] = '}'; - name[plen + 2] = '-'; /* {gensym}-nnn */ - - p = pos_int_to_str(sc, sc->gensym_counter++, &len, '\0'); - memcpy((void *)(name + plen + 3), (void *)p, len); - nlen = len + plen + 2; - hash = raw_string_hash((const uint8_t *)name, nlen); - location = hash % SYMBOL_TABLE_SIZE; - - if ((WITH_WARNINGS) && (!is_null(symbol_table_find_by_name(sc, name, hash, location, nlen)))) - s7_warn(sc, nlen + 32, "%s is already in use!", name); - - /* make-string for symbol name */ - if (S7_DEBUGGING) full_type(str) = 0; /* here and below, this is needed to avoid set_type check errors (mallocate above) */ - set_full_type(str, T_STRING | T_IMMUTABLE | T_UNHEAP); - string_length(str) = nlen; - string_value(str) = name; - string_hash(str) = hash; - - /* allocate the symbol in the heap so GC'd when inaccessible */ - new_cell(sc, x, T_SYMBOL | T_GENSYM); - symbol_set_name_cell(x, str); - symbol_info(x) = ib; - set_global_slot(x, sc->undefined); /* set_initial_slot(x, sc->undefined); */ - symbol_set_local_slot_unchecked(x, 0LL, sc->nil); - symbol_clear_ctr(x); - symbol_set_tag(x, 0); - symbol_set_tag2(x, 0); - symbol_clear_type(x); - gensym_block(x) = b; - - /* place new symbol in symbol-table */ - if (S7_DEBUGGING) full_type(stc) = 0; - set_full_type(stc, T_PAIR | T_IMMUTABLE | T_UNHEAP); - set_car(stc, x); - set_cdr(stc, vector_element(sc->symbol_table, location)); - vector_element(sc->symbol_table, location) = stc; - pair_set_raw_hash(stc, hash); - pair_set_raw_len(stc, (uint64_t)string_length(str)); - pair_set_raw_name(stc, string_value(str)); - - add_gensym(sc, x); - return(x); -} - - -/* -------------------------------- syntax? -------------------------------- */ -bool s7_is_syntax(s7_pointer p) {return(is_syntax(p));} - -static s7_pointer g_is_syntax(s7_scheme *sc, s7_pointer args) -{ - #define H_is_syntax "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)" - #define Q_is_syntax sc->pl_bt - check_boolean_method(sc, is_syntax, sc->is_syntax_symbol, args); -} - - -/* -------------------------------- symbol? -------------------------------- */ -bool s7_is_symbol(s7_pointer p) {return(is_symbol(p));} - -static s7_pointer g_is_symbol(s7_scheme *sc, s7_pointer args) -{ - #define H_is_symbol "(symbol? obj) returns #t if obj is a symbol" - #define Q_is_symbol sc->pl_bt - check_boolean_method(sc, is_symbol, sc->is_symbol_symbol, args); -} - -const char *s7_symbol_name(s7_pointer p) {return(symbol_name(p));} - -s7_pointer s7_name_to_value(s7_scheme *sc, const char *name) {return(s7_symbol_value(sc, make_symbol_with_strlen(sc, name)));} -/* should this also handle non-symbols such as "+nan.0"? */ - - -/* -------------------------------- symbol->string -------------------------------- */ -static Inline s7_pointer inline_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) -{ - s7_pointer x; - new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE); - string_block(x) = inline_mallocate(sc, len + 1); - string_value(x) = (char *)block_data(string_block(x)); - memcpy((void *)string_value(x), (void *)str, len); - string_value(x)[len] = 0; - string_length(x) = len; - string_hash(x) = 0; - add_string(sc, x); - return(x); -} - -static s7_pointer make_string_with_length(s7_scheme *sc, const char *str, s7_int len) -{ - return(inline_make_string_with_length(sc, str, len)); /* packaged to avoid inlining everywhere */ -} - -static s7_pointer g_symbol_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol_to_string "(symbol->string sym) returns the symbol sym converted to a string" - #define Q_symbol_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_symbol_symbol) - - s7_pointer sym = car(args); - if (!is_symbol(sym)) - return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, sc->type_names[T_SYMBOL])); - /* s7_make_string uses strlen which stops at an embedded null */ - return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy */ -} - -static s7_pointer g_symbol_to_string_uncopied(s7_scheme *sc, s7_pointer args) -{ - s7_pointer sym = car(args); - if (!is_symbol(sym)) - return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, sc->type_names[T_SYMBOL])); - if (is_gensym(sym)) - return(make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy of gensym name (which will be freed) */ - return(symbol_name_cell(sym)); -} - -static s7_pointer symbol_to_string_p_p(s7_scheme *sc, s7_pointer sym) -{ - if (!is_symbol(sym)) - return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL])); - return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); -} - -static s7_pointer symbol_to_string_uncopied_p(s7_scheme *sc, s7_pointer sym) -{ - if (!is_symbol(sym)) - return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL])); - if (is_gensym(sym)) - return(make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); - return(symbol_name_cell(sym)); -} - - -/* -------------------------------- string->symbol -------------------------------- */ -static inline s7_pointer g_string_to_symbol_1(s7_scheme *sc, s7_pointer str, s7_pointer caller) -{ - if (!is_string(str)) - return(method_or_bust_p(sc, str, caller, sc->type_names[T_STRING])); - if (string_length(str) <= 0) - sole_arg_wrong_type_error_nr(sc, caller, str, wrap_string(sc, "a non-null string", 17)); - return(make_symbol(sc, string_value(str), string_length(str))); -} - -static s7_pointer g_string_to_symbol(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_symbol "(string->symbol str) returns the string str converted to a symbol" - #define Q_string_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_string_symbol) - return(g_string_to_symbol_1(sc, car(args), sc->string_to_symbol_symbol)); -} - -static s7_pointer string_to_symbol_p_p(s7_scheme *sc, s7_pointer p) {return(g_string_to_symbol_1(sc, p, sc->string_to_symbol_symbol));} - - -/* -------------------------------- symbol -------------------------------- */ -static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller); - -static s7_pointer mark_as_symbol_from_symbol(s7_pointer sym) -{ - set_is_symbol_from_symbol(sym); - return(sym); -} - -static s7_pointer g_symbol(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol "(symbol str ...) returns its string arguments concatenated and converted to a symbol" - #define Q_symbol s7_make_circular_signature(sc, 1, 2, sc->is_symbol_symbol, sc->is_string_symbol) - - /* (let ((x 0)) (set! (symbol "x") 12)) ;symbol (a c-function) does not have a setter: (set! (symbol "x") 12) - * (let (((symbol "x") 3)) x) ; bad variable ((symbol "x") - * (let ((x 2)) (+ (symbol "x") 1)) ;+ first argument, x, is a symbol but should be a number - * maybe document this: (symbol...) just returns the symbol - * (let ((x 3)) (+ (symbol->value (symbol "x")) 1)) -> 4, (let ((x 0)) (apply set! (symbol "x") (list 32)) x) -> 32 - */ - - s7_int len = 0, cur_len; - s7_pointer p, sym; - block_t *b; - char *name; - - for (p = args; is_pair(p); p = cdr(p)) - if (is_string(car(p))) - len += string_length(car(p)); - else break; - if (is_pair(p)) - { - if (is_null(cdr(args))) - return(mark_as_symbol_from_symbol(g_string_to_symbol_1(sc, car(args), sc->symbol_symbol))); - return(mark_as_symbol_from_symbol(g_string_to_symbol_1(sc, g_string_append_1(sc, args, sc->symbol_symbol), sc->symbol_symbol))); - } - if (len == 0) - sole_arg_wrong_type_error_nr(sc, sc->symbol_symbol, car(args), wrap_string(sc, "a non-null string", 17)); - - b = mallocate(sc, len + 1); - name = (char *)block_data(b); - /* can't use catstrs_direct here because it stops at embedded null */ - for (cur_len = 0, p = args; is_pair(p); p = cdr(p)) - { - s7_pointer str = car(p); - if (string_length(str) > 0) - { - memcpy((void *)(name + cur_len), (void *)string_value(str), string_length(str)); - cur_len += string_length(str); - }} - name[len] = '\0'; - sym = mark_as_symbol_from_symbol(inline_make_symbol(sc, name, len)); - liberate(sc, b); - return(sym); -} - -static s7_pointer symbol_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - char buf[256]; - s7_int len; - if ((!is_string(p1)) || (!is_string(p2))) return(g_symbol(sc, set_plist_2(sc, p1, p2))); - len = string_length(p1) + string_length(p2); - if ((len == 0) || (len >= 256)) return(g_symbol(sc, set_plist_2(sc, p1, p2))); - memcpy((void *)buf, (void *)string_value(p1), string_length(p1)); - memcpy((void *)(buf + string_length(p1)), (void *)string_value(p2), string_length(p2)); - return(mark_as_symbol_from_symbol(inline_make_symbol(sc, buf, len))); -} - - -/* -------- symbol sets -------- */ -static inline s7_pointer add_symbol_to_list(s7_scheme *sc, s7_pointer sym) -{ - symbol_set_tag(sym, sc->syms_tag); - symbol_set_tag2(sym, sc->syms_tag2); - return(sym); -} - -static inline void clear_symbol_list(s7_scheme *sc) -{ - sc->syms_tag++; - if (sc->syms_tag == 0) - { - sc->syms_tag = 1; /* we're assuming (in let_equal) that this tag is not 0 */ - sc->syms_tag2++; - } -} - -#define symbol_is_in_list(Sc, Sym) ((symbol_tag(Sym) == Sc->syms_tag) && (symbol_tag2(Sym) == Sc->syms_tag2)) - - -/* -------------------------------- lets/slots -------------------------------- */ -static Inline s7_pointer inline_make_let(s7_scheme *sc, s7_pointer old_let) -{ - s7_pointer x; - new_cell(sc, x, T_LET | T_SAFE_PROCEDURE); - let_set_id(x, ++sc->let_number); - let_set_slots(x, slot_end(sc)); - let_set_outlet(x, old_let); - return(x); -} - -static inline s7_pointer make_let(s7_scheme *sc, s7_pointer old_let) {return(inline_make_let(sc, old_let));} - -static Inline s7_pointer inline_make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer new_let, slot; - sc->value = value; - new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); - let_set_id(new_let, ++sc->let_number); - let_set_outlet(new_let, old_let); - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - symbol_set_local_slot(symbol, sc->let_number, slot); - slot_set_next(slot, slot_end(sc)); - let_set_slots(new_let, slot); - return(new_let); -} - -static s7_pointer make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value) -{ - return(inline_make_let_with_slot(sc, old_let, symbol, value)); -} - -static Inline s7_pointer inline_make_let_with_two_slots(s7_scheme *sc, s7_pointer old_let, - s7_pointer symbol1, s7_pointer value1, s7_pointer symbol2, s7_pointer value2) -{ - /* we leave value1/value2 computation order to the C compiler here -- in the old macro, it was explicitly value1 then value2 - * this means any let in old scheme code that actually depends on the order may break -- it should be let*. - */ - s7_pointer new_let, slot1, slot2; - new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); - let_set_id(new_let, ++sc->let_number); - let_set_outlet(new_let, old_let); - - new_cell_no_check(sc, slot1, T_SLOT); - slot_set_symbol_and_value(slot1, symbol1, value1); - symbol_set_local_slot(symbol1, sc->let_number, slot1); - let_set_slots(new_let, slot1); - - new_cell_no_check(sc, slot2, T_SLOT); - slot_set_symbol_and_value(slot2, symbol2, value2); - symbol_set_local_slot(symbol2, sc->let_number, slot2); - slot_set_next(slot2, slot_end(sc)); - slot_set_next(slot1, slot2); - return(new_let); -} - -static s7_pointer make_let_with_two_slots(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol1, s7_pointer value1, s7_pointer symbol2, s7_pointer value2) -{ - return(inline_make_let_with_two_slots(sc, old_let, symbol1, value1, symbol2, value2)); -} - -/* in all these functions, symbol_set_local_slot should follow slot_set_value so that we can evaluate the slot's value in its old state */ -static inline void add_slot_unchecked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value, uint64_t id) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - set_local(symbol); - symbol_set_local_slot(symbol, id, slot); -} - -static void add_slot_unchecked_no_local(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - set_local(symbol); -} - -#define add_slot(Sc, Let, Symbol, Value) add_slot_unchecked(Sc, Let, Symbol, Value, let_id(Let)) - -static inline s7_pointer add_slot_checked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - symbol_set_local_slot(symbol, let_id(let), slot); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - return(slot); -} - -static inline s7_pointer add_slot_checked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - set_local(symbol); - if (let_id(let) >= symbol_id(symbol)) - symbol_set_local_slot(symbol, let_id(let), slot); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - return(slot); -} - -static s7_pointer add_slot_unchecked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - set_local(symbol); - if (let_id(let) >= symbol_id(symbol)) - symbol_set_local_slot(symbol, let_id(let), slot); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - return(slot); -} - -static Inline s7_pointer inline_add_slot_at_end(s7_scheme *sc, uint64_t id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - slot_set_next(slot, slot_end(sc)); - symbol_set_local_slot(symbol, id, slot); - slot_set_next(last_slot, slot); - return(slot); -} - -static s7_pointer add_slot_at_end(s7_scheme *sc, uint64_t id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) -{ - return(inline_add_slot_at_end(sc, id, last_slot, symbol, value)); -} - -static s7_pointer add_slot_at_end_no_local(s7_scheme *sc, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) -{ - s7_pointer slot; - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - slot_set_next(slot, slot_end(sc)); - slot_set_next(last_slot, slot); - return(slot); -} - -static inline void make_let_with_three_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3) -{ - s7_pointer last_slot, cargs = closure_args(func); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, cadr(cargs), val2); - last_slot = next_slot(let_slots(sc->curlet)); - inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(cargs), val3); -} - -static inline void make_let_with_four_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4) -{ - s7_pointer last_slot, cargs = closure_args(func); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, cadr(cargs), val2); - cargs = cddr(cargs); - last_slot = next_slot(let_slots(sc->curlet)); - last_slot = inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(cargs), val3); - inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(cargs), val4); -} - -static s7_pointer reuse_as_let(s7_scheme *sc, s7_pointer let, s7_pointer next_let) -{ - /* we're reusing let here as a let -- it was probably a pair */ -#if S7_DEBUGGING - let->debugger_bits = 0; - if (!in_heap(let)) {fprintf(stderr, "reusing an unheaped %s as a let?\n", s7_type_names[type(let)]); abort();} -#endif - set_full_type(T_Pair(let), T_LET | T_SAFE_PROCEDURE); - let_set_slots(let, slot_end(sc)); - let_set_outlet(let, next_let); - let_set_id(let, ++sc->let_number); - return(let); -} - -static s7_pointer reuse_as_slot(s7_scheme *sc, s7_pointer slot, s7_pointer symbol, s7_pointer value) -{ - set_full_type(T_Pair(slot), T_SLOT); - slot_set_symbol_and_value(slot, symbol, value); - return(slot); -} - -#define update_slot(Slot, Val, Id) do {s7_pointer sym; slot_set_value(Slot, Val); sym = slot_symbol(Slot); symbol_set_local_slot_unincremented(sym, Id, Slot);} while (0) - -static s7_pointer update_let_with_slot(s7_scheme *sc, s7_pointer let, s7_pointer val) -{ - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - update_slot(slot, val, id); - return(let); -} - -static s7_pointer update_let_with_two_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2) -{ - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - update_slot(slot, val1, id); slot = next_slot(slot); - update_slot(slot, val2, id); - return(let); -} - -static s7_pointer update_let_with_three_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2, s7_pointer val3) -{ - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - update_slot(slot, val1, id); slot = next_slot(slot); - update_slot(slot, val2, id); slot = next_slot(slot); - update_slot(slot, val3, id); - return(let); -} - -static s7_pointer update_let_with_four_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4) -{ - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - update_slot(slot, val1, id); slot = next_slot(slot); - update_slot(slot, val2, id); slot = next_slot(slot); - update_slot(slot, val3, id); slot = next_slot(slot); - update_slot(slot, val4, id); - return(let); -} - -static s7_pointer make_semipermanent_let(s7_scheme *sc, s7_pointer vars) -{ - s7_pointer slot, let = alloc_pointer(sc); - set_full_type(let, T_LET | T_SAFE_PROCEDURE | T_UNHEAP); - let_set_id(let, ++sc->let_number); - let_set_outlet(let, sc->curlet); - slot = make_semipermanent_slot(sc, caar(vars), sc->F); - add_semipermanent_let_or_slot(sc, slot); - symbol_set_local_slot(caar(vars), sc->let_number, slot); - let_set_slots(let, slot); - for (s7_pointer var = cdr(vars); is_pair(var); var = cdr(var)) - { - s7_pointer last_slot = slot; - slot = make_semipermanent_slot(sc, caar(var), sc->F); - add_semipermanent_let_or_slot(sc, slot); - symbol_set_local_slot(caar(var), sc->let_number, slot); - slot_set_next(last_slot, slot); - } - slot_set_next(slot, slot_end(sc)); - add_semipermanent_let_or_slot(sc, let); /* need to mark outlet and maybe slot values */ - return(let); -} - -static s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer old_value); - -static inline s7_pointer checked_slot_set_value(s7_scheme *sc, s7_pointer y, s7_pointer value) -{ - if (slot_has_setter(y)) - slot_set_value(y, call_setter(sc, y, value)); - else - { - if (is_immutable_slot(y)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_set_symbol, slot_symbol(y))); - slot_set_value(y, value); - } - return(slot_value(y)); -} - -static s7_pointer let_fill(s7_scheme *sc, s7_pointer args) -{ - s7_pointer e = car(args), val; - if (e == sc->rootlet) - out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! rootlet", 19)); - if (e == sc->s7_starlet) - out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! *s7*", 16)); - if (e == sc->owlet) /* (owlet) copies sc->owlet, so this probably can't happen */ - out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! owlet", 17)); - if (is_funclet(e)) - out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! a funclet", 21)); - val = cadr(args); - for (s7_pointer p = let_slots(e); tis_slot(p); p = next_slot(p)) - checked_slot_set_value(sc, p, val); - return(val); -} - -static s7_int s7_starlet_length(void); - -static s7_int let_length(s7_scheme *sc, s7_pointer e) -{ - /* used by length, applicable_length, copy, and some length optimizations */ - s7_int i; - s7_pointer p; - - if (e == sc->rootlet) - return(sc->rootlet_entries); - if (e == sc->s7_starlet) - return(s7_starlet_length()); - if (has_active_methods(sc, e)) - { - s7_pointer length_func = find_method(sc, e, sc->length_symbol); - if (length_func != sc->undefined) - { - p = s7_apply_function(sc, length_func, set_plist_1(sc, e)); - return((s7_is_integer(p)) ? s7_integer(p) : -1); /* ?? */ - }} - for (i = 0, p = let_slots(e); tis_slot(p); i++, p = next_slot(p)); - return(i); -} - - -static void slot_set_setter(s7_pointer p, s7_pointer val) -{ - if ((type(val) == T_C_FUNCTION) && - (c_function_has_bool_setter(val))) - slot_set_setter_1(p, c_function_bool_setter(val)); - else slot_set_setter_1(p, val); -} - -static void slot_set_value_with_hook_1(s7_scheme *sc, s7_pointer slot, s7_pointer value) -{ - /* (set! (hook-functions *rootlet-redefinition-hook*) (list (lambda (hook) (format *stderr* "~A ~A~%" (hook 'name) (hook 'value))))) */ - s7_pointer symbol = slot_symbol(slot); - if ((global_slot(symbol) == slot) && - (value != slot_value(slot))) - s7_call(sc, sc->rootlet_redefinition_hook, set_plist_2(sc, symbol, value)); - slot_set_value(slot, value); -} - -static void remove_function_from_heap(s7_scheme *sc, s7_pointer value); /* calls remove_let_from_heap */ - -static void remove_let_from_heap(s7_scheme *sc, s7_pointer lt) -{ - for (s7_pointer p = let_slots(lt); tis_slot(p); p = next_slot(p)) - { - s7_pointer val = slot_value(p); - if ((has_closure_let(val)) && - (in_heap(closure_args(val)))) - remove_function_from_heap(sc, val); - } - let_set_removed(lt); -} - -static void add_slot_to_rootlet(s7_scheme *sc, s7_pointer slot) -{ - s7_pointer ge = sc->rootlet; - rootlet_element(ge, sc->rootlet_entries++) = slot; - set_in_rootlet(slot); - if (sc->rootlet_entries >= vector_length(ge)) - { - s7_int len; - block_t *ob, *nb; - vector_length(ge) *= 2; - len = vector_length(ge); - ob = rootlet_block(ge); - nb = reallocate(sc, ob, len * sizeof(s7_pointer)); - block_info(nb) = NULL; - rootlet_block(ge) = nb; - rootlet_elements(ge) = (s7_pointer *)block_data(nb); - for (s7_int i = sc->rootlet_entries; i < len; i++) rootlet_element(ge, i) = sc->nil; - } -} - -static void remove_function_from_heap(s7_scheme *sc, s7_pointer value) -{ - s7_pointer lt; - remove_from_heap(sc, closure_args(value)); - remove_from_heap(sc, closure_body(value)); - /* remove closure if it's local to current func (meaning (define f (let ...) (lambda ...)) removes the enclosing let) */ - lt = closure_let(value); /* closure_let and all its outlets can't be rootlet */ - if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) - { - lt = let_outlet(lt); - if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) - { - remove_let_from_heap(sc, lt); - lt = let_outlet(lt); - if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) - remove_let_from_heap(sc, lt); - }} -} - -s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - if ((!is_let(let)) || - (let == sc->rootlet)) - { - s7_pointer slot; - if (is_immutable(sc->rootlet)) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't define '~S; rootlet is immutable", 38), symbol)); - if ((sc->safety <= NO_SAFETY) && - (has_closure_let(value))) - remove_function_from_heap(sc, value); - - /* first look for existing slot -- this is not always checked before calling s7_make_slot */ - if (is_slot(global_slot(symbol))) - { - slot = global_slot(symbol); - symbol_increment_ctr(symbol); - slot_set_value_with_hook(slot, value); - return(slot); - } - - slot = make_semipermanent_slot(sc, symbol, value); - add_slot_to_rootlet(sc, slot); - set_global_slot(symbol, slot); - if (symbol_id(symbol) == 0) /* never defined locally? */ - { - if ((!is_gensym(symbol)) && - (initial_slot(symbol) == sc->undefined) && - (!in_heap(value)) && /* else initial_slot value can be GC'd if symbol set! (initial != global, initial unprotected) */ - ((!sc->unlet) || /* init_unlet creates sc->unlet (includes syntax), after that initial_slot is for c_functions?? */ - (is_c_function(value)))) /* || (is_syntax(value)) -- we need 'else as a special case? */ - set_initial_slot(symbol, make_semipermanent_slot(sc, symbol, value)); - set_local_slot(symbol, slot); - set_global(symbol); - } - symbol_increment_ctr(symbol); - if (is_gensym(symbol)) - remove_gensym_from_heap(sc, symbol); - return(slot); - } - return(add_slot_checked_with_id(sc, let, symbol, value)); - /* there are about as many lets as local variables -- this strikes me as surprising, but it holds up across a lot of code */ -} - -static s7_pointer make_slot(s7_scheme *sc, s7_pointer variable, s7_pointer value) -{ - s7_pointer y; - new_cell(sc, y, T_SLOT); - slot_set_symbol_and_value(y, variable, value); - return(y); -} - - -/* -------------------------------- let? -------------------------------- */ -bool s7_is_let(s7_pointer e) {return(is_let(e));} - -static s7_pointer g_is_let(s7_scheme *sc, s7_pointer args) -{ - #define H_is_let "(let? obj) returns #t if obj is a let." - #define Q_is_let sc->pl_bt - check_boolean_method(sc, is_let, sc->is_let_symbol, args); -} - - -/* -------------------------------- funclet? -------------------------------- */ -static s7_pointer g_is_funclet(s7_scheme *sc, s7_pointer args) -{ - #define H_is_funclet "(funclet? obj) returns #t if obj is a funclet (a function's environment)." - #define Q_is_funclet sc->pl_bt - - s7_pointer lt = car(args); - if ((is_let(lt)) && ((is_funclet(lt)) || (is_maclet(lt)))) - return(sc->T); - if (!has_active_methods(sc, lt)) - return(sc->F); - return(apply_boolean_method(sc, lt, sc->is_funclet_symbol)); -} - - -/* -------------------------------- unlet -------------------------------- */ -static s7_pointer normal_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val); -static s7_pointer normal_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc); - -#define UNLET_ENTRIES 512 /* 397 if not --disable-deprecated etc */ - -static void init_unlet(s7_scheme *sc) -{ - int32_t k = 0; - s7_pointer *inits; - s7_pointer *els = vector_elements(sc->symbol_table); - block_t *block = mallocate(sc, UNLET_ENTRIES * sizeof(s7_pointer)); - sc->unlet = (s7_pointer)Calloc(1, sizeof(s7_cell)); /* freed explicitly in s7_free */ - set_full_type(sc->unlet, T_VECTOR | T_UNHEAP); - vector_length(sc->unlet) = UNLET_ENTRIES; - vector_block(sc->unlet) = block; - vector_elements(sc->unlet) = (s7_pointer *)block_data(block); - vector_set_dimension_info(sc->unlet, NULL); - vector_getter(sc->unlet) = normal_vector_getter; - vector_setter(sc->unlet) = normal_vector_setter; - inits = vector_elements(sc->unlet); - s7_vector_fill(sc, sc->unlet, sc->nil); - - inits[k++] = initial_slot(sc->else_symbol); - for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = els[i]; is_pair(x); x = cdr(x)) - { - s7_pointer sym = car(x); - if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) - { - s7_pointer val = initial_value(sym); - if ((is_c_function(val)) || (is_syntax(val))) /* we assume the initial_slot value needs no GC protection */ - inits[k++] = initial_slot(sym); - /* non-c_functions that are not set! (and therefore initial_slot GC) protected by default: make-hook hook-functions - * if these initial_slot values are added to unlet, they need explicit GC protection. - */ - if ((S7_DEBUGGING) && (k >= UNLET_ENTRIES)) fprintf(stderr, "unlet overflow\n"); - }} -} - -static s7_pointer g_unlet(s7_scheme *sc, s7_pointer unused_args) -{ - /* add sc->unlet bindings to the current environment */ - #define H_unlet "(unlet) returns a let that establishes the original bindings of all the predefined functions" - #define Q_unlet s7_make_signature(sc, 1, sc->is_let_symbol) - - s7_pointer *inits = vector_elements(sc->unlet); - s7_pointer res; - - sc->w = make_let(sc, sc->curlet); - for (int32_t i = 0; (i < UNLET_ENTRIES) && (is_slot(inits[i])); i++) - { - s7_pointer sym = slot_symbol(inits[i]); - s7_pointer x = slot_value(inits[i]); - if ((x != global_value(sym)) || /* it has been changed globally */ - ((!is_global(sym)) && /* it might be shadowed locally */ - (s7_symbol_local_value(sc, sym, sc->curlet) != global_value(sym)))) - add_slot_checked_with_id(sc, sc->w, sym, x); - } - /* if (set! + -) then + needs to be overridden, but the local bit isn't set, so we have to check the actual values in the non-local case. - * (define (f x) (with-let (unlet) (+ x 1))) - */ - res = sc->w; - sc->w = sc->unused; - return(res); -} - - -/* -------------------------------- openlet? -------------------------------- */ -bool s7_is_openlet(s7_pointer e) {return(has_methods(e));} - -static s7_pointer g_is_openlet(s7_scheme *sc, s7_pointer args) -{ - #define H_is_openlet "(openlet? obj) returns #t is 'obj' has methods." - #define Q_is_openlet sc->pl_bt - - s7_pointer e = car(args); /* if e is not a let, should this raise an error? -- no, easier to use this way in cond */ - check_method(sc, e, sc->is_openlet_symbol, args); - return(make_boolean(sc, has_methods(e))); -} - - -/* -------------------------------- openlet -------------------------------- */ -s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e) -{ - set_has_methods(e); - return(e); -} - -static s7_pointer g_openlet(s7_scheme *sc, s7_pointer args) -{ - #define H_openlet "(openlet e) tells the built-in generic functions that the let 'e might have an over-riding method." - #define Q_openlet sc->pcl_e - - s7_pointer e = car(args), elet, func; - if ((e == sc->rootlet) || (e == sc->nil)) - error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet rootlet", 21))); - elet = find_let(sc, e); /* returns nil if no let found, so has to follow error check above */ - if (!is_let(elet)) - sole_arg_wrong_type_error_nr(sc, sc->openlet_symbol, e, a_let_string); - if ((has_active_methods(sc, e)) && - ((func = find_method(sc, elet, sc->openlet_symbol)) != sc->undefined)) - return(s7_apply_function(sc, func, args)); - set_has_methods(e); - return(e); -} - -/* -------------------------------- coverlet -------------------------------- */ -static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args) -{ - #define H_coverlet "(coverlet e) undoes an earlier openlet." - #define Q_coverlet sc->pcl_e - - s7_pointer e = car(args); - check_method(sc, e, sc->coverlet_symbol, set_plist_1(sc, e)); - if ((e == sc->rootlet) || (e == sc->s7_starlet)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), e)); - - if ((is_let(e)) || (has_closure_let(e)) || - ((is_c_object(e)) && (c_object_let(e) != sc->nil)) || - ((is_c_pointer(e)) && (is_let(c_pointer_info(e))))) - { - clear_has_methods(e); - return(e); - } - sole_arg_wrong_type_error_nr(sc, sc->coverlet_symbol, e, a_let_string); - return(NULL); -} - - -/* -------------------------------- varlet -------------------------------- */ -static void check_let_fallback(s7_scheme *sc, s7_pointer symbol, s7_pointer let) -{ - if (symbol == sc->let_ref_fallback_symbol) - set_has_let_ref_fallback(let); - else - if (symbol == sc->let_set_fallback_symbol) - set_has_let_set_fallback(let); -} - -static void append_let(s7_scheme *sc, s7_pointer new_e, s7_pointer old_e) -{ - if ((old_e == sc->rootlet) || (new_e == sc->s7_starlet)) - return; - if (new_e == sc->rootlet) - for (s7_pointer x = let_slots(old_e); tis_slot(x); x = next_slot(x)) - { - s7_pointer sym = slot_symbol(x), val = slot_value(x); - if (is_slot(global_slot(sym))) - slot_set_value(global_slot(sym), val); - else s7_make_slot(sc, new_e, sym, val); - } - else - if (old_e == sc->s7_starlet) - { - s7_pointer iter = s7_make_iterator(sc, sc->s7_starlet); - s7_int gc_loc = s7_gc_protect(sc, iter); - iterator_current(iter) = cons_unchecked(sc, sc->F, sc->F); - set_mark_seq(iter); /* so carrier is GC protected by mark_iterator */ - while (true) - { - s7_pointer y = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - add_slot_checked_with_id(sc, new_e, car(y), cdr(y)); - } - s7_gc_unprotect_at(sc, gc_loc); - } - else - for (s7_pointer x = let_slots(old_e); tis_slot(x); x = next_slot(x)) - add_slot_checked_with_id(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */ -} - -static s7_pointer check_c_object_let(s7_scheme *sc, s7_pointer old_e, s7_pointer caller) -{ - if (is_c_object(old_e)) - old_e = c_object_let(old_e); - if (!is_let(old_e)) - sole_arg_wrong_type_error_nr(sc, caller, old_e, a_let_string); - return(old_e); -} - -s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - if (!is_let(let)) - wrong_type_error_nr(sc, sc->varlet_symbol, 1, let, a_let_string); - if (!is_symbol(symbol)) - wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, a_symbol_string); - - if ((is_slot(global_slot(symbol))) && - (is_syntax(global_value(symbol)))) - wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); - - if (let == sc->rootlet) - { - if (is_slot(global_slot(symbol))) - slot_set_value(global_slot(symbol), value); - else s7_make_slot(sc, let, symbol, value); - } - else - { - add_slot_checked_with_id(sc, let, symbol, value); - check_let_fallback(sc, symbol, let); - } - return(value); -} - -static int32_t position_of(s7_pointer p, s7_pointer args) -{ - int32_t i; - for (i = 1; p != args; i++, args = cdr(args)); - return(i); -} - -static s7_pointer g_varlet(s7_scheme *sc, s7_pointer args) /* varlet = with-let + define */ -{ - #define H_varlet "(varlet let ...) adds its arguments (a let, a cons: symbol . value, or two arguments, the symbol and its value) \ -to the let let, and returns let. (varlet (curlet) 'a 1) adds 'a to the current environment with the value 1." - #define Q_varlet s7_make_circular_signature(sc, 2, 4, sc->is_let_symbol, \ - s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \ - s7_make_signature(sc, 3, sc->is_pair_symbol, sc->is_symbol_symbol, sc->is_let_symbol), \ - sc->T) - - s7_pointer e = car(args); - if (is_null(e)) - e = sc->rootlet; - else - { - check_method(sc, e, sc->varlet_symbol, args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->varlet_symbol, 1, e, a_let_string); - if ((is_immutable(e)) || (e == sc->s7_starlet)) - error_nr(sc, sc->immutable_error_symbol, - set_elist_3(sc, wrap_string(sc, "can't (varlet ~{~S~^ ~}), ~S is immutable", 41), args, e)); - } - for (s7_pointer x = cdr(args); is_pair(x); x = cdr(x)) - { - s7_pointer sym, val, p = car(x); - switch (type(p)) - { - case T_SYMBOL: - sym = (is_keyword(p)) ? keyword_symbol(p) : p; - if (!is_pair(cdr(x))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "varlet: symbol ~S, but no value: ~S", 35), p, args)); - if (is_constant_symbol(sc, sym)) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string); - x = cdr(x); - val = car(x); - break; - - case T_PAIR: - sym = car(p); - if (!is_symbol(sym)) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string); - if (is_constant_symbol(sc, sym)) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string); - val = cdr(p); - break; - - case T_LET: - append_let(sc, e, check_c_object_let(sc, p, sc->varlet_symbol)); - if (has_let_set_fallback(p)) set_has_let_set_fallback(e); - if (has_let_ref_fallback(p)) set_has_let_ref_fallback(e); - continue; - - default: - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string); - } - if (e == sc->rootlet) - { - if (is_slot(global_slot(sym))) - { - if (is_syntax(global_value(sym))) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, wrap_string(sc, "a non-syntactic symbol", 22)); - /* without this check we can end up turning our code into gibberish: - * (set! quote 1) -> ;can't set! quote - * (varlet (rootlet) '(quote . 1)), :quote -> 1 - * or worse set quote to a function of one arg that tries to quote something -- infinite loop - */ - slot_set_value_with_hook(global_slot(sym), val); - } - else s7_make_slot(sc, e, sym, val); - } - else - { - check_let_fallback(sc, sym, e); - add_slot_checked_with_id(sc, e, sym, val); - }} - /* this used to check for sym already defined, and set its value, but that greatly slows down - * the most common use (adding a slot), and makes it hard to shadow explicitly. Don't use - * varlet as a substitute for set!/let-set!. - */ - return(e); -} - - -/* -------------------------------- cutlet -------------------------------- */ -static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) -{ - #define H_cutlet "(cutlet e symbol ...) removes symbols from the let e." - #define Q_cutlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, sc->is_let_symbol, sc->is_symbol_symbol) - - s7_pointer e = car(args); - s7_int the_un_id; - if (is_null(e)) - e = sc->rootlet; - else - { - check_method(sc, e, sc->cutlet_symbol, args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->cutlet_symbol, 1, e, a_let_string); - if ((is_immutable(e)) || (e == sc->s7_starlet)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, e)); - } - /* besides removing the slot we have to make sure the symbol_id does not match else - * let-ref and others will use the old slot! What's the un-id? Perhaps the next one? - * (let ((b 1)) (let ((b 2)) (cutlet (curlet) 'b)) b) - */ - the_un_id = ++sc->let_number; - - for (s7_pointer syms = cdr(args); is_pair(syms); syms = cdr(syms)) - { - s7_pointer sym = car(syms); - - if (!is_symbol(sym)) - wrong_type_error_nr(sc, sc->cutlet_symbol, position_of(syms, args), sym, a_symbol_string); - if (is_keyword(sym)) - sym = keyword_symbol(sym); - - if (e == sc->rootlet) - { - if (!is_slot(global_slot(sym))) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); - if (is_immutable(global_slot(sym))) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); - symbol_set_id(sym, the_un_id); - slot_set_value(global_slot(sym), sc->undefined); - /* here we need to at least clear bits: syntactic binder clean-symbol(?) etc, maybe also locally */ - } - else - { - s7_pointer slot; - if ((has_let_fallback(e)) && - ((sym == sc->let_ref_fallback_symbol) || (sym == sc->let_set_fallback_symbol))) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); - - slot = let_slots(e); - if (tis_slot(slot)) - { - if (slot_symbol(slot) == sym) - { - if (is_immutable(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); - let_set_slots(e, next_slot(let_slots(e))); - symbol_set_id(sym, the_un_id); - } - else - { - s7_pointer last_slot = slot; - for (slot = next_slot(let_slots(e)); tis_slot(slot); last_slot = slot, slot = next_slot(slot)) - if (slot_symbol(slot) == sym) - { - if (is_immutable(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); - symbol_set_id(sym, the_un_id); - slot_set_next(last_slot, next_slot(slot)); - break; - }}}}} - return(e); -} - - -/* -------------------------------- sublet -------------------------------- */ -static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_pointer caller) -{ - s7_pointer new_e = make_let(sc, (e == sc->rootlet) ? sc->nil : e); - set_all_methods(new_e, e); - - if (!is_null(bindings)) - { - s7_pointer sp = NULL; - sc->temp3 = new_e; - for (s7_pointer x = bindings; is_pair(x); x = cdr(x)) - { - s7_pointer p = car(x), sym, val; - - switch (type(p)) - { - case T_SYMBOL: - sym = (is_keyword(p)) ? keyword_symbol(p) : p; - if (!is_pair(cdr(x))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: entry ~S, but no value: ~S", 30), caller, p, bindings)); - x = cdr(x); - val = car(x); - break; - - case T_PAIR: - sym = car(p); - if (!is_symbol(sym)) - wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), p, a_symbol_string); - if (is_keyword(sym)) - sym = keyword_symbol(sym); - val = cdr(p); - break; - - case T_LET: - append_let(sc, new_e, check_c_object_let(sc, p, caller)); - if (tis_slot(let_slots(new_e))) /* make sure the end slot (sp) is correct */ - for (sp = let_slots(new_e); tis_slot(next_slot(sp)); sp = next_slot(sp)); - continue; - - default: - wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), p, a_symbol_string); - } - - if (is_constant_symbol(sc, sym)) - wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), sym, a_non_constant_symbol_string); - if ((is_slot(global_slot(sym))) && - (is_syntax_or_qq(global_value(sym)))) - wrong_type_error_nr(sc, caller, 2, sym, wrap_string(sc, "a non-syntactic symbol", 22)); - - /* here we know new_e is a let and is not rootlet */ - if (!sp) - sp = add_slot_checked_with_id(sc, new_e, sym, val); - else - { - if (sc->free_heap_top <= sc->free_heap_trigger) try_to_call_gc(sc); /* or maybe add add_slot_at_end_checked? */ - sp = inline_add_slot_at_end(sc, let_id(new_e), sp, sym, val); - set_local(sym); /* ? */ - } - check_let_fallback(sc, sym, new_e); - } - sc->temp3 = sc->unused; - } - return(new_e); -} - -s7_pointer s7_sublet(s7_scheme *sc, s7_pointer e, s7_pointer bindings) {return(sublet_1(sc, e, bindings, sc->sublet_symbol));} - -static s7_pointer g_sublet(s7_scheme *sc, s7_pointer args) -{ - #define H_sublet "(sublet let ...) makes a new let within the environment 'let', initializing it with the bindings" - #define Q_sublet Q_varlet - - s7_pointer e = car(args); - if (is_null(e)) - e = sc->rootlet; - else - { - check_method(sc, e, sc->sublet_symbol, args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->sublet_symbol, 1, e, a_let_string); - } - return(sublet_1(sc, e, cdr(args), sc->sublet_symbol)); -} - -static s7_pointer g_sublet_curlet(s7_scheme *sc, s7_pointer args) -{ - s7_pointer sym = cadr(args), new_e; - check_method(sc, sc->curlet, sc->sublet_symbol, args); - new_e = inline_make_let_with_slot(sc, sc->curlet, sym, caddr(args)); - set_all_methods(new_e, sc->curlet); - check_let_fallback(sc, sym, new_e); - return(new_e); -} - -static s7_pointer sublet_chooser(s7_scheme *sc, s7_pointer f, int32_t num_args, s7_pointer expr, bool ops) -{ - if (num_args == 3) - { - s7_pointer args = cdr(expr); - if ((is_pair(car(args))) && (caar(args) == sc->curlet_symbol) && (is_null(cdar(args))) && - (is_pair(cadr(args))) && (caadr(args) == sc->quote_symbol) && (is_symbol(cadadr(args)))) - return(sc->sublet_curlet); - } - return(f); -} - - -/* -------------------------------- inlet -------------------------------- */ -s7_pointer s7_inlet(s7_scheme *sc, s7_pointer args) -{ - #define H_inlet "(inlet ...) adds its arguments, each a let, a cons: '(symbol . value), or a keyword/value pair, \ -to a new let, and returns the new let. (inlet :a 1 :b 2) or (inlet '(a . 1) '(b . 2))" - #define Q_inlet s7_make_circular_signature(sc, 1, 2, sc->is_let_symbol, sc->T) - return(sublet_1(sc, sc->rootlet, args, sc->inlet_symbol)); -} - -#define g_inlet s7_inlet - -static s7_pointer g_simple_inlet(s7_scheme *sc, s7_pointer args) -{ - /* here all args are paired with normal symbol/value, no fallbacks, no immutable symbols, no syntax, etc */ - s7_pointer new_e = make_let(sc, sc->nil); - int64_t id = let_id(new_e); - s7_pointer sp = NULL; - - sc->temp3 = new_e; - for (s7_pointer x = args; is_pair(x); x = cddr(x)) - { - s7_pointer symbol = car(x); - if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */ - symbol = keyword_symbol(symbol); - if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); - if (!sp) - { - add_slot_unchecked(sc, new_e, symbol, cadr(x), id); - sp = let_slots(new_e); - } - else sp = inline_add_slot_at_end(sc, id, sp, symbol, cadr(x)); - } - sc->temp3 = sc->unused; - return(new_e); -} - -static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value) -{ - s7_pointer x; - - if (!is_symbol(symbol)) - return(sublet_1(sc, sc->nil, set_plist_2(sc, symbol, value), sc->inlet_symbol)); - if (is_keyword(symbol)) - symbol = keyword_symbol(symbol); - if (is_constant_symbol(sc, symbol)) - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); - if ((is_global(symbol)) && - (is_syntax_or_qq(global_value(symbol)))) - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); - - new_cell(sc, x, T_LET | T_SAFE_PROCEDURE); - sc->temp3 = x; - let_set_id(x, ++sc->let_number); - let_set_outlet(x, sc->nil); - let_set_slots(x, slot_end(sc)); - add_slot_unchecked(sc, x, symbol, value, let_id(x)); - sc->temp3 = sc->unused; - return(x); -} - -static s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...) -{ - va_list ap; - s7_pointer new_e = make_let(sc, sc->nil); - int64_t id = let_id(new_e); - s7_pointer sp = NULL; - - sc->temp3 = new_e; - va_start(ap, num_args); - for (s7_int i = 0; i < num_args; i += 2) - { - s7_pointer symbol = va_arg(ap, s7_pointer); - s7_pointer value = va_arg(ap, s7_pointer); - if ((S7_DEBUGGING) && (is_keyword(symbol))) fprintf(stderr, "internal_inlet key: %s??\n", display(symbol)); - if (!sp) - { - add_slot_unchecked(sc, new_e, symbol, value, id); - sp = let_slots(new_e); - } - else sp = inline_add_slot_at_end(sc, id, sp, symbol, value); - } - va_end(ap); - sc->temp3 = sc->unused; - return(new_e); -} - -static bool is_proper_quote(s7_scheme *sc, s7_pointer p) -{ - return((is_quoted_pair(p)) && - (is_pair(cdr(p))) && - (is_null(cddr(p))) && - (is_global(sc->quote_symbol))); -} - -static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((args > 0) && - ((args % 2) == 0)) - { - for (s7_pointer p = cdr(expr); is_pair(p); p = cddr(p)) - if (!is_symbol_and_keyword(car(p))) - { - s7_pointer sym; - if (!is_proper_quote(sc, car(p))) /* 'abs etc, but tricky: ':abs */ - return(f); - sym = cadar(p); - if ((!is_symbol(sym)) || - (is_possibly_constant(sym)) || /* define-constant etc */ - (is_syntactic_symbol(sym)) || /* (inlet 'if 3) */ - ((is_slot(global_slot(sym))) && - (is_syntax_or_qq(global_value(sym)))) || /* (inlet 'quasiquote 1) */ - (sym == sc->let_ref_fallback_symbol) || - (sym == sc->let_set_fallback_symbol)) - return(f); - } - return(sc->simple_inlet); - } - return(f); -} - - -/* -------------------------------- let->list -------------------------------- */ -static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list); - -s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) -{ - s7_pointer x; - sc->temp3 = sc->w; - sc->w = sc->nil; - if (let == sc->rootlet) - { - s7_int i, lim2 = sc->rootlet_entries; - s7_pointer *entries = rootlet_elements(let); - - if (lim2 & 1) lim2--; - for (i = 0; i < lim2; ) - { - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); i++; - sc->w = cons_unchecked(sc, cons_unchecked(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); i++; - } - if (lim2 < sc->rootlet_entries) - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(entries[i]), slot_value(entries[i])), sc->w); - } - else - { - s7_pointer iter, func; - s7_int gc_loc = -1; - /* need to check make-iterator method before dropping into let->list */ - - if ((has_active_methods(sc, let)) && - ((func = find_method(sc, let, sc->make_iterator_symbol)) != sc->undefined)) - iter = s7_apply_function(sc, func, set_plist_1(sc, let)); - else - if (let == sc->s7_starlet) /* (let->list *s7*) via s7_starlet_make_iterator */ - { - iter = s7_make_iterator(sc, let); - gc_loc = s7_gc_protect(sc, iter); - } - else iter = sc->nil; - - if (is_null(iter)) - for (x = let_slots(let); tis_slot(x); x = next_slot(x)) - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(x), slot_value(x)), sc->w); - else - /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */ - while (true) - { - x = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - sc->w = cons(sc, x, sc->w); - } - sc->w = proper_list_reverse_in_place(sc, sc->w); - if (gc_loc != -1) - s7_gc_unprotect_at(sc, gc_loc); - } - x = sc->w; - sc->w = sc->temp3; - sc->temp3 = sc->unused; - return(x); -} - -#if (!WITH_PURE_S7) -static s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_let_to_list "(let->list let) returns let's bindings as a list of cons's: '(symbol . value)." - #define Q_let_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_let_symbol) - - s7_pointer let = car(args); - check_method(sc, let, sc->let_to_list_symbol, args); - if (!is_let(let)) - { - if (is_c_object(let)) - let = c_object_let(let); - else - if (is_c_pointer(let)) - let = c_pointer_info(let); - if (!is_let(let)) - sole_arg_wrong_type_error_nr(sc, sc->let_to_list_symbol, let, a_let_string); - } - return(s7_let_to_list(sc, let)); -} -#endif - - -/* -------------------------------- let-ref -------------------------------- */ -static s7_pointer call_let_ref_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol) -{ - s7_pointer p; - push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); - p = s7_apply_function(sc, find_method(sc, let, sc->let_ref_fallback_symbol), set_qlist_2(sc, let, symbol)); - unstack(sc); - sc->code = T_Pos(sc->stack_end[0]); /* can be # */ - sc->value = T_Ext(sc->stack_end[2]); - return(p); -} - -static s7_pointer call_let_set_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer p; - push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); - p = s7_apply_function(sc, find_method(sc, let, sc->let_set_fallback_symbol), set_qlist_3(sc, let, symbol, value)); - unstack(sc); - sc->code = T_Pos(sc->stack_end[0]); - sc->value = T_Ext(sc->stack_end[2]); - return(p); -} - -static /* inline */ s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol) -{ - /* (let ((a 1)) ((curlet) 'a)) or ((rootlet) 'abs) */ - if (!is_let(let)) - { - let = find_let(sc, let); - if (!is_let(let)) - wrong_type_error_nr(sc, sc->let_ref_symbol, 1, let, a_let_string); - } - if (!is_symbol(symbol)) - { - if (has_let_ref_fallback(let)) /* let-ref|set-fallback refer to (explicit) let-ref in various forms, not the method lookup process */ - return(call_let_ref_fallback(sc, let, symbol)); - wrong_type_error_nr(sc, sc->let_ref_symbol, 2, symbol, a_symbol_string); - } -#if 0 - /* let-ref is currently immutable */ - if (!is_global(sc->let_ref_symbol)) - check_method(sc, let, sc->let_ref_symbol, set_plist_2(sc, let, symbol)); - /* a let-ref method is almost impossible to write without creating an infinite loop: - * any reference to the let will probably call let-ref somewhere, calling us again, and looping. - * This is not a problem in c-objects and funclets because c-object-ref and funclet-ref don't exist. - * After much wasted debugging, I decided to make let-ref and let-set! immutable. - */ -#endif - if (is_keyword(symbol)) - symbol = keyword_symbol(symbol); - - if (let == sc->rootlet) - return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); - - if (let_id(let) == symbol_id(symbol)) - return(local_value(symbol)); /* this has to follow the rootlet check(?) */ - - for (s7_pointer x = let; is_let(x); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(slot_value(y)); - - if (is_openlet(let)) - { - /* If a let is a mock-hash-table (for example), implicit indexing of the hash-table collides with the same thing for the let (field names - * versus keys), and we can't just try again here because that makes it too easy to get into infinite recursion. So, 'let-ref-fallback... - */ - if (has_let_ref_fallback(let)) - return(call_let_ref_fallback(sc, let, symbol)); - } - return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); /* (let () ((curlet) 'pi)) */ -} - -s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol) {return(let_ref(sc, let, symbol));} - -static s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_let_ref "(let-ref let sym) returns the value of the symbol sym in the let" - #define Q_let_ref s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol) - return(let_ref(sc, car(args), cadr(args))); -} - -static s7_pointer slot_in_let(s7_scheme *sc, s7_pointer e, s7_pointer sym) -{ - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(y); - return(sc->undefined); -} - -static s7_pointer lint_let_ref_p_pp(s7_scheme *sc, s7_pointer lt, s7_pointer sym) -{ - for (s7_pointer x = lt; is_let(x); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(slot_value(y)); - - if (has_let_ref_fallback(lt)) - return(call_let_ref_fallback(sc, lt, sym)); - - return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); -} - -static inline s7_pointer g_lint_let_ref(s7_scheme *sc, s7_pointer args) -{ - s7_pointer lt = car(args), sym = cadr(args); - if (!is_let(lt)) - wrong_type_error_nr(sc, sc->let_ref_symbol, 1, lt, a_let_string); - for (s7_pointer y = let_slots(lt); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(slot_value(y)); - return(lint_let_ref_p_pp(sc, let_outlet(lt), sym)); -} - -static s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool ops) -{ - if (!ops) /* || (!is_global(sc->let_ref_symbol))) */ return(f); - if (optimize_op(expr) == HOP_SAFE_C_opSq_C) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if ((car(arg1) == sc->cdr_symbol) && - (is_quoted_symbol(arg2)) && - (!is_possibly_constant(cadr(arg2)))) - { - set_opt3_sym(cdr(expr), cadr(arg2)); - return(sc->lint_let_ref); - }} - return(f); -} - -static bool op_implicit_let_ref_c(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_let(s)) {sc->last_function = s; return(false);} - sc->value = let_ref(sc, T_Ext(s), opt3_con(sc->code)); - return(true); -} - -static bool op_implicit_let_ref_a(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_let(s)) {sc->last_function = s; return(false);} - sc->value = let_ref(sc, s, fx_call(sc, cdr(sc->code))); - return(true); -} - - -/* -------------------------------- let-set! -------------------------------- */ -static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - if (is_keyword(symbol)) - symbol = keyword_symbol(symbol); - symbol_increment_ctr(symbol); - - if (let == sc->rootlet) - { - s7_pointer slot; - if (is_constant_symbol(sc, symbol)) /* (let-set! (rootlet) 'pi #f) */ - wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_non_constant_symbol_string); - - slot = global_slot(symbol); - if (!is_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let)); - if (is_syntax(slot_value(slot))) - wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); - slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, value) : value); - return(slot_value(slot)); - } - - if (let_id(let) == symbol_id(symbol)) - { - s7_pointer slot = local_slot(symbol); - if (is_slot(slot)) - return(checked_slot_set_value(sc, slot, value)); - } - for (s7_pointer x = let; is_let(x); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(checked_slot_set_value(sc, y, value)); - - if (!has_let_set_fallback(let)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let)); - /* not sure about this -- what's the most useful choice? */ - return(call_let_set_fallback(sc, let, symbol, value)); -} - -static s7_pointer let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - if (!is_let(let)) - wrong_type_error_nr(sc, sc->let_set_symbol, 1, let, a_let_string); - if (!is_symbol(symbol)) - { - if (has_let_set_fallback(let)) - return(call_let_set_fallback(sc, let, symbol, value)); - wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_symbol_string); - } -#if 0 - /* currently let-set! is immutable */ - if (!is_global(sc->let_set_symbol)) - check_method(sc, let, sc->let_set_symbol, set_plist_3(sc, let, symbol, value)); -#endif - return(let_set_1(sc, let, symbol, value)); -} - -s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) {return(let_set(sc, let, symbol, value));} - -static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args) -{ - /* (let ((a 1)) (set! ((curlet) 'a) 32) a) */ - #define H_let_set "(let-set! let sym val) sets the symbol sym's value in the let to val" - #define Q_let_set s7_make_signature(sc, 4, sc->T, sc->is_let_symbol, sc->is_symbol_symbol, sc->T) - - if (!is_pair(cdr(args))) /* (let ((a 123.0)) (define (f) (set! (let-ref) a)) (catch #t f (lambda args #f)) (f)) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: not enough arguments: ~S", 28), sc->let_set_symbol, sc->code)); - - return(let_set(sc, car(args), cadr(args), caddr(args))); -} - -static s7_pointer let_set_p_ppp_2(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) -{ - if (!is_symbol(p2)) - wrong_type_error_nr(sc, sc->let_set_symbol, 2, p2, a_symbol_string); - return(let_set_1(sc, p1, p2, p3)); -} - -static s7_pointer g_lint_let_set(s7_scheme *sc, s7_pointer args) -{ - s7_pointer y, lt = car(args), sym = cadr(args), val = caddr(args); - - if (!is_let(lt)) - wrong_type_error_nr(sc, sc->let_set_symbol, 1, lt, a_let_string); - if (lt != sc->rootlet) - { - for (s7_pointer x = lt; is_let(x); x = let_outlet(x)) - for (y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - { - slot_set_value(y, (slot_has_setter(y)) ? call_setter(sc, y, val) : val); - return(slot_value(y)); - } - if (has_let_set_fallback(lt)) - return(call_let_set_fallback(sc, lt, sym, val)); - } - y = global_slot(sym); - if (!is_slot(y)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), sym, lt)); - slot_set_value(y, (slot_has_setter(y)) ? call_setter(sc, y, val) : val); - return(slot_value(y)); -} - -static s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool ops) -{ - if (!ops) /* || (!is_global(sc->let_set_symbol))) */ return(f); - if (optimize_op(expr) == HOP_SAFE_C_opSq_CS) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); - if ((car(arg1) == sc->cdr_symbol) && - (car(arg2) == sc->quote_symbol) && - (is_symbol(cadr(arg2))) && - (!is_possibly_constant(cadr(arg2))) && - (!is_possibly_constant(arg3))) - return(sc->lint_let_set); - } - return(f); -} - - -static s7_pointer reverse_slots(s7_scheme *sc, s7_pointer list) -{ - s7_pointer p = list, result = slot_end(sc); - while (tis_slot(p)) - { - s7_pointer q = next_slot(p); - slot_set_next(p, result); - result = p; - p = q; - } - return(result); -} - -static s7_pointer let_copy(s7_scheme *sc, s7_pointer let) -{ - s7_pointer new_e; - - if (T_Let(let) == sc->rootlet) /* (copy (rootlet)) or (copy (funclet abs)) etc */ - return(sc->rootlet); - /* we can't make copy handle lets-as-objects specially because the make-object function in define-class uses copy to make a new object! - * So if it is present, we get it here, and then there's almost surely trouble. - */ - new_e = make_let(sc, let_outlet(let)); - set_all_methods(new_e, let); - sc->temp3 = new_e; - if (tis_slot(let_slots(let))) - { - s7_int id = let_id(new_e); - s7_pointer y = NULL; - for (s7_pointer x = let_slots(let); tis_slot(x); x = next_slot(x)) - { - s7_pointer z; - new_cell(sc, z, T_SLOT); - slot_set_symbol_and_value(z, slot_symbol(x), slot_value(x)); - if (symbol_id(slot_symbol(z)) != id) /* keep shadowing intact */ - symbol_set_local_slot(slot_symbol(x), id, z); - if (slot_has_setter(x)) - { - slot_set_setter(z, slot_setter(x)); - slot_set_has_setter(z); - } - if (y) - slot_set_next(y, z); - else let_set_slots(new_e, z); - slot_set_next(z, slot_end(sc)); /* in case GC runs during this loop */ - y = z; - }} - /* We can't do a (normal) loop here then reverse the slots later because the symbol's local_slot has to - * match the unshadowed slot, not the last in the list: - * (let ((e1 (inlet 'a 1 'a 2))) (let ((e2 (copy e1))) (list (equal? e1 e2) (equal? (e1 'a) (e2 'a))))) - */ - sc->temp3 = sc->unused; - return(new_e); -} - - -/* -------------------------------- rootlet -------------------------------- */ -static s7_pointer g_rootlet(s7_scheme *sc, s7_pointer unused) -{ - #define H_rootlet "(rootlet) returns the current top-level definitions (symbol bindings)." - #define Q_rootlet s7_make_signature(sc, 1, sc->is_let_symbol) - return(sc->rootlet); -} -/* as with the symbol-table, this function can lead to disaster -- user could - * clobber the let etc. But we want it to be editable and augmentable, - * so I guess I'll leave it alone. (See curlet|funclet as well). - */ - -s7_pointer s7_rootlet(s7_scheme *sc) {return(sc->rootlet);} - -/* shadow_rootlet is a convenience for foreign function writers -- the C code can act as if it were loading everything into rootlet, - * but when actually loaded, everything can be shunted into a separate namespace (*motif* for example). - */ -s7_pointer s7_shadow_rootlet(s7_scheme *sc) {return(sc->shadow_rootlet);} - -s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let) -{ - s7_pointer old_let = sc->shadow_rootlet; - sc->shadow_rootlet = let; - return(old_let); /* like s7_set_curlet below */ -} - - -/* -------------------------------- curlet -------------------------------- */ -static s7_pointer g_curlet(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_curlet "(curlet) returns the current definitions (symbol bindings)" - #define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol) - - sc->capture_let_counter++; - return((is_let(sc->curlet)) ? sc->curlet : sc->rootlet); -} - -s7_pointer s7_curlet(s7_scheme *sc) -{ - sc->capture_let_counter++; - return(sc->curlet); -} - -static void update_symbol_ids(s7_scheme *sc, s7_pointer e) -{ - for (s7_pointer p = let_slots(e); tis_slot(p); p = next_slot(p)) - { - s7_pointer sym = slot_symbol(p); - if (symbol_id(sym) != sc->let_number) - symbol_set_local_slot_unincremented(sym, sc->let_number, p); - } -} - -s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e) -{ - s7_pointer old_e = sc->curlet; - set_curlet(sc, e); - if ((is_let(e)) && (let_id(e) > 0)) /* might be () [id=-1] or rootlet [id=0?] etc */ - { - let_set_id(e, ++sc->let_number); - update_symbol_ids(sc, e); - } - return(old_e); -} - - -/* -------------------------------- outlet -------------------------------- */ -s7_pointer s7_outlet(s7_scheme *sc, s7_pointer let) -{ - if ((let == sc->rootlet) || (is_null(let_outlet(let)))) - return(sc->rootlet); - return(let_outlet(let)); -} - -s7_pointer outlet_p_p(s7_scheme *sc, s7_pointer let) -{ - if (!is_let(let)) - sole_arg_wrong_type_error_nr(sc, sc->outlet_symbol, let, a_let_string); /* not a method call here! */ - if ((let == sc->rootlet) || (is_null(let_outlet(let)))) - return(sc->rootlet); - return(let_outlet(let)); -} - -static s7_pointer g_outlet(s7_scheme *sc, s7_pointer args) -{ - #define H_outlet "(outlet let) is the environment that contains let." - #define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_let_symbol) - return(outlet_p_p(sc, car(args))); -} - - -static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args) -{ - /* (let ((a 1)) (let ((b 2)) (set! (outlet (curlet)) (rootlet)) ((curlet) 'a))) */ - s7_pointer let = car(args), new_outer; - - if (!is_let(let)) - wrong_type_error_nr(sc, wrap_string(sc, "set! outlet", 11), 1, let, sc->type_names[T_LET]); - if (let == sc->s7_starlet) - error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't set! (outlet *s7*)", 24))); - if (is_immutable(let)) - immutable_object_error_nr(sc, set_elist_4(sc, wrap_string(sc, "can't (set! (outlet ~S) ~S), ~S is immutable", 44), let, cadr(args), let)); - new_outer = cadr(args); - if (!is_let(new_outer)) - wrong_type_error_nr(sc, wrap_string(sc, "set! outlet", 11), 2, new_outer, sc->type_names[T_LET]); - if (let != sc->rootlet) - { - /* here it's possible to get cyclic let chains; maybe do this check only if safety>0 */ - for (s7_pointer lt = new_outer; (is_let(lt)) && (lt != sc->rootlet); lt = let_outlet(lt)) - if (let == lt) - error_nr(sc, make_symbol(sc, "cyclic-let", 10), - set_elist_2(sc, wrap_string(sc, "set! (outlet ~A) creates a cyclic let chain", 43), let)); - let_set_outlet(let, (new_outer == sc->rootlet) ? sc->nil : new_outer); /* outlet rootlet->() so that slot search can use is_let(outlet) I think */ - } - return(new_outer); -} - -/* -------------------------------- symbol lookup -------------------------------- */ -static Inline s7_pointer inline_lookup_from(s7_scheme *sc, const s7_pointer symbol, s7_pointer e) -{ - if (let_id(e) == symbol_id(symbol)) - return(local_value(symbol)); - if (symbol_id(symbol) < let_id(e)) - { - do {e = let_outlet(e);} while (symbol_id(symbol) < let_id(e)); - if (let_id(e) == symbol_id(symbol)) - return(local_value(symbol)); - } - for (; is_let(e); e = let_outlet(e)) - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(slot_value(y)); - - if (is_slot(global_slot(symbol))) - return(global_value(symbol)); -#if WITH_GCC - return(NULL); /* much faster than various alternatives */ -#else - return(unbound_variable(sc, symbol)); -#endif -} - -#if WITH_GCC && S7_DEBUGGING -static s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol) -#else -static inline s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol) /* lookup_checked includes the unbound_variable call */ -#endif -{ - return(inline_lookup_from(sc, symbol, sc->curlet)); -} - -static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e) -{ - if (let_id(e) == symbol_id(symbol)) - return(local_slot(symbol)); - if (symbol_id(symbol) < let_id(e)) - { - do {e = let_outlet(e);} while (symbol_id(symbol) < let_id(e)); - if (let_id(e) == symbol_id(symbol)) - return(local_slot(symbol)); - } - for (; is_let(e); e = let_outlet(e)) - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); - return(global_slot(symbol)); -} - -s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol) {return(lookup_slot_from(symbol, sc->curlet));} - -s7_pointer s7_slot_value(s7_pointer slot) {return(slot_value(slot));} - -s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value) {slot_set_value(slot, value); return(value);} - -void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value) {set_real(slot_value(slot), value);} - -static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer e) -{ - if (!is_let(e)) - return(global_slot(symbol)); - if (symbol_id(symbol) != 0) - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); - return(sc->undefined); -} - -s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym) -{ - s7_pointer x = lookup_slot_from(sym, sc->curlet); - return((is_slot(x)) ? slot_value(x) : sc->undefined); -} - -s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer let) -{ - /* restrict the search to local let outward */ - if ((let == sc->rootlet) || (is_global(sym))) - return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); - - if (!is_let(let)) - return(s7_symbol_value(sc, sym)); - - if (let_id(let) == symbol_id(sym)) - return(local_value(sym)); - if (symbol_id(sym) < let_id(let)) - { - do {let = let_outlet(let);} while (symbol_id(sym) < let_id(let)); - if (let_id(let) == symbol_id(sym)) - return(local_value(sym)); - } - for (; is_let(let); let = let_outlet(let)) - for (s7_pointer y = let_slots(let); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(slot_value(y)); - - /* need to check rootlet before giving up */ - if (is_slot(global_slot(sym))) - return(global_value(sym)); - - /* (let ((e (curlet))) (let ((a 1)) (symbol->value 'a e))) -> # not 1 */ - return(sc->undefined); /* 29-Nov-17 */ -} - - -/* -------------------------------- symbol->value -------------------------------- */ -#define lookup_global(Sc, Sym) ((is_global(Sym)) ? global_value(Sym) : lookup_checked(Sc, Sym)) - -static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val); -static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice); - -static s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol_to_value "(symbol->value sym (let (curlet))) returns the binding of (the value associated with) the \ -symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32" - #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->is_let_symbol) - /* (symbol->value 'x e) => (e 'x)? */ - - s7_pointer sym = car(args); - if (!is_symbol(sym)) - return(method_or_bust(sc, sym, sc->symbol_to_value_symbol, args, sc->type_names[T_SYMBOL], 1)); - - if (is_not_null(cdr(args))) - { - s7_pointer local_let = cadr(args); - if (local_let == sc->unlet_symbol) - return((is_slot(initial_slot(sym))) ? initial_value(sym) : sc->undefined); - - if (!is_let(local_let)) - { - local_let = find_let(sc, local_let); - if (!is_let(local_let)) - return(method_or_bust(sc, cadr(args), sc->symbol_to_value_symbol, args, a_let_string, 2)); - } - if (local_let == sc->s7_starlet) - return(s7_starlet(sc, s7_starlet_symbol(sym))); - - return(s7_symbol_local_value(sc, sym, local_let)); - } - if (is_global(sym)) - return(global_value(sym)); - return(s7_symbol_value(sc, sym)); -} - -s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - s7_pointer x = lookup_slot_from(sym, sc->curlet); /* if immutable should this return an error? */ - if (is_slot(x)) - slot_set_value(x, val); /* with_hook? */ - return(val); -} - - -/* -------------------------------- symbol->dynamic-value -------------------------------- */ -static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer x, s7_pointer sym, int64_t *id) -{ - for (; symbol_id(sym) < let_id(x); x = let_outlet(x)); - if (let_id(x) == symbol_id(sym)) - { - (*id) = let_id(x); - return(local_value(sym)); - } - for (; (is_let(x)) && (let_id(x) > (*id)); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - { - (*id) = let_id(x); - return(slot_value(y)); - } - return(sc->unused); -} - -static s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol_to_dynamic_value "(symbol->dynamic-value sym) returns the dynamic binding of the symbol sym" - #define Q_symbol_to_dynamic_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol) - - s7_pointer sym = car(args), val; - int64_t top_id = -1; - - if (!is_symbol(sym)) - return(method_or_bust(sc, sym, sc->symbol_to_dynamic_value_symbol, args, sc->type_names[T_SYMBOL], 1)); - - if (is_global(sym)) - return(global_value(sym)); - - if (let_id(sc->curlet) == symbol_id(sym)) - return(local_value(sym)); - - val = find_dynamic_value(sc, sc->curlet, sym, &top_id); - if (top_id == symbol_id(sym)) - return(val); - - for (int64_t i = current_stack_top(sc) - 1; i > 0; i -= 4) - if (is_let_unchecked(stack_let(sc->stack, i))) /* OP_GC_PROTECT let slot can be anything (even free) */ - { - s7_pointer cur_val = find_dynamic_value(sc, stack_let(sc->stack, i), sym, &top_id); - if (cur_val != sc->unused) - val = cur_val; - if (top_id == symbol_id(sym)) - return(val); - } - return((val == sc->unused) ? s7_symbol_value(sc, sym) : val); -} - -static bool direct_memq(const s7_pointer symbol, s7_pointer symbols) -{ - for (s7_pointer x = symbols; is_pair(x); x = cdr(x)) - if (car(x) == symbol) - return(true); - return(false); -} - -static bool direct_assq(const s7_pointer symbol, s7_pointer symbols) -{ /* used only below in do_symbol_is_safe */ - for (s7_pointer x = symbols; is_pair(x); x = cdr(x)) - if (caar(x) == symbol) - return(true); - return(false); -} - -static bool do_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) -{ - return((is_slot(global_slot(sym))) || - (direct_assq(sym, e)) || - (is_slot(lookup_slot_from(sym, sc->curlet)))); -} - -static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) -{ - if (is_slot(global_slot(sym))) - return(true); - if (is_null(e)) - e = sc->rootlet; - return((!is_with_let_let(e)) && - (is_slot(lookup_slot_from(sym, sc->curlet)))); -} - -static bool let_symbol_is_safe_or_listed(s7_scheme *sc, s7_pointer sym, s7_pointer e) -{ - return((symbol_is_in_list(sc, sym)) || - (let_symbol_is_safe(sc, sym, e))); -} - -static bool let_star_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) -{ - return((symbol_is_in_list(sc, sym)) || - (is_slot(global_slot(sym))) || - ((is_let(e)) && (!is_with_let_let(e)) && (is_slot(lookup_slot_from(sym, sc->curlet))))); -} - -static bool pair_symbol_is_safe(s7_scheme *unused_sc, s7_pointer sym, s7_pointer e) -{ - return((is_slot(global_slot(sym))) || - (direct_memq(sym, e))); -} - -static s7_pointer collect_variables(s7_scheme *sc, s7_pointer lst, s7_pointer e) -{ - /* collect local variable names from let/do (pre-error-check), 20 overhead in tgen -> 14 if cons_unchecked below */ - sc->w = e; - for (s7_pointer p = lst; is_pair(p); p = cdr(p)) - sc->w = cons(sc, add_symbol_to_list(sc, caar(p)), sc->w); - return(sc->w); -} - -static s7_pointer collect_parameters(s7_scheme *sc, s7_pointer lst, s7_pointer e) -{ - /* collect local variable names from lambda arglists (pre-error-check) */ - s7_pointer p; - s7_int the_un_id = ++sc->let_number; - if (is_symbol(lst)) - { - symbol_set_id(lst, the_un_id); - return(cons(sc, add_symbol_to_list(sc, lst), e)); - } - sc->w = e; - for (p = lst; is_pair(p); p = cdr(p)) - { - s7_pointer car_p = car(p); - if (is_pair(car_p)) - car_p = car(car_p); - if (is_normal_symbol(car_p)) - { - symbol_set_id(car_p, the_un_id); - sc->w = cons(sc, add_symbol_to_list(sc, car_p), sc->w); - }} - if (is_symbol(p)) /* rest arg */ - { - symbol_set_id(p, the_un_id); - sc->w = cons(sc, add_symbol_to_list(sc, p), sc->w); - } - return(sc->w); -} - -typedef enum {OPT_F, OPT_T, OPT_OOPS} opt_t; -static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e); - -static void clear_all_optimizations(s7_scheme *sc, s7_pointer p) -{ - /* I believe that we would not have been optimized to begin with if the tree were circular, - * and this tree is supposed to be a function call + args -- a circular list here is a bug. - */ - if (is_pair(p)) - { - if ((is_optimized(p)) && - (((optimize_op(p) >= FIRST_UNHOPPABLE_OP) || /* avoid clearing hop ops, fx_function and op_unknown* need to be cleared */ - (!op_has_hop(p))))) - { - clear_optimized(p); /* includes T_SYNTACTIC */ - clear_optimize_op(p); - } - clear_all_optimizations(sc, cdr(p)); - clear_all_optimizations(sc, car(p)); - } -} - -static s7_pointer add_trace(s7_scheme *sc, s7_pointer code) -{ - if ((is_pair(car(code))) && (caar(code) == sc->trace_in_symbol)) - return(code); - return(cons_unchecked(sc, list_2(sc, sc->trace_in_symbol, list_1(sc, sc->curlet_symbol)), code)); -} - -static s7_pointer add_profile(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p; - if ((is_pair(car(code))) && (caar(code) == sc->profile_in_symbol)) - return(code); - p = cons_unchecked(sc, list_3(sc, sc->profile_in_symbol, make_integer_unchecked(sc, sc->profile_position), list_1(sc, sc->curlet_symbol)), code); - sc->profile_position++; - set_unsafe_optimize_op(car(p), OP_PROFILE_IN); - return(p); -} - -static bool tree_has_definers(s7_scheme *sc, s7_pointer tree) -{ - for (s7_pointer p = tree; is_pair(p); p = cdr(p)) - if (tree_has_definers(sc, car(p))) - return(true); - return((is_symbol(tree)) && (is_definer(tree))); -} - -static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) -{ - s7_pointer mac, body, mac_name = NULL; - uint64_t typ; - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display_80(sc->code)); - switch (op) - { - case OP_DEFINE_MACRO: case OP_MACRO: typ = T_MACRO; break; - case OP_DEFINE_MACRO_STAR: case OP_MACRO_STAR: typ = T_MACRO_STAR; break; - case OP_DEFINE_BACRO: case OP_BACRO: typ = T_BACRO; break; - case OP_DEFINE_BACRO_STAR: case OP_BACRO_STAR: typ = T_BACRO_STAR; break; - case OP_DEFINE_EXPANSION: typ = T_MACRO | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); break; /* local expansions are just normal macros */ - case OP_DEFINE_EXPANSION_STAR: typ = T_MACRO_STAR | ((is_let(sc->curlet)) ? 0 : T_EXPANSION); break; - default: - if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__, op_names[op]); - typ = T_MACRO; - break; - } - new_cell(sc, mac, typ | T_DONT_EVAL_ARGS); - closure_set_args(mac, (named) ? cdar(sc->code) : car(sc->code)); - body = cdr(sc->code); - closure_set_body(mac, body); - closure_set_setter(mac, sc->F); - closure_set_let(mac, sc->curlet); - closure_set_arity(mac, CLOSURE_ARITY_NOT_SET); - sc->capture_let_counter++; - gc_protect_via_stack(sc, mac); - - if (named) - { - s7_pointer mac_slot; - mac_name = caar(sc->code); - - if (((op == OP_DEFINE_EXPANSION) || (op == OP_DEFINE_EXPANSION_STAR)) && - (!is_let(sc->curlet))) - set_full_type(mac_name, T_EXPANSION | T_SYMBOL | (full_type(mac_name) & T_UNHEAP)); - - /* symbol? macro name has already been checked, find name in let, and define it */ - mac_slot = symbol_to_local_slot(sc, mac_name, sc->curlet); /* returns global_slot(symbol) if sc->curlet == nil */ - if (is_slot(mac_slot)) - { - if ((sc->curlet == sc->nil) && (!in_rootlet(mac_slot))) - add_slot_to_rootlet(sc, mac_slot); - slot_set_value_with_hook(mac_slot, mac); - } - else s7_make_slot(sc, sc->curlet, mac_name, mac); /* was current but we've checked immutable already */ - if (tree_has_definers(sc, body)) - set_is_definer(mac_name); /* (list-values 'define ...) aux-13 */ - } - - if ((!is_either_bacro(mac)) && - (optimize(sc, body, 1, collect_parameters(sc, closure_args(mac), sc->nil)) == OPT_OOPS)) - clear_all_optimizations(sc, body); - - if (sc->debug > 1) /* no profile here */ - closure_set_body(mac, add_trace(sc, body)); - - unstack(sc); - if (named) - { - set_pair_macro(closure_body(mac), mac_name); - set_has_pair_macro(mac); - if (has_location(car(sc->code))) - { - pair_set_location(closure_body(mac), pair_location(car(sc->code))); - set_has_location(closure_body(mac)); - }} - /* passed to maclet in apply_macro et al, copied in copy_closure */ - return(mac); -} - -static s7_pointer make_closure_unchecked(s7_scheme *sc, s7_pointer args, s7_pointer code, uint64_t type, int32_t arity) -{ - s7_pointer x; - new_cell_no_check(sc, x, (type | closure_bits(code))); - closure_set_args(x, args); - closure_set_let(x, sc->curlet); - closure_set_setter(x, sc->F); - closure_set_arity(x, arity); - closure_set_body(x, code); - if (is_pair(cdr(code))) set_closure_has_multiform(x); else set_closure_has_one_form(x); - sc->capture_let_counter++; - return(x); -} - -static inline s7_pointer make_closure_gc_checked(s7_scheme *sc, s7_pointer args, s7_pointer code, uint64_t type, int32_t arity) /* inline 100=1% tgc, 35=2% texit */ -{ - s7_pointer x; - new_cell(sc, x, (type | closure_bits(code))); - closure_set_args(x, args); - closure_set_let(x, sc->curlet); - closure_set_setter(x, sc->F); - closure_set_arity(x, arity); - closure_set_body(x, code); - if (is_pair(cdr(code))) set_closure_has_multiform(x); else set_closure_has_one_form(x); - sc->capture_let_counter++; - return(x); -} - -static s7_pointer make_closure(s7_scheme *sc, s7_pointer args, s7_pointer code, uint64_t type, int32_t arity) -{ - /* this is called (almost?) every time a lambda form is evaluated, or during letrec, etc */ - s7_pointer x; - new_cell(sc, x, (type | closure_bits(code))); - closure_set_args(x, args); - closure_set_let(x, sc->curlet); - closure_set_setter(x, sc->F); - closure_set_arity(x, arity); - closure_set_body(x, code); /* in case add_trace triggers GC, new func (x) needs some legit body for mark_closure */ - if (sc->debug_or_profile) - { - gc_protect_via_stack(sc, x); /* GC protect func during add_trace */ - closure_set_body(x, (sc->debug > 1) ? add_trace(sc, code) : add_profile(sc, code)); - set_closure_has_multiform(x); - unstack(sc); - } - else - if (is_pair(cdr(code))) - set_closure_has_multiform(x); - else set_closure_has_one_form(x); - sc->capture_let_counter++; - return(x); -} - -static int32_t closure_length(s7_scheme *sc, s7_pointer e) -{ - /* we can't use let_length(sc, closure_let(e)) because the closure_let(closure) - * changes. So the open bit is not always on. Besides, the fallbacks need to be for closures, not lets. - */ - s7_pointer length_func = find_method(sc, closure_let(e), sc->length_symbol); - if (length_func != sc->undefined) - return((int32_t)s7_integer(s7_apply_function(sc, length_func, set_plist_1(sc, e)))); - /* there are cases where this should raise a wrong-type-arg error, but for now... */ - return(-1); -} - -static s7_pointer cons_unchecked_with_type(s7_scheme *sc, s7_pointer p, s7_pointer a, s7_pointer b) /* (used only in copy_tree_with_type) */ -{ - s7_pointer x; - new_cell_no_check(sc, x, full_type(p) & (TYPE_MASK | T_IMMUTABLE | T_SAFE_PROCEDURE)); - set_car(x, a); - set_cdr(x, b); - return(x); -} - -static s7_pointer copy_tree_with_type(s7_scheme *sc, s7_pointer tree) -{ - /* if sc->safety > NO_SAFETY, '(1 2) is set immutable by the reader, but eval (in that safety case) calls - * copy_body on the incoming tree, so we have to preserve T_IMMUTABLE in that case. - * if tree is something like (+ 1 (car '#1=(2 . #1#))), we have to see the quoted list and not copy it. - * Before getting here, we have checked that there is room for the entire tree (in copy_body), or 8192 cells (in list_values) in the free heap. - */ -#if WITH_GCC - #define COPY_TREE_WITH_TYPE(P) ({s7_pointer _p; _p = P; \ - cons_unchecked_with_type(sc, _p, (is_unquoted_pair(car(_p))) ? copy_tree_with_type(sc, car(_p)) : car(_p), \ - (is_unquoted_pair(cdr(_p))) ? copy_tree_with_type(sc, cdr(_p)) : cdr(_p));}) -#else - #define COPY_TREE_WITH_TYPE(P) copy_tree_with_type(sc, P) -#endif - return(cons_unchecked_with_type(sc, tree, - (is_unquoted_pair(car(tree))) ? COPY_TREE_WITH_TYPE(car(tree)) : car(tree), - (is_unquoted_pair(cdr(tree))) ? COPY_TREE_WITH_TYPE(cdr(tree)) : cdr(tree))); -} - -static inline s7_pointer copy_tree(s7_scheme *sc, s7_pointer tree) -{ -#if WITH_GCC - #define COPY_TREE(P) ({s7_pointer _p; _p = P; \ - cons_unchecked(sc, (is_unquoted_pair(car(_p))) ? copy_tree(sc, car(_p)) : car(_p), \ - (is_pair(cdr(_p))) ? copy_tree(sc, cdr(_p)) : cdr(_p));}) -#else - #define COPY_TREE(P) copy_tree(sc, P) -#endif - return(cons_unchecked(sc, - (is_unquoted_pair(car(tree))) ? COPY_TREE(car(tree)) : car(tree), - (is_pair(cdr(tree))) ? COPY_TREE(cdr(tree)) : cdr(tree))); -} - - -/* -------------------------------- tree-cyclic? -------------------------------- */ -#define TREE_NOT_CYCLIC 0 -#define TREE_CYCLIC 1 -#define TREE_HAS_PAIRS 2 - -static int32_t tree_is_cyclic_or_has_pairs(s7_scheme *sc, s7_pointer tree) -{ - s7_pointer fast = tree, slow = tree; /* we assume tree is a pair */ - bool has_pairs = false; - while (true) - { - if (tree_is_collected(fast)) return(TREE_CYCLIC); - if ((!has_pairs) && (is_unquoted_pair(car(fast)))) - has_pairs = true; - fast = cdr(fast); - if (!is_pair(fast)) - { - if (!has_pairs) return(TREE_NOT_CYCLIC); - break; - } - if (tree_is_collected(fast)) return(TREE_CYCLIC); - if ((!has_pairs) && (is_unquoted_pair(car(fast)))) - has_pairs = true; - fast = cdr(fast); - if (!is_pair(fast)) - { - if (!has_pairs) return(TREE_NOT_CYCLIC); - break; - } - slow = cdr(slow); - if (fast == slow) return(TREE_CYCLIC); - } - return(TREE_HAS_PAIRS); -} - -/* we can't use shared_info here because tree_is_cyclic may be called in the midst of output that depends on sc->circle_info */ - -static bool tree_is_cyclic_1(s7_scheme *sc, s7_pointer tree) -{ - for (s7_pointer p = tree; is_pair(p); p = cdr(p)) - { - tree_set_collected(p); - if (sc->tree_pointers_top == sc->tree_pointers_size) - { - if (sc->tree_pointers_size == 0) - { - sc->tree_pointers_size = 8; - sc->tree_pointers = (s7_pointer *)Malloc(sc->tree_pointers_size * sizeof(s7_pointer)); - } - else - { - sc->tree_pointers_size *= 2; - sc->tree_pointers = (s7_pointer *)Realloc(sc->tree_pointers, sc->tree_pointers_size * sizeof(s7_pointer)); - }} - sc->tree_pointers[sc->tree_pointers_top++] = p; - if (is_unquoted_pair(car(p))) - { - int32_t old_top = sc->tree_pointers_top, result; - result = tree_is_cyclic_or_has_pairs(sc, car(p)); - if ((result == TREE_CYCLIC) || - (tree_is_cyclic_1(sc, car(p)))) - return(true); - for (int32_t i = old_top; i < sc->tree_pointers_top; i++) - tree_clear_collected(sc->tree_pointers[i]); - sc->tree_pointers_top = old_top; - }} - return(false); -} - -static bool tree_is_cyclic(s7_scheme *sc, s7_pointer tree) -{ - int32_t result; - if (!is_pair(tree)) return(false); - result = tree_is_cyclic_or_has_pairs(sc, tree); - if (result == TREE_NOT_CYCLIC) return(false); - if (result == TREE_CYCLIC) return(true); - result = tree_is_cyclic_1(sc, tree); - for (int32_t i = 0; i < sc->tree_pointers_top; i++) - tree_clear_collected(sc->tree_pointers[i]); - sc->tree_pointers_top = 0; - return(result); -} - -static s7_pointer g_tree_is_cyclic(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_is_cyclic "(tree-cyclic? tree) returns #t if the tree has a cycle." - #define Q_tree_is_cyclic sc->pl_bt - return(make_boolean(sc, tree_is_cyclic(sc, car(args)))); -} - -static inline s7_int tree_len(s7_scheme *sc, s7_pointer p); - -static s7_pointer copy_body(s7_scheme *sc, s7_pointer p) -{ - sc->w = p; - if (tree_is_cyclic(sc, p)) /* don't wrap this in is_safety_checked */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "copy: tree is cyclic: ~S", 24), p)); - check_free_heap_size(sc, tree_len(sc, p) * 2); - return((sc->safety > NO_SAFETY) ? copy_tree_with_type(sc, p) : copy_tree(sc, p)); -} - -static s7_pointer copy_closure(s7_scheme *sc, s7_pointer fnc) -{ - /* copy the source tree annotating (for eventual optimization), return a thing of the same type as fnc */ - s7_pointer x, body = copy_body(sc, closure_body(fnc)); - if ((is_any_macro(fnc)) && (has_pair_macro(fnc))) - { - set_pair_macro(body, pair_macro(closure_body(fnc))); - set_has_pair_macro(fnc); - } - new_cell(sc, x, full_type(fnc) & (~T_COLLECTED)); /* I'm paranoid about that is_collected bit */ - closure_set_args(x, closure_args(fnc)); - closure_set_body(x, body); - closure_set_setter(x, closure_setter(fnc)); - closure_set_arity(x, closure_arity(fnc)); - closure_set_let(x, closure_let(fnc)); - return(x); -} - - -/* -------------------------------- defined? -------------------------------- */ -static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args) -{ - #define H_is_defined "(defined? symbol (let (curlet)) ignore-globals) returns #t if symbol has a binding (a value) in the let. \ -Only the let is searched if ignore-globals is not #f." - #define Q_is_defined s7_make_signature(sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, \ - s7_make_signature(sc, 5, sc->is_let_symbol, sc->is_procedure_symbol, sc->is_macro_symbol, \ - sc->is_c_object_symbol, sc->is_c_pointer_symbol), sc->is_boolean_symbol) - /* if the symbol has a global slot and e is unset or rootlet, this returns #t */ - s7_pointer sym = car(args); - if (!is_symbol(sym)) - return(method_or_bust(sc, sym, sc->is_defined_symbol, args, sc->type_names[T_SYMBOL], 1)); - - if (is_pair(cdr(args))) - { - s7_pointer e = cadr(args), b, x; - if (!is_let(e)) - { - bool nil_is_rootlet = is_any_procedure(e); /* (defined? 'abs (lambda () 1)) -- unsure about this */ - e = find_let(sc, e); - if ((is_null(e)) && (nil_is_rootlet)) - e = sc->rootlet; - else - if (!is_let(e)) - wrong_type_error_nr(sc, sc->is_defined_symbol, 2, cadr(args), a_let_string); - } - if (is_keyword(sym)) /* if no "e", is global -> #t */ - sym = keyword_symbol(sym); /* (defined? :print-length *s7*) */ - if (e == sc->s7_starlet) - return(make_boolean(sc, s7_starlet_symbol(sym) != SL_NO_FIELD)); - if (is_pair(cddr(args))) - { - b = caddr(args); - if (!is_boolean(b)) - return(method_or_bust(sc, b, sc->is_defined_symbol, args, a_boolean_string, 3)); - } - else b = sc->F; - if (e == sc->rootlet) /* we checked (let? e) above */ - { - if (b == sc->F) - return(make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to # */ - return(sc->F); - } - x = symbol_to_local_slot(sc, sym, e); - if (is_slot(x)) - return(sc->T); - return((b == sc->T) ? sc->F : make_boolean(sc, is_slot(global_slot(sym)))); - } - return((is_global(sym)) ? sc->T : make_boolean(sc, is_slot(lookup_slot_from(sym, sc->curlet)))); -} - -static s7_pointer g_is_defined_in_rootlet(s7_scheme *sc, s7_pointer args) -{ - /* here we know arg2=(rootlet), and no arg3, arg1 is a symbol (see chooser below) */ - s7_pointer sym = lookup(sc, car(args)); /* args are unevalled because the chooser calls us through op_safe_c_nc?? */ - if (!is_symbol(sym)) /* if sym is openlet with defined? perhaps it makes sense to call it, but we need to include the rootlet arg */ - return(method_or_bust_pp(sc, sym, sc->is_defined_symbol, sym, sc->rootlet, sc->type_names[T_SYMBOL], 1)); - return(make_boolean(sc, is_slot(global_slot(sym)))); -} - -static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((args == 2) && (is_symbol(cadr(expr)))) - { - s7_pointer e = caddr(expr); - if ((is_pair(e)) && (is_null(cdr(e))) && (car(e) == sc->rootlet_symbol)) - { - set_safe_optimize_op(expr, HOP_SAFE_C_NC); - return(sc->is_defined_in_rootlet); - }} - return(f); -} - -bool s7_is_defined(s7_scheme *sc, const char *name) -{ - s7_pointer x = s7_symbol_table_find_name(sc, name); - if (!x) return(false); - x = lookup_slot_from(x, sc->curlet); - return(is_slot(x)); -} - -static bool is_defined_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_symbol(p)) return(method_or_bust(sc, p, sc->is_defined_symbol, set_plist_1(sc, p), sc->type_names[T_SYMBOL], 1) != sc->F); - return(is_slot(lookup_slot_from(p, sc->curlet))); -} - -static bool is_defined_b_7pp(s7_scheme *sc, s7_pointer p, s7_pointer e) {return(g_is_defined(sc, set_plist_2(sc, p, e)) != sc->F);} - - -void s7_define(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) -{ - s7_pointer x; - if ((let == sc->nil) || (let == sc->rootlet)) - let = sc->shadow_rootlet; - x = symbol_to_local_slot(sc, symbol, let); - if (is_slot(x)) - slot_set_value_with_hook(x, value); - else - { - s7_make_slot(sc, let, symbol, value); /* I think this means C code can override "constant" defs */ - /* if let is sc->nil or rootlet, s7_make_slot makes a semipermanent_slot */ - if ((let == sc->shadow_rootlet) && - (!is_slot(global_slot(symbol)))) - { - set_global(symbol); /* is_global => global_slot is usable -- is this a good idea? */ - set_global_slot(symbol, local_slot(symbol)); - }} -} - -s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value) -{ - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, value); - return(sym); -} - -s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help) -{ - s7_pointer sym = s7_define_variable(sc, name, value); - symbol_set_has_help(sym); - symbol_set_help(sym, copy_string(help)); - add_saved_pointer(sc, symbol_help(sym)); - return(sym); -} - -s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer envir, const char *name, s7_pointer value) -{ - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, envir, sym, value); - set_immutable(sym); - set_possibly_constant(sym); - set_immutable(global_slot(sym)); - set_immutable(local_slot(sym)); - return(sym); -} - -s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value) -{ - return(s7_define_constant_with_environment(sc, sc->nil, name, value)); -} - -/* (define (func a) (let ((cvar (+ a 1))) cvar)) (define-constant cvar 23) (func 1) -> ;can't bind an immutable object: cvar - * (let ((aaa 1)) (define-constant aaa 32) (set! aaa 3)) -> set!: can't alter immutable object: aaa - */ - -s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help) -{ - s7_pointer sym = s7_define_constant(sc, name, value); - symbol_set_has_help(sym); - symbol_set_help(sym, copy_string(help)); - add_saved_pointer(sc, symbol_help(sym)); - return(value); /* inconsistent with variable above, but consistent with define_function? */ -} - - -/* -------------------------------- keyword? -------------------------------- */ -bool s7_is_keyword(s7_pointer obj) {return(is_symbol_and_keyword(obj));} - -static s7_pointer g_is_keyword(s7_scheme *sc, s7_pointer args) -{ - #define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t" - #define Q_is_keyword sc->pl_bt - check_boolean_method(sc, is_symbol_and_keyword, sc->is_keyword_symbol, args); -} - - -/* -------------------------------- string->keyword -------------------------------- */ -s7_pointer s7_make_keyword(s7_scheme *sc, const char *key) -{ - s7_pointer sym; - size_t slen = (size_t)safe_strlen(key); - block_t *b = inline_mallocate(sc, slen + 2); - char *name = (char *)block_data(b); - name[0] = ':'; - memcpy((void *)(name + 1), (void *)key, slen); - name[slen + 1] = '\0'; - sym = inline_make_symbol(sc, name, slen + 1); /* keyword slot etc taken care of here (in new_symbol actually) */ - liberate(sc, b); - return(sym); -} - -static s7_pointer g_string_to_keyword(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_keyword "(string->keyword str) prepends ':' to str and defines that as a keyword" - #define Q_string_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_string_symbol) - - s7_pointer str = car(args); - if (!is_string(str)) - return(sole_arg_method_or_bust(sc, str, sc->string_to_keyword_symbol, args, sc->type_names[T_STRING])); - if ((string_length(str) == 0) || - (string_value(str)[0] == '\0')) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "string->keyword wants a non-null string: ~S", 43), str)); - return(s7_make_keyword(sc, string_value(str))); -} - - -/* -------------------------------- keyword->symbol -------------------------------- */ -static s7_pointer g_keyword_to_symbol(s7_scheme *sc, s7_pointer args) -{ - #define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended colon" - #define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol) - - s7_pointer sym = car(args); - if (!is_symbol_and_keyword(sym)) - return(sole_arg_method_or_bust_p(sc, sym, sc->keyword_to_symbol_symbol, wrap_string(sc, "a keyword", 9))); - return(keyword_symbol(sym)); -} - -s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key) {return(keyword_symbol(key));} - - -/* -------------------------------- symbol->keyword -------------------------------- */ -#define symbol_to_keyword(Sc, Sym) s7_make_keyword(Sc, symbol_name(Sym)) - -static s7_pointer g_symbol_to_keyword(s7_scheme *sc, s7_pointer args) -{ - #define H_symbol_to_keyword "(symbol->keyword sym) returns a keyword with the same name as sym, but with a colon prepended" - #define Q_symbol_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_symbol_symbol) - - if (!is_symbol(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->symbol_to_keyword_symbol, args, sc->type_names[T_SYMBOL])); - return(symbol_to_keyword(sc, car(args))); -} - - -/* -------------------------------- c-pointer? -------------------------------- */ -bool s7_is_c_pointer(s7_pointer arg) {return(is_c_pointer(arg));} - -bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type) {return((is_c_pointer(arg)) && (c_pointer_type(arg) == type));} - -static s7_pointer g_is_c_pointer(s7_scheme *sc, s7_pointer args) -{ - #define H_is_c_pointer "(c-pointer? obj type) returns #t if obj is a C pointer being held in s7. \ -If type is given, the c_pointer's type is also checked." - #define Q_is_c_pointer s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) - - s7_pointer p = car(args); - if (is_c_pointer(p)) - return((is_pair(cdr(args))) ? make_boolean(sc, c_pointer_type(p) == cadr(args)) : sc->T); - if (!has_active_methods(sc, p)) return(sc->F); - return(apply_boolean_method(sc, p, sc->is_c_pointer_symbol)); -} - - -/* -------------------------------- c-pointer -------------------------------- */ -void *s7_c_pointer(s7_pointer p) {return(c_pointer(p));} - -void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer p, s7_pointer expected_type, const char *caller, s7_int argnum) -{ - if (!is_c_pointer(p)) - wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), argnum, p, sc->type_names[T_C_POINTER]); - if ((c_pointer(p) != NULL) && - (c_pointer_type(p) != expected_type)) - error_nr(sc, sc->wrong_type_arg_symbol, - (argnum == 0) ? - set_elist_4(sc, wrap_string(sc, "~S argument is a pointer of type ~S, but expected ~S", 52), - wrap_string(sc, caller, safe_strlen(caller)), c_pointer_type(p), expected_type) : - set_elist_5(sc, wrap_string(sc, "~S ~:D argument got a pointer of type ~S, but expected ~S", 57), - wrap_string(sc, caller, safe_strlen(caller)), - wrap_integer(sc, argnum), c_pointer_type(p), expected_type)); - return(c_pointer(p)); -} - -s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info) -{ - s7_pointer x; - new_cell(sc, x, T_C_POINTER); - c_pointer(x) = ptr; - c_pointer_type(x) = type; - c_pointer_info(x) = info; - c_pointer_weak1(x) = sc->F; - c_pointer_weak2(x) = sc->F; - return(x); -} - -s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr) {return(s7_make_c_pointer_with_type(sc, ptr, sc->F, sc->F));} - -static s7_pointer g_c_pointer(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer "(c-pointer int type info weak1 weak2) returns a c-pointer object. The type and info args are optional, defaulting to #f." - #define Q_c_pointer s7_make_circular_signature(sc, 2, 3, sc->is_c_pointer_symbol, sc->is_integer_symbol, sc->T) - - s7_pointer arg = car(args), type = sc->F, info = sc->F, weak1 = sc->F, weak2 = sc->F, cp; - intptr_t p; - - if (!s7_is_integer(arg)) - return(method_or_bust(sc, arg, sc->c_pointer_symbol, args, sc->type_names[T_INTEGER], 1)); - p = (intptr_t)s7_integer_clamped_if_gmp(sc, arg); /* (c-pointer (bignum "1234")) */ - args = cdr(args); - if (is_pair(args)) - { - type = car(args); - args = cdr(args); - if (is_pair(args)) - { - info = car(args); - args = cdr(args); - if (is_pair(args)) - { - weak1 = car(args); - args = cdr(args); - if (is_pair(args)) - weak2 = car(args); - }}} - cp = s7_make_c_pointer_with_type(sc, (void *)p, type, info); - c_pointer_set_weak1(cp, weak1); - c_pointer_set_weak2(cp, weak2); - if ((weak1 != sc->F) || (weak2 != sc->F)) - add_weak_ref(sc, cp); - return(cp); -} - - -/* -------------------------------- c-pointer-info -------------------------------- */ -static s7_pointer c_pointer_info_p_p(s7_scheme *sc, s7_pointer p) -{ - if (!is_c_pointer(p)) - return(method_or_bust_p(sc, p, sc->c_pointer_info_symbol, sc->type_names[T_C_POINTER])); - return(c_pointer_info(p)); -} - -static s7_pointer g_c_pointer_info(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_info "(c-pointer-info obj) returns the c-pointer info field" - #define Q_c_pointer_info s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) - return(c_pointer_info_p_p(sc, car(args))); -} - - -/* -------------------------------- c-pointer-type -------------------------------- */ -static s7_pointer method_or_bust_lp(s7_scheme *sc, s7_pointer obj, s7_pointer method, uint8_t typ) -{ /* weird -- overhead goes berserk in callgrind if using the simpler method_or_bust_p! */ - if (!has_active_methods(sc, obj)) - wrong_type_error_nr(sc, method, 1, obj, sc->type_names[typ]); - return(find_and_apply_method(sc, obj, method, set_plist_1(sc, obj))); -} - -s7_pointer s7_c_pointer_type(s7_pointer p) {return((is_c_pointer(p)) ? c_pointer_type(p) : NULL);} - -static s7_pointer c_pointer_type_p_p(s7_scheme *sc, s7_pointer p) -{ - return((is_c_pointer(p)) ? c_pointer_type(p) : method_or_bust_lp(sc, p, sc->c_pointer_type_symbol, T_C_POINTER)); -} - -static s7_pointer g_c_pointer_type(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_type "(c-pointer-type obj) returns the c-pointer type field" - #define Q_c_pointer_type s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) - return(c_pointer_type_p_p(sc, car(args))); -} - - -/* -------------------------------- c-pointer-weak1/2 -------------------------------- */ -static s7_pointer c_pointer_weak1_p_p(s7_scheme *sc, s7_pointer p) -{ - return((is_c_pointer(p)) ? c_pointer_weak1(p) : method_or_bust_lp(sc, p, sc->c_pointer_weak1_symbol, T_C_POINTER)); -} - -static s7_pointer g_c_pointer_weak1(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_weak1 "(c-pointer-weak1 obj) returns the c-pointer weak1 field" - #define Q_c_pointer_weak1 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) - return(c_pointer_weak1_p_p(sc, car(args))); -} - -static s7_pointer c_pointer_weak2_p_p(s7_scheme *sc, s7_pointer p) -{ - return((is_c_pointer(p)) ? c_pointer_weak2(p) : method_or_bust_lp(sc, p, sc->c_pointer_weak2_symbol, T_C_POINTER)); -} - -static s7_pointer g_c_pointer_weak2(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_weak2 "(c-pointer-weak2 obj) returns the c-pointer weak2 field" - #define Q_c_pointer_weak2 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol) - return(c_pointer_weak2_p_p(sc, car(args))); -} - - -/* -------------------------------- c-pointer->list -------------------------------- */ -static s7_pointer g_c_pointer_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_c_pointer_to_list "(c-pointer->list obj) returns the c-pointer data as (list pointer-as-int type info)" - #define Q_c_pointer_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_c_pointer_symbol) - - s7_pointer p = car(args); - if (!is_c_pointer(p)) - return(method_or_bust(sc, p, sc->c_pointer_to_list_symbol, args, sc->type_names[T_C_POINTER], 1)); - return(list_3(sc, make_integer(sc, (s7_int)((intptr_t)c_pointer(p))), c_pointer_type(p), c_pointer_info(p))); -} - - -/* -------------------------------- continuations and gotos -------------------------------- */ -enum {NO_JUMP, CALL_WITH_EXIT_JUMP, THROW_JUMP, CATCH_JUMP, ERROR_JUMP, ERROR_QUIT_JUMP}; -enum {NO_SET_JUMP, READ_SET_JUMP, LOAD_SET_JUMP, DYNAMIC_WIND_SET_JUMP, S7_CALL_SET_JUMP, EVAL_SET_JUMP}; - - -/* ----------------------- continuation? -------------------------------- */ -static s7_pointer g_is_continuation(s7_scheme *sc, s7_pointer args) -{ - #define H_is_continuation "(continuation? obj) returns #t if obj is a continuation" - #define Q_is_continuation sc->pl_bt - check_boolean_method(sc, is_continuation, sc->is_continuation_symbol, args); - /* is this the right thing? It returns #f for call-with-exit ("goto") because - * that form of continuation can't continue (via a jump back to its context). - */ -} - -static bool is_continuation_b_p(s7_pointer p) {return(is_continuation(p));} - -#if S7_DEBUGGING -static s7_pointer check_wrap_return(s7_pointer lst) -{ - for (s7_pointer fast = lst, slow = lst; is_pair(fast); slow = cdr(slow), fast = cdr(fast)) - { - if (is_matched_pair(fast)) fprintf(stderr, "matched_pair not cleared\n"); - fast = cdr(fast); - if (!is_pair(fast)) return(lst); - if (fast == slow) return(lst); - if (is_matched_pair(fast)) fprintf(stderr, "matched_pair not cleared\n"); - } - return(lst); -} -#endif - -static s7_pointer copy_any_list(s7_scheme *sc, s7_pointer a) -{ - s7_pointer slow = cdr(a); - s7_pointer fast = slow; - s7_pointer p; -#if S7_DEBUGGING - #define wrap_return(W) do {fast = W; W = sc->unused; sc->y = sc->unused; return(check_wrap_return(fast));} while (0) -#else - #define wrap_return(W) do {fast = W; W = sc->unused; sc->y = sc->unused; return(fast);} while (0) -#endif - init_temp(sc->y, a); /* gc_protect_via_stack doesn't work here because we're called in copy_stack, I think (trouble is in call/cc stuff) */ - sc->w = list_1(sc, car(a)); - p = sc->w; - while (true) - { - if (!is_pair(fast)) - { - if (is_null(fast)) - wrap_return(sc->w); - set_cdr(p, fast); - wrap_return(sc->w); - } - - set_cdr(p, list_1(sc, car(fast))); - p = cdr(p); - fast = cdr(fast); - if (!is_pair(fast)) - { - if (is_null(fast)) - wrap_return(sc->w); - set_cdr(p, fast); - wrap_return(sc->w); - } - /* if unrolled further, it's a lot slower? */ - set_cdr(p, list_1_unchecked(sc, car(fast))); - p = cdr(p); - fast = cdr(fast); - slow = cdr(slow); - if (fast == slow) - { - /* try to preserve the original cyclic structure */ - s7_pointer p1, f1, p2, f2; - set_match_pair(a); - for (p1 = sc->w, f1 = a; !(is_matched_pair(cdr(f1))); f1 = cdr(f1), p1 = cdr(p1)) - set_match_pair(f1); - for (p2 = sc->w, f2 = a; cdr(f1) != f2; f2 = cdr(f2), p2 = cdr(p2)) - clear_match_pair(f2); - for (f1 = f2; is_pair(f1); f1 = cdr(f1), f2 = cdr(f2)) - { - clear_match_pair(f1); - f1 = cdr(f1); - clear_match_pair(f1); - if (f1 == f2) break; - } - clear_match_pair(a); - if (is_null(p1)) - set_cdr(p2, p2); - else set_cdr(p1, p2); - wrap_return(sc->w); - }} - wrap_return(sc->w); -} - -static s7_pointer copy_counter(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer nobj; - new_cell(sc, nobj, T_COUNTER); - counter_set_result(nobj, counter_result(obj)); - counter_set_list(nobj, counter_list(obj)); - counter_set_capture(nobj, counter_capture(obj)); - counter_set_let(nobj, counter_let(obj)); - counter_set_slots(nobj, counter_slots(obj)); - return(nobj); -} - -static void copy_stack_list_set_immutable(s7_scheme *unused_sc, s7_pointer pold, s7_pointer pnew) -{ - for (s7_pointer p1 = pold, p2 = pnew, slow = pold; is_pair(p2); p1 = cdr(p1), p2 = cdr(p2)) - { - if (is_immutable(p1)) set_immutable(p2); - if (is_pair(cdr(p1))) - { - p1 = cdr(p1); - p2 = cdr(p2); - if (is_immutable(p1)) set_immutable(p2); - if (p1 == slow) break; - slow = cdr(slow); - }} -} - -static s7_pointer copy_stack(s7_scheme *sc, s7_pointer new_v, s7_pointer old_v, int64_t top) -{ - bool has_pairs = false; - s7_pointer *nv = stack_elements(new_v); - s7_pointer *ov = stack_elements(old_v); - memcpy((void *)nv, (void *)ov, top * sizeof(s7_pointer)); - stack_clear_flags(new_v); - - s7_gc_on(sc, false); - if (stack_has_counters(old_v)) - { - for (int64_t i = 2; i < top; i += 4) - { - s7_pointer p = ov[i]; /* args */ - /* if op_gc_protect, any ov[i] (except op) can be a list, but it isn't the arglist, so it seems to be safe */ - if (is_pair(p)) /* args need not be a list (it can be a port or #f, etc) */ - { - has_pairs = true; - if (is_null(cdr(p))) - nv[i] = cons_unchecked(sc, car(p), sc->nil); /* GC is off -- could uncheck list_2 et al also */ - else - if ((is_pair(cdr(p))) && (is_null(cddr(p)))) - nv[i] = list_2_unchecked(sc, car(p), cadr(p)); - else nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ - /* if op=eval_args4 for example, this has to be a proper list, and in many cases it doesn't need to be copied */ - copy_stack_list_set_immutable(sc, p, nv[i]); - } - /* lst can be dotted or circular here. The circular list only happens in a case like: - * (dynamic-wind (lambda () (eq? (let ((lst (cons 1 2))) (set-cdr! lst lst) lst) (call/cc (lambda (k) k)))) (lambda () #f) (lambda () #f)) - * proper_list_reverse_in_place(sc->args) is one reason we need to copy, another reuse_as_let - */ - else - if (is_counter(p)) /* these can only occur in this context (not in a list etc) */ - { - stack_set_has_counters(new_v); - nv[i] = copy_counter(sc, p); - }}} - else - for (int64_t i = 2; i < top; i += 4) - if (is_pair(ov[i])) - { - s7_pointer p = ov[i]; - has_pairs = true; - if (is_null(cdr(p))) - nv[i] = cons_unchecked(sc, car(p), sc->nil); - else - if ((is_pair(cdr(p))) && (is_null(cddr(p)))) - nv[i] = list_2_unchecked(sc, car(p), cadr(p)); - else nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ - copy_stack_list_set_immutable(sc, p, nv[i]); - } - if (has_pairs) stack_set_has_pairs(new_v); - s7_gc_on(sc, true); - return(new_v); -} - -static s7_pointer copy_op_stack(s7_scheme *sc) -{ - int32_t len = (int32_t)(sc->op_stack_now - sc->op_stack); - s7_pointer nv = make_simple_vector(sc, len); /* not sc->op_stack_size */ - if (len > 0) - { - s7_pointer *src = sc->op_stack; - s7_pointer *dst = (s7_pointer *)vector_elements(nv); - for (int32_t i = len; i > 0; i--) *dst++ = *src++; - } - return(nv); -} - -/* -------------------------------- with-baffle -------------------------------- */ -/* (with-baffle . body) calls body guaranteeing that there can be no jumps into the - * middle of it from outside -- no outer evaluation of a continuation can jump across this - * barrier: The flip-side of call-with-exit. - */ - -static bool find_baffle(s7_scheme *sc, s7_int key) -{ - /* search backwards through sc->curlet for baffle_let with (continuation_)key as its baffle_key value */ - if (sc->baffle_ctr > 0) - for (s7_pointer x = sc->curlet; is_let(x); x = let_outlet(x)) - if ((is_baffle_let(x)) && - (let_baffle_key(x) == key)) - return(true); - return(false); -} - -#define NOT_BAFFLED -1 - -static s7_int find_any_baffle(s7_scheme *sc) -{ - /* search backwards through sc->curlet for any sc->baffle_symbol -- called by s7_make_continuation to set continuation_key */ - if (sc->baffle_ctr > 0) - for (s7_pointer x = sc->curlet; is_let(x); x = let_outlet(x)) - if (is_baffle_let(x)) - return(let_baffle_key(x)); - return(NOT_BAFFLED); -} - -static void check_with_baffle(s7_scheme *sc) -{ - if (!s7_is_proper_list(sc, sc->code)) - syntax_error_nr(sc, "with-baffle: unexpected dot? ~A", 31, sc->code); - pair_set_syntax_op(sc->code, OP_WITH_BAFFLE_UNCHECKED); -} - -static bool op_with_baffle_unchecked(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - if (is_null(sc->code)) - { - sc->value = sc->nil; - return(true); - } - sc->curlet = make_let(sc, sc->curlet); - set_baffle_let(sc->curlet); - set_let_baffle_key(sc->curlet, sc->baffle_ctr++); - return(false); -} - - -/* -------------------------------- call/cc -------------------------------- */ -static void make_room_for_cc_stack(s7_scheme *sc) -{ - if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8)) /* we probably never need this much space */ - { - call_gc(sc); - if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8)) - resize_heap(sc); - } -} - -s7_pointer s7_make_continuation(s7_scheme *sc) -{ - s7_pointer x, stack; - int64_t loc; - block_t *block; - - sc->continuation_counter++; - make_room_for_cc_stack(sc); - if (sc->continuation_counter > 2000) call_gc(sc); /* call_gc zeros cc counter, gc time up, but run time down -- try big cache */ - - loc = current_stack_top(sc); - stack = make_simple_vector(sc, loc); - set_full_type(stack, T_STACK); - temp_stack_top(stack) = loc; - sc->temp7 = stack; - copy_stack(sc, stack, sc->stack, loc); - - new_cell(sc, x, T_CONTINUATION); - block = mallocate_block(sc); - continuation_block(x) = block; - continuation_set_stack(x, stack); - continuation_stack_size(x) = vector_length(continuation_stack(x)); - continuation_stack_start(x) = stack_elements(continuation_stack(x)); - continuation_stack_end(x) = (s7_pointer *)(continuation_stack_start(x) + loc); - continuation_op_stack(x) = copy_op_stack(sc); - continuation_op_loc(x) = (int32_t)(sc->op_stack_now - sc->op_stack); - continuation_op_size(x) = sc->op_stack_size; - continuation_key(x) = find_any_baffle(sc); - continuation_name(x) = sc->F; - sc->temp7 = sc->unused; - - add_continuation(sc, x); - return(x); -} - -static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let); -static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value); -static s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer e); -static s7_pointer eval(s7_scheme *sc, opcode_t first_op); - -static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c) -{ - /* called only from call_with_current_continuation. - * if call/cc jumps into a dynamic-wind, the init/finish funcs are wrapped in with-baffle - * so they'll complain. Otherwise we're supposed to re-run the init func before diving - * into the body. Similarly for let-temporarily. If a call/cc jumps out of a dynamic-wind - * body-func, we're supposed to call the finish-func. The continuation is called at - * current_stack_top(sc); the continuation form is at continuation_stack_top(c). - * - * check sc->stack for dynamic-winds we're jumping out of - * we need to check from the current stack top down to where the continuation stack matches the current stack?? - * this was (i > 0), but that goes too far back; perhaps s7 should save the position of the call/cc invocation. - * also the two stacks can be different sizes (either can be larger) - */ - int64_t top1 = current_stack_top(sc), top2 = continuation_stack_top(c); - for (int64_t i = top1 - 1; (i > 0) && ((i >= top2) || (stack_code(sc->stack, i) != stack_code(continuation_stack(c), i))); i -= 4) - { - opcode_t op = stack_op(sc->stack, i); - switch (op) - { - case OP_DYNAMIC_WIND: - case OP_LET_TEMP_DONE: - { - s7_pointer x = stack_code(sc->stack, i); - int64_t s_base = 0; - for (int64_t j = 3; j < top2; j += 4) - if (((stack_op(continuation_stack(c), j) == OP_DYNAMIC_WIND) || - (stack_op(continuation_stack(c), j) == OP_LET_TEMP_DONE)) && - (x == stack_code(continuation_stack(c), j))) - { - s_base = i; - break; - } - if (s_base == 0) - { - if (op == OP_DYNAMIC_WIND) - { - if (dynamic_wind_state(x) == DWIND_BODY) - { - dynamic_wind_state(x) = DWIND_FINISH; - if (dynamic_wind_out(x) != sc->F) - sc->value = s7_call(sc, dynamic_wind_out(x), sc->nil); - }} - else let_temp_done(sc, stack_args(sc->stack, i), stack_let(sc->stack, i)); - }} - break; - - case OP_DYNAMIC_UNWIND: - case OP_DYNAMIC_UNWIND_PROFILE: - stack_element(sc->stack, i) = (s7_pointer)OP_GC_PROTECT; - break; - - case OP_LET_TEMP_UNWIND: - let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_UNWIND: - s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_DIRECT_UNWIND: - sc->has_openlets = (stack_args(sc->stack, i) != sc->F); - break; - - case OP_BARRIER: - if (i > top2) /* otherwise it's some unproblematic outer eval-string? */ - return(false); /* but what if we've already evaluated a dynamic-wind closer? */ - break; - - case OP_DEACTIVATE_GOTO: /* here we're jumping out of an unrelated call-with-exit block */ - if (i > top2) - call_exit_active(stack_args(sc->stack, i)) = false; - break; - - case OP_UNWIND_INPUT: - if (stack_args(sc->stack, i) != sc->unused) - set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; - - case OP_UNWIND_OUTPUT: - if (stack_args(sc->stack, i) != sc->unused) - set_current_output_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; - - default: - if ((S7_DEBUGGING) && (op == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); - break; - }} - - /* check continuation-stack for dynamic-winds we're jumping into */ - for (int64_t i = current_stack_top(sc) - 1; i < top2; i += 4) - { - opcode_t op = stack_op(continuation_stack(c), i); - if (op == OP_DYNAMIC_WIND) - { - s7_pointer x = T_Dyn(stack_code(continuation_stack(c), i)); - if (dynamic_wind_in(x) != sc->F) - sc->value = s7_call(sc, dynamic_wind_in(x), sc->nil); - dynamic_wind_state(x) = DWIND_BODY; - } - else - if (op == OP_DEACTIVATE_GOTO) - call_exit_active(stack_args(continuation_stack(c), i)) = true; - /* not let_temp_done here! */ - /* if op == OP_LET_TEMP_DONE, we're jumping back into a let-temporarily. MIT and Chez scheme say they remember the - * let-temp vars (fluid-let or parameters in their terminology) at the point of the call/cc, and restore them - * on re-entry; that strikes me as incoherently complex -- they've wrapped a hidden dynamic-wind around the - * call/cc to restore all let-temp vars! I think let-temp here should be the same as let -- if you jump back - * in, nothing hidden happens. So, - * (let ((x #f) (cc #f)) - * (let-temporarily ((x 1)) - * (set! x 2) (call/cc (lambda (r) (set! cc r))) (display x) (unless (= x 2) (newline) (exit)) (set! x 3) (cc))) - * behaves the same (in this regard) if let-temp is replaced with let. - */ - } - return(true); -} - -static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args); - -static void call_with_current_continuation(s7_scheme *sc) -{ - s7_pointer c = sc->code; /* sc->args are the returned values */ - - /* check for (baffle ...) blocking the current attempt to continue */ - if ((continuation_key(c) != NOT_BAFFLED) && - (!(find_baffle(sc, continuation_key(c))))) - error_nr(sc, sc->baffled_symbol, - (is_symbol(continuation_name(sc->code))) ? - set_elist_2(sc, wrap_string(sc, "continuation ~S can't jump into with-baffle", 43), continuation_name(sc->code)) : - set_elist_1(sc, wrap_string(sc, "continuation can't jump into with-baffle", 40))); - - if (check_for_dynamic_winds(sc, c)) - { - /* make_room_for_cc_stack(sc); */ /* 28-May-21 */ - /* we push_stack sc->code before calling an embedded eval above, so sc->code should still be c here, etc */ - if ((stack_has_pairs(continuation_stack(c))) || - (stack_has_counters(continuation_stack(c)))) - { - make_room_for_cc_stack(sc); - copy_stack(sc, sc->stack, continuation_stack(c), continuation_stack_top(c)); - } - else - { - s7_pointer *nv = stack_elements(sc->stack); - s7_pointer *ov = stack_elements(continuation_stack(c)); - memcpy((void *)nv, (void *)ov, continuation_stack_top(c) * sizeof(s7_pointer)); - } - /* copy_stack(sc, sc->stack, continuation_stack(c), continuation_stack_top(c)); */ - sc->stack_end = (s7_pointer *)(sc->stack_start + continuation_stack_top(c)); - - { - int32_t top = continuation_op_loc(c); - s7_pointer *src, *dst; - sc->op_stack_now = (s7_pointer *)(sc->op_stack + top); - sc->op_stack_size = continuation_op_size(c); - sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size); - src = (s7_pointer *)vector_elements(continuation_op_stack(c)); - dst = sc->op_stack; - for (int32_t i = 0; i < top; i++) dst[i] = src[i]; - } - sc->value = (is_null(sc->args)) ? sc->nil : ((is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, sc->args)); - } -} - -static s7_pointer g_call_cc(s7_scheme *sc, s7_pointer args) -{ - #define H_call_cc "(call-with-current-continuation (lambda (continuer)...)) is always a mistake!" - #define Q_call_cc s7_make_signature(sc, 2, sc->T, sc->is_procedure_symbol) - - s7_pointer p = car(args); /* this is the procedure passed to call/cc */ - if (!is_t_procedure(p)) /* this includes continuations */ - { - check_method(sc, p, sc->call_cc_symbol, args); - check_method(sc, p, sc->call_with_current_continuation_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->call_cc_symbol, p, a_procedure_string); - } - if (((!is_closure(p)) || - (closure_arity(p) != 1)) && - (!s7_is_aritable(sc, p, 1))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "call/cc procedure, ~A, should take one argument", 47), p)); - - sc->w = s7_make_continuation(sc); - if ((is_any_closure(p)) && (is_pair(closure_args(p))) && (is_symbol(car(closure_args(p))))) - continuation_name(sc->w) = car(closure_args(p)); - push_stack(sc, OP_APPLY, list_1_unchecked(sc, sc->w), p); /* apply function p to continuation sc->w */ - sc->w = sc->unused; - return(sc->nil); -} - -/* we can't naively optimize call/cc to call-with-exit if the continuation is only - * used as a function in the call/cc body because it might (for example) be wrapped - * in a lambda form that is being exported. See b-func in s7test for an example. - */ - -static void op_call_cc(s7_scheme *sc) -{ - sc->w = s7_make_continuation(sc); - continuation_name(sc->w) = caar(opt2_pair(sc->code)); /* caadadr(sc->code) */ - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, continuation_name(sc->w), sc->w); - sc->w = sc->unused; - sc->code = cdr(opt2_pair(sc->code)); /* cddadr(sc->code) */ -} - -static bool op_implicit_continuation_a(s7_scheme *sc) -{ - s7_pointer code = sc->code; /* dumb-looking code, but it's faster than the pretty version, according to callgrind */ - s7_pointer s = lookup_checked(sc, car(code)); - if (!is_continuation(s)) {sc->last_function = s; return(false);} - sc->code = s; - sc->args = set_plist_1(sc, fx_call(sc, cdr(code))); - call_with_current_continuation(sc); - return(true); -} - - -/* -------------------------------- call-with-exit -------------------------------- */ -static void pop_input_port(s7_scheme *sc); - -static void call_with_exit(s7_scheme *sc) -{ - int64_t i, new_stack_top, quit = 0; - - if (!call_exit_active(sc->code)) - error_nr(sc, sc->invalid_escape_function_symbol, - set_elist_1(sc, wrap_string(sc, "call-with-exit escape procedure called outside its block", 56))); - - call_exit_active(sc->code) = false; - new_stack_top = call_exit_goto_loc(sc->code); - sc->op_stack_now = (s7_pointer *)(sc->op_stack + call_exit_op_loc(sc->code)); - - /* look for dynamic-wind in the stack section that we are jumping out of */ - i = current_stack_top(sc) - 1; - do { - switch (stack_op(sc->stack, i)) /* avoidable if we group these ops at the end and use op< */ - { - case OP_DYNAMIC_WIND: - { - s7_pointer lx = T_Dyn(stack_code(sc->stack, i)); - if (dynamic_wind_state(lx) == DWIND_BODY) - { - dynamic_wind_state(lx) = DWIND_FINISH; - if (dynamic_wind_out(lx) != sc->F) - { - s7_pointer arg = (sc->args == sc->plist_1) ? car(sc->plist_1) : sc->unused; /* might also need GC protection here */ - /* protect the sc->args value across this call if it is sc->plist_1 -- I can't find a broken case */ - sc->value = s7_call(sc, dynamic_wind_out(lx), sc->nil); - if (arg != sc->unused) set_plist_1(sc, arg); - }}} - break; - - case OP_DYNAMIC_UNWIND: - case OP_DYNAMIC_UNWIND_PROFILE: - stack_element(sc->stack, i) = (s7_pointer)OP_GC_PROTECT; - dynamic_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; - - case OP_EVAL_STRING: - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - break; - - case OP_BARRIER: /* oops -- we almost certainly went too far */ - goto SET_VALUE; - - case OP_DEACTIVATE_GOTO: /* here we're jumping into an unrelated call-with-exit block */ - call_exit_active(stack_args(sc->stack, i)) = false; - break; - - case OP_LET_TEMP_DONE: - { - s7_pointer old_args = sc->args; - let_temp_done(sc, stack_args(sc->stack, i), stack_let(sc->stack, i)); - sc->args = old_args; - } - break; - - case OP_LET_TEMP_UNWIND: - let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_UNWIND: - s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_DIRECT_UNWIND: - sc->has_openlets = (stack_args(sc->stack, i) != sc->F); - break; - - /* call/cc does not close files, but I think call-with-exit should */ - case OP_GET_OUTPUT_STRING: - case OP_UNWIND_OUTPUT: - { - s7_pointer x = T_Prt(stack_code(sc->stack, i)); /* "code" = port that we opened */ - s7_close_output_port(sc, x); - x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not # */ - if (x != sc->unused) - set_current_output_port(sc, x); - } - break; - - case OP_UNWIND_INPUT: - s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */ - if (stack_args(sc->stack, i) != sc->unused) - set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; - - case OP_EVAL_DONE: /* goto called in a method -- put off the inner eval return(s) until we clean up the stack */ - quit++; - break; - - default: - if ((S7_DEBUGGING) && (stack_op(sc->stack, i) == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); - break; - } - i -= 4; - } while (i > new_stack_top); - - SET_VALUE: - sc->stack_end = (s7_pointer *)(sc->stack_start + new_stack_top); - - /* the return value should have an implicit values call, just as in call/cc */ - sc->value = (is_null(sc->args)) ? sc->nil : ((is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, sc->args)); - if (quit > 0) - { - if (sc->longjmp_ok) - { - pop_stack(sc); - LongJmp(*(sc->goto_start), CALL_WITH_EXIT_JUMP); - } - for (i = 0; i < quit; i++) - push_stack_op_let(sc, OP_EVAL_DONE); - } -} - -static s7_pointer g_is_goto(s7_scheme *sc, s7_pointer args) -{ - #define H_is_goto "(goto? obj) returns #t if obj is a call-with-exit exit function" - #define Q_is_goto sc->pl_bt - return(make_boolean(sc, is_goto(car(args)))); -} - -static inline s7_pointer make_goto(s7_scheme *sc, s7_pointer name) /* inline for 73=1% in tgc */ -{ - s7_pointer x; - new_cell(sc, x, T_GOTO); - call_exit_goto_loc(x) = current_stack_top(sc); - call_exit_op_loc(x) = (int32_t)(sc->op_stack_now - sc->op_stack); - call_exit_active(x) = true; - call_exit_name(x) = name; - return(x); -} - -static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args) /* (call-with-exit (lambda (return) ...)) */ -{ - #define H_call_with_exit "(call-with-exit (lambda (exiter) ...)) is call/cc without the ability to jump back into a previous computation." - #define Q_call_with_exit s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol) - - s7_pointer p = car(args), x; - if (is_any_closure(p)) - { - x = make_goto(sc, ((is_pair(closure_args(p))) && (is_symbol(car(closure_args(p))))) ? car(closure_args(p)) : sc->F); - push_stack(sc, OP_DEACTIVATE_GOTO, x, p); /* this means call-with-exit is not tail-recursive */ - push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->nil), p); - return(sc->nil); - } - /* maybe just return an error here -- these gotos as args are stupid; also an error above if closure not aritable 1 */ - if (!is_t_procedure(p)) - return(sole_arg_method_or_bust_p(sc, p, sc->call_with_exit_symbol, a_procedure_string)); - if (!s7_is_aritable(sc, p, 1)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "call-with-exit argument should be a function of one argument: ~S", 64), p)); - x = make_goto(sc, sc->F); - call_exit_active(x) = false; - return((is_c_function(p)) ? c_function_call(p)(sc, set_plist_1(sc, x)) : s7_apply_function_star(sc, p, set_plist_1(sc, x))); -} - -static inline void op_call_with_exit(s7_scheme *sc) -{ - s7_pointer args = opt2_pair(sc->code); - s7_pointer go = make_goto(sc, caar(args)); - push_stack_no_let_no_code(sc, OP_DEACTIVATE_GOTO, go); /* was also pushing code */ - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(args), go); - sc->code = T_Pair(cdr(args)); -} - -static void op_call_with_exit_o(s7_scheme *sc) -{ - op_call_with_exit(sc); - sc->code = car(sc->code); -} - -static bool op_implicit_goto(s7_scheme *sc) -{ - s7_pointer g = lookup_checked(sc, car(sc->code)); - if (!is_goto(g)) {sc->last_function = g; return(false);} - sc->args = sc->nil; - sc->code = g; - call_with_exit(sc); - return(true); -} - -static bool op_implicit_goto_a(s7_scheme *sc) -{ - s7_pointer g = lookup_checked(sc, car(sc->code)); - if (!is_goto(g)) {sc->last_function = g; return(false);} - sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); - sc->code = g; - call_with_exit(sc); - return(true); -} - - -/* -------------------------------- numbers -------------------------------- */ -static block_t *string_to_block(s7_scheme *sc, const char *p, s7_int len) -{ - block_t *b = inline_mallocate(sc, len + 1); - char *bp = (char *)block_data(b); - memcpy((void *)bp, (void *)p, len); - bp[len] = '\0'; - return(b); -} - -static Inline s7_pointer inline_block_to_string(s7_scheme *sc, block_t *block, s7_int len) -{ - s7_pointer x; - new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE); - string_block(x) = block; - string_value(x) = (char *)block_data(block); - string_length(x) = len; - string_value(x)[len] = '\0'; - string_hash(x) = 0; - add_string(sc, x); - return(x); -} - -static s7_pointer block_to_string(s7_scheme *sc, block_t *block, s7_int len) {return(inline_block_to_string(sc, block, len));} - -static inline s7_pointer make_simple_ratio(s7_scheme *sc, s7_int num, s7_int den) -{ - s7_pointer x; - if (den == 1) - return(make_integer(sc, num)); - if (den == -1) - return(make_integer(sc, -num)); - if ((den == S7_INT64_MIN) && ((num & 1) != 0)) - return(make_real(sc, (long_double)num / (long_double)den)); - new_cell(sc, x, T_RATIO); - if (den < 0) /* this is noticeably faster in callgrind than using (den < 0) ? ... twice */ - { - numerator(x) = -num; - denominator(x) = -den; - } - else - { - numerator(x) = num; - denominator(x) = den; - } - return(x); -} - -static bool is_zero(s7_pointer x); -static bool is_positive(s7_scheme *sc, s7_pointer x); -static bool is_negative(s7_scheme *sc, s7_pointer x); -static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b); - -static bool is_NaN(s7_double x) {return(x != x);} -/* callgrind says this is faster than isnan, I think (very confusing data...) */ - -#if defined(__sun) && defined(__SVR4) - static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));} /* there's no isinf in Solaris */ -#else -#if (!MS_WINDOWS) - #if __cplusplus - #define is_inf(x) std::isinf(x) - #else - #define is_inf(x) isinf(x) - #endif -#else - static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));} /* Another possibility: (x * 0) != 0 */ - -#if (_MSC_VER < 1700) - /* in MS C, we need to provide inverse hyperbolic trig funcs and cbrt */ - static double asinh(double x) {return(log(x + sqrt(1.0 + x * x)));} - static double acosh(double x) {return(log(x + sqrt(x * x - 1.0)));} - /* perhaps less prone to numerical troubles (untested): 2.0 * log(sqrt(0.5 * (x + 1.0)) + sqrt(0.5 * (x - 1.0))) */ - static double atanh(double x) {return(log((1.0 + x) / (1.0 - x)) / 2.0);} - static double cbrt(double x) {if (x >= 0.0) return(pow(x, 1.0 / 3.0)); return(-pow(-x, 1.0 / 3.0));} -#endif -#endif /* windows */ -#endif /* not sun */ - - -/* -------------------------------- NaN payloads -------------------------------- */ -typedef union {int64_t ix; double fx;} decode_float_t; - -static double nan_with_payload(int64_t payload) -{ - decode_float_t num; - if (payload <= 0) return(NAN); - num.fx = NAN; - num.ix = num.ix | payload; - return(num.fx); -} - -static s7_pointer make_nan_with_payload(s7_scheme *sc, s7_int payload) -{ - s7_pointer x = make_real(sc, nan_with_payload(payload)); - char buf[32]; - s7_int nlen = 0; - nlen = snprintf(buf, 32, "+nan.%" ld64, payload); - set_number_name(x, buf, nlen); - return(x); -} - -static s7_pointer g_nan(s7_scheme *sc, s7_pointer args) -{ - #define H_nan "(nan int) returns a NaN with payload int" - #define Q_nan s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_integer_symbol) - #define NAN_PAYLOAD_LIMIT (1LL << 51LL) /* 53 is probably ok, (nan (- (ash 1 53) 1)): +nan.9007199254740991 -- 52 bits available? */ - s7_pointer x; - if (is_null(args)) return(real_NaN); - x = car(args); - if (!is_t_integer(x)) - sole_arg_wrong_type_error_nr(sc, sc->nan_symbol, x, sc->type_names[T_INTEGER]); - if (integer(x) < 0) - sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, x), it_is_negative_string); - if (integer(x) >= NAN_PAYLOAD_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, x), it_is_too_large_string); - return(make_nan_with_payload(sc, integer(x))); -} - -static s7_int nan_payload(double x) -{ - decode_float_t num; - num.fx = x; - return(num.ix & 0xffffffffffff); -} - -static s7_pointer g_nan_payload(s7_scheme *sc, s7_pointer args) -{ - #define H_nan_payload "(nan-payload x) returns the payload associated with the NaN x" - #define Q_nan_payload s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - s7_pointer x = car(args); - if ((!is_t_real(x)) || (!is_NaN(real(x)))) /* for complex case, use real-part etc (see s7test.scm) */ - sole_arg_wrong_type_error_nr(sc, sc->nan_payload_symbol, x, wrap_string(sc, "a NaN", 5)); - return(make_integer(sc, nan_payload(real(x)))); -} - -/* no similar support for +inf.0 because inf is just a single bit pattern in ieee754 */ - - -/* -------- gmp stuff -------- */ -#if WITH_GMP -static mp_prec_t mpc_precision = DEFAULT_BIGNUM_PRECISION; -static mp_prec_t mpc_set_default_precision(mp_prec_t prec) {mpc_precision = prec; return(prec);} -#define mpc_init(Z) mpc_init2(Z, mpc_precision) - -static bigint *alloc_bigint(s7_scheme *sc) -{ - bigint *p; - if (sc->bigints) - { - p = sc->bigints; - sc->bigints = p->nxt; - } - else - { - p = (bigint *)Malloc(sizeof(bigint)); - /* not permalloc here: gmp must be playing tricky games with realloc or something. permalloc can lead - * to mpz_set_si overwriting adjacent memory (valgrind does not catch this), clobbering at least the - * bigint nxt field. Someday I need to look at the source. - */ - mpz_init(p->n); - } - return(p); -} - -static bigrat *alloc_bigrat(s7_scheme *sc) -{ - bigrat *p; - if (sc->bigrats) - { - p = sc->bigrats; - sc->bigrats = p->nxt; - } - else - { - p = (bigrat *)Malloc(sizeof(bigrat)); - mpq_init(p->q); - } - return(p); -} - -static bigflt *alloc_bigflt(s7_scheme *sc) -{ - bigflt *p; - if (sc->bigflts) - { - p = sc->bigflts; - sc->bigflts = p->nxt; - mpfr_set_prec(p->x, sc->bignum_precision); - } - else - { - p = (bigflt *)Malloc(sizeof(bigflt)); - mpfr_init2(p->x, sc->bignum_precision); - } - return(p); -} - -static bigcmp *alloc_bigcmp(s7_scheme *sc) -{ - bigcmp *p; - if (sc->bigcmps) - { - p = sc->bigcmps; - sc->bigcmps = p->nxt; - mpc_set_prec(p->z, sc->bignum_precision); - } - else - { - p = (bigcmp *)Malloc(sizeof(bigcmp)); - mpc_init(p->z); - } - return(p); -} - -static s7_pointer mpz_to_big_integer(s7_scheme *sc, mpz_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_INTEGER); - big_integer_bgi(x) = alloc_bigint(sc); - mpz_set(big_integer(x), val); - add_big_integer(sc, x); - return(x); -} - -static s7_pointer mpz_to_integer(s7_scheme *sc, mpz_t val) -{ - if (mpz_fits_slong_p(val)) - return(make_integer(sc, mpz_get_si(val))); - return(mpz_to_big_integer(sc, val)); -} - -#if (!WITH_PURE_S7) -static s7_pointer mpz_to_big_real(s7_scheme *sc, mpz_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_set_z(big_real(x), val, MPFR_RNDN); - return(x); -} -#endif - -static s7_pointer mpq_to_big_ratio(s7_scheme *sc, mpq_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_set(big_ratio(x), val); - return(x); -} - -static s7_pointer mpq_to_rational(s7_scheme *sc, mpq_t val) -{ - if (mpz_cmp_ui(mpq_denref(val), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(val))); -#if S7_DEBUGGING - mpq_canonicalize(val); - if (mpz_cmp_ui(mpq_denref(val), 1) == 0) - { - fprintf(stderr, "mpq_to_rational: missing canonicalize\n"); - return(mpz_to_integer(sc, mpq_numref(val))); - } -#endif - if ((mpz_fits_slong_p(mpq_numref(val))) && (mpz_fits_slong_p(mpq_denref(val)))) - return(make_simple_ratio(sc, mpz_get_si(mpq_numref(val)), mpz_get_si(mpq_denref(val)))); - return(mpq_to_big_ratio(sc, val)); -} - -static s7_pointer mpq_to_canonicalized_rational(s7_scheme *sc, mpq_t mpq) -{ - mpq_canonicalize(mpq); - return(mpq_to_rational(sc, mpq)); -} - -static s7_pointer mpz_to_rational(s7_scheme *sc, mpz_t n, mpz_t d) /* mpz_3 and mpz_4 */ -{ - if (mpz_cmp_ui(d, 1) == 0) - return(mpz_to_integer(sc, n)); - mpq_set_num(sc->mpq_1, n); - mpq_set_den(sc->mpq_1, d); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); -} - -#if (!WITH_PURE_S7) -static s7_pointer mpq_to_big_real(s7_scheme *sc, mpq_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_set_q(big_real(x), val, MPFR_RNDN); - return(x); -} -#endif - -static s7_pointer any_rational_to_mpq(s7_scheme *sc, s7_pointer z, mpq_t bigq) -{ - switch (type(z)) - { - case T_INTEGER: mpq_set_si(bigq, integer(z), 1); break; - case T_BIG_INTEGER: mpq_set_z(bigq, big_integer(z)); break; - case T_RATIO: mpq_set_si(bigq, numerator(z), denominator(z)); break; - case T_BIG_RATIO: mpq_set(bigq, big_ratio(z)); break; - } - return(z); -} - -static s7_pointer mpfr_to_integer(s7_scheme *sc, mpfr_t val) -{ - mpfr_get_z(sc->mpz_4, val, MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_4)); -} - -static s7_pointer mpfr_to_big_real(s7_scheme *sc, mpfr_t val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - add_big_real(sc, x); - big_real_bgf(x) = alloc_bigflt(sc); - mpfr_set(big_real(x), val, MPFR_RNDN); - return(x); -} - -static s7_pointer mpc_to_number(s7_scheme *sc, mpc_t val) -{ - s7_pointer x; - if (mpfr_zero_p(mpc_imagref(val))) - return(mpfr_to_big_real(sc, mpc_realref(val))); - new_cell(sc, x, T_BIG_COMPLEX); - big_complex_bgc(x) = alloc_bigcmp(sc); - add_big_complex(sc, x); - mpc_set(big_complex(x), val, MPC_RNDNN); - return(x); -} - -/* s7.h */ -mpz_t *s7_big_integer(s7_pointer x) {return(&big_integer(x));} -mpq_t *s7_big_ratio(s7_pointer x) {return(&big_ratio(x));} -mpfr_t *s7_big_real(s7_pointer x) {return(&big_real(x));} -mpc_t *s7_big_complex(s7_pointer x) {return(&big_complex(x));} - -bool s7_is_big_integer(s7_pointer x) {return(is_t_big_integer(x));} -bool s7_is_big_ratio(s7_pointer x) {return(is_t_big_ratio(x));} -bool s7_is_big_real(s7_pointer x) {return(is_t_big_real(x));} -bool s7_is_big_complex(s7_pointer x) {return(is_t_big_complex(x));} - -s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val) {return(mpz_to_integer(sc, *val));} -s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val) {return(mpq_to_rational(sc, *val));} -s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val) {return(mpfr_to_big_real(sc, *val));} -s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val) {return(mpc_to_number(sc, *val));} - -#if (!WITH_PURE_S7) -static s7_pointer big_integer_to_big_real(s7_scheme *sc, s7_pointer x) {return(mpz_to_big_real(sc, big_integer(x)));} -static s7_pointer big_ratio_to_big_real(s7_scheme *sc, s7_pointer x) {return(mpq_to_big_real(sc, big_ratio(x)));} -#endif - -static s7_pointer s7_int_to_big_integer(s7_scheme *sc, s7_int val) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_INTEGER); - big_integer_bgi(x) = alloc_bigint(sc); - mpz_set_si(big_integer(x), val); - add_big_integer(sc, x); - return(x); -} - -static s7_pointer s7_int_to_big_ratio(s7_scheme *sc, s7_int num, s7_int den) -{ - /* (called only in g_bignum), den here always comes from denominator(x) or some positive constant so it is not negative */ - s7_pointer x; - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_set_si(big_ratio(x), num, den); - return(x); -} - -static s7_pointer s7_double_to_big_real(s7_scheme *sc, s7_double rl) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_set_d(big_real(x), rl, MPFR_RNDN); - return(x); -} - -static s7_pointer s7_double_to_big_complex(s7_scheme *sc, s7_double rl, s7_double im) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_COMPLEX); - add_big_complex(sc, x); - big_complex_bgc(x) = alloc_bigcmp(sc); - mpc_set_d_d(big_complex(x), rl, im, MPC_RNDNN); - return(x); -} - -static s7_pointer big_pi(s7_scheme *sc) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL | T_IMMUTABLE); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_const_pi(big_real(x), MPFR_RNDN); - return(x); -} - -static bool is_integer_via_method(s7_scheme *sc, s7_pointer p) -{ - if (s7_is_integer(p)) - return(true); - if (has_active_methods(sc, p)) - { - s7_pointer f = find_method_with_let(sc, p, sc->is_integer_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - } - return(false); -} - -#if (!WITH_PURE_S7) -static s7_pointer s7_number_to_big_real(s7_scheme *sc, s7_pointer p) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - - switch (type(p)) - { - case T_INTEGER: - mpfr_set_si(big_real(x), integer(p), MPFR_RNDN); - break; - case T_RATIO: - /* here we can't use fraction(number(p)) even though that uses long_double division because - * there are lots of int64_t ratios that will still look the same. - * We have to do the actual bignum divide by hand. - */ - mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); - mpfr_set_q(big_real(x), sc->mpq_1, MPFR_RNDN); - break; - default: - mpfr_set_d(big_real(x), s7_real(p), MPFR_RNDN); - break; - } - return(x); -} -#endif - -static s7_pointer s7_number_to_big_complex(s7_scheme *sc, s7_pointer p) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_COMPLEX); - big_complex_bgc(x) = alloc_bigcmp(sc); - add_big_complex(sc, x); - - switch (type(p)) - { - case T_INTEGER: - mpc_set_si(big_complex(x), integer(p), MPC_RNDNN); - break; - case T_RATIO: - /* can't use fraction here */ - mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpc_set_fr(big_complex(x), sc->mpfr_1, MPC_RNDNN); - break; - case T_REAL: - mpc_set_d(big_complex(x), s7_real(p), MPC_RNDNN); - break; - default: - mpc_set_d_d(big_complex(x), real_part(p), imag_part(p), MPC_RNDNN); - break; - } - return(x); -} - -static s7_pointer any_real_to_mpfr(s7_scheme *sc, s7_pointer p, mpfr_t bigx) -{ - switch (type(p)) - { - case T_INTEGER: - mpfr_set_si(bigx, integer(p), MPFR_RNDN); - break; - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); - mpfr_set_q(bigx, sc->mpq_1, MPFR_RNDN); - break; - case T_REAL: - mpfr_set_d(bigx, real(p), MPFR_RNDN); - if (is_NaN(real(p))) return(real_NaN); - if (is_inf(real(p))) return(real_infinity); - break; - case T_BIG_INTEGER: - mpfr_set_z(bigx, big_integer(p), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(bigx, big_ratio(p), MPFR_RNDN); - break; - case T_BIG_REAL: - mpfr_set(bigx, big_real(p), MPFR_RNDN); - if (mpfr_nan_p(big_real(p))) return(real_NaN); - if (mpfr_inf_p(big_real(p))) return(real_infinity); - break; - } - return(NULL); -} - -#define mpc_zero_p(z) ((mpfr_zero_p(mpc_realref(z))) && (mpfr_zero_p(mpc_imagref(z)))) - -static s7_pointer any_number_to_mpc(s7_scheme *sc, s7_pointer p, mpc_t bigz) -{ - switch (type(p)) - { - case T_INTEGER: - mpc_set_si(bigz, integer(p), MPC_RNDNN); - break; - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); - mpc_set_q(bigz, sc->mpq_1, MPC_RNDNN); - break; - case T_REAL: - if (is_NaN(real(p))) return(real_NaN); - if (is_inf(real(p))) return(real_infinity); - mpc_set_d(bigz, real(p), MPC_RNDNN); - break; - case T_COMPLEX: - if (is_NaN(imag_part(p))) return(complex_NaN); - if (is_NaN(real_part(p))) return(real_NaN); - mpc_set_d_d(bigz, real_part(p), imag_part(p), MPC_RNDNN); - break; - case T_BIG_INTEGER: - mpc_set_z(bigz, big_integer(p), MPC_RNDNN); - break; - case T_BIG_RATIO: - mpc_set_q(bigz, big_ratio(p), MPC_RNDNN); - break; - case T_BIG_REAL: - mpc_set_fr(bigz, big_real(p), MPC_RNDNN); - if (mpfr_nan_p(big_real(p))) return(real_NaN); - if (mpfr_inf_p(big_real(p))) return(real_infinity); - break; - case T_BIG_COMPLEX: - if (mpfr_nan_p(mpc_imagref(big_complex(p)))) return(complex_NaN); - if (mpfr_nan_p(mpc_realref(big_complex(p)))) return(real_NaN); - mpc_set(bigz, big_complex(p), MPC_RNDNN); - break; - } - return(NULL); -} - -static s7_pointer make_big_complex(s7_scheme *sc, mpfr_t rl, mpfr_t im) -{ - /* there is no mpc_get_str equivalent, so we need to split up str, use make_big_real to get the 2 halves, then mpc_init, then mpc_set_fr_fr */ - s7_pointer x; - new_cell(sc, x, T_BIG_COMPLEX); - big_complex_bgc(x) = alloc_bigcmp(sc); - add_big_complex(sc, x); - mpc_set_fr_fr(big_complex(x), rl ,im, MPC_RNDNN); - return(x); -} - -static block_t *mpfr_to_string(s7_scheme *sc, mpfr_t val, int32_t radix) -{ - char *str; - mp_exp_t expptr; - int32_t ep; - s7_int i, len; - block_t *b, *btmp; - - if (mpfr_zero_p(val)) - return(string_to_block(sc, "0.0", 3)); - if (mpfr_nan_p(val)) - return(string_to_block(sc, "+nan.0", 6)); - if (mpfr_inf_p(val)) - return((mpfr_signbit(val) == 0) ? string_to_block(sc, "+inf.0", 6) : string_to_block(sc, "-inf.0", 6)); - - b = callocate(sc, sc->bignum_precision + 32); - str = mpfr_get_str((char *)block_data(b), &expptr, radix, 0, val, MPFR_RNDN); - ep = (int32_t)expptr; - len = safe_strlen(str); - - /* remove trailing 0's */ - for (i = len - 1; i > 3; i--) - if (str[i] != '0') - break; - if (i < len - 1) - str[i + 1] = '\0'; - - btmp = mallocate(sc, len + 64); - if (str[0] == '-') - snprintf((char *)block_data(btmp), len + 64, "-%c.%s%c%d", str[1], (char *)(str + 2), (radix <= 10) ? 'E' : '@', ep - 1); - else snprintf((char *)block_data(btmp), len + 64, "%c.%s%c%d", str[0], (char *)(str + 1), (radix <= 10) ? 'E' : '@', ep - 1); - - liberate(sc, b); - return(btmp); -} - -static block_t *mpc_to_string(s7_scheme *sc, mpc_t val, int32_t radix, use_write_t use_write) -{ - block_t *rl, *im, *tmp; - s7_int len; - - mpc_real(sc->mpfr_1, val, MPFR_RNDN); - rl = mpfr_to_string(sc, sc->mpfr_1, radix); - mpc_imag(sc->mpfr_2, val, MPFR_RNDN); - im = mpfr_to_string(sc, sc->mpfr_2, radix); - - len = safe_strlen((char *)block_data(rl)) + safe_strlen((char *)block_data(im)) + 128; - tmp = mallocate(sc, len); - snprintf((char *)block_data(tmp), len, "%s%s%si", - (char *)block_data(rl), - ((((char *)block_data(im))[0] == '-') || (((char *)block_data(im))[0] == '+')) ? "" : "+", (char *)block_data(im)); - - liberate(sc, rl); - liberate(sc, im); - return(tmp); -} - -static block_t *big_number_to_string_with_radix(s7_scheme *sc, s7_pointer p, int32_t radix, s7_int width, s7_int *nlen, use_write_t use_write) -{ - block_t *str; - switch (type(p)) - { - case T_BIG_INTEGER: - str = callocate(sc, mpz_sizeinbase(big_integer(p), radix) + 64); - mpz_get_str((char *)block_data(str), radix, big_integer(p)); - break; - case T_BIG_RATIO: - mpz_set(sc->mpz_1, mpq_numref(big_ratio(p))); - mpz_set(sc->mpz_2, mpq_denref(big_ratio(p))); - str = callocate(sc, mpz_sizeinbase(sc->mpz_1, radix) + mpz_sizeinbase(sc->mpz_2, radix) + 64); - mpq_get_str((char *)block_data(str), radix, big_ratio(p)); - break; - case T_BIG_REAL: - str = mpfr_to_string(sc, big_real(p), radix); - break; - default: - str = mpc_to_string(sc, big_complex(p), radix, use_write); - break; - } - if (width > 0) - { - s7_int len = safe_strlen((char *)block_data(str)); - if (width > len) - { - int32_t spaces = width - len; - block_t *tmp = (block_t *)mallocate(sc, width + 1); - ((char *)block_data(tmp))[width] = '\0'; - memmove((void *)((char *)block_data(tmp) + spaces), (void *)block_data(str), len); - local_memset((void *)block_data(tmp), (int)' ', spaces); - (*nlen) = width; - liberate(sc, str); - return(tmp); - } - (*nlen) = len; - } - else (*nlen) = safe_strlen((char *)block_data(str)); - return(str); -} - -static s7_pointer string_to_big_integer(s7_scheme *sc, const char *str, int32_t radix) -{ - mpz_set_str(sc->mpz_4, (str[0] == '+') ? (const char *)(str + 1) : str, radix); - return(mpz_to_integer(sc, sc->mpz_4)); -} - -static s7_pointer string_to_big_ratio(s7_scheme *sc, const char *str, int32_t radix) -{ - s7_pointer x; - mpq_set_str(sc->mpq_1, str, radix); - mpq_canonicalize(sc->mpq_1); - if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_set(big_ratio(x), sc->mpq_1); - return(x); -} - -static s7_pointer string_to_big_real(s7_scheme *sc, const char *str, int32_t radix) -{ - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpfr_set_str(big_real(x), str, radix, MPFR_RNDN); - return(x); -} - -static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow); - -static s7_pointer string_to_either_integer(s7_scheme *sc, const char *str, int32_t radix) -{ - bool overflow = false; - s7_int val = string_to_integer(str, radix, &overflow); - if (!overflow) - return(make_integer(sc, val)); - return(string_to_big_integer(sc, str, radix)); -} - -static s7_pointer string_to_either_ratio(s7_scheme *sc, const char *nstr, const char *dstr, int32_t radix) -{ - bool overflow = false; - /* gmp segfaults if passed a bignum/0 so this needs to check first that the denominator is not 0 before letting gmp screw up. - * Also, if the first character is '+', gmp returns 0! - */ - s7_int d = string_to_integer(dstr, radix, &overflow); - if (!overflow) - { - s7_int n; - if (d == 0) return(real_NaN); - n = string_to_integer(nstr, radix, &overflow); - if (!overflow) - return(make_ratio(sc, n, d)); - } - if (nstr[0] == '+') - return(string_to_big_ratio(sc, (const char *)(nstr + 1), radix)); - return(string_to_big_ratio(sc, nstr, radix)); -} - -static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix, bool *overflow); -static s7_pointer string_to_either_real(s7_scheme *sc, const char *str, int32_t radix) -{ - bool overflow = false; - s7_double val = string_to_double_with_radix((char *)str, radix, &overflow); - if (!overflow) return(make_real(sc, val)); - return(string_to_big_real(sc, str, radix)); -} - -static s7_pointer string_to_either_complex_1(s7_scheme *sc, char *q, char *slash1, char *ex1, bool has_dec_point1, int32_t radix, s7_double *d_rl) -{ - bool overflow = false; - /* there's a real problem here -- we don't want to promote s7_double .1 to a bignum because - * its low order digits are garbage, causing (rationalize .1 0) to return 3602879701896397/36028797018963968 - * no matter what the bignum-precision. But we can't just fallback on gmp's reader because (for example) - * it reads 1/2+i or 1+0/0i as 1.0. Also format gets screwed up. And string->number signals an error - * where it should return #f. I wonder what to do. - */ - if ((has_dec_point1) || - (ex1)) - { - (*d_rl) = string_to_double_with_radix(q, radix, &overflow); - if (overflow) return(string_to_big_real(sc, q, radix)); - } - else - { - if (slash1) - { - s7_int d, n = string_to_integer(q, radix, &overflow); /* q can include the slash and denominator */ - if (overflow) return(string_to_big_ratio(sc, q, radix)); - d = string_to_integer(slash1, radix, &overflow); - if (overflow) return(string_to_big_ratio(sc, q, radix)); - (*d_rl) = (s7_double)n / (s7_double)d; - } - else - { - s7_int val = string_to_integer(q, radix, &overflow); - if (overflow) return(string_to_big_integer(sc, q, radix)); - (*d_rl) = (s7_double)val; - }} - if ((*d_rl) == -0.0) (*d_rl) = 0.0; - return(NULL); -} - -static s7_pointer string_to_either_complex(s7_scheme *sc, char *q, char *slash1, char *ex1, bool has_dec_point1, - char *plus, char *slash2, char *ex2, bool has_dec_point2, - int32_t radix, int32_t has_plus_or_minus) -{ - /* this can be just about anything involving 2 real/ratio/int portions, +/- in between and 'i' at the end */ - double d_rl = 0.0, d_im = 0.0; - s7_pointer p_rl = string_to_either_complex_1(sc, q, slash1, ex1, has_dec_point1, radix, &d_rl); - s7_pointer p_im = string_to_either_complex_1(sc, plus, slash2, ex2, has_dec_point2, radix, &d_im); - - if ((d_im == 0.0) && /* 1.0+0.0000000000000000000000000000i */ - ((!p_im) || (is_zero(p_im)))) - return((p_rl) ? p_rl : make_real(sc, d_rl)); - - if ((!p_rl) && (!p_im)) - return(s7_make_complex(sc, d_rl, (has_plus_or_minus == -1) ? (-d_im) : d_im)); - - if (p_rl) - any_real_to_mpfr(sc, p_rl, sc->mpfr_1); - else mpfr_set_d(sc->mpfr_1, d_rl, MPFR_RNDN); - - if (p_im) - any_real_to_mpfr(sc, p_im, sc->mpfr_2); - else mpfr_set_d(sc->mpfr_2, d_im, MPFR_RNDN); - - if (has_plus_or_minus == -1) - mpfr_neg(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); - return(make_big_complex(sc, sc->mpfr_1, sc->mpfr_2)); -} - -static bool big_numbers_are_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - /* either or both can be big here, but not neither, and types might not match at all */ - switch (type(a)) - { - case T_INTEGER: - return((is_t_big_integer(b)) && (mpz_cmp_si(big_integer(b), integer(a)) == 0)); - case T_BIG_INTEGER: - if (is_t_big_integer(b)) return(mpz_cmp(big_integer(a), big_integer(b)) == 0); - return((is_t_integer(b)) && (mpz_cmp_si(big_integer(a), integer(b)) == 0)); - case T_RATIO: - if (!is_t_big_ratio(b)) return(false); - mpq_set_si(sc->mpq_1, numerator(a), denominator(a)); - return(mpq_equal(sc->mpq_1, big_ratio(b))); - case T_BIG_RATIO: - if (is_t_big_ratio(b)) return(mpq_equal(big_ratio(a), big_ratio(b))); - if (!is_t_ratio(b)) return(false); - mpq_set_si(sc->mpq_1, numerator(b), denominator(b)); - return(mpq_equal(sc->mpq_1, big_ratio(a))); - case T_REAL: - if (is_NaN(real(a))) return(false); - return((is_t_big_real(b)) && (!mpfr_nan_p(big_real(b))) && (mpfr_cmp_d(big_real(b), real(a)) == 0)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(a))) return(false); - if (is_t_big_real(b)) return((!mpfr_nan_p(big_real(b))) && (mpfr_equal_p(big_real(a), big_real(b)))); - return((is_t_real(b)) && (!is_NaN(real(b))) && (mpfr_cmp_d(big_real(a), real(b)) == 0)); - case T_COMPLEX: - if ((is_NaN(real_part(a))) || (is_NaN(imag_part(a)))) return(false); - if (!is_t_big_complex(b)) return(false); - if ((mpfr_nan_p(mpc_realref(big_complex(b)))) || (mpfr_nan_p(mpc_imagref(big_complex(b))))) - return(false); - mpc_set_d_d(sc->mpc_1, real_part(a), imag_part(a), MPC_RNDNN); - return(mpc_cmp(sc->mpc_1, big_complex(b)) == 0); - case T_BIG_COMPLEX: - if ((mpfr_nan_p(mpc_realref(big_complex(a)))) || (mpfr_nan_p(mpc_imagref(big_complex(a))))) - return(false); - if (is_t_big_complex(b)) - { - if ((mpfr_nan_p(mpc_realref(big_complex(b)))) || (mpfr_nan_p(mpc_imagref(big_complex(b))))) - return(false); - return(mpc_cmp(big_complex(a), big_complex(b)) == 0); - } - if (is_t_complex(b)) - { - if ((is_NaN(real_part(b))) || (is_NaN(imag_part(b)))) return(false); - mpc_set_d_d(sc->mpc_2, real_part(b), imag_part(b), MPC_RNDNN); - return(mpc_cmp(big_complex(a), sc->mpc_1) == 0); - }} - return(false); -} - -static s7_int big_integer_to_s7_int(s7_scheme *sc, mpz_t n) -{ - if (!mpz_fits_slong_p(n)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "bigint does not fit in s7_int: ~S", 33), mpz_to_big_integer(sc, n))); - return(mpz_get_si(n)); -} -#endif - -#ifndef HAVE_OVERFLOW_CHECKS - #if ((defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) || (defined(__GNUC__) && __GNUC__ >= 5)) - #define HAVE_OVERFLOW_CHECKS 1 - #else - #define HAVE_OVERFLOW_CHECKS 0 - #pragma message("no arithmetic overflow checks in this version of s7") - /* these are untested */ - static bool add_overflow(s7_int A, s7_int B, s7_int *C) {*C = A + B; return(false);} /* #define add_overflow(A, B, C) 0 */ - static bool subtract_overflow(s7_int A, s7_int B, s7_int *C) {*C = A - B; return(false);} /* #define subtract_overflow(A, B, C) 0 */ - static bool multiply_overflow(s7_int A, s7_int B, s7_int *C) {*C = A * B; return(false);} /* #define multiply_overflow(A, B, C) 0 */ - #endif -#endif - -#if (defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) - #define subtract_overflow(A, B, C) __builtin_ssubll_overflow((long long)A, (long long)B, (long long *)C) - #define add_overflow(A, B, C) __builtin_saddll_overflow((long long)A, (long long)B, (long long *)C) - #define multiply_overflow(A, B, C) __builtin_smulll_overflow((long long)A, (long long)B, (long long *)C) - #define int32_add_overflow(A, B, C) __builtin_sadd_overflow(A, B, C) - #define int32_multiply_overflow(A, B, C) __builtin_smul_overflow(A, B, C) -#else -#if (defined(__GNUC__) && __GNUC__ >= 5) - #define subtract_overflow(A, B, C) __builtin_sub_overflow(A, B, C) - #define add_overflow(A, B, C) __builtin_add_overflow(A, B, C) - #define multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C) - #define int32_add_overflow(A, B, C) __builtin_add_overflow(A, B, C) - #define int32_multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C) -#endif -#endif - -#if WITH_GCC -#define s7_int_abs(x) ({s7_int _X_; _X_ = x; _X_ >= 0 ? _X_ : -_X_;}) -#else -#define s7_int_abs(x) ((x) >= 0 ? (x) : -(x)) -#endif -/* can't use abs even in gcc -- it doesn't work with int64_ts! */ - -#if (!__NetBSD__) - #define s7_fabsl(X) fabsl(X) -#else - static double s7_fabsl(long_double x) {return((signbit(x)) ? -x : x);} -#endif - -/* for g_log, we also need round. this version is from stackoverflow, see also r5rs_round below */ -double s7_round(double number) {return((number < 0.0) ? ceil(number - 0.5) : floor(number + 0.5));} - -#if HAVE_COMPLEX_NUMBERS -#if __cplusplus - #define _Complex_I (complex(0.0, 1.0)) - #define creal(x) Real(x) - #define cimag(x) Imag(x) - #define carg(x) arg(x) - #define cabs(x) abs(x) - #define csqrt(x) sqrt(x) - #define cpow(x, y) pow(x, y) - #define clog(x) log(x) - #define cexp(x) exp(x) - #define csin(x) sin(x) - #define ccos(x) cos(x) - #define ctan(x) tan(x) - #define csinh(x) sinh(x) - #define ccosh(x) cosh(x) - #define ctanh(x) tanh(x) - #define casin(x) asin(x) - #define cacos(x) acos(x) - #define catan(x) atan(x) - #define casinh(x) asinh(x) - #define cacosh(x) acosh(x) - #define catanh(x) atanh(x) -#else - typedef double complex s7_complex; -#endif - - -#if (!HAVE_COMPLEX_TRIG) -#if (__cplusplus) - - static s7_complex ctan(s7_complex z) {return(csin(z) / ccos(z));} - static s7_complex ctanh(s7_complex z) {return(csinh(z) / ccosh(z));} - static s7_complex casin(s7_complex z) {return(-_Complex_I * clog(_Complex_I * z + csqrt(1.0 - z * z)));} - static s7_complex cacos(s7_complex z) {return(-_Complex_I * clog(z + _Complex_I * csqrt(1.0 - z * z)));} - static s7_complex catan(s7_complex z) {return(_Complex_I * clog((_Complex_I + z) / (_Complex_I - z)) / 2.0);} - static s7_complex casinh(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));} - static s7_complex cacosh(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));} - static s7_complex catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);} -#else - -#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 12) -static s7_complex clog(s7_complex z) {return(log(fabs(cabs(z))) + carg(z) * _Complex_I);} -static s7_complex cpow(s7_complex x, s7_complex y) -{ - s7_double r = cabs(x); - s7_double theta = carg(x); - s7_double yre = creal(y); - s7_double yim = cimag(y); - s7_double nr = exp(yre * log(r) - yim * theta); - s7_double ntheta = yre * theta + yim * log(r); - return(nr * cos(ntheta) + (nr * sin(ntheta)) * _Complex_I); -} -#endif -#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 9) /* untested -- this orignally looked at __FreeBSD_version which apparently no longer exists */ - static s7_complex cexp(s7_complex z) {return(exp(creal(z)) * cos(cimag(z)) + (exp(creal(z)) * sin(cimag(z))) * _Complex_I);} -#endif - -#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 10) - static s7_complex csin(s7_complex z) {return(sin(creal(z)) * cosh(cimag(z)) + (cos(creal(z)) * sinh(cimag(z))) * _Complex_I);} - static s7_complex ccos(s7_complex z) {return(cos(creal(z)) * cosh(cimag(z)) + (-sin(creal(z)) * sinh(cimag(z))) * _Complex_I);} - static s7_complex csinh(s7_complex z) {return(sinh(creal(z)) * cos(cimag(z)) + (cosh(creal(z)) * sin(cimag(z))) * _Complex_I);} - static s7_complex ccosh(s7_complex z) {return(cosh(creal(z)) * cos(cimag(z)) + (sinh(creal(z)) * sin(cimag(z))) * _Complex_I);} - static s7_complex ctan(s7_complex z) {return(csin(z) / ccos(z));} - static s7_complex ctanh(s7_complex z) {return(csinh(z) / ccosh(z));} - static s7_complex casin(s7_complex z) {return(-_Complex_I * clog(_Complex_I * z + csqrt(1.0 - z * z)));} - static s7_complex cacos(s7_complex z) {return(-_Complex_I * clog(z + _Complex_I * csqrt(1.0 - z * z)));} - static s7_complex catan(s7_complex z) {return(_Complex_I * clog((_Complex_I + z) / (_Complex_I - z)) / 2.0);} - static s7_complex catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);} - static s7_complex casinh(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));} - static s7_complex cacosh(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));} -#endif /* not FreeBSD 10 */ -#endif /* not c++ */ -#endif /* not HAVE_COMPLEX_TRIG */ - -#else /* not HAVE_COMPLEX_NUMBERS */ - typedef double s7_complex; - #define _Complex_I 1 - #define creal(x) x - #define cimag(x) x - #define csin(x) sin(x) - #define casin(x) x - #define ccos(x) cos(x) - #define cacos(x) x - #define ctan(x) x - #define catan(x) x - #define csinh(x) x - #define casinh(x) x - #define ccosh(x) x - #define cacosh(x) x - #define ctanh(x) x - #define catanh(x) x - #define cexp(x) exp(x) - #define cpow(x, y) pow(x, y) - #define clog(x) log(x) - #define csqrt(x) sqrt(x) - #define conj(x) x -#endif - -#ifdef __OpenBSD__ - /* openbsd's builtin versions of these functions are not usable */ - static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);} - static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));} - static s7_complex cacosh_1(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));} -#endif -#ifdef __NetBSD__ - static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);} - static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));} -#endif - - -bool s7_is_number(s7_pointer p) {return(is_number(p));} -bool s7_is_complex(s7_pointer p) {return(is_number(p));} -bool s7_is_real(s7_pointer p) {return(is_real(p));} -bool s7_is_rational(s7_pointer p) {return(is_rational(p));} - -bool s7_is_integer(s7_pointer p) -{ -#if WITH_GMP - return((is_t_integer(p)) || (is_t_big_integer(p))); -#else - return(is_t_integer(p)); -#endif -} - -bool s7_is_ratio(s7_pointer p) -{ -#if WITH_GMP - return((is_t_ratio(p)) || (is_t_big_ratio(p))); -#else - return(is_t_ratio(p)); -#endif -} - -static s7_int c_gcd(s7_int u, s7_int v) -{ - s7_int a, b; - if ((u == s7_int_min) || (v == s7_int_min)) - { - /* can't take abs of these (below) so do it by hand */ - s7_int divisor = 1; - if (u == v) return(u); - while (((u & 1) == 0) && ((v & 1) == 0)) - { - u /= 2; - v /= 2; - divisor *= 2; - } - return(divisor); - } - a = s7_int_abs(u); - b = s7_int_abs(v); - /* there are faster gcd algorithms but does it ever matter? */ - while (b != 0) - { - s7_int temp = a % b; - a = b; - b = temp; - } - return(a); -} - -#define RATIONALIZE_LIMIT 1.0e12 - -static bool c_rationalize(s7_double ux, s7_double error, s7_int *numer, s7_int *denom) -{ - /* from CL code in Canny, Donald, Ressler, "A Rational Rotation Method for Robust Geometric Algorithms" */ - double x0, x1; - s7_int i, p0, q0 = 1, p1, q1 = 1; - double e0, e1, e0p, e1p; - int32_t tries = 0; - /* don't use long_double: the loop below will hang */ - - /* #e1e19 is a killer -- it's bigger than most-positive-fixnum, but if we ceil(ux) below - * it turns into most-negative-fixnum. 1e19 is trouble in many places. - */ - if (fabs(ux) > RATIONALIZE_LIMIT) - { - /* (rationalize most-positive-fixnum) should not return most-negative-fixnum - * but any number > 1e14 here is so inaccurate that rationalize is useless - * for example, - * default: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 1185866354261165/4 - * gmp: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 9223372036854775807/31111 - * can't return false here because that confuses some of the callers! - */ - (*numer) = (s7_int)ux; - (*denom) = 1; - return(true); - } - - if (error < 0.0) error = -error; - x0 = ux - error; - x1 = ux + error; - i = (s7_int)ceil(x0); - - if (error >= 1.0) /* aw good grief! */ - { - if (x0 < 0.0) - (*numer) = (x1 < 0.0) ? (s7_int)floor(x1) : 0; - else (*numer) = i; - (*denom) = 1; - return(true); - } - if (x1 >= i) - { - (*numer) = (i >= 0) ? i : (s7_int)floor(x1); - (*denom) = 1; - return(true); - } - - p0 = (s7_int)floor(x0); - p1 = (s7_int)ceil(x1); - e0 = p1 - x0; - e1 = x0 - p0; - e0p = p1 - x1; - e1p = x1 - p0; - while (true) - { - s7_int old_p1, old_q1; - double old_e0, old_e1, old_e0p, r, r1; - double val = (double)p0 / (double)q0; - - if (((x0 <= val) && (val <= x1)) || (e1 == 0.0) || (e1p == 0.0) || (tries > 100)) - { - if ((q0 == s7_int_min) && (p0 == 1)) /* (rationalize 1.000000004297917e-12) when error is 1e-12 */ - { - (*numer) = 0; - (*denom) = 1; - } - else - { - (*numer) = p0; - (*denom) = q0; - if ((S7_DEBUGGING) && (q0 == 0)) fprintf(stderr, "%f %" ld64 "/0\n", ux, p0); - } - return(true); - } - tries++; - r = (s7_int)floor(e0 / e1); - r1 = (s7_int)ceil(e0p / e1p); - if (r1 < r) r = r1; - /* do handles all step vars in parallel */ - old_p1 = p1; - p1 = p0; - old_q1 = q1; - q1 = q0; - old_e0 = e0; - e0 = e1p; - old_e0p = e0p; - e0p = e1; - old_e1 = e1; - p0 = old_p1 + r * p0; - q0 = old_q1 + r * q0; - e1 = old_e0p - r * e1p; /* if the error is set too low, we can get e1 = 0 here: (rationalize (/ pi) 1e-17) */ - e1p = old_e0 - r * old_e1; - } - return(false); -} - -s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error) -{ - s7_int numer = 0, denom = 1; - if (c_rationalize(x, error, &numer, &denom)) - return(make_ratio(sc, numer, denom)); - return(make_real(sc, x)); -} - -s7_pointer s7_make_integer(s7_scheme *sc, s7_int n) -{ - s7_pointer x; - if (is_small_int(n)) - return(small_int(n)); - new_cell(sc, x, T_INTEGER); - integer(x) = n; - return(x); -} - -static s7_pointer make_mutable_integer(s7_scheme *sc, s7_int n) -{ - s7_pointer x; - new_cell(sc, x, T_INTEGER | T_MUTABLE | T_IMMUTABLE); - integer(x) = n; - return(x); -} - -s7_pointer s7_make_real(s7_scheme *sc, s7_double n) -{ - s7_pointer x; - new_cell(sc, x, T_REAL); - set_real(x, n); - return(x); -} - -s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n) -{ - s7_pointer x; - new_cell(sc, x, T_REAL | T_MUTABLE | T_IMMUTABLE); - set_real(x, n); - return(x); -} - -s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b) -{ - s7_pointer x; - if (b == 0.0) - { - new_cell(sc, x, T_REAL); - set_real(x, a); - } - else - { - new_cell(sc, x, T_COMPLEX); - set_real_part(x, a); - set_imag_part(x, b); - } - return(x); -} - -static s7_complex s7_to_c_complex(s7_pointer p) -{ -#if HAVE_COMPLEX_NUMBERS - return(CMPLX(s7_real_part(p), s7_imag_part(p))); -#else - return(0.0); -#endif -} - -static inline s7_pointer c_complex_to_s7(s7_scheme *sc, s7_complex z) {return(make_complex(sc, creal(z), cimag(z)));} - -static noreturn void division_by_zero_error_1_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x) -{ - error_nr(sc, sc->division_by_zero_symbol, - set_elist_4(sc, wrap_string(sc, "~A: division by zero, (~A ~S)", 29), caller, caller, x)); -} - -static noreturn void division_by_zero_error_2_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x, s7_pointer y) -{ - error_nr(sc, sc->division_by_zero_symbol, - set_elist_5(sc, wrap_string(sc, "~A: division by zero, (~A ~S ~S)", 32), caller, caller, x, y)); -} - -static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b) -{ - s7_pointer x; - if (b == s7_int_min) - { - /* This should not trigger an error during reading -- we might have the - * ratio on a switch with-bignums or whatever, so its mere occurrence is just an annoyance. - */ - if (a & 1) - return(make_real(sc, (long_double)a / (long_double)b)); - a /= 2; - b /= 2; - } - if (b < 0) - { - a = -a; - b = -b; - } - if (a == s7_int_min) - { - while (((a & 1) == 0) && ((b & 1) == 0)) - { - a /= 2; - b /= 2; - }} - else - { - s7_int b1 = b, divisor = s7_int_abs(a); - do { - s7_int temp = divisor % b1; - divisor = b1; - b1 = temp; - } while (b1 != 0); - if (divisor != 1) - { - a /= divisor; - b /= divisor; - }} - if (b == 1) - return(make_integer(sc, a)); - - new_cell(sc, x, T_RATIO); - numerator(x) = a; - denominator(x) = b; - return(x); -} - -/* using "make-ratio" here is a desperate kludge trying to maintain backwards compatibility; internally we use make_ratio_with_div_check below */ -s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b) -{ - if (b == 0) - division_by_zero_error_2_nr(sc, wrap_string(sc, "make-ratio", 10), wrap_integer(sc, a), int_zero); - return(make_ratio(sc, a, b)); -} - -static s7_pointer make_ratio_with_div_check(s7_scheme *sc, s7_pointer caller, s7_int a, s7_int b) -{ - if (b == 0) - division_by_zero_error_2_nr(sc, caller, wrap_integer(sc, a), int_zero); - return(make_ratio(sc, a, b)); -} - - -#define WITH_OVERFLOW_ERROR true -#define WITHOUT_OVERFLOW_ERROR false - -#define INT64_TO_DOUBLE_LIMIT (1LL << 53) -#define DOUBLE_TO_INT64_LIMIT (1LL << 53) - -/* 9007199254740991LL is where a truncated double starts to skip integers (expt 2 53) = ca 1e16 - * (ceiling (+ 1e16 1)) -> 10000000000000000 - * (> 9007199254740993.0 9007199254740992.0) -> #f ; in non-gmp 64-bit doubles - * but we can't fix this except in the gmp case because: - * (integer-decode-float (+ (expt 2.0 62) 100)) -> (4503599627370496 10 1) - * (integer-decode-float (+ (expt 2.0 62) 500)) -> (4503599627370496 10 1) - * (> (+ (expt 2.0 62) 500) (+ (expt 2.0 62) 100)) -> #f ; non-gmp again - * i.e. the bits are identical. We can't even detect when it has happened (without tedious effort), so should - * we just give an error for any floor (or whatever) of an arg>1e16? (sin has a similar problem)? - * I think in the non-gmp case I'll throw an error in these cases because the results are bogus: - * (floor (+ (expt 2.0 62) 512)) -> 4611686018427387904 - * (floor (+ (expt 2.0 62) 513)) -> 4611686018427388928 - * another case at the edge: (round 9007199254740992.51) -> 9007199254740992 - * This spells trouble for normal arithmetic in this range. If no gmp, - * (- (+ (expt 2.0 62) 512) (+ (expt 2.0 62) 513)) = -1024.0 (should be -1.0) - * but we don't currently give an error in this case -- not sure what the right thing is. - */ - -s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller) -{ - if (is_t_real(x)) return(real(x)); - switch (type(x)) - { - case T_INTEGER: return((s7_double)integer(x)); - case T_RATIO: return(fraction(x)); -#if WITH_GMP - case T_BIG_INTEGER: return((s7_double)big_integer_to_s7_int(sc, big_integer(x))); - case T_BIG_RATIO: return((s7_double)((long_double)big_integer_to_s7_int(sc, mpq_numref(big_ratio(x))) / - (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x))))); - case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); -#endif - default: - sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_REAL]); - } - return(0.0); -} - -s7_double s7_number_to_real_with_location(s7_scheme *sc, s7_pointer x, s7_pointer caller) -{ - if (is_t_real(x)) return(real(x)); - switch (type(x)) - { - case T_INTEGER: return((s7_double)integer(x)); - case T_RATIO: return(fraction(x)); -#if WITH_GMP - case T_BIG_INTEGER: return((s7_double)big_integer_to_s7_int(sc, big_integer(x))); - case T_BIG_RATIO: return((s7_double)((long_double)big_integer_to_s7_int(sc, mpq_numref(big_ratio(x))) / - (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x))))); - case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); -#endif - default: - sole_arg_wrong_type_error_nr(sc, caller, x, sc->type_names[T_REAL]); - } - return(0.0); -} - -s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x) {return(s7_number_to_real_with_location(sc, x, sc->number_to_real_symbol));} - -s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller) -{ - if (is_t_integer(x)) return(integer(x)); -#if WITH_GMP - if (is_t_big_integer(x)) return(big_integer_to_s7_int(sc, big_integer(x))); -#endif - sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_INTEGER]); - return(0); -} - -s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x) {return(s7_number_to_integer_with_caller(sc, x, "s7_number_to_integer"));} - -s7_int s7_numerator(s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x)); - case T_RATIO: return(numerator(x)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_get_si(big_integer(x))); /* big_integer_to_s7_int but no sc -- no error if out of range */ - case T_BIG_RATIO: return(mpz_get_si(mpq_numref(big_ratio(x)))); -#endif - } - return(0); -} - -s7_int s7_denominator(s7_pointer x) -{ - if (is_t_ratio(x)) return(denominator(x)); -#if WITH_GMP - if (is_t_big_ratio(x)) return(mpz_get_si(mpq_denref(big_ratio(x)))); -#endif - return(1); -} - -s7_int s7_integer(s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p)); -#if WITH_GMP - if (is_t_big_integer(p)) return(mpz_get_si(big_integer(p))); -#endif - return(0); -} - -s7_double s7_real(s7_pointer x) -{ - if (is_t_real(x)) return(real(x)); - switch (type(x)) - { - case T_RATIO: return(fraction(x)); - case T_INTEGER: return((s7_double)integer(x)); -#if WITH_GMP - case T_BIG_INTEGER: return((s7_double)mpz_get_si(big_integer(x))); - case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); - case T_BIG_RATIO: - { - s7_double result; - mpfr_t bx; - mpfr_init2(bx, DEFAULT_BIGNUM_PRECISION); - mpfr_set_q(bx, big_ratio(x), MPFR_RNDN); - result = mpfr_get_d(bx, MPFR_RNDN); - mpfr_clear(bx); - return(result); - } -#endif - } - return(0.0); -} - -static bool is_one(s7_pointer x) -{ - return(((is_t_integer(x)) && (integer(x) == 1)) || - ((is_t_real(x)) && (real(x) == 1.0))); -} - - -/* -------- optimize exponents -------- */ - -#define MAX_POW 64 -static double **pepow = NULL; /* [17][MAX_POW * 2]; */ - -static void init_pows(void) -{ - pepow = (double **)Malloc(17 * sizeof(double *)); - pepow[0] = NULL; - pepow[1] = NULL; - for (int32_t i = 2; i < 17; i++) pepow[i] = (double *)Malloc((MAX_POW * 2) * sizeof(double)); - for (int32_t i = 2; i < 17; i++) /* radix between 2 and 16 */ - for (int32_t j = -MAX_POW; j < MAX_POW; j++) /* saved exponent between 0 and +/- MAX_POW */ - pepow[i][j + MAX_POW] = pow((double)i, (double)j); -} - -static inline double dpow(int32_t x, int32_t y) -{ - if ((y >= MAX_POW) || (y < -MAX_POW)) /* this can happen (once in a blue moon) */ - return(pow((double)x, (double)y)); - return(pepow[x][y + MAX_POW]); -} - - -/* -------------------------------- number->string -------------------------------- */ -#define WITH_DTOA 1 -#if WITH_DTOA -/* fpconv, revised to fit the local coding style - - The MIT License - -Copyright (c) 2013 Andreas Samoljuk - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be -included in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE -LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION -OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION -WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -*/ - -#define dtoa_npowers 87 -#define dtoa_steppowers 8 -#define dtoa_firstpower -348 /* 10 ^ -348 */ -#define dtoa_expmax -32 -#define dtoa_expmin -60 - -typedef struct dtoa_np {uint64_t frac; int32_t exp;} dtoa_np; - -static const dtoa_np dtoa_powers_ten[] = { - { 18054884314459144840U, -1220 }, { 13451937075301367670U, -1193 }, { 10022474136428063862U, -1166 }, { 14934650266808366570U, -1140 }, - { 11127181549972568877U, -1113 }, { 16580792590934885855U, -1087 }, { 12353653155963782858U, -1060 }, { 18408377700990114895U, -1034 }, - { 13715310171984221708U, -1007 }, { 10218702384817765436U, -980 }, { 15227053142812498563U, -954 }, { 11345038669416679861U, -927 }, - { 16905424996341287883U, -901 }, { 12595523146049147757U, -874 }, { 9384396036005875287U, -847 }, { 13983839803942852151U, -821 }, - { 10418772551374772303U, -794 }, { 15525180923007089351U, -768 }, { 11567161174868858868U, -741 }, { 17236413322193710309U, -715 }, - { 12842128665889583758U, -688 }, { 9568131466127621947U, -661 }, { 14257626930069360058U, -635 }, { 10622759856335341974U, -608 }, - { 15829145694278690180U, -582 }, { 11793632577567316726U, -555 }, { 17573882009934360870U, -529 }, { 13093562431584567480U, -502 }, - { 9755464219737475723U, -475 }, { 14536774485912137811U, -449 }, { 10830740992659433045U, -422 }, { 16139061738043178685U, -396 }, - { 12024538023802026127U, -369 }, { 17917957937422433684U, -343 }, { 13349918974505688015U, -316 }, { 9946464728195732843U, -289 }, - { 14821387422376473014U, -263 }, { 11042794154864902060U, -236 }, { 16455045573212060422U, -210 }, { 12259964326927110867U, -183 }, - { 18268770466636286478U, -157 }, { 13611294676837538539U, -130 }, { 10141204801825835212U, -103 }, { 15111572745182864684U, -77 }, - { 11258999068426240000U, -50 }, { 16777216000000000000U, -24 }, { 12500000000000000000U, 3 }, { 9313225746154785156U, 30 }, - { 13877787807814456755U, 56 }, { 10339757656912845936U, 83 }, { 15407439555097886824U, 109 }, { 11479437019748901445U, 136 }, - { 17105694144590052135U, 162 }, { 12744735289059618216U, 189 }, { 9495567745759798747U, 216 }, { 14149498560666738074U, 242 }, - { 10542197943230523224U, 269 }, { 15709099088952724970U, 295 }, { 11704190886730495818U, 322 }, { 17440603504673385349U, 348 }, - { 12994262207056124023U, 375 }, { 9681479787123295682U, 402 }, { 14426529090290212157U, 428 }, { 10748601772107342003U, 455 }, - { 16016664761464807395U, 481 }, { 11933345169920330789U, 508 }, { 17782069995880619868U, 534 }, { 13248674568444952270U, 561 }, - { 9871031767461413346U, 588 }, { 14708983551653345445U, 614 }, { 10959046745042015199U, 641 }, { 16330252207878254650U, 667 }, - { 12166986024289022870U, 694 }, { 18130221999122236476U, 720 }, { 13508068024458167312U, 747 }, { 10064294952495520794U, 774 }, - { 14996968138956309548U, 800 }, { 11173611982879273257U, 827 }, { 16649979327439178909U, 853 }, { 12405201291620119593U, 880 }, - { 9242595204427927429U, 907 }, { 13772540099066387757U, 933 }, { 10261342003245940623U, 960 }, { 15290591125556738113U, 986 }, - { 11392378155556871081U, 1013 }, { 16975966327722178521U, 1039 }, - { 12648080533535911531U, 1066 }}; - -static dtoa_np dtoa_find_cachedpow10(int exp, int* k) -{ - const double one_log_ten = 0.30102999566398114; - int32_t approx = -(exp + dtoa_npowers) * one_log_ten; - int32_t idx = (approx - dtoa_firstpower) / dtoa_steppowers; - while (true) - { - int32_t current = exp + dtoa_powers_ten[idx].exp + 64; - if (current < dtoa_expmin) - { - idx++; - continue; - } - if (current > dtoa_expmax) - { - idx--; - continue; - } - *k = (dtoa_firstpower + idx * dtoa_steppowers); - return(dtoa_powers_ten[idx]); - } -} - -#define dtoa_fracmask 0x000FFFFFFFFFFFFFU -#define dtoa_expmask 0x7FF0000000000000U -#define dtoa_hiddenbit 0x0010000000000000U -#define dtoa_signmask 0x8000000000000000U -#define dtoa_expbias (1023 + 52) -#define dtoa_absv(n) ((n) < 0 ? -(n) : (n)) -#define dtoa_minv(a, b) ((a) < (b) ? (a) : (b)) - -static uint64_t dtoa_tens[] = - { 10000000000000000000U, 1000000000000000000U, 100000000000000000U, - 10000000000000000U, 1000000000000000U, 100000000000000U, - 10000000000000U, 1000000000000U, 100000000000U, - 10000000000U, 1000000000U, 100000000U, - 10000000U, 1000000U, 100000U, - 10000U, 1000U, 100U, - 10U, 1U}; - -static uint64_t dtoa_get_dbits(double d) -{ - union {double dbl; uint64_t i;} dbl_bits = {d}; - return(dbl_bits.i); -} - -static dtoa_np dtoa_build_np(double d) -{ - uint64_t bits = dtoa_get_dbits(d); - dtoa_np fp; - fp.frac = bits & dtoa_fracmask; - fp.exp = (bits & dtoa_expmask) >> 52; - if (fp.exp) - { - fp.frac += dtoa_hiddenbit; - fp.exp -= dtoa_expbias; - } - else fp.exp = -dtoa_expbias + 1; - return(fp); -} - -static void dtoa_normalize(dtoa_np* fp) -{ - int32_t shift = 64 - 52 - 1; - while ((fp->frac & dtoa_hiddenbit) == 0) - { - fp->frac <<= 1; - fp->exp--; - } - fp->frac <<= shift; - fp->exp -= shift; -} - -static void dtoa_get_normalized_boundaries(dtoa_np* fp, dtoa_np* lower, dtoa_np* upper) -{ - int32_t u_shift, l_shift; - upper->frac = (fp->frac << 1) + 1; - upper->exp = fp->exp - 1; - while ((upper->frac & (dtoa_hiddenbit << 1)) == 0) - { - upper->frac <<= 1; - upper->exp--; - } - u_shift = 64 - 52 - 2; - upper->frac <<= u_shift; - upper->exp = upper->exp - u_shift; - l_shift = fp->frac == dtoa_hiddenbit ? 2 : 1; - lower->frac = (fp->frac << l_shift) - 1; - lower->exp = fp->exp - l_shift; - lower->frac <<= lower->exp - upper->exp; - lower->exp = upper->exp; -} - -static dtoa_np dtoa_multiply(dtoa_np* a, dtoa_np* b) -{ - dtoa_np fp; - const uint64_t lomask = 0x00000000FFFFFFFF; - uint64_t ah_bl = (a->frac >> 32) * (b->frac & lomask); - uint64_t al_bh = (a->frac & lomask) * (b->frac >> 32); - uint64_t al_bl = (a->frac & lomask) * (b->frac & lomask); - uint64_t ah_bh = (a->frac >> 32) * (b->frac >> 32); - uint64_t tmp = (ah_bl & lomask) + (al_bh & lomask) + (al_bl >> 32); - /* round up */ - tmp += 1U << 31; - fp.frac = ah_bh + (ah_bl >> 32) + (al_bh >> 32) + (tmp >> 32); - fp.exp = a->exp + b->exp + 64; - return(fp); -} - -static void dtoa_round_digit(char* digits, int32_t ndigits, uint64_t delta, uint64_t rem, uint64_t kappa, uint64_t frac) -{ - while ((rem < frac) && (delta - rem >= kappa) && - ((rem + kappa < frac) || (frac - rem > rem + kappa - frac))) - { - digits[ndigits - 1]--; - rem += kappa; - } -} - -static int32_t dtoa_generate_digits(dtoa_np* fp, dtoa_np* upper, dtoa_np* lower, char* digits, int* K) -{ - uint64_t part1, part2, wfrac = upper->frac - fp->frac, delta = upper->frac - lower->frac; - uint64_t *unit; - int32_t idx = 0, kappa = 10; - dtoa_np one; - - one.frac = 1ULL << -upper->exp; - one.exp = upper->exp; - part1 = upper->frac >> -one.exp; - part2 = upper->frac & (one.frac - 1); - - /* 1000000000 */ - for (uint64_t *divp = dtoa_tens + 10; kappa > 0; divp++) - { - uint64_t tmp, div = *divp; - unsigned digit = part1 / div; - if (digit || idx) - digits[idx++] = digit + '0'; - part1 -= digit * div; - kappa--; - tmp = (part1 << -one.exp) + part2; - if (tmp <= delta) - { - *K += kappa; - dtoa_round_digit(digits, idx, delta, tmp, div << -one.exp, wfrac); - return(idx); - }} - - /* 10 */ - unit = dtoa_tens + 18; - while(true) - { - unsigned digit; - part2 *= 10; - delta *= 10; - kappa--; - digit = part2 >> -one.exp; - if (digit || idx) - digits[idx++] = digit + '0'; - part2 &= one.frac - 1; - if (part2 < delta) - { - *K += kappa; - dtoa_round_digit(digits, idx, delta, part2, one.frac, wfrac * *unit); - return(idx); - } - unit--; - } -} - -static int32_t dtoa_grisu2(double d, char* digits, int* K) -{ - int32_t k; - dtoa_np cp, lower, upper; - dtoa_np w = dtoa_build_np(d); - dtoa_get_normalized_boundaries(&w, &lower, &upper); - dtoa_normalize(&w); - cp = dtoa_find_cachedpow10(upper.exp, &k); - w = dtoa_multiply(&w, &cp); - upper = dtoa_multiply(&upper, &cp); - lower = dtoa_multiply(&lower, &cp); - lower.frac++; - upper.frac--; - *K = -k; - return(dtoa_generate_digits(&w, &upper, &lower, digits, K)); -} - -static int32_t dtoa_emit_digits(char* digits, int32_t ndigits, char* dest, int32_t K, bool neg) -{ - int32_t idx, cent; - char sign; - int32_t exp = dtoa_absv(K + ndigits - 1); - - /* write plain integer */ - if ((K >= 0) && (exp < (ndigits + 7))) - { - memcpy(dest, digits, ndigits); - local_memset(dest + ndigits, '0', K); - dest[ndigits + K] = '.'; - dest[ndigits + K + 1] = '0'; - return(ndigits + K + 2); - } - - /* write decimal w/o scientific notation */ - if ((K < 0) && (K > -7 || exp < 4)) - { - int32_t offset = ndigits - dtoa_absv(K); - /* fp < 1.0 -> write leading zero */ - if (offset <= 0) - { - offset = -offset; - dest[0] = '0'; - dest[1] = '.'; - local_memset(dest + 2, '0', offset); - memcpy(dest + offset + 2, digits, ndigits); - return(ndigits + 2 + offset); - /* fp > 1.0 */ - } - else - { - memcpy(dest, digits, offset); - dest[offset] = '.'; - memcpy(dest + offset + 1, digits + offset, ndigits - offset); - return(ndigits + 1); - }} - - /* write decimal w/ scientific notation */ - ndigits = dtoa_minv(ndigits, 18 - neg); - idx = 0; - dest[idx++] = digits[0]; - if (ndigits > 1) - { - dest[idx++] = '.'; - memcpy(dest + idx, digits + 1, ndigits - 1); - idx += ndigits - 1; - } - dest[idx++] = 'e'; - sign = K + ndigits - 1 < 0 ? '-' : '+'; - dest[idx++] = sign; - cent = 0; - if (exp > 99) - { - cent = exp / 100; - dest[idx++] = cent + '0'; - exp -= cent * 100; - } - if (exp > 9) - { - int32_t dec = exp / 10; - dest[idx++] = dec + '0'; - exp -= dec * 10; - } - else - if (cent) - dest[idx++] = '0'; - - dest[idx++] = exp % 10 + '0'; - return(idx); -} - -static int32_t dtoa_filter_special(double fp, char* dest, bool neg) -{ - uint64_t bits; - bool nan; - if (fp == 0.0) - { - dest[0] = '0'; dest[1] = '.'; dest[2] = '0'; - return(3); - } - bits = dtoa_get_dbits(fp); - nan = (bits & dtoa_expmask) == dtoa_expmask; - if (!nan) return(0); - - if (!neg) - { - dest[0] = '+'; /* else 1.0-nan...? */ - dest++; - } - if (bits & dtoa_fracmask) - { - s7_int payload = nan_payload(fp); - size_t len; - len = snprintf(dest, 22, "nan.%" ld64, payload); - /* dest[0] = 'n'; dest[1] = 'a'; dest[2] = 'n'; dest[3] = '.'; dest[4] = '0'; */ - return((neg) ? len : len + 1); - } - dest[0] = 'i'; dest[1] = 'n'; dest[2] = 'f'; dest[3] = '.'; dest[4] = '0'; - return((neg) ? 5 : 6); -} - -static inline int32_t fpconv_dtoa(double d, char dest[24]) -{ - char digit[23]; - int32_t str_len = 0, spec, K, ndigits; - bool neg = false; - - if (dtoa_get_dbits(d) & dtoa_signmask) - { - dest[0] = '-'; - str_len++; - neg = true; - } - spec = dtoa_filter_special(d, dest + str_len, neg); - if (spec) return(str_len + spec); - K = 0; - ndigits = dtoa_grisu2(d, digit, &K); - str_len += dtoa_emit_digits(digit, ndigits, dest + str_len, K, neg); - return(str_len); -} -#endif - - -/* -------------------------------- number->string -------------------------------- */ -static const char dignum[] = "0123456789abcdef"; - -static size_t integer_to_string_any_base(char *p, s7_int n, int32_t radix) /* called by number_to_string_with_radix */ -{ - s7_int i, len, end; - bool sign; - s7_int pown; - - if ((radix < 2) || (radix > 16)) - return(0); - - if (n == S7_INT64_MIN) /* can't negate this, so do it by hand */ - { - static const char *mnfs[17] = {"","", - "-1000000000000000000000000000000000000000000000000000000000000000", "-2021110011022210012102010021220101220222", - "-20000000000000000000000000000000", "-1104332401304422434310311213", "-1540241003031030222122212", - "-22341010611245052052301", "-1000000000000000000000", "-67404283172107811828", "-9223372036854775808", - "-1728002635214590698", "-41a792678515120368", "-10b269549075433c38", "-4340724c6c71dc7a8", "-160e2ad3246366808", "-8000000000000000"}; - - len = safe_strlen(mnfs[radix]); - memcpy((void *)p, (void *)mnfs[radix], len); - p[len] = '\0'; - return(len); - } - - sign = (n < 0); - if (sign) n = -n; - - /* the previous version that counted up to n, rather than dividing down below n, as here, - * could be confused by large ints on 64 bit machines - */ - pown = n; - for (i = 1; i < 100; i++) - { - if (pown < radix) - break; - pown /= (s7_int)radix; - } - len = i - 1; - if (sign) len++; - end = 0; - if (sign) - { - p[0] = '-'; - end++; - } - for (i = len; i >= end; i--) - { - p[i] = dignum[n % radix]; - n /= radix; - } - p[len + 1] = '\0'; - return(len + 1); -} - -static char *integer_to_string(s7_scheme *sc, s7_int num, s7_int *nlen) /* do not free the returned string */ -{ - char *p, *op; - bool sign; - - if (num == S7_INT64_MIN) - { - (*nlen) = 20; - return((char *)"-9223372036854775808"); - } - p = (char *)(sc->int_to_str1 + INT_TO_STR_SIZE - 1); - op = p; - *p-- = '\0'; - - sign = (num < 0); - if (sign) num = -num; /* we need a positive index below */ - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - if (sign) - { - *p = '-'; - (*nlen) = op - p; - return(p); - } - (*nlen) = op - p - 1; - return(++p); -} - -static char *integer_to_string_no_length(s7_scheme *sc, s7_int num) /* do not free the returned string */ -{ - char *p; - bool sign; - - if (num == S7_INT64_MIN) - return((char *)"-9223372036854775808"); - p = (char *)(sc->int_to_str2 + INT_TO_STR_SIZE - 1); - *p-- = '\0'; - sign = (num < 0); - if (sign) num = -num; - do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); - if (sign) - { - *p = '-'; - return(p); - } - return(++p); -} - -static char *floatify(char *str, s7_int *nlen) -{ - if ((!strchr(str, '.')) && (!strchr(str, 'e'))) /* faster than (strcspn(str, ".e") >= (size_t)(*nlen)) */ - { - s7_int len = *nlen; - /* snprintf returns "nan" and "inf" but we (stupidly) want "+nan.0" and "+inf.0"; "-nan" and "-inf" will be handled by the normal case */ - if (len == 3) - { - if (str[0] == 'n') - { - str[0] = '+'; str[1] = 'n'; str[2] = 'a'; str[3] = 'n'; - len = 4; - } - if (str[0] == 'i') - { - str[0] = '+'; str[1] = 'i'; str[2] = 'n'; str[3] = 'f'; - len = 4; - }} - str[len]='.'; - str[len + 1]='0'; - str[len + 2]='\0'; - (*nlen) = len + 2; - } - return(str); -} - -static void insert_spaces(s7_scheme *sc, const char *src, s7_int width, s7_int len) -{ - s7_int spaces = width - len; - if (width >= sc->num_to_str_size) - { - sc->num_to_str_size = width + 1; - sc->num_to_str = (char *)Realloc(sc->num_to_str, sc->num_to_str_size); - } - sc->num_to_str[width] = '\0'; - memmove((void *)(sc->num_to_str + spaces), (void *)src, len); - local_memset((void *)(sc->num_to_str), (int)' ', spaces); -} - -static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int width, s7_int precision, - char float_choice, s7_int *nlen, use_write_t choice) /* don't free result */ -{ - /* called by number_to_string_with_radix g_number_to_string, number_to_string_p_p number_to_port format_number */ - /* the rest of s7 assumes nlen is set to the correct length - * a tricky case: (format #f "~f" 1e308) -- tries to print 308 digits! so 256 as default len is too small. - * but then even worse: (format #f "~F" 1e308+1e308i)! - */ - s7_int len = width + precision; - len = (len > 512) ? (512 + 2 * len) : 1024; - if (len > sc->num_to_str_size) - { - sc->num_to_str = (sc->num_to_str) ? (char *)Realloc(sc->num_to_str, len) : (char *)Malloc(len); - sc->num_to_str_size = len; - } - - /* bignums can't happen here */ - if (is_t_integer(obj)) - { - char *p; - if (width == 0) - { - if (has_number_name(obj)) - { - (*nlen) = number_name_length(obj); - return((char *)number_name(obj)); - } - return(integer_to_string(sc, integer(obj), nlen)); - } - p = integer_to_string(sc, integer(obj), &len); - if (width > len) - { - insert_spaces(sc, p, width, len); - (*nlen) = width; - return(sc->num_to_str); - } - (*nlen) = len; - return(p); - } - - if (is_t_real(obj)) - { - if (width == 0) - { -#if WITH_DTOA - if ((float_choice == 'g') && - (precision == WRITE_REAL_PRECISION)) - { - /* (number->string 0.0000001) is sensitive to (*s7* 'float-format-precision) and inconsistent: either 1e-7 or 0.0000001 - * because fpconv_dtoa has some complicated decision about 'g' vs 'f' -- not sure if this is a bug. - */ - len = fpconv_dtoa(real(obj), sc->num_to_str); - sc->num_to_str[len] = '\0'; - (*nlen) = len; - return(sc->num_to_str); - } -#endif - len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, - (float_choice == 'g') ? "%.*g" : ((float_choice == 'f') ? "%.*f" : "%.*e"), - (int32_t)precision, real(obj)); /* -4 for floatify */ - } - else len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, - (float_choice == 'g') ? "%*.*g" : ((float_choice == 'f') ? "%*.*f" : "%*.*e"), - (int32_t)width, (int32_t)precision, real(obj)); /* -4 for floatify */ - (*nlen) = len; - floatify(sc->num_to_str, nlen); - return(sc->num_to_str); - } - - if (is_t_complex(obj)) - { - char *imag; - sc->num_to_str[0] = '\0'; - imag = copy_string(number_to_string_base_10(sc, wrap_real(sc, imag_part(obj)), 0, precision, float_choice, &len, choice)); - - sc->num_to_str[0] = '\0'; - number_to_string_base_10(sc, wrap_real(sc, real_part(obj)), 0, precision, float_choice, &len, choice); - - sc->num_to_str[len] = '\0'; - len = catstrs(sc->num_to_str, sc->num_to_str_size, ((imag[0] == '+') || (imag[0] == '-')) ? "" : "+", imag, "i", (char *)NULL); - free(imag); - - if (width > len) /* (format #f "~20g" 1+i) */ - { - insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */ - (*nlen) = width; - } - else (*nlen) = len; - return(sc->num_to_str); - } - - /* ratio */ - len = catstrs_direct(sc->num_to_str, integer_to_string_no_length(sc, numerator(obj)), "/", pos_int_to_str_direct(sc, denominator(obj)), (const char *)NULL); - if (width > len) - { - insert_spaces(sc, sc->num_to_str, width, len); - (*nlen) = width; - } - else (*nlen) = len; - return(sc->num_to_str); -} - -static block_t *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t radix, s7_int width, s7_int precision, char float_choice, s7_int *nlen) -{ - /* called by s7_number_to_string (char*), g_number_to_string (strp), number_to_string_p_pp (strp), format_number (strp basically) */ - /* the rest of s7 assumes nlen is set to the correct length */ - block_t *b; - char *p; - s7_int len, str_len; - -#if WITH_GMP - if (s7_is_bignum(obj)) - return(big_number_to_string_with_radix(sc, obj, radix, width, nlen, P_WRITE)); - /* this ignores precision because it's way too hard to get the mpfr string to look like - * C's output -- we either have to call mpfr_get_str twice (the first time just to - * find out what the exponent is and how long the string actually is), or we have - * to do messy string manipulations. So (format #f "",3F" pi) ignores the "3" and - * prints the full string. And don't even think about mpfr_snprintf! - */ -#endif - if (radix == 10) - { - p = number_to_string_base_10(sc, obj, width, precision, float_choice, nlen, P_WRITE); - return(string_to_block(sc, p, *nlen)); - } - - switch (type(obj)) - { - case T_INTEGER: - { - size_t len1; - b = inline_mallocate(sc, (128 + width)); - p = (char *)block_data(b); - len1 = integer_to_string_any_base(p, integer(obj), radix); - if ((size_t)width > len1) - { - size_t start = width - len1; - memmove((void *)(p + start), (void *)p, len1); - local_memset((void *)p, (int)' ', start); - p[width] = '\0'; - *nlen = width; - } - else *nlen = len1; - return(b); - } - - case T_RATIO: - { - size_t len1, len2; - str_len = 256 + width; - b = inline_mallocate(sc, str_len); - p = (char *)block_data(b); - len1 = integer_to_string_any_base(p, numerator(obj), radix); - p[len1] = '/'; - len2 = integer_to_string_any_base((char *)(p + len1 + 1), denominator(obj), radix); - len = len1 + 1 + len2; - p[len] = '\0'; - } - break; - - case T_REAL: - { - int32_t i; - s7_int int_part, nsize; - s7_double x = real(obj), frac_part, min_frac, base; - bool sign = false; - char n[128], d[256]; - - if (is_NaN(x)) - return(string_to_block(sc, "+nan.0", *nlen = 6)); - if (is_inf(x)) - { - if (x < 0.0) - return(string_to_block(sc, "-inf.0", *nlen = 6)); - return(string_to_block(sc, "+inf.0", *nlen = 6)); - } - if (x < 0.0) - { - sign = true; - x = -x; - } - if (x > 1.0e18) /* i.e. close to or greater than most-positive-fixnum (9.22e18), so the code below is unlikely to work, (format #f "~X" 1e19) */ - { - int32_t ep = (int32_t)floor(log(x) / log((double)radix)); - block_t *b1; - len = 0; - b = number_to_string_with_radix(sc, wrap_real(sc, x / pow((double)radix, (double)ep)), /* divide it down to one digit, then the fractional part */ - radix, width, precision, float_choice, &len); - b1 = inline_mallocate(sc, len + 8); - p = (char *)block_data(b1); - p[0] = '\0'; - (*nlen) = catstrs(p, len + 8, (sign) ? "-" : "", (char *)block_data(b), (radix == 16) ? "@" : "e", integer_to_string_no_length(sc, ep), (char *)NULL); - liberate(sc, b); - return(b1); - } - - int_part = (s7_int)floor(x); - frac_part = x - int_part; - nsize = integer_to_string_any_base(n, int_part, radix); - min_frac = dpow(radix, -precision); - - /* doesn't this assume precision < 128/256 and that we can fit in 256 digits (1e308)? */ - for (i = 0, base = radix; (i < precision) && (frac_part > min_frac); i++, base *= radix) - { - s7_int ipart = (s7_int)(frac_part * base); - if (ipart >= radix) /* rounding confusion */ - ipart = radix - 1; - frac_part -= (ipart / base); - /* d[i] = ((const char *)"0123456789abcdef")[ipart]; */ - d[i] = dignum[ipart]; - } - if (i == 0) - d[i++] = '0'; - d[i] = '\0'; - b = inline_mallocate(sc, 256); - p = (char *)block_data(b); - /* much faster than catstrs because we know the string lengths */ - { - char *pt = p; - if (sign) {pt[0] = '-'; pt++;} - memcpy(pt, n, nsize); - pt += nsize; - pt[0] = '.'; - pt++; - memcpy(pt, d, i); - pt[i] = '\0'; - /* len = ((sign) ? 1 : 0) + 1 + nsize + i; */ - len = pt + i - p; - } - str_len = 256; - } - break; - - default: - { - char *pt; - s7_int real_len = 0, imag_len = 0; - block_t *n = number_to_string_with_radix(sc, wrap_real(sc, real_part(obj)), radix, 0, precision, float_choice, &real_len); /* include floatify */ - block_t *d = number_to_string_with_radix(sc, wrap_real(sc, imag_part(obj)), radix, 0, precision, float_choice, &imag_len); - char *dp = (char *)block_data(d); - b = inline_mallocate(sc, 512); - p = (char *)block_data(b); - pt = p; - memcpy(pt, (void *)block_data(n), real_len); - pt += real_len; - if ((dp[0] != '+') && (dp[0] != '-')) {pt[0] = '+'; pt++;} - memcpy(pt, dp, imag_len); - pt[imag_len] = 'i'; - pt[imag_len + 1] = '\0'; - len = pt + imag_len + 1 - p; - str_len = 512; - liberate(sc, n); - liberate(sc, d); - } - break; - } - - if (width > len) - { - s7_int spaces; - if (width >= str_len) - { - str_len = width + 1; - b = reallocate(sc, b, str_len); - p = (char *)block_data(b); - } - spaces = width - len; - p[width] = '\0'; - memmove((void *)(p + spaces), (void *)p, len); - local_memset((void *)p, (int)' ', spaces); - (*nlen) = width; - } - else (*nlen) = len; - return(b); -} - -char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix) -{ - s7_int nlen = 0; - block_t *b = number_to_string_with_radix(sc, obj, radix, 0, 20, 'g', &nlen); /* (log top 10) so we get all the digits in base 10 (??) */ - char *str = copy_string_with_length((char *)block_data(b), nlen); - liberate(sc, b); - return(str); -} - -static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_number_to_string "(number->string num (radix 10)) converts the number num into a string." - #define Q_number_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_number_symbol, sc->is_integer_symbol) - - s7_int nlen = 0, radix; /* ignore cppcheck complaint about radix! */ - char *res; - s7_pointer x = car(args); - - if (!is_number(x)) - return(method_or_bust(sc, x, sc->number_to_string_symbol, args, a_number_string, 1)); - - if (is_pair(cdr(args))) - { - s7_pointer y = cadr(args); - if (s7_is_integer(y)) - radix = s7_integer_clamped_if_gmp(sc, y); - else return(method_or_bust(sc, y, sc->number_to_string_symbol, args, sc->type_names[T_INTEGER], 2)); - if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, sc->number_to_string_symbol, int_two, y, a_valid_radix_string); -#if (WITH_GMP) - if (!s7_is_bignum(x)) -#endif - { - block_t *b = number_to_string_with_radix(sc, x, radix, 0, sc->float_format_precision, 'g', &nlen); - return(block_to_string(sc, b, nlen)); - }} -#if WITH_GMP - else radix = 10; - if (s7_is_bignum(x)) - { - block_t *b = big_number_to_string_with_radix(sc, x, radix, 0, &nlen, P_WRITE); - return(block_to_string(sc, b, nlen)); - } - res = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, P_WRITE); -#else - if (is_t_integer(x)) - { - if (has_number_name(x)) - { - nlen = number_name_length(x); - res = (char *)number_name(x); - } - else res = integer_to_string(sc, integer(x), &nlen); - } - else res = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, P_WRITE); -#endif - return(inline_make_string_with_length(sc, res, nlen)); -} - -static s7_pointer number_to_string_p_p(s7_scheme *sc, s7_pointer p) -{ -#if WITH_GMP - return(g_number_to_string(sc, set_plist_1(sc, p))); -#else - s7_int nlen = 0; - char *res; - if (!is_number(p)) - return(sole_arg_method_or_bust_p(sc, p, sc->number_to_string_symbol, a_number_string)); - res = number_to_string_base_10(sc, p, 0, sc->float_format_precision, 'g', &nlen, P_WRITE); - return(inline_make_string_with_length(sc, res, nlen)); -#endif -} - -static s7_pointer number_to_string_p_i(s7_scheme *sc, s7_int p) -{ - s7_int nlen = 0; - char *res = integer_to_string(sc, p, &nlen); - return(inline_make_string_with_length(sc, res, nlen)); -} -/* not number_to_string_p_d! */ - -static s7_pointer number_to_string_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ -#if WITH_GMP - return(g_number_to_string(sc, set_plist_2(sc, p1, p2))); -#else - s7_int nlen = 0, radix; - block_t *b; - - if (!is_number(p1)) - wrong_type_error_nr(sc, sc->number_to_string_symbol, 1, p1, a_number_string); - if (!is_t_integer(p2)) - wrong_type_error_nr(sc, sc->number_to_string_symbol, 2, p2, sc->type_names[T_INTEGER]); - radix = integer(p2); - if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, sc->number_to_string_symbol, int_two, p2, a_valid_radix_string); - - b = number_to_string_with_radix(sc, p1, radix, 0, sc->float_format_precision, 'g', &nlen); - return(block_to_string(sc, b, nlen)); -#endif -} - - -/* -------------------------------------------------------------------------------- */ -#define CTABLE_SIZE 256 -static bool *exponent_table, *slashify_table, *char_ok_in_a_name, *white_space, *number_table, *symbol_slashify_table; -static int32_t *digits; - -static void init_ctables(void) -{ - exponent_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - slashify_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - symbol_slashify_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - char_ok_in_a_name = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - white_space = (bool *)Calloc(CTABLE_SIZE + 1, sizeof(bool)); - white_space++; /* leave white_space[-1] false for white_space[EOF] */ - number_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool)); - digits = (int32_t *)Calloc(CTABLE_SIZE, sizeof(int32_t)); - - for (int32_t i = 0; i < CTABLE_SIZE; i++) - { - char_ok_in_a_name[i] = true; - white_space[i] = false; - digits[i] = 256; - number_table[i] = false; - } - - char_ok_in_a_name[0] = false; - char_ok_in_a_name[(uint8_t)'('] = false; /* cast for C++ */ - char_ok_in_a_name[(uint8_t)')'] = false; - char_ok_in_a_name[(uint8_t)';'] = false; - char_ok_in_a_name[(uint8_t)'\t'] = false; - char_ok_in_a_name[(uint8_t)'\n'] = false; - char_ok_in_a_name[(uint8_t)'\r'] = false; - char_ok_in_a_name[(uint8_t)' '] = false; - char_ok_in_a_name[(uint8_t)'"'] = false; - - white_space[(uint8_t)'\t'] = true; - white_space[(uint8_t)'\n'] = true; - white_space[(uint8_t)'\r'] = true; - white_space[(uint8_t)'\f'] = true; - white_space[(uint8_t)'\v'] = true; - white_space[(uint8_t)' '] = true; - white_space[(uint8_t)'\205'] = true; /* 133 */ - white_space[(uint8_t)'\240'] = true; /* 160 */ - - /* surely only 'e' is needed... */ - exponent_table[(uint8_t)'e'] = true; exponent_table[(uint8_t)'E'] = true; - exponent_table[(uint8_t)'@'] = true; -#if WITH_EXTRA_EXPONENT_MARKERS - exponent_table[(uint8_t)'s'] = true; exponent_table[(uint8_t)'S'] = true; - exponent_table[(uint8_t)'f'] = true; exponent_table[(uint8_t)'F'] = true; - exponent_table[(uint8_t)'d'] = true; exponent_table[(uint8_t)'D'] = true; - exponent_table[(uint8_t)'l'] = true; exponent_table[(uint8_t)'L'] = true; -#endif - for (int32_t i = 0; i < 32; i++) slashify_table[i] = true; - for (int32_t i = 127; i < 160; i++) slashify_table[i] = true; - slashify_table[(uint8_t)'\\'] = true; - slashify_table[(uint8_t)'"'] = true; - slashify_table[(uint8_t)'\n'] = false; - - for (int32_t i = 0; i < CTABLE_SIZE; i++) - symbol_slashify_table[i] = ((slashify_table[i]) || (!char_ok_in_a_name[i])); /* force use of (symbol ...) for cases like '(ab) as symbol */ - - digits[(uint8_t)'0'] = 0; digits[(uint8_t)'1'] = 1; digits[(uint8_t)'2'] = 2; digits[(uint8_t)'3'] = 3; digits[(uint8_t)'4'] = 4; - digits[(uint8_t)'5'] = 5; digits[(uint8_t)'6'] = 6; digits[(uint8_t)'7'] = 7; digits[(uint8_t)'8'] = 8; digits[(uint8_t)'9'] = 9; - digits[(uint8_t)'a'] = 10; digits[(uint8_t)'A'] = 10; - digits[(uint8_t)'b'] = 11; digits[(uint8_t)'B'] = 11; - digits[(uint8_t)'c'] = 12; digits[(uint8_t)'C'] = 12; - digits[(uint8_t)'d'] = 13; digits[(uint8_t)'D'] = 13; - digits[(uint8_t)'e'] = 14; digits[(uint8_t)'E'] = 14; - digits[(uint8_t)'f'] = 15; digits[(uint8_t)'F'] = 15; - - number_table[(uint8_t)'0'] = true; number_table[(uint8_t)'1'] = true; number_table[(uint8_t)'2'] = true; number_table[(uint8_t)'3'] = true; - number_table[(uint8_t)'4'] = true; number_table[(uint8_t)'5'] = true; number_table[(uint8_t)'6'] = true; number_table[(uint8_t)'7'] = true; - number_table[(uint8_t)'8'] = true; number_table[(uint8_t)'9'] = true; number_table[(uint8_t)'.'] = true; - number_table[(uint8_t)'+'] = true; - number_table[(uint8_t)'-'] = true; - number_table[(uint8_t)'#'] = true; -} - -#define is_white_space(C) white_space[C] - /* this is much faster than C's isspace, and does not depend on the current locale. - * if c == EOF (-1), it indexes into the empty (0) slot we preallocated below white_space - */ - -/* -------------------------------- *#readers* -------------------------------- */ -static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name) -{ - s7_pointer value = sc->F, args = sc->F; - bool need_loader_port = is_loader_port(current_input_port(sc)); - - /* *#reader* is assumed to be an alist of (char . proc) - * where each proc takes one argument, the string from just beyond the "#" to the next delimiter. - * The procedure can call read-char to read ahead in the current-input-port. - * If it returns anything other than #f, that is the value of the sharp expression. - * Since #f means "nothing found", it is tricky to handle #F: - * (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t)))) ; or ''#f used in lint.scm - * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback. Added #_ later) - */ - if (need_loader_port) - clear_loader_port(current_input_port(sc)); - - /* normally read* can't read from current_input_port(sc) if it is in use by the loader, but here we are deliberately making that possible */ - for (s7_pointer reader = slot_value(sc->sharp_readers); is_not_null(reader); reader = cdr(reader)) - if (name[0] == s7_character(caar(reader))) - { - if (args == sc->F) - args = set_plist_1(sc, s7_make_string_wrapper(sc, name)); - /* args is GC protected by s7_apply_function?? (placed on the stack) */ - value = s7_apply_function(sc, cdar(reader), args); /* this is much less error-safe than s7_call */ - if (value != sc->F) - break; - } - if (need_loader_port) - set_loader_port(current_input_port(sc)); - return(value); -} - -static s7_pointer g_sharp_readers_set(s7_scheme *sc, s7_pointer args) -{ - /* new value must be either () or a proper list of conses (char . func) */ - s7_pointer x; - if (is_null(cadr(args))) return(cadr(args)); - if (!is_pair(cadr(args))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); - for (x = cadr(args); is_pair(x); x = cdr(x)) - if ((!is_pair(car(x))) || - (!is_character(caar(x))) || - (!is_procedure(cdar(x)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); - if (!is_null(x)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); - return(cadr(args)); -} - -static s7_pointer make_undefined(s7_scheme *sc, const char* name) -{ - s7_int len = safe_strlen(name); - char *newstr = (char *)Malloc(len + 2); - s7_pointer p; - new_cell(sc, p, T_UNDEFINED | T_IMMUTABLE); - newstr[0] = '#'; - memcpy((void *)(newstr + 1), (void *)name, len); - newstr[len + 1] = '\0'; - if (sc->undefined_constant_warnings) s7_warn(sc, len + 32, "%s is undefined\n", newstr); - undefined_set_name_length(p, len + 1); - undefined_name(p) = newstr; - add_undefined(sc, p); - return(p); -} - -static int32_t inchar(s7_pointer pt) -{ - int32_t c; - if (is_file_port(pt)) - c = fgetc(port_file(pt)); /* not uint8_t! -- could be EOF */ - else - { - if (port_data_size(pt) <= port_position(pt)) - return(EOF); - c = (uint8_t)port_data(pt)[port_position(pt)++]; - } - if (c == '\n') - port_line_number(pt)++; - return(c); -} - -static void backchar(char c, s7_pointer pt) -{ - if (c == '\n') - port_line_number(pt)--; - - if (is_file_port(pt)) - ungetc(c, port_file(pt)); - else - if (port_position(pt) > 0) - port_position(pt)--; -} - -static void resize_strbuf(s7_scheme *sc, s7_int needed_size) -{ - s7_int old_size = sc->strbuf_size; - while (sc->strbuf_size <= needed_size) sc->strbuf_size *= 2; - sc->strbuf = (char *)Realloc(sc->strbuf, sc->strbuf_size); - for (s7_int i = old_size; i < sc->strbuf_size; i++) sc->strbuf[i] = '\0'; -} - -static s7_pointer *chars; - -static s7_pointer unknown_sharp_constant(s7_scheme *sc, const char *name, s7_pointer pt) -{ - /* if name[len - 1] != '>' there's no > delimiter at the end */ - - if (hook_has_functions(sc->read_error_hook)) /* check *read-error-hook* */ - { - bool old_history_enabled = s7_set_history_enabled(sc, false); /* see sc->error_hook for a more robust way to handle this */ - s7_pointer result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->T, s7_make_string_wrapper(sc, name))); - s7_set_history_enabled(sc, old_history_enabled); - if (result != sc->unspecified) - return(result); - } - if (pt) /* #<"..."> which gets here as name="#<" */ - { - s7_int len = safe_strlen(name); - if ((name[len - 1] != '>') && - (is_input_port(pt)) && - (pt != sc->standard_input)) - { - if (s7_peek_char(sc, pt) != chars[(uint8_t)'"']) /* if not #<"...">, just return it */ - return(make_undefined(sc, name)); - /* PERHAPS: strchr port-data '>'?? it might be # etc -- what would this break? maybe extend section below */ - - if (is_string_port(pt)) /* probably unnecessary (see below) */ - { - s7_int c = inchar(pt); - const char *pstart = (const char *)(port_data(pt) + port_position(pt)); - const char *p = strchr(pstart, (int)'"'); - s7_int added_len; - char *buf; - s7_pointer res; - - if (!p) - { - backchar(c, pt); - return(make_undefined(sc, name)); - } - p++; - while (char_ok_in_a_name[(uint8_t)(*p)]) {p++;} - added_len = (s7_int)(p - pstart); /* p is one past '>' presumably */ - /* we can't use strbuf here -- it might be the source of the "name" argument! */ - buf = (char *)Malloc(len + added_len + 2); - memcpy((void *)buf, (void *)name, len); - buf[len] = '"'; /* from inchar */ - memcpy((void *)(buf + len + 1), (void *)pstart, added_len); - buf[len + added_len + 1] = 0; - port_position(pt) += added_len; - res = make_undefined(sc, (const char *)buf); - free(buf); - return(res); - }}} - return(make_undefined(sc, name)); -} - -static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_symbol, bool with_error); -#define SYMBOL_OK true -#define NO_SYMBOLS false - -static s7_pointer make_sharp_constant(s7_scheme *sc, const char *name, bool with_error, s7_pointer pt, bool error_if_bad_number) -{ - /* name is the stuff after the '#', return sc->nil if not a recognized #... entity */ - if ((!name) || (!*name)) /* (string->number "#") for example */ - return(make_undefined(sc, name)); - - /* stupid r7rs special cases */ - if ((name[0] == 't') && - ((name[1] == '\0') || (c_strings_are_equal(name, "true")))) - return(sc->T); - - if ((name[0] == 'f') && - ((name[1] == '\0') || (c_strings_are_equal(name, "false")))) - return(sc->F); - - if (name[0] == '_') - { - /* this needs to be unsettable via *#readers*: - * (set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1)))))) - * (let ((+ -)) (#_+ 1 2)): -1 - */ - s7_pointer sym = make_symbol_with_strlen(sc, (char *)(name + 1)); - if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) - return(initial_value(sym)); - /* here we should not necessarily raise an error that *_... is undefined. reader-cond, for example, needs to - * read undefined #_ vals that it will eventually discard. - */ - return(make_undefined(sc, name)); /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */ - } - - if (is_not_null(slot_value(sc->sharp_readers))) - { - s7_pointer x = check_sharp_readers(sc, name); - if (x != sc->F) - return(x); - } - - if ((name[0] == '\0') || name[1] == '\0') - return(unknown_sharp_constant(sc, name, pt)); /* pt here because #<"..."> comes here as "<" so name[1] is '\0'! */ - - switch (name[0]) - { - /* -------- #< ... > -------- */ - case '<': - if (c_strings_are_equal(name, "")) return(sc->unspecified); - if (c_strings_are_equal(name, "")) return(sc->undefined); - if (c_strings_are_equal(name, "")) return(eof_object); - return(unknown_sharp_constant(sc, name, pt)); - - /* -------- #o #x #b -------- */ - case 'o': /* #o (octal) */ - case 'x': /* #x (hex) */ - case 'b': /* #b (binary) */ - { - s7_pointer res = make_atom(sc, (char *)(name + 1), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), NO_SYMBOLS, with_error); - if ((error_if_bad_number) && (res == sc->F)) /* #b32 etc but not if called from string->number */ - { - char buf[256]; - size_t len = snprintf(buf, 256, "#%s is not a number", name); - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, s7_make_string_with_length(sc, buf, len))); /* can't use wrap_string here (buf is local) */ - } - return(res); - } - - /* -------- #\... -------- */ - case '\\': - if (name[2] == 0) /* the most common case: #\a */ - return(chars[(uint8_t)(name[1])]); - /* not uint32_t here! (uint32_t)255 (as a char) returns -1!! */ - switch (name[1]) - { - case 'n': - if ((c_strings_are_equal(name + 1, "null")) || - (c_strings_are_equal(name + 1, "nul"))) - return(chars[0]); - - if (c_strings_are_equal(name + 1, "newline")) - return(chars[(uint8_t)'\n']); - break; - - case 's': if (c_strings_are_equal(name + 1, "space")) return(chars[(uint8_t)' ']); break; - case 'r': if (c_strings_are_equal(name + 1, "return")) return(chars[(uint8_t)'\r']); break; - case 'l': if (c_strings_are_equal(name + 1, "linefeed")) return(chars[(uint8_t)'\n']); break; - case 't': if (c_strings_are_equal(name + 1, "tab")) return(chars[(uint8_t)'\t']); break; - case 'a': if (c_strings_are_equal(name + 1, "alarm")) return(chars[7]); break; - case 'b': if (c_strings_are_equal(name + 1, "backspace")) return(chars[8]); break; - case 'e': if (c_strings_are_equal(name + 1, "escape")) return(chars[0x1b]); break; - case 'd': if (c_strings_are_equal(name + 1, "delete")) return(chars[0x7f]); break; - - case 'x': - /* #\x is just x, but apparently #\x is int->char? #\x65 -> #\e, and #\xcebb is lambda? */ - { - /* sscanf here misses errors like #\x1.4, but make_atom misses #\x6/3, - * #\x#b0, #\x#e0.0, #\x-0, #\x#e0e100 etc, so we have to do it at an even lower level. - * another problem: #\xbdca2cbec overflows so lval is -593310740 -> segfault unless caught - */ - bool happy = true; - char *tmp = (char *)(name + 2); - int32_t lval = 0; - - while ((*tmp) && (happy) && (lval >= 0) && (lval < 256)) - { - int32_t dig = digits[(int32_t)(*tmp++)]; - if (dig < 16) - lval = dig + (lval * 16); - else happy = false; - } - if ((happy) && - (lval < 256) && - (lval >= 0)) - return(chars[lval]); - } - break; - }} - return(unknown_sharp_constant(sc, name, NULL)); -} - -static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow) -{ - bool negative = false; - s7_int lval = 0; - int32_t dig; - char *tmp = (char *)str; -#if WITH_GMP - char *tmp1; -#endif - if (str[0] == '+') - tmp++; - else - if (str[0] == '-') - { - negative = true; - tmp++; - } - while (*tmp == '0') {tmp++;}; -#if WITH_GMP - tmp1 = tmp; -#endif - if (radix == 10) - { - while (true) - { - dig = digits[(uint8_t)(*tmp++)]; - if (dig > 9) break; -#if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow(lval, (s7_int)10, &lval)) || - (add_overflow(lval, (s7_int)dig, &lval))) - { - if ((radix == 10) && - (strncmp(str, "-9223372036854775808", 20) == 0) && - (digits[(uint8_t)(*tmp++)] > 9)) /* i.e. next thing is not a digit -- "/" for example */ - return(S7_INT64_MIN); - *overflow = true; - return((negative) ? S7_INT64_MIN : S7_INT64_MAX); - } -#else - lval = dig + (lval * 10); - dig = digits[(uint8_t)(*tmp++)]; - if (dig > 9) break; - lval = dig + (lval * 10); -#endif - }} - else - while (true) - { - dig = digits[(uint8_t)(*tmp++)]; - if (dig >= radix) break; -#if HAVE_OVERFLOW_CHECKS && (!WITH_GMP) - { - s7_int oval = 0; - if (multiply_overflow(lval, (s7_int)radix, &oval)) - { - /* maybe a bad idea! #xffffffffffffffff -> -1??? this is needed for 64-bit number hacks (see s7test.scm bit-reverse) */ - if ((radix == 16) && - (digits[(uint8_t)(*tmp)] >= radix)) - { - lval -= 576460752303423488LL; /* turn off sign bit */ - lval *= radix; - lval += dig; - lval -= 9223372036854775807LL; - return(lval - 1); - } - lval = oval; /* old case */ - if ((lval == S7_INT64_MIN) && (digits[(uint8_t)(*tmp++)] > 9)) - return(lval); - *overflow = true; - break; - } - else lval = oval; - if (add_overflow(lval, (s7_int)dig, &lval)) - { - if (lval == S7_INT64_MIN) return(lval); - *overflow = true; - break; - }} -#else - lval = dig + (lval * radix); - dig = digits[(uint8_t)(*tmp++)]; - if (dig >= radix) break; - lval = dig + (lval * radix); -#endif - } - -#if WITH_GMP - if (!(*overflow)) - (*overflow) = ((lval > S7_INT32_MAX) || - ((tmp - tmp1) > s7_int_digits_by_radix[radix])); - /* this tells the string->number readers to create a bignum. We need to be very conservative here to catch contexts such as (/ 1/524288 19073486328125) */ -#endif - return((negative) ? -lval : lval); -} - -/* 9223372036854775807 9223372036854775807 - * -9223372036854775808 -9223372036854775808 - * 0000000000000000000000000001.0 1.0 - * 1.0000000000000000000000000000 1.0 - * 1000000000000000000000000000.0e-40 1.0e-12 - * 0.0000000000000000000000000001e40 1.0e12 - * 1.0e00000000000000000001 10.0 - */ - -#if WITH_GMP -static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix, bool *overflow) -#else -#define string_to_double_with_radix(Str, Rad, Over) string_to_double_with_radix_1(Str, Rad) -static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix) -#endif -{ - /* strtod follows LANG which is not what we want (only "." is decimal point in Scheme). - * To overcome LANG in strtod would require screwing around with setlocale which never works. - * So we use our own code -- according to valgrind, this function is much faster than strtod. - * comma as decimal point causes ambiguities: `(+ ,1 2) etc - */ - - int32_t i, sign = 1, frac_len, int_len, dig, exponent = 0; - int32_t max_len = s7_int_digits_by_radix[radix]; - int64_t int_part = 0, frac_part = 0; - char *str = (char *)ur_str; - char *ipart, *fpart; - s7_double dval = 0.0; - - /* there's an ambiguity in number notation here if we allow "1e1" or "1.e1" in base 16 (or 15) -- is e a digit or an exponent marker? - * but 1e+1, for example disambiguates it -- kind of messy! -- the scheme spec says "e" can only occur in base 10. - * '@' can now be used as the exponent marker (26-Mar-12). - * Another slight ambiguity: 1+1/2i is parsed as 1 + 0.5i, not 1+1/(2i), or (1+1)/(2i) or (1+1/2)i etc - */ - if (*str == '-') - { - str++; - sign = -1; - } - else - if (*str == '+') - str++; - while (*str == '0') {str++;}; - - ipart = str; - while (digits[(int32_t)(*str)] < radix) str++; - int_len = str - ipart; - - if (*str == '.') str++; - fpart = str; - while (digits[(int32_t)(*str)] < radix) str++; - frac_len = str - fpart; - - if ((*str) && (exponent_table[(uint8_t)(*str)])) - { - bool exp_negative = false; - str++; - if (*str == '+') - str++; - else - if (*str == '-') - { - str++; - exp_negative = true; - } - while ((dig = digits[(int32_t)(*str++)]) < 10) /* exponent itself is always base 10 */ - { -#if HAVE_OVERFLOW_CHECKS - if ((int32_multiply_overflow(exponent, 10, &exponent)) || - (int32_add_overflow(exponent, dig, &exponent))) - { - exponent = 1000000; /* see below */ - break; - } -#else - exponent = dig + (exponent * 10); -#endif - } -#if (!defined(__GNUC__)) || ((__GNUC__ < 5) && (!defined(__clang__))) - if (exponent < 0) /* we overflowed, so make sure we notice it below (need to check for 0.0e... first) (Brian Damgaard) */ - exponent = 1000000; /* see below for examples -- this number needs to be very big but not too big for add */ -#endif - if (exp_negative) - exponent = -exponent; - - /* 2e12341234123123123123213123123123 -> 0.0 - * but exp len is not the decider: 2e00000000000000000000000000000000000000001 -> 20.0 - * first zero: 2e123412341231231231231 - * then: 2e12341234123123123123123123 -> inf - * then: 2e123412341231231231231231231231231231 -> 0.0 - * 2e-123412341231231231231 -> inf - * but: 0e123412341231231231231231231231231231 - */ - } - -#if WITH_GMP - /* 9007199254740995.0 */ - if (int_len + frac_len >= max_len) - { - (*overflow) = true; - return(0.0); - } -#endif - str = ipart; - if ((int_len + exponent) > max_len) - { - /* 12341234.56789e12 12341234567889999872.0 1.234123456789e+19 - * -1234567890123456789.0 -1234567890123456768.0 -1.2345678901235e+18 - * 12345678901234567890.0 12345678901234567168.0 1.2345678901235e+19 - * 123.456e30 123456000000000012741097792995328.0 1.23456e+32 - * 12345678901234567890.0e12 12345678901234569054409354903552.0 1.2345678901235e+31 - * 1.234567890123456789012e30 1234567890123456849145940148224.0 1.2345678901235e+30 - * 1e20 100000000000000000000.0 1e+20 - * 1234567890123456789.0 1234567890123456768.0 1.2345678901235e+18 - * 123.456e16 1234560000000000000.0 1.23456e+18 - * 98765432101234567890987654321.0e-5 987654321012345728401408.0 9.8765432101235e+23 - * 98765432101234567890987654321.0e-10 9876543210123456512.0 9.8765432101235e+18 - * 0.00000000000000001234e20 1234.0 - * 0.000000000000000000000000001234e30 1234.0 - * 0.0000000000000000000000000000000000001234e40 1234.0 - * 0.000000000012345678909876543210e15 12345.678909877 - * 0e1000 0.0 - */ - - for (i = 0; i < max_len; i++) - { - dig = digits[(int32_t)(*str++)]; - if (dig < radix) - int_part = dig + (int_part * radix); - else break; - } - - /* if the exponent is huge, check for 0 int_part and frac_part before complaining (0e1000 or 0.0e1000) - */ - if ((int_part == 0) && - (exponent > max_len)) - { - /* if frac_part is also 0, return 0.0 */ - if (frac_len == 0) return(0.0); - str = fpart; - while ((dig = digits[(int32_t)(*str++)]) < radix) - frac_part = dig + (frac_part * radix); - if (frac_part == 0) return(0.0); -#if WITH_GMP - (*overflow) = true; -#endif - } -#if WITH_GMP - (*overflow) = ((int_part > 0) || (exponent > 20)); /* .1e310 is a tricky case */ -#endif - if (int_part != 0) /* 0.<310 zeros here>1e310 for example -- pow (via dpow) thinks it has to be too big, returns Nan, - * then Nan * 0 -> Nan and the NaN propagates - */ - { - if (int_len <= max_len) - dval = int_part * dpow(radix, exponent); - else dval = int_part * dpow(radix, exponent + int_len - max_len); - } - else dval = 0.0; - - /* shift by exponent, but if int_len > max_len then we assumed (see below) int_len - max_len 0's on the left */ - /* using int_to_int or table lookups here instead of pow did not make any difference in speed */ - - if (int_len < max_len) - { - str = fpart; - for (int32_t k = 0; (frac_len > 0) && (k < exponent); k += max_len) - { - int32_t flen = (frac_len > max_len) ? max_len : frac_len; /* ? */ - frac_len -= max_len; - frac_part = 0; - for (i = 0; i < flen; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - if (frac_part != 0) /* same pow->NaN problem as above can occur here */ - dval += frac_part * dpow(radix, exponent - flen - k); - }} - else - /* some of the fraction is in the integer part before the negative exponent shifts it over */ - if (int_len > max_len) - { - int32_t ilen = int_len - max_len; /* we read these above */ - /* str should be at the last digit we read */ - if (ilen > max_len) - ilen = max_len; - for (i = 0; i < ilen; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - dval += frac_part * dpow(radix, exponent - ilen); - } - return(sign * dval); - } - - /* int_len + exponent <= max_len */ - if (int_len <= max_len) - { - int32_t int_exponent = exponent; - /* a better algorithm (since the inaccuracies are in the radix^exponent portion): - * strip off leading zeros and possible sign, - * strip off digits beyond max_len, then remove any trailing zeros. - * (maybe fiddle with the lowest order digit here for rounding, but I doubt it matters) - * read digits until end of number or max_len reached, ignoring the decimal point - * get exponent and use it and decimal point location to position the current result integer - * this always combines the same integer and the same exponent no matter how the number is expressed. - */ - if (int_len > 0) - { - char *iend = (char *)(str + int_len - 1); - while ((*iend == '0') && (iend != str)) {iend--; int_exponent++;} - while (str <= iend) - int_part = digits[(int32_t)(*str++)] + (int_part * radix); - } - dval = (int_exponent == 0) ? (s7_double)int_part : int_part * dpow(radix, int_exponent); - } - else - { - int32_t flen, len = int_len + exponent; - int64_t frpart = 0; - - /* 98765432101234567890987654321.0e-20 987654321.012346 - * 98765432101234567890987654321.0e-29 0.98765432101235 - * 98765432101234567890987654321.0e-30 0.098765432101235 - * 98765432101234567890987654321.0e-28 9.8765432101235 - */ - for (i = 0; i < len; i++) - int_part = digits[(int32_t)(*str++)] + (int_part * radix); - flen = -exponent; - if (flen > max_len) - flen = max_len; - for (i = 0; i < flen; i++) - frpart = digits[(int32_t)(*str++)] + (frpart * radix); - if (len <= 0) - dval = int_part + frpart * dpow(radix, len - flen); - else dval = int_part + frpart * dpow(radix, -flen); - } - - if (frac_len > 0) - { - str = fpart; - if (frac_len <= max_len) - { - /* splitting out base 10 case saves very little here */ - /* this ignores trailing zeros, so that 0.3 equals 0.300 */ - char *fend = (char *)(str + frac_len - 1); - - while ((*fend == '0') && (fend != str)) {fend--; frac_len--;} /* (= .6 0.6000) */ - if ((frac_len & 1) == 0) - { - while (str <= fend) - { - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - }} - else - while (str <= fend) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - - dval += frac_part * dpow(radix, exponent - frac_len); - - /* 0.6: frac: 6, exp: 0.10000000000000000555, val: 0.60000000000000008882 - * 0.60: frac: 60, exp: 0.01000000000000000021, val: 0.59999999999999997780 - * 0.6000: frac: 6000, exp: 0.00010000000000000000, val: 0.59999999999999997780 - * (= 0.6 0.60): #f - * (= #i3/5 0.6): #f - * so (string->number (number->string num)) == num only if both num's are the same text (or you get lucky) - * (= 0.6 6e-1): #t ; but not 60e-2 - * to fix the 0.60 case, we need to ignore trailing post-dot zeros. - */ - } - else - { - if (exponent <= 0) - { - for (i = 0; i < max_len; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - - dval += frac_part * dpow(radix, exponent - max_len); - } - else - { - /* 1.0123456789876543210e1 10.12345678987654373771 - * 1.0123456789876543210e10 10123456789.87654304504394531250 - * 0.000000010000000000000000e10 100.0 - * 0.000000010000000000000000000000000000000000000e10 100.0 - * 0.000000012222222222222222222222222222222222222e10 122.22222222222222 - * 0.000000012222222222222222222222222222222222222e17 1222222222.222222 - */ - int_part = 0; - for (i = 0; i < exponent; i++) - int_part = digits[(int32_t)(*str++)] + (int_part * radix); - frac_len -= exponent; - if (frac_len > max_len) - frac_len = max_len; - for (i = 0; i < frac_len; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - dval += int_part + frac_part * dpow(radix, -frac_len); - }}} -#if WITH_GMP - if ((int_part == 0) && - (frac_part == 0)) - return(0.0); - (*overflow) = ((frac_len - exponent) > max_len); -#endif - return(sign * dval); -} - -#if (!WITH_GMP) -static s7_pointer make_undefined_bignum(s7_scheme *sc, const char *name) -{ - s7_int len = safe_strlen(name) + 16; - block_t *b = mallocate(sc, len); - char *buf = (char *)block_data(b); - s7_pointer res; - snprintf(buf, len, "", name); - res = make_undefined(sc, (const char *)buf); /* 123123123123123123123123123123 -> +inf.0 originally, but now # */ - liberate(sc, b); - return(res); -} -#endif - -static s7_pointer nan1_or_bust(s7_scheme *sc, s7_double x, char *p, char *q, int32_t radix, bool want_symbol, int32_t offset) -{ - s7_int len = safe_strlen(p); - if (p[len - 1] == 'i') /* +nan.0[+/-]...i */ - { - if (len == (offset + 2)) /* +nan.0+i */ - return(make_complex_not_0i(sc, x, (p[offset] == '+') ? 1.0 : -1.0)); - if ((len > (offset + 1)) && (len < 1024)) /* make compiler happy */ - { - char *ip = copy_string_with_length((const char *)(p + offset), len - offset - 1); - s7_pointer imag = make_atom(sc, ip, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); - free(ip); - if (is_real(imag)) - return(make_complex(sc, x, real_to_double(sc, imag, __func__))); /* +nan.0+2/3i etc */ - }} - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); -} - -static s7_pointer nan2_or_bust(s7_scheme *sc, s7_double x, char *q, int32_t radix, bool want_symbol, int64_t rl_len) -{ - s7_int len = safe_strlen(q); - /* fprintf(stderr, "\n%s %s %" ld64, __func__, q, len); */ - if ((len > rl_len) && (len < 1024)) /* make compiler happy */ - { - char *ip = copy_string_with_length((const char *)q, rl_len); - s7_pointer rl = make_atom(sc, ip, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); - free(ip); - /* fprintf(stderr, "\nrl: %s\n", display(rl)); */ - if (is_real(rl)) - return(make_complex(sc, real_to_double(sc, rl, __func__), x)); - } - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); -} - -#if WITH_NUMBER_SEPARATOR -static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix); -static s7_pointer make_symbol_or_number(s7_scheme *sc, const char *name, int32_t radix, bool want_symbol) -{ - block_t *b; - char *new_name; - char sep = sc->number_separator; - s7_int len, i, j; - s7_pointer res; - - if (name[0] == sep) - return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); - len = safe_strlen(name); - b = mallocate(sc, len + 1); - new_name = (char *)block_data(b); - memcpy((void *)new_name, (void *)name, len); - new_name[len] = 0; - - for (i = 0, j = 0; i < len; i++) - if (name[i] != sep) - { - if ((digits[(uint8_t)(name[i])] < radix) || (!t_number_separator_p[(uint8_t)name[i]])) - new_name[j++] = name[i]; - else - { - liberate(sc, b); - return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); - }} - else /* sep has to be between two digits */ - if ((digits[(uint8_t)(name[i - 1])] >= radix) || (digits[(uint8_t)(name[i + 1])] >= radix)) - { - liberate(sc, b); - return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); - } - - new_name[j] = '\0'; - res = string_to_number(sc, new_name, radix); - liberate(sc, b); - return(res); -} -#endif - -static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_symbol, bool with_error) -{ - /* make symbol or number from string, a number starts with + - . or digit, but so does 1+ for example */ -#if WITH_NUMBER_SEPARATOR - #define is_digit(Chr, Rad) ((digits[(uint8_t)Chr] < Rad) || ((Chr == sc->number_separator) && (sc->number_separator != '\0'))) -#else - #define is_digit(Chr, Rad) (digits[(uint8_t)Chr] < Rad) -#endif - char c, *p = q; - bool has_dec_point1 = false; - - c = *p++; - switch (c) - { - case '#': - /* from string->number, (string->number #xc) */ - return(make_sharp_constant(sc, p, with_error, NULL, false)); /* make_sharp_constant expects the '#' to be removed */ - - case '+': - case '-': - c = *p++; - if (c == '.') - { - has_dec_point1 = true; - c = *p++; - } - if (!c) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - if (!is_digit(c, radix)) - { - if (has_dec_point1) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - if (c == 'n') - { - if (local_strcmp(p, "an.0")) /* +nan.0, even if we read -nan.0 -- what's the point of a negative NaN? */ - return(real_NaN); - if ((local_strncmp(p, "an.0", 4)) && /* +nan.0[+/-]...i */ - ((p[4] == '+') || (p[4] == '-'))) - return(nan1_or_bust(sc, NAN, p, q, radix, want_symbol, 4)); - /* read +/-nan. or +/-nan.+/-...i */ - if (local_strncmp(p, "an.", 3)) /* +nan. */ - { - bool overflow = false; - int32_t i; - for (i = 3; is_digit(p[i], 10); i++); - if ((p[i] == '+') || (p[i] == '-')) /* complex case */ - { - int64_t payload = string_to_integer((char *)(p + 3), 10, &overflow); - return(nan1_or_bust(sc, nan_with_payload(payload), p, q, radix, want_symbol, i)); - } - if ((p[i] != '\0') && (!white_space[(uint8_t)(p[i])])) /* check for +nan.0i etc, '\0' is not white_space apparently */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - return(make_nan_with_payload(sc, string_to_integer((char *)(p + 3), 10, &overflow))); - }} - if (c == 'i') - { - if (local_strcmp(p, "nf.0")) /* +inf.0 */ - return((q[0] == '+') ? real_infinity : real_minus_infinity); - if ((local_strncmp(p, "nf.0", 4)) && - ((p[4] == '+') || (p[4] == '-'))) - return(nan1_or_bust(sc, (q[0] == '-') ? -INFINITY : INFINITY, p, q, radix, want_symbol, 4)); - } - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - } - break; - - case '.': - has_dec_point1 = true; - c = *p++; - if ((!c) || (!is_digit(c, radix))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - break; - - case 'n': - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - case 'i': - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - case '0': /* these two are always digits */ - case '1': - break; - - default: - if (!is_digit(c, radix)) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - break; - } - - /* now it's possibly a number -- the first character(s) could be part of a number in the current radix */ - { - char *slash1 = NULL, *slash2 = NULL, *plus = NULL, *ex1 = NULL, *ex2 = NULL; - bool has_i = false, has_dec_point2 = false; - int32_t has_plus_or_minus = 0, current_radix; -#if (!WITH_GMP) - bool overflow = false; /* for string_to_integer */ -#endif - current_radix = radix; /* current_radix is 10 for the exponent portions, but radix for all the rest */ - - for ( ; (c = *p) != 0; ++p) - { - /* what about embedded null? (string->number (string #\1 (integer->char 0) #\0)) - * currently we stop and return 1, but Guile returns #f. - * this also means we can't use substring_uncopied if (string->number (substring...)) - */ - if (!is_digit(c, current_radix)) /* moving this inside the switch statement was much slower */ - { - current_radix = radix; - - switch (c) - { - /* -------- decimal point -------- */ - case '.': - if ((!is_digit(p[1], current_radix)) && - (!is_digit(p[-1], current_radix))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (has_plus_or_minus == 0) - { - if ((has_dec_point1) || (slash1)) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - has_dec_point1 = true; - } - else - { - if ((has_dec_point2) || (slash2)) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - has_dec_point2 = true; - } - continue; - - /* -------- exponent marker -------- */ -#if WITH_EXTRA_EXPONENT_MARKERS - /* 1st 3d-perspective 0.0f 128.0f 3d 1s -- in 2 million lines of public scheme code, not one actual use! */ - case 's': case 'S': - case 'd': case 'D': - case 'f': case 'F': - case 'l': case 'L': -#endif - case 'e': case 'E': - if (current_radix > 10) /* see above */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - /* fall through -- if '@' used, radices>10 are ok */ - - case '@': - current_radix = 10; - - if (((ex1) || - (slash1)) && - (has_plus_or_minus == 0)) /* ee */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (((ex2) || - (slash2)) && - (has_plus_or_minus != 0)) /* 1+1.0ee */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if ((!is_digit(p[-1], radix)) && /* was current_radix but that's always 10! */ - (p[-1] != '.')) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (has_plus_or_minus == 0) - { - ex1 = p; - has_dec_point1 = true; /* decimal point illegal from now on */ - } - else - { - ex2 = p; - has_dec_point2 = true; - } - p++; - if ((*p == '-') || (*p == '+')) p++; - if (is_digit(*p, current_radix)) - continue; - break; - - /* -------- internal + or - -------- */ - case '+': - case '-': - if (has_plus_or_minus != 0) /* already have the separator */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - has_plus_or_minus = (c == '+') ? 1 : -1; - plus = (char *)(p + 1); - /* now check for nan/inf as imaginary part */ - - if ((plus[0] == 'n') && - (local_strncmp(plus, "nan.", 4))) - { - bool overflow = false; - int64_t payload = string_to_integer((char *)(p + 5), 10, &overflow); - /* fprintf(stderr, "\n%s: %s %s %ld %ld\n", __func__, p, q, (intptr_t)(p - q), payload); */ - return(nan2_or_bust(sc, nan_with_payload(payload), q, radix, want_symbol, (intptr_t)(p - q))); - } - if ((plus[0] == 'i') && - (local_strcmp(plus, "inf.0i"))) - return(nan2_or_bust(sc, (c == '+') ? INFINITY : -INFINITY, q, radix, want_symbol, (intptr_t)(p - q))); - continue; - - /* ratio marker */ - case '/': - if ((has_plus_or_minus == 0) && - ((ex1) || - (slash1) || - (has_dec_point1))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if ((has_plus_or_minus != 0) && - ((ex2) || - (slash2) || - (has_dec_point2))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (has_plus_or_minus == 0) - slash1 = (char *)(p + 1); - else slash2 = (char *)(p + 1); - - if ((!is_digit(p[1], current_radix)) || - (!is_digit(p[-1], current_radix))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - continue; - - /* -------- i for the imaginary part -------- */ - case 'i': - if ((has_plus_or_minus != 0) && - (!has_i)) - { - has_i = true; - continue; - } - break; - - default: - break; - } - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - }} - - if ((has_plus_or_minus != 0) && /* that is, we have an internal + or - */ - (!has_i)) /* but no i for the imaginary part */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - -#if WITH_NUMBER_SEPARATOR - if ((sc->number_separator != '\0') && (strchr(q, (int)(sc->number_separator)))) - return(make_symbol_or_number(sc, q, radix, want_symbol)); -#endif - - if (has_i) - { -#if (!WITH_GMP) - s7_double rl = 0.0, im = 0.0; -#else - char e1 = 0, e2 = 0; -#endif - s7_pointer result; - s7_int len = safe_strlen(q); - char ql1, pl1; - - if (q[len - 1] != 'i') - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - /* save original string */ - ql1 = q[len - 1]; - pl1 = (*(plus - 1)); -#if WITH_GMP - if (ex1) {e1 = *ex1; (*ex1) = '@';} /* for mpfr */ - if (ex2) {e2 = *ex2; (*ex2) = '@';} -#endif - /* look for cases like 1+i */ - q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */ - - (*((char *)(plus - 1))) = '\0'; - -#if (!WITH_GMP) - if ((has_dec_point1) || - (ex1)) /* (string->number "1100.1+0.11i" 2) -- need to split into 2 honest reals before passing to non-base-10 str->dbl */ - rl = string_to_double_with_radix(q, radix, ignored); - else /* no decimal point, no exponent, a ratio (1/2+i for example, but 1+2/3i is handled below) */ - { - if (slash1) - { - /* here the overflow could be innocuous if it's in the denominator and the numerator is 0: 0/100000000000000000000000000000000000000 */ - s7_int den, num = string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - den = string_to_integer(slash1, radix, &overflow); - if (den == 0) - rl = NAN; /* real_part if complex */ - else - { - if (num == 0) - { - rl = 0.0; - overflow = false; - } - else - { - if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */ - rl = (long_double)num / (long_double)den; /* no gmp, so we do what we can */ - }}} - else - { - rl = (s7_double)string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - }} - if (rl == -0.0) rl = 0.0; - - if ((has_dec_point2) || - (ex2)) - im = string_to_double_with_radix(plus, radix, ignored); - else - { - if (slash2) /* complex part I think */ - { - /* same as above: 0-0/100000000000000000000000000000000000000i */ - s7_int den, num = string_to_integer(plus, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - den = string_to_integer(slash2, radix, &overflow); - if (den == 0) - im = NAN; - else - { - if (num == 0) - { - im = 0.0; - overflow = false; - } - else - { - if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */ - im = (long_double)num / (long_double)den; - }}} - else - { - im = (s7_double)string_to_integer(plus, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - }} - if ((has_plus_or_minus == -1) && - (im != 0.0)) - im = -im; - result = s7_make_complex(sc, rl, im); -#else - result = string_to_either_complex(sc, q, slash1, ex1, has_dec_point1, plus, slash2, ex2, has_dec_point2, radix, has_plus_or_minus); -#endif - /* restore original string */ - q[len - 1] = ql1; - (*((char *)(plus - 1))) = pl1; -#if WITH_GMP - if (ex1) (*ex1) = e1; - if (ex2) (*ex2) = e2; -#endif - return(result); - } - - /* not complex */ - if ((has_dec_point1) || - (ex1)) - { - s7_pointer result; - if (slash1) /* not complex, so slash and "." is not a number */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - -#if (!WITH_GMP) - result = make_real(sc, string_to_double_with_radix(q, radix, ignored)); -#else - { - char old_e = 0; - if (ex1) - { - old_e = (*ex1); - (*ex1) = '@'; - } - result = string_to_either_real(sc, q, radix); - if (ex1) - (*ex1) = old_e; - } -#endif - return(result); - } - - /* rational */ - if (slash1) -#if (!WITH_GMP) - { - s7_int d, n = string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - d = string_to_integer(slash1, radix, &overflow); - - if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */ - return(int_zero); - if (d == 0) return(real_NaN); - if (overflow) return(make_undefined_bignum(sc, q)); - /* it would be neat to return 1 from 10000000000000000000000000000/10000000000000000000000000000 - * but q is the entire number ('/' included) and slash1 is the stuff after the '/', and every - * big number comes through here, so there's no clean and safe way to check that q == slash1. - */ - return(make_ratio(sc, n, d)); - } -#else - return(string_to_either_ratio(sc, q, slash1, radix)); -#endif - /* integer */ -#if (!WITH_GMP) - { - s7_int x = string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - return(make_integer(sc, x)); - } -#else - return(string_to_either_integer(sc, q, radix)); -#endif - } -} - - -/* -------------------------------- string->number -------------------------------- */ -static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix) -{ - s7_pointer x = make_atom(sc, str, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); - return((is_number(x)) ? x : sc->F); /* only needed because str might start with '#' and not be a number (#t for example) */ -} - -static s7_pointer string_to_number_p_p(s7_scheme *sc, s7_pointer str1) -{ - char *str; - if (!is_string(str1)) - wrong_type_error_nr(sc, sc->string_to_number_symbol, 1, str1, sc->type_names[T_STRING]); - str = (char *)string_value(str1); - return(((!str) || (!(*str))) ? sc->F : string_to_number(sc, str, 10)); -} - -static s7_pointer string_to_number_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer radix1) -{ - s7_int radix; - char *str; - if (!is_string(str1)) - wrong_type_error_nr(sc, sc->string_to_number_symbol, 1, str1, sc->type_names[T_STRING]); - - if (!is_t_integer(radix1)) - wrong_type_error_nr(sc, sc->string_to_number_symbol, 2, radix1, sc->type_names[T_INTEGER]); - radix = integer(radix1); - if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, sc->string_to_number_symbol, int_two, radix1, a_valid_radix_string); - - str = (char *)string_value(str1); - if ((!str) || (!(*str))) - return(sc->F); - return(string_to_number(sc, str, radix)); -} - -static s7_pointer g_string_to_number_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - s7_int radix; - char *str; - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), caller, args, sc->type_names[T_STRING], 1)); - - if (is_pair(cdr(args))) - { - s7_pointer rad = cadr(args); - if (!s7_is_integer(rad)) - return(method_or_bust(sc, rad, caller, args, sc->type_names[T_INTEGER], 2)); - radix = s7_integer_clamped_if_gmp(sc, rad); - if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, caller, int_two, rad, a_valid_radix_string); - } - else radix = 10; - str = (char *)string_value(car(args)); - if ((!str) || (!(*str))) - return(sc->F); - return(string_to_number(sc, str, radix)); -} - -static s7_pointer g_string_to_number(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_number "(string->number str (radix 10)) converts str into a number. \ -If str does not represent a number, string->number returns #f. If 'str' has an embedded radix, \ -the optional 'radix' argument is ignored: (string->number \"#x11\" 2) -> 17 not 3." - #define Q_string_to_number s7_make_signature(sc, 3, \ - s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), \ - sc->is_string_symbol, sc->is_integer_symbol) - return(g_string_to_number_1(sc, args, sc->string_to_number_symbol)); -} - - -/* -------------------------------- abs -------------------------------- */ -static inline s7_pointer abs_p_p(s7_scheme *sc, s7_pointer x) -{ -#if (!WITH_GMP) - if (is_t_integer(x)) - { - if (integer(x) >= 0) return(x); - if (integer(x) > S7_INT64_MIN) return(make_integer(sc, -integer(x))); - } - if (is_t_real(x)) - { - if (is_NaN(real(x))) - return((nan_payload(real(x)) > 0) ? x : real_NaN); /* (abs -nan.0) -> +nan.0?? */ - return((signbit(real(x))) ? make_real(sc, -real(x)) : x); - } -#endif - switch (type(x)) - { - case T_INTEGER: - if (integer(x) >= 0) return(x); -#if WITH_GMP - if (integer(x) == S7_INT64_MIN) - { - x = s7_int_to_big_integer(sc, integer(x)); - mpz_neg(big_integer(x), big_integer(x)); - return(x); - } -#else - if (integer(x) == S7_INT64_MIN) - sole_arg_out_of_range_error_nr(sc, sc->abs_symbol, set_elist_1(sc, x), result_is_too_large_string); -#endif - return(make_integer(sc, -integer(x))); - - case T_RATIO: - if (numerator(x) >= 0) return(x); -#if WITH_GMP && (!POINTER_32) - if (numerator(x) == S7_INT64_MIN) - { - s7_pointer p; - mpz_set_si(sc->mpz_1, S7_INT64_MIN); - mpz_neg(sc->mpz_1, sc->mpz_1); - mpz_set_si(sc->mpz_2, denominator(x)); - new_cell(sc, p, T_BIG_RATIO); - big_ratio_bgr(p) = alloc_bigrat(sc); - add_big_ratio(sc, p); - mpq_set_num(big_ratio(p), sc->mpz_1); - mpq_set_den(big_ratio(p), sc->mpz_2); - return(p); - } -#else - if (numerator(x) == S7_INT64_MIN) - return(make_ratio(sc, S7_INT64_MAX, denominator(x))); -#endif - return(make_simple_ratio(sc, -numerator(x), denominator(x))); - - case T_REAL: - if (is_NaN(real(x))) /* (abs -nan.0) -> +nan.0, not -nan.0 */ - return((nan_payload(real(x)) > 0) ? x : real_NaN); - return((signbit(real(x))) ? make_real(sc, -real(x)) : x); /* (abs -0.0) returns -0.0 -- Shiro Kawai */ -#if WITH_GMP - case T_BIG_INTEGER: - mpz_abs(sc->mpz_1, big_integer(x)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_abs(sc->mpq_1, big_ratio(x)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_abs(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif - default: - return(method_or_bust_p(sc, x, sc->abs_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_abs(s7_scheme *sc, s7_pointer args) -{ - #define H_abs "(abs x) returns the absolute value of the real number x" - #define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol) - return(abs_p_p(sc, car(args))); -} - -static s7_double abs_d_d(s7_double x) {return((signbit(x)) ? (-x) : x);} -static s7_int abs_i_i(s7_int x) {return((x < 0) ? (-x) : x);} - - -/* -------------------------------- magnitude -------------------------------- */ -static double my_hypot(double x, double y) -{ - /* according to callgrind, this is much faster than libc's hypot */ - if (x == 0.0) return(fabs(y)); - if (y == 0.0) return(fabs(x)); - if (x == y) return(1.414213562373095 * fabs(x)); - if (is_NaN(x)) return(x); - if (is_NaN(y)) return(y); - return(sqrt(x * x + y * y)); -} - -static s7_pointer magnitude_p_p(s7_scheme *sc, s7_pointer x) -{ - if (is_t_complex(x)) - return(make_real(sc, my_hypot(real_part(x), imag_part(x)))); /* was reversed? 8-Nov-22 */ - - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == S7_INT64_MIN) return(mostfix); - /* (magnitude -9223372036854775808) -> -9223372036854775808 - * same thing happens in abs, lcm and gcd: (gcd -9223372036854775808) -> -9223372036854775808 - */ - return((integer(x) < 0) ? make_integer(sc, -integer(x)) : x); - case T_RATIO: - return((numerator(x) < 0) ? make_simple_ratio(sc, -numerator(x), denominator(x)) : x); - case T_REAL: - if (is_NaN(real(x))) /* (magnitude -nan.0) -> +nan.0, not -nan.0 */ - return((nan_payload(real(x)) > 0) ? x : real_NaN); - return((signbit(real(x))) ? make_real(sc, -real(x)) : x); -#if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: - case T_BIG_REAL: - return(abs_p_p(sc, x)); - case T_BIG_COMPLEX: - mpc_abs(sc->mpfr_1, big_complex(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->magnitude_symbol, a_number_string)); - } -} - -static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args) -{ - #define H_magnitude "(magnitude z) returns the magnitude of z" - #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - return(magnitude_p_p(sc, car(args))); -} - -static s7_int magnitude_i_i(s7_int x) {return((x < 0) ? (-x) : x);} -static s7_double magnitude_d_d(s7_double x) {return((signbit(x)) ? (-x) : x);} - - -/* -------------------------------- rationalize -------------------------------- */ -#if WITH_GMP - -static rat_locals_t *init_rat_locals_t(s7_scheme *sc) -{ - rat_locals_t *r = (rat_locals_t *)Malloc(sizeof(rat_locals_t)); - sc->ratloc = r; - mpz_inits(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, r->q1, r->old_p1, r->old_q1, NULL); - mpq_init(r->q); - mpfr_inits2(sc->bignum_precision, r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL); - return(r); -} - -static void free_rat_locals(s7_scheme *sc) -{ - rat_locals_t *r = sc->ratloc; - mpz_clears(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, r->q1, r->old_p1, r->old_q1, NULL); - mpq_clear(r->q); - mpfr_clears(r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL); - free(r); -} - -static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args) -{ - /* can return be non-rational? */ - /* currently (rationalize 1/0 1e18) -> 0 - * remember to pad with many trailing zeros: - * (rationalize 0.1 0) -> 3602879701896397/36028797018963968 - * (rationalize 0.1000000000000000 0) -> 1/10 - * perhaps gmp number reader used if gmp -- could this be the trailing zeros problem? (why is the non-gmp case ok?) - * also the bignum function is faking it. - * (rationalize (real-part (bignum "0.1+i")) 0) -> 3602879701896397/36028797018963968 - * a confusing case: - * (rationalize 5925563891587147521650777143.74135805596e05) should be 148139097289678688041269428593533951399/250000 - * but that requires more than 128 bits of bignum-precision. - */ - - s7_pointer pp0 = car(args); - rat_locals_t *r = (sc->ratloc) ? sc->ratloc : init_rat_locals_t(sc); - - switch (type(pp0)) - { - case T_INTEGER: - mpfr_set_si(r->ux, integer(pp0), MPFR_RNDN); - break; - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(pp0), denominator(pp0)); - mpfr_set_q(r->ux, sc->mpq_1, MPFR_RNDN); - break; - case T_REAL: - if (is_NaN(real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_nan_string); - if (is_inf(real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_infinite_string); - mpfr_set_d(r->ux, real(pp0), MPFR_RNDN); - break; - case T_BIG_INTEGER: - mpfr_set_z(r->ux, big_integer(pp0), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(r->ux, big_ratio(pp0), MPFR_RNDN); - break; - case T_BIG_REAL: - if (mpfr_nan_p(big_real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_nan_string); - if (mpfr_inf_p(big_real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_infinite_string); - mpfr_set(r->ux, big_real(pp0), MPFR_RNDN); - break; - case T_COMPLEX: - case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->rationalize_symbol, 1, pp0, sc->type_names[T_REAL]); - default: - return(method_or_bust(sc, pp0, sc->rationalize_symbol, args, sc->type_names[T_REAL], 1)); - } - - if (is_null(cdr(args))) - mpfr_set_d(r->error, sc->default_rationalize_error, MPFR_RNDN); - else - { - s7_pointer pp1 = cadr(args); - switch (type(pp1)) - { - case T_INTEGER: - mpfr_set_si(r->error, integer(pp1), MPFR_RNDN); - break; - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(pp1), denominator(pp1)); - mpfr_set_q(r->error, sc->mpq_1, MPFR_RNDN); - break; - case T_REAL: - if (is_NaN(real(pp1))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, pp1, it_is_nan_string); - if (is_inf(real(pp1))) - return(int_zero); - mpfr_set_d(r->error, real(pp1), MPFR_RNDN); - break; - case T_BIG_INTEGER: - mpfr_set_z(r->error, big_integer(pp1), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(r->error, big_ratio(pp1), MPFR_RNDN); - break; - case T_BIG_REAL: - if (mpfr_nan_p(big_real(pp1))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, pp1, it_is_nan_string); - if (mpfr_inf_p(big_real(pp1))) - return(int_zero); - mpfr_set(r->error, big_real(pp1), MPFR_RNDN); - break; - case T_COMPLEX: - case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->rationalize_symbol, 2, pp1, sc->type_names[T_REAL]); - default: - return(method_or_bust(sc, pp1, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2)); - } - mpfr_abs(r->error, r->error, MPFR_RNDN); - } - - mpfr_set(r->x0, r->ux, MPFR_RNDN); /* x0 = ux - error */ - mpfr_sub(r->x0, r->x0, r->error, MPFR_RNDN); - mpfr_set(r->x1, r->ux, MPFR_RNDN); /* x1 = ux + error */ - mpfr_add(r->x1, r->x1, r->error, MPFR_RNDN); - mpfr_get_z(r->i, r->x0, MPFR_RNDU); /* i = ceil(x0) */ - - if (mpfr_cmp_ui(r->error, 1) >= 0) /* if (error >= 1.0) */ - { - if (mpfr_cmp_ui(r->x0, 0) < 0) /* if (x0 < 0) */ - { - if (mpfr_cmp_ui(r->x1, 0) < 0) /* if (x1 < 0) */ - mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* num = floor(x1) */ - else mpz_set_ui(r->n, 0); /* else num = 0 */ - } - else mpz_set(r->n, r->i); /* else num = i */ - return(mpz_to_integer(sc, r->n)); - } - - if (mpfr_cmp_z(r->x1, r->i) >= 0) /* if (x1 >= i) */ - { - if (mpz_cmp_ui(r->i, 0) >= 0) /* if (i >= 0) */ - mpz_set(r->n, r->i); /* num = i */ - else mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* else num = floor(x1) */ - return(mpz_to_integer(sc, r->n)); - } - - mpfr_get_z(r->i0, r->x0, MPFR_RNDD); /* i0 = floor(x0) */ - mpfr_get_z(r->i1, r->x1, MPFR_RNDU); /* i1 = ceil(x1) */ - - mpz_set(r->p0, r->i0); /* p0 = i0 */ - mpz_set_ui(r->q0, 1); /* q0 = 1 */ - mpz_set(r->p1, r->i1); /* p1 = i1 */ - mpz_set_ui(r->q1, 1); /* q1 = 1 */ - mpfr_sub_z(r->e0, r->x0, r->i1, MPFR_RNDN); /* e0 = i1 - x0 */ - mpfr_neg(r->e0, r->e0, MPFR_RNDN); - mpfr_sub_z(r->e1, r->x0, r->i0, MPFR_RNDN); /* e1 = x0 - i0 */ - mpfr_sub_z(r->e0p, r->x1, r->i1, MPFR_RNDN); /* e0p = i1 - x1 */ - mpfr_neg(r->e0p, r->e0p, MPFR_RNDN); - mpfr_sub_z(r->e1p, r->x1, r->i0, MPFR_RNDN); /* e1p = x1 - i0 */ - - while (true) - { - mpfr_set_z(r->val, r->p0, MPFR_RNDN); - mpfr_div_z(r->val, r->val, r->q0, MPFR_RNDN); /* val = p0/q0 */ - - if (((mpfr_lessequal_p(r->x0, r->val)) && /* if ((x0 <= val) && (val <= x1)) */ - (mpfr_lessequal_p(r->val, r->x1))) || - (mpfr_cmp_ui(r->e1, 0) == 0) || - (mpfr_cmp_ui(r->e1p, 0) == 0)) - /* these last 2 are probably not needed -- they protect against running out of bits in the non-gmp case above */ - { - mpq_set_num(r->q, r->p0); /* return(p0/q0) */ - mpq_set_den(r->q, r->q0); - return(mpq_to_rational(sc, r->q)); - } - - mpfr_div(r->val, r->e0, r->e1, MPFR_RNDN); - mpfr_get_z(r->r, r->val, MPFR_RNDD); /* r = floor(e0/e1) */ - mpfr_div(r->val, r->e0p, r->e1p, MPFR_RNDN); - mpfr_get_z(r->r1, r->val, MPFR_RNDU); /* r1 = ceil(e0p/e1p) */ - if (mpz_cmp(r->r1, r->r) < 0) /* if (r1 < r) */ - mpz_set(r->r, r->r1); /* r = r1 */ - - mpz_set(r->old_p1, r->p1); /* old_p1 = p1 */ - mpz_set(r->p1, r->p0); /* p1 = p0 */ - mpz_set(r->old_q1, r->q1); /* old_q1 = q1 */ - mpz_set(r->q1, r->q0); /* q1 = q0 */ - - mpfr_set(r->old_e0, r->e0, MPFR_RNDN); /* old_e0 = e0 */ - mpfr_set(r->e0, r->e1p, MPFR_RNDN); /* e0 = e1p */ - mpfr_set(r->old_e0p, r->e0p, MPFR_RNDN); /* old_e0p = e0p */ - mpfr_set(r->e0p, r->e1, MPFR_RNDN); /* e0p = e1 */ - mpfr_set(r->old_e1, r->e1, MPFR_RNDN); /* old_e1 = e1 */ - - mpz_mul(r->p0, r->p0, r->r); /* p0 = old_p1 + r * p0 */ - mpz_add(r->p0, r->p0, r->old_p1); - - mpz_mul(r->q0, r->q0, r->r); /* q0 = old_q1 + r * q0 */ - mpz_add(r->q0, r->q0, r->old_q1); - - mpfr_mul_z(r->e1, r->e1p, r->r, MPFR_RNDN); /* e1 = old_e0p - r * e1p */ - mpfr_sub(r->e1, r->old_e0p, r->e1, MPFR_RNDN); - - mpfr_mul_z(r->e1p, r->old_e1, r->r, MPFR_RNDN);/* e1p = old_e0 - r * old_e1 */ - mpfr_sub(r->e1p, r->old_e0, r->e1p, MPFR_RNDN); - } -} -#endif - -static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args) -{ - #define H_rationalize "(rationalize x err) returns the ratio with smallest denominator within err of x" - #define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol) - /* I can't find a case where this returns a non-rational result */ - - s7_double err; - s7_pointer x = car(args); - -#if WITH_GMP - if (is_big_number(x)) - return(big_rationalize(sc, args)); -#endif - if (!is_real(x)) - return(method_or_bust(sc, x, sc->rationalize_symbol, args, sc->type_names[T_REAL], 1)); - - if (is_null(cdr(args))) - err = sc->default_rationalize_error; - else - { - s7_pointer ex = cadr(args); -#if WITH_GMP - if (is_big_number(ex)) - return(big_rationalize(sc, args)); -#endif - if (!is_real(ex)) - return(method_or_bust(sc, ex, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2)); - err = real_to_double(sc, ex, "rationalize"); - if (is_NaN(err)) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, cadr(args), it_is_nan_string); - if (err < 0.0) err = -err; - } - - switch (type(x)) - { - case T_INTEGER: - { - s7_int a, b, pa; - if (err < 1.0) return(x); - a = integer(x); - pa = (a < 0) ? -a : a; - if (err >= pa) return(int_zero); - b = (s7_int)err; - pa -= b; - return(make_integer(sc, (a < 0) ? -pa : pa)); - } - - case T_RATIO: - if (err == 0.0) - return(x); - - case T_REAL: - { - s7_double rat = s7_real(x); /* possible fall through from above */ - s7_int numer = 0, denom = 1; - - if ((is_NaN(rat)) || (is_inf(rat))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, x, a_normal_real_string); - - if (err >= fabs(rat)) - return(int_zero); - -#if WITH_GMP - if (fabs(rat) > RATIONALIZE_LIMIT) - return(big_rationalize(sc, set_plist_2(sc, x, wrap_real(sc, err)))); -#else - if (fabs(rat) > RATIONALIZE_LIMIT) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, x, it_is_too_large_string); -#endif - if ((fabs(rat) + fabs(err)) < 1.0e-18) - err = 1.0e-18; - /* (/ 1.0 most-positive-fixnum) is 1.0842021e-19, so if we let err be less than that, - * (rationalize 1e-19 1e-20) hangs, but this only affects the initial ceiling, I believe. - */ - - if (fabs(rat) < fabs(err)) - return(int_zero); - - return((c_rationalize(rat, err, &numer, &denom)) ? make_ratio(sc, numer, denom) : sc->F); - }} - return(sc->F); /* make compiler happy */ -} - -static s7_int rationalize_i_i(s7_int x) {return(x);} -static s7_pointer rationalize_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));} -static s7_pointer rationalize_p_d(s7_scheme *sc, s7_double x) -{ - if ((is_NaN(x)) || (is_inf(x))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, wrap_real(sc, x), a_normal_real_string); /* was make_real, also below */ - if (fabs(x) > RATIONALIZE_LIMIT) -#if WITH_GMP - return(big_rationalize(sc, set_plist_1(sc, wrap_real(sc, x)))); -#else - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, wrap_real(sc, x), it_is_too_large_string); -#endif - return(s7_rationalize(sc, x, sc->default_rationalize_error)); -} - - -/* -------------------------------- angle -------------------------------- */ -static s7_pointer g_angle(s7_scheme *sc, s7_pointer args) -{ - #define H_angle "(angle z) returns the angle of z" - #define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - - s7_pointer x = car(args); /* (angle inf+infi) -> 0.78539816339745 ? I think this should be -pi < ang <= pi */ - switch (type(x)) - { - case T_INTEGER: return((integer(x) < 0) ? real_pi : int_zero); - case T_RATIO: return((numerator(x) < 0) ? real_pi : int_zero); - case T_COMPLEX: return(make_real(sc, atan2(imag_part(x), real_part(x)))); - - case T_REAL: - if (is_NaN(real(x))) return(x); - return((real(x) < 0.0) ? real_pi : real_zero); -#if WITH_GMP - case T_BIG_INTEGER: return((mpz_cmp_ui(big_integer(x), 0) >= 0) ? int_zero : big_pi(sc)); - case T_BIG_RATIO: return((mpq_cmp_ui(big_ratio(x), 0, 1) >= 0) ? int_zero : big_pi(sc)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_d(big_real(x), 0.0) >= 0) ? real_zero : big_pi(sc)); - case T_BIG_COMPLEX: - { - s7_pointer z; - new_cell(sc, z, T_BIG_REAL); - big_real_bgf(z) = alloc_bigflt(sc); - add_big_real(sc, z); - mpc_arg(big_real(z), big_complex(x), MPFR_RNDN); - return(z); - } -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->angle_symbol, a_number_string)); - } -} - - -/* -------------------------------- complex -------------------------------- */ - -static s7_pointer complex_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ -#if WITH_GMP - if ((is_big_number(x)) || (is_big_number(y))) - { - s7_pointer p0 = x, p1 = y, p = NULL; - - if (!is_real(p0)) - return(method_or_bust(sc, p0, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - if (!is_real(p1)) - return(method_or_bust(sc, p1, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2)); - - switch (type(p1)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - { - s7_double iz = s7_real(p1); - if (iz == 0.0) /* imag-part is 0.0 */ - return(p0); - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set_d(mpc_imagref(big_complex(p)), iz, MPFR_RNDN); - } - break; - case T_BIG_REAL: - if (mpfr_zero_p(big_real(p1))) return(p0); - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set(mpc_imagref(big_complex(p)), big_real(p1), MPFR_RNDN); - break; - case T_BIG_RATIO: - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set_q(mpc_imagref(big_complex(p)), big_ratio(p1), MPFR_RNDN); - break; - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(p1), 0) == 0) return(p0); - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set_z(mpc_imagref(big_complex(p)), big_integer(p1), MPFR_RNDN); - break; - } - switch (type(p0)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - mpfr_set_d(mpc_realref(big_complex(p)), s7_real(p0), MPFR_RNDN); - break; - case T_BIG_REAL: - mpfr_set(mpc_realref(big_complex(p)), big_real(p0), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(mpc_realref(big_complex(p)), big_ratio(p0), MPFR_RNDN); - break; - case T_BIG_INTEGER: - mpfr_set_z(mpc_realref(big_complex(p)), big_integer(p0), MPFR_RNDN); - break; - } - add_big_complex(sc, p); - return(p); - } -#endif - switch (type(y)) - { - case T_INTEGER: - switch (type(x)) - { - case T_INTEGER: return((integer(y) == 0) ? x : s7_make_complex(sc, (s7_double)integer(x), (s7_double)integer(y))); - /* these int->dbl's are problematic: - * (complex 9223372036854775807 9007199254740995): 9223372036854776000.0+9007199254740996.0i - * should we raise an error? - */ - case T_RATIO: return((integer(y) == 0) ? x : s7_make_complex(sc, (s7_double)fraction(x), (s7_double)integer(y))); - case T_REAL: return((integer(y) == 0) ? x : s7_make_complex(sc, real(x), (s7_double)integer(y))); - default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - } - case T_RATIO: - switch (type(x)) - { - case T_INTEGER: return(s7_make_complex(sc, (s7_double)integer(x), (s7_double)fraction(y))); /* can fraction be 0.0? */ - case T_RATIO: return(s7_make_complex(sc, (s7_double)fraction(x), (s7_double)fraction(y))); - case T_REAL: return(s7_make_complex(sc, real(x), (s7_double)fraction(y))); - default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - } - case T_REAL: - switch (type(x)) - { - case T_INTEGER: return((real(y) == 0.0) ? x : s7_make_complex(sc, (s7_double)integer(x), real(y))); - case T_RATIO: return((real(y) == 0.0) ? x : s7_make_complex(sc, (s7_double)fraction(x), real(y))); - case T_REAL: return((real(y) == 0.0) ? x : s7_make_complex(sc, real(x), real(y))); - default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - } - default: - return(method_or_bust(sc, (is_let(x)) ? x : y, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2)); - } -} - -static s7_pointer g_complex(s7_scheme *sc, s7_pointer args) -{ - #define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2" - #define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol) - return(complex_p_pp(sc, car(args), cadr(args))); -} - -static s7_pointer complex_p_ii(s7_scheme *sc, s7_int x, s7_int y) -{ - return((y == 0.0) ? make_integer(sc, x) : make_complex_not_0i(sc, (s7_double)x, (s7_double)y)); -} - -static s7_pointer complex_p_dd(s7_scheme *sc, s7_double x, s7_double y) -{ - return((y == 0.0) ? make_real(sc, x) : make_complex_not_0i(sc, x, y)); -} - - -/* -------------------------------- bignum -------------------------------- */ -static s7_pointer g_bignum(s7_scheme *sc, s7_pointer args) -{ - #define H_bignum "(bignum val (radix 10)) returns a multiprecision version of the string 'val'. If the argument is a number \ -bignum returns that number as a bignum" -#if WITH_GMP - #define Q_bignum s7_make_signature(sc, 3, sc->is_bignum_symbol, s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), sc->is_integer_symbol) -#else - #define Q_bignum s7_make_signature(sc, 3, \ - s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), \ - sc->is_integer_symbol) -#endif - - s7_pointer p = car(args); - if (is_number(p)) - { - if (!is_null(cdr(args))) - error_nr(sc, make_symbol(sc, "bignum-error", 12), - set_elist_2(sc, wrap_string(sc, "bignum of a number takes only one argument: ~S", 46), args)); -#if WITH_GMP - switch (type(p)) - { - case T_INTEGER: return(s7_int_to_big_integer(sc, integer(p))); - case T_RATIO: return(s7_int_to_big_ratio(sc, numerator(p), denominator(p))); - case T_REAL: return(s7_double_to_big_real(sc, real(p))); - case T_COMPLEX: return(s7_double_to_big_complex(sc, real_part(p), imag_part(p))); - default: return(p); - } -#else - return(p); -#endif - } - p = g_string_to_number_1(sc, args, sc->bignum_symbol); - if (is_false(sc, p)) /* (bignum "1/3.0") */ - error_nr(sc, make_symbol(sc, "bignum-error", 12), - set_elist_2(sc, wrap_string(sc, "bignum string argument does not represent a number: ~S", 54), car(args))); -#if WITH_GMP - switch (type(p)) - { - case T_INTEGER: return(s7_int_to_big_integer(sc, integer(p))); - case T_RATIO: return(s7_int_to_big_ratio(sc, numerator(p), denominator(p))); - case T_COMPLEX: return(s7_number_to_big_complex(sc, p)); - case T_REAL: - if (is_NaN(real(p))) return(p); - return(s7_double_to_big_real(sc, real(p))); - /* 9Sep21: this was return(string_to_big_real(sc, string_value(car(args)), (is_pair(cdr(args))) ? s7_integer_clamped_if_gmp(sc, cadr(args)) : 10)); */ - default: - return(p); - } -#else - return(p); -#endif -} - - -/* -------------------------------- exp -------------------------------- */ -#if (!HAVE_COMPLEX_NUMBERS) - static s7_pointer no_complex_numbers_string; -#endif - -#define EXP_LIMIT 100.0 - -#if WITH_GMP -static s7_pointer exp_1(s7_scheme *sc, s7_double x) -{ - mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN); - mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -} - -static s7_pointer exp_2(s7_scheme *sc, s7_double x, s7_double y) -{ - mpc_set_d_d(sc->mpc_1, x, y, MPC_RNDNN); - mpc_exp(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -} -#endif - -static s7_pointer exp_p_p(s7_scheme *sc, s7_pointer x) -{ - s7_double z; - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_one); /* (exp 0) -> 1 */ - z = (s7_double)integer(x); -#if WITH_GMP - if (fabs(z) > EXP_LIMIT) - return(exp_1(sc, z)); -#endif - return(make_real(sc, exp(z))); - - case T_RATIO: - z = (s7_double)fraction(x); -#if WITH_GMP - if (fabs(z) > EXP_LIMIT) - return(exp_1(sc, z)); -#endif - return(make_real(sc, exp(z))); - - case T_REAL: -#if WITH_GMP - if (fabs(real(x)) > EXP_LIMIT) - return(exp_1(sc, real(x))); -#endif - return(make_real(sc, exp(real(x)))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS -#if WITH_GMP - if ((fabs(real_part(x)) > EXP_LIMIT) || - (fabs(imag_part(x)) > EXP_LIMIT)) - return(exp_2(sc, real_part(x), imag_part(x))); -#endif - return(c_complex_to_s7(sc, cexp(to_c_complex(x)))); - /* this is inaccurate for large arguments: - * (exp 0+1e20i) -> -0.66491178990701-0.74692189125949i, not 7.639704044417283004001468027378811228331E-1-6.45251285265780844205811711312523007406E-1i - */ -#else - out_of_range_error_nr(sc, sc->exp_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_exp(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_exp(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->exp_symbol, a_number_string)); - } -} - -static s7_pointer g_exp(s7_scheme *sc, s7_pointer args) -{ - #define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459" - #define Q_exp sc->pl_nn - return(exp_p_p(sc, car(args))); -} - -static s7_double exp_d_d(s7_double x) {return(exp(x));} -static s7_pointer exp_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, exp(x)));} - - -/* -------------------------------- log -------------------------------- */ -#if __cplusplus -#define LOG_2 1.4426950408889634074 -#else -#define LOG_2 1.4426950408889634073599246810018921L /* (/ (log 2.0)) */ -#endif - -#if WITH_GMP -static s7_pointer big_log(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p0 = car(args), p1 = NULL, res; - - if (!is_number(p0)) - return(method_or_bust(sc, p0, sc->log_symbol, args, a_number_string, 1)); - - if (is_pair(cdr(args))) - { - p1 = cadr(args); - if (!is_number(p1)) - return(method_or_bust(sc, p1, sc->log_symbol, args, a_number_string, 2)); - } - - if (is_real(p0)) - { - res = any_real_to_mpfr(sc, p0, sc->mpfr_1); - if (res == real_NaN) return(res); - if ((is_positive(sc, p0)) && - ((!p1) || - ((is_real(p1)) && (is_positive(sc, p1))))) - { - if (res) return(res); - mpfr_log(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - if (p1) - { - res = any_real_to_mpfr(sc, p1, sc->mpfr_2); - if (res) - return((res == real_infinity) ? real_zero : res); - if (mpfr_zero_p(sc->mpfr_2)) - out_of_range_error_nr(sc, sc->log_symbol, int_two, p1, wrap_string(sc, "can't be zero", 13)); - mpfr_log(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - } - if ((mpfr_integer_p(sc->mpfr_1)) && ((is_rational(p0)) && ((!p1) || (is_rational(p1))))) - return(mpfr_to_integer(sc, sc->mpfr_1)); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - }} - if (p1) - { - res = any_number_to_mpc(sc, p1, sc->mpc_2); - if (res) - return((res == real_infinity) ? real_zero : complex_NaN); - if (mpc_zero_p(sc->mpc_2)) - out_of_range_error_nr(sc, sc->log_symbol, int_two, p1, wrap_string(sc, "can't be zero", 13)); - } - res = any_number_to_mpc(sc, p0, sc->mpc_1); - if (res) - { - if ((res == real_infinity) && (p1) && ((is_negative(sc, p0)))) - return(make_complex_not_0i(sc, INFINITY, -NAN)); - return((res == real_NaN) ? complex_NaN : res); - } - mpc_log(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - if (p1) - { - mpc_log(sc->mpc_2, sc->mpc_2, MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - } - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -} -#endif - -static s7_pointer g_int_log2(s7_scheme *sc, s7_pointer args) -{ - s7_int ix = integer(car(args)); - s7_double fx = log2((double)ix); - return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx)); -} - -static s7_pointer g_log(s7_scheme *sc, s7_pointer args) -{ - #define H_log "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults to e: (log 8 2) = 3" - #define Q_log sc->pcl_n - - s7_pointer x = car(args); - -#if WITH_GMP - if (is_big_number(x)) return(big_log(sc, args)); -#endif - - if (!is_number(x)) - return(method_or_bust(sc, x, sc->log_symbol, args, a_number_string, 1)); - - if (is_pair(cdr(args))) - { - s7_pointer y = cadr(args); - if (!(is_number(y))) - return(method_or_bust(sc, y, sc->log_symbol, args, a_number_string, 2)); - -#if WITH_GMP - if (is_big_number(y)) return(big_log(sc, args)); -#endif - if ((is_t_integer(y)) && (integer(y) == 2)) - { - /* (define (2^n? x) (and (not (zero? x)) (zero? (logand x (- x 1))))) */ - if (is_t_integer(x)) - { - s7_int ix = integer(x); - if (ix > 0) - { - s7_double fx; -#if (__ANDROID__) || (MS_WINDOWS) || (((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ <= 4)))) && (!defined(__clang__))) - /* just a guess -- log2 gets a warning in gcc 4.3.2, but not in 4.4.4 */ - fx = log((double)ix) * LOG_2; -#else - fx = log2((double)ix); -#endif - /* (s7_int)fx rounds (log 8 2) to 2 in FreeBSD! */ -#if (((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 4)))) && (!defined(__clang__))) - return(make_real(sc, fx)); -#else - return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx)); -#endif - }} - if ((is_real(x)) && - (is_positive(sc, x))) - return(make_real(sc, log(s7_real(x)) * LOG_2)); - return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) * LOG_2)); - } - - if ((is_t_integer(x)) && (integer(x) == 1) && (is_t_integer(y)) && (integer(y) == 1)) /* (log 1 1) -> 0 (this is NaN in the bignum case) */ - return(int_zero); - - /* (log 1 0) must be 0 since everyone says (expt 0 0) is 1 */ - if (is_zero(y)) - { - if ((is_t_integer(y)) && (is_t_integer(x)) && (integer(x) == 1)) - return(y); - out_of_range_error_nr(sc, sc->log_symbol, int_two, y, wrap_string(sc, "can't be zero", 13)); - } - - if ((is_t_real(x)) && (is_NaN(real(x)))) - return(x); - if (is_one(y)) /* this used to raise an error, but the bignum case is simpler if we return inf */ - return((is_one(x)) ? real_zero : real_infinity); /* but (log 1.0 1.0) -> 0.0, currently (log 1/0 1) is inf? */ - - if ((is_real(x)) && - (is_real(y)) && - (is_positive(sc, x)) && - (is_positive(sc, y))) - { - if ((is_rational(x)) && - (is_rational(y))) - { - s7_double res = log(rational_to_double(sc, x)) / log(rational_to_double(sc, y)); - s7_int ires = (s7_int)res; - if (res - ires == 0.0) - return(make_integer(sc, ires)); /* (log 8 2) -> 3 or (log 1/8 2) -> -3 */ - /* since x and y are rational here, it seems reasonable to try to rationalize the result, but not go overboard? - * what about (expt 16 3/2) -> 64? also 2 as base is handled above and always returns a float. - */ - if (fabs(res) < RATIONALIZE_LIMIT) - { - s7_int num, den; - if ((c_rationalize(res, sc->default_rationalize_error, &num, &den)) && - (s7_int_abs(num) < 100) && (s7_int_abs(den) < 100)) - return(make_simple_ratio(sc, num, den)); - } - return(make_real(sc, res)); - } - return(make_real(sc, log(s7_real(x)) / log(s7_real(y)))); - } - if ((is_t_real(x)) && (is_NaN(real(x)))) - return(x); - if ((is_t_complex(y)) && ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))))) - return(y); - return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) / clog(s7_to_c_complex(y)))); - } - - if (!is_real(x)) - return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)))); - if (is_positive(sc, x)) - return(make_real(sc, log(s7_real(x)))); - return(make_complex_not_0i(sc, log(-s7_real(x)), M_PI)); -} - -static s7_pointer log_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ -#if (!WITH_GMP) - if (args == 2) - { - s7_pointer x = cadr(expr), y = caddr(expr); - if ((is_t_integer(y)) && (integer(y) == 2) && (is_t_integer(x)) && (integer(x) > 0)) - return(sc->int_log2); - } -#endif - return(f); -} - -/* -------------------------------- sin -------------------------------- */ -#define SIN_LIMIT 1.0e16 -#define SINH_LIMIT 20.0 -/* (- (sinh (bignum 30.0)) (sinh 30.0)): -3.718172657214174140191915872003397016115E-4 - * (- (sinh (bignum 20.0)) (sinh 20.0)): -7.865629467297586346406367346575835463792E-10, slightly worse (e-8) if imag-part - */ - -static s7_pointer sin_p_p(s7_scheme *sc, s7_pointer x) -{ -#if (!WITH_GMP) - if (is_t_real(x)) return(make_real(sc, sin(real(x)))); /* range check in gmp case */ -#endif - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_zero); /* (sin 0) -> 0 */ -#if WITH_GMP - if (integer(x) > SIN_LIMIT) - { - mpz_set_si(sc->mpz_1, integer(x)); - mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, sin((s7_double)(integer(x))))); /* bogus for very large integers, but so is the equivalent real (see SIN_LIMIT) */ - - case T_RATIO: - return(make_real(sc, sin((s7_double)(fraction(x))))); - - case T_REAL: - { - s7_double y = real(x); -#if WITH_GMP - if (fabs(y) > SIN_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, sin(y))); - } - - case T_COMPLEX: -#if WITH_GMP - if ((fabs(real_part(x)) > SIN_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sin(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } -#endif -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, csin(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->sin_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_sin(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_sin(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->sin_symbol, a_number_string)); - } - /* sin is inaccurate over about 1e30. There's a way to get true results, but it involves fancy "range reduction" techniques. - * (sin 1e32): 0.5852334864823946 - * but it should be 3.901970254333630491697613212893425767786E-1 - * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 !! (it's now a range error) - * it should be 5.263007914620499494429139986095833592117E0 - * before comparing imag-part to 0, we need to look for NaN and inf, else: - * (sinh 0+0/0i) -> 0.0 and (sinh (log 0.0)) -> inf.0 - */ -} - -static s7_pointer g_sin(s7_scheme *sc, s7_pointer args) -{ - #define H_sin "(sin z) returns sin(z)" - #define Q_sin sc->pl_nn - return(sin_p_p(sc, car(args))); -} - -#if WITH_GMP -static s7_pointer sin_p_d(s7_scheme *sc, s7_double x) -{ - if (fabs(x) <= SIN_LIMIT) - return(make_real(sc, sin(x))); - mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -} -#else -static s7_pointer sin_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, sin(x)));} -#endif - -static s7_double sin_d_d(s7_double x) {return(sin(x));} - - -/* -------------------------------- cos -------------------------------- */ -static s7_pointer cos_p_p(s7_scheme *sc, s7_pointer x) -{ -#if (!WITH_GMP) - if (is_t_real(x)) return(make_real(sc, cos(real(x)))); /* range check in gmp case */ -#endif - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_one); /* (cos 0) -> 1 */ -#if WITH_GMP - if (integer(x) > SIN_LIMIT) - { - mpz_set_si(sc->mpz_1, integer(x)); - mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, cos((s7_double)(integer(x))))); - - case T_RATIO: - return(make_real(sc, cos((s7_double)(fraction(x))))); - - case T_REAL: /* if with_gmp */ - { - s7_double y = real(x); -#if WITH_GMP - if (fabs(y) > SIN_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, cos(y))); - } - - case T_COMPLEX: -#if WITH_GMP - if ((fabs(real_part(x)) > SIN_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_cos(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } -#endif -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, ccos(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->cos_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_cos(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_cos(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->cos_symbol, a_number_string)); - } -} - -static s7_pointer g_cos(s7_scheme *sc, s7_pointer args) -{ - #define H_cos "(cos z) returns cos(z)" - #define Q_cos sc->pl_nn - return(cos_p_p(sc, car(args))); -} - -#if WITH_GMP -static s7_pointer cos_p_d(s7_scheme *sc, s7_double x) -{ - if (fabs(x) <= SIN_LIMIT) - return(make_real(sc, cos(x))); - mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -} -#else -static s7_pointer cos_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, cos(x)));} -#endif - -static s7_double cos_d_d(s7_double x) {return(cos(x));} - - -/* -------------------------------- tan -------------------------------- */ -#define TAN_LIMIT 1.0e18 - -static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x) -{ -#if (!WITH_GMP) - if (is_t_real(x)) return(make_real(sc, tan(real(x)))); -#endif - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_zero); /* (tan 0) -> 0 */ -#if WITH_GMP - if (integer(x) > TAN_LIMIT) - { - mpz_set_si(sc->mpz_1, integer(x)); - mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, tan((s7_double)(integer(x))))); - - case T_RATIO: - return(make_real(sc, tan((s7_double)(fraction(x))))); - -#if WITH_GMP - case T_REAL: - if (fabs(real(x)) > TAN_LIMIT) - { - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, tan(real(x)))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - if (imag_part(x) > 350.0) - return(make_complex_not_0i(sc, 0.0, 1.0)); - return((imag_part(x) < -350.0) ? s7_make_complex(sc, 0.0, -1.0) : c_complex_to_s7(sc, ctan(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->tan_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_tan(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, 350))) > 0) - return(make_complex_not_0i(sc, 0.0, 1.0)); - if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, -350))) < 0) - return(make_complex_not_0i(sc, 0.0, -1.0)); - mpc_tan(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->tan_symbol, a_number_string)); - } -} - -static s7_pointer g_tan(s7_scheme *sc, s7_pointer args) -{ - #define H_tan "(tan z) returns tan(z)" - #define Q_tan sc->pl_nn - return(tan_p_p(sc, car(args))); -} - -static s7_double tan_d_d(s7_double x) {return(tan(x));} - - -/* -------------------------------- asin -------------------------------- */ -static s7_pointer c_asin(s7_scheme *sc, s7_double x) -{ - s7_double absx = fabs(x), recip; - s7_complex result; - - if (absx <= 1.0) - return(make_real(sc, asin(x))); - - /* otherwise use maxima code: */ - recip = 1.0 / absx; - result = (M_PI / 2.0) - (_Complex_I * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip))))); - return((x < 0.0) ? c_complex_to_s7(sc, -result) : c_complex_to_s7(sc, result)); -} - -static s7_pointer asin_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_real(p)) return(c_asin(sc, real(p))); - switch (type(p)) - { - case T_INTEGER: - if (integer(p) == 0) return(int_zero); /* (asin 0) -> 0 */ - /* in netBSD, (asin 2) returns 0.25383842987008+0.25383842987008i according to Peter Bex */ - return(c_asin(sc, (s7_double)integer(p))); - - case T_RATIO: - return(c_asin(sc, fraction(p))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - /* if either real or imag part is very large, use explicit formula, not casin */ - /* this code taken from sbcl's src/code/irrat.lisp; break is around x+70000000i */ - if ((fabs(real_part(p)) > 1.0e7) || - (fabs(imag_part(p)) > 1.0e7)) - { - s7_complex sq1mz, sq1pz, z = to_c_complex(p); - sq1mz = csqrt(1.0 - z); - sq1pz = csqrt(1.0 + z); - return(s7_make_complex(sc, atan(real_part(p) / creal(sq1mz * sq1pz)), asinh(cimag(sq1pz * conj(sq1mz))))); - } - return(c_complex_to_s7(sc, casin(to_c_complex(p)))); -#else - out_of_range_error_nr(sc, sc->asin_symbol, int_one, p, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); - goto ASIN_BIG_REAL; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); - goto ASIN_BIG_REAL; - case T_BIG_REAL: - if (mpfr_inf_p(big_real(p))) - { - if (mpfr_cmp_ui(big_real(p), 0) < 0) - return(make_complex_not_0i(sc, NAN, INFINITY)); /* match non-bignum choice */ - return(make_complex_not_0i(sc, NAN, -INFINITY)); - } - mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); - ASIN_BIG_REAL: - mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN); - if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) - { - mpfr_asin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN); - mpc_asin(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_asin(sc->mpc_1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->asin_symbol, a_number_string)); - } -} - -static s7_pointer g_asin(s7_scheme *sc, s7_pointer args) -{ - #define H_asin "(asin z) returns asin(z); (sin (asin x)) = x" - #define Q_asin sc->pl_nn - return(asin_p_p(sc, car(args))); -} - - -/* -------------------------------- acos -------------------------------- */ -static s7_pointer c_acos(s7_scheme *sc, s7_double x) -{ - s7_double absx = fabs(x), recip; - s7_complex result; - - if (absx <= 1.0) - return(make_real(sc, acos(x))); - - /* else follow maxima again: */ - recip = 1.0 / absx; - if (x > 0.0) - result = _Complex_I * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))); - else result = M_PI - _Complex_I * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))); - return(c_complex_to_s7(sc, result)); -} - -static s7_pointer acos_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_real(p)) return(c_acos(sc, real(p))); - switch (type(p)) - { - case T_INTEGER: - return((integer(p) == 1) ? int_zero : c_acos(sc, (s7_double)integer(p))); - - case T_RATIO: - return(c_acos(sc, fraction(p))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - /* if either real or imag part is very large, use explicit formula, not cacos */ - /* this code taken from sbcl's src/code/irrat.lisp */ - - if ((fabs(real_part(p)) > 1.0e7) || - (fabs(imag_part(p)) > 1.0e7)) - { - s7_complex sq1mz, sq1pz, z = to_c_complex(p); - sq1mz = csqrt(1.0 - z); - sq1pz = csqrt(1.0 + z); /* creal(sq1pz) can be 0.0 */ - if (creal(sq1pz) == 0.0) /* so the atan arg will be inf, so the real part will be pi/2(?) */ - return(s7_make_complex(sc, M_PI / 2.0, asinh(cimag(sq1mz * conj(sq1pz))))); - return(s7_make_complex(sc, 2.0 * atan(creal(sq1mz) / creal(sq1pz)), asinh(cimag(sq1mz * conj(sq1pz))))); - } - return(c_complex_to_s7(sc, cacos(s7_to_c_complex(p)))); -#else - out_of_range_error_nr(sc, sc->acos_symbol, int_one, p, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); - goto ACOS_BIG_REAL; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); - goto ACOS_BIG_REAL; - case T_BIG_REAL: - if (mpfr_inf_p(big_real(p))) - { - if (mpfr_cmp_ui(big_real(p), 0) < 0) - return(make_complex_not_0i(sc, -NAN, -INFINITY)); /* match non-bignum choice */ - return(make_complex_not_0i(sc, -NAN, INFINITY)); - } - mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); - ACOS_BIG_REAL: - mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN); - if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) - { - mpfr_acos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN); - mpc_acos(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_acos(sc->mpc_1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->acos_symbol, a_number_string)); - } -} - -static s7_pointer g_acos(s7_scheme *sc, s7_pointer args) -{ - #define H_acos "(acos z) returns acos(z); (cos (acos 1)) = 1" - #define Q_acos sc->pl_nn - return(acos_p_p(sc, car(args))); -} - - -/* -------------------------------- atan -------------------------------- */ -static s7_pointer g_atan(s7_scheme *sc, s7_pointer args) -{ - #define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)" - #define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol) - /* actually if there are two args, both should be real, but how to express that in the signature? */ - - s7_pointer x = car(args), y; - /* currently (atan inf.0 inf.0) -> 0.78539816339745, and (atan inf.0 -inf.0) -> 2.3561944901923 (etc) */ - - if (!is_pair(cdr(args))) - { - switch (type(x)) - { - case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, atan((double)integer(x)))); - case T_RATIO: return(make_real(sc, atan(fraction(x)))); - case T_REAL: return(make_real(sc, atan(real(x)))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, catan(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->atan_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_atan(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_atan(sc->mpc_1, big_complex(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->atan_symbol, a_number_string)); - }} - - y = cadr(args); - switch (type(x)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - if (is_small_real(y)) - return(make_real(sc, atan2(s7_real(x), s7_real(y)))); -#if WITH_GMP - if (!is_real(y)) - return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2)); - mpfr_set_d(sc->mpfr_1, s7_real(x), MPFR_RNDN); - goto ATAN2_BIG_REAL; - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - goto ATAN2_BIG_REAL; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - goto ATAN2_BIG_REAL; - case T_BIG_REAL: - mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); - goto ATAN2_BIG_REAL; -#endif - default: - return(method_or_bust(sc, x, sc->atan_symbol, args, sc->type_names[T_REAL], 1)); - } -#if WITH_GMP - ATAN2_BIG_REAL: - if (is_small_real(y)) - mpfr_set_d(sc->mpfr_2, s7_real(y), MPFR_RNDN); - else - if (is_t_big_real(y)) - mpfr_set(sc->mpfr_2, big_real(y), MPFR_RNDN); - else - if (is_t_big_integer(y)) - mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); - else - if (is_t_big_ratio(y)) - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - else return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2)); - mpfr_atan2(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif -} - -static s7_double atan_d_dd(s7_double x, s7_double y) {return(atan2(x, y));} - - -/* -------------------------------- sinh -------------------------------- */ -static s7_pointer sinh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_zero); /* (sinh 0) -> 0 */ - - case T_REAL: - case T_RATIO: - { - s7_double y = s7_real(x); -#if WITH_GMP - if (fabs(y) > SINH_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, sinh(y))); - } - - case T_COMPLEX: -#if WITH_GMP - if ((fabs(real_part(x)) > SINH_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sinh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } -#endif -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, csinh(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->sinh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_sinh(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_sinh(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->sinh_symbol, a_number_string)); - } -} - -static s7_pointer g_sinh(s7_scheme *sc, s7_pointer args) -{ - #define H_sinh "(sinh z) returns sinh(z)" - #define Q_sinh sc->pl_nn - return(sinh_p_p(sc, car(args))); -} - -static s7_double sinh_d_d(s7_double x) {return(sinh(x));} -static s7_pointer sinh_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, sinh(x)));} - - -/* -------------------------------- cosh -------------------------------- */ -static s7_pointer cosh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_one); /* (cosh 0) -> 1 */ - - case T_REAL: - case T_RATIO: - { - s7_double y = s7_real(x); -#if WITH_GMP - if (fabs(y) > SINH_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, cosh(y))); - } - - case T_COMPLEX: -#if WITH_GMP - if ((fabs(real_part(x)) > SINH_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_cosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } -#endif -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, ccosh(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->cosh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_cosh(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_cosh(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->cosh_symbol, a_number_string)); - } -} - -static s7_pointer g_cosh(s7_scheme *sc, s7_pointer args) -{ - #define H_cosh "(cosh z) returns cosh(z)" - #define Q_cosh sc->pl_nn - return(cosh_p_p(sc, car(args))); -} - -static s7_double cosh_d_d(s7_double x) {return(cosh(x));} -static s7_pointer cosh_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, cosh(x)));} - - -/* -------------------------------- tanh -------------------------------- */ -#define TANH_LIMIT 350.0 -static s7_pointer tanh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, tanh((s7_double)integer(x)))); - case T_RATIO: return(make_real(sc, tanh(fraction(x)))); - case T_REAL: return(make_real(sc, tanh(real(x)))); - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - if (real_part(x) > TANH_LIMIT) - return(real_one); /* closer than 0.0 which is what ctanh is about to return! */ - if (real_part(x) < -TANH_LIMIT) - return(make_real(sc, -1.0)); /* closer than ctanh's -0.0 */ - return(c_complex_to_s7(sc, ctanh(to_c_complex(x)))); -#else - out_of_range_error_nr(sc, sc->tanh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - goto BIG_REAL_TANH; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - goto BIG_REAL_TANH; - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); - BIG_REAL_TANH: - if (mpfr_cmp_d(sc->mpfr_1, TANH_LIMIT) > 0) return(real_one); - if (mpfr_cmp_d(sc->mpfr_1, -TANH_LIMIT) < 0) return(make_real(sc, -1.0)); - mpfr_tanh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), TANH_LIMIT, 1))) > 0) - return(real_one); - if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), -TANH_LIMIT, 1))) < 0) - return(make_real(sc, -1.0)); - if ((mpfr_nan_p(mpc_imagref(big_complex(x)))) || - (mpfr_inf_p(mpc_imagref(big_complex(x))))) - { - if (mpfr_cmp_ui(mpc_realref(big_complex(x)), 0) == 0) - return(make_complex_not_0i(sc, 0.0, NAN)); /* match non-bignum choice */ - return(complex_NaN); - } - mpc_tanh(sc->mpc_1, big_complex(x), MPC_RNDNN); - if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->tanh_symbol, a_number_string)); - } -} - -static s7_pointer g_tanh(s7_scheme *sc, s7_pointer args) -{ - #define H_tanh "(tanh z) returns tanh(z)" - #define Q_tanh sc->pl_nn - return(tanh_p_p(sc, car(args))); -} - -static s7_double tanh_d_d(s7_double x) {return(tanh(x));} - - -/* -------------------------------- asinh -------------------------------- */ -static s7_pointer asinh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, asinh((s7_double)integer(x)))); - case T_RATIO: return(make_real(sc, asinh(fraction(x)))); - case T_REAL: return(make_real(sc, asinh(real(x)))); - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - #if (defined(__OpenBSD__)) || (defined(__NetBSD__)) - return(c_complex_to_s7(sc, casinh_1(to_c_complex(x)))); - #else - return(c_complex_to_s7(sc, casinh(to_c_complex(x)))); - #endif -#else - out_of_range_error_nr(sc, sc->asinh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_asinh(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_asinh(sc->mpc_1, big_complex(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->asinh_symbol, a_number_string)); - } -} - -static s7_pointer g_asinh(s7_scheme *sc, s7_pointer args) -{ - #define H_asinh "(asinh z) returns asinh(z)" - #define Q_asinh sc->pl_nn - return(asinh_p_p(sc, car(args))); -} - - -/* -------------------------------- acosh -------------------------------- */ -static s7_pointer acosh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 1) return(int_zero); - case T_REAL: - case T_RATIO: - { - s7_double x1 = s7_real(x); - if (x1 >= 1.0) - return(make_real(sc, acosh(x1))); - } - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - #ifdef __OpenBSD__ - return(c_complex_to_s7(sc, cacosh_1(s7_to_c_complex(x)))); - #else - return(c_complex_to_s7(sc, cacosh(s7_to_c_complex(x)))); /* not to_c_complex because x might not be complex */ - #endif -#else - /* since we can fall through to this branch, we need a better error message than "must be a number, not 0.0" */ - out_of_range_error_nr(sc, sc->acosh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_fr(sc->mpc_1, big_real(x), MPC_RNDNN); - mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_acosh(sc->mpc_1, big_complex(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->acosh_symbol, a_number_string)); - } -} - -static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args) -{ - #define H_acosh "(acosh z) returns acosh(z)" - #define Q_acosh sc->pl_nn - return(acosh_p_p(sc, car(args))); -} - - -/* -------------------------------- atanh -------------------------------- */ -static s7_pointer atanh_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) return(int_zero); /* (atanh 0) -> 0 */ - case T_REAL: - case T_RATIO: - { - s7_double x1 = s7_real(x); - if (fabs(x1) < 1.0) - return(make_real(sc, atanh(x1))); - } - /* if we can't distinguish x from 1.0 even with long_doubles, we'll get inf.0: - * (atanh 9223372036854775/9223372036854776) -> 18.714973875119 - * (atanh 92233720368547758/92233720368547757) -> inf.0 - * (atanh (bignum 92233720368547758/92233720368547757)) -> 1.987812468492420421418925013176932317086E1+1.570796326794896619231321691639751442098E0i - * but the imaginary part is unnecessary - */ - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - #if (defined(__OpenBSD__)) || (defined(__NetBSD__)) - return(c_complex_to_s7(sc, catanh_1(s7_to_c_complex(x)))); - #else - return(c_complex_to_s7(sc, catanh(s7_to_c_complex(x)))); - #endif -#else - out_of_range_error_nr(sc, sc->atanh_symbol, int_one, x, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_2, big_integer(x), MPFR_RNDN); - goto ATANH_BIG_REAL; - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_2, big_ratio(x), MPFR_RNDN); - goto ATANH_BIG_REAL; - case T_BIG_REAL: - mpfr_set(sc->mpfr_2, big_real(x), MPFR_RNDN); - ATANH_BIG_REAL: - mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN); - if (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) < 0) - { - mpfr_atanh(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_2)); - } - mpc_set_fr(sc->mpc_1, sc->mpfr_2, MPC_RNDNN); - mpc_atanh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_atanh(sc->mpc_1, big_complex(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, x, sc->atanh_symbol, a_number_string)); - } -} - -static s7_pointer g_atanh(s7_scheme *sc, s7_pointer args) -{ - #define H_atanh "(atanh z) returns atanh(z)" - #define Q_atanh sc->pl_nn - return(atanh_p_p(sc, car(args))); -} - - -/* -------------------------------- sqrt -------------------------------- */ -static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer p) -{ - switch (type(p)) - { - case T_INTEGER: - { - s7_double sqx; - if (integer(p) >= 0) - { - s7_int ix; -#if WITH_GMP - mpz_set_si(sc->mpz_1, integer(p)); - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, sc->mpz_1); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - return(make_integer(sc, mpz_get_si(sc->mpz_1))); - mpfr_set_si(sc->mpfr_1, integer(p), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif - sqx = sqrt((s7_double)integer(p)); - ix = (s7_int)sqx; - return(((ix * ix) == integer(p)) ? make_integer(sc, ix) : make_real(sc, sqx)); - /* Mark Weaver notes that (zero? (- (sqrt 9007199136250226) 94906265.0)) -> #t - * but (* 94906265 94906265) -> 9007199136250225 -- oops - * if we use bigfloats, we're ok: - * (* (sqrt 9007199136250226.0) (sqrt 9007199136250226.0)) -> 9.007199136250226000000000000000000000026E15 - * at least we return a real here, not an incorrect integer and (sqrt 9007199136250225) -> 94906265 - */ - } -#if HAVE_COMPLEX_NUMBERS -#if WITH_GMP - mpc_set_si(sc->mpc_1, integer(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - sqx = (s7_double)integer(p); /* we're trying to protect against (sqrt -9223372036854775808) where we can't negate the integer argument */ - return(s7_make_complex(sc, 0.0, sqrt((s7_double)(-sqx)))); -#else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string); -#endif - } - - case T_RATIO: - if (numerator(p) > 0) /* else it's complex, so it can't be a ratio */ - { - s7_int nm = (s7_int)sqrt(numerator(p)); - if (nm * nm == numerator(p)) - { - s7_int dn = (s7_int)sqrt(denominator(p)); - if (dn * dn == denominator(p)) - return(make_ratio(sc, nm, dn)); - } - return(make_real(sc, sqrt((s7_double)fraction(p)))); - } -#if HAVE_COMPLEX_NUMBERS - return(s7_make_complex(sc, 0.0, sqrt((s7_double)(-fraction(p))))); -#else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string); -#endif - - case T_REAL: - if (is_NaN(real(p))) return(p); - if (real(p) >= 0.0) - return(make_real(sc, sqrt(real(p)))); - return(make_complex_not_0i(sc, 0.0, sqrt(-real(p)))); - - case T_COMPLEX: /* (* inf.0 (sqrt -1)) -> -nan+infi, but (sqrt -inf.0) -> 0+infi */ -#if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, csqrt(to_c_complex(p)))); /* sqrt(+inf.0+1.0i) -> +inf.0 */ -#else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string); -#endif - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(p), 0) >= 0) - { - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, big_integer(p)); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - return(mpz_to_integer(sc, sc->mpz_1)); - mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - mpc_set_z(sc->mpc_1, big_integer(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - - case T_BIG_RATIO: /* if big ratio, check both num and den for squares */ - if (mpq_cmp_ui(big_ratio(p), 0, 1) < 0) - { - mpc_set_q(sc->mpc_1, big_ratio(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(p))); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - { - mpz_sqrtrem(sc->mpz_3, sc->mpz_2, mpq_denref(big_ratio(p))); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - { - mpq_set_num(sc->mpq_1, sc->mpz_1); - mpq_set_den(sc->mpq_1, sc->mpz_3); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - }} - mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - - case T_BIG_REAL: - if (mpfr_cmp_ui(big_real(p), 0) < 0) - { - mpc_set_fr(sc->mpc_1, big_real(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } - mpfr_sqrt(sc->mpfr_1, big_real(p), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - - case T_BIG_COMPLEX: - mpc_sqrt(sc->mpc_1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->sqrt_symbol, a_number_string)); - } -} - -static s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args) -{ - #define H_sqrt "(sqrt z) returns the square root of z" - #define Q_sqrt sc->pl_nn - return(sqrt_p_p(sc, car(args))); -} - - -/* -------------------------------- expt -------------------------------- */ -static s7_int int_to_int(s7_int x, s7_int n) -{ - /* from GSL */ - s7_int value = 1; - do { - if (n & 1) value *= x; - n >>= 1; -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(x, x, &x)) - break; -#else - x *= x; -#endif - } while (n); - return(value); -} - -static const int64_t nth_roots[63] = { - S7_INT64_MAX, S7_INT64_MAX, 3037000499LL, 2097151, 55108, 6208, 1448, 511, 234, 127, 78, 52, 38, 28, 22, - 18, 15, 13, 11, 9, 8, 7, 7, 6, 6, 5, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2}; - -static bool int_pow_ok(s7_int x, s7_int y) -{ - return((y < S7_INT_BITS) && (nth_roots[y] >= s7_int_abs(x))); -} - -#if WITH_GMP -static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p); -static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2); - -static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args), y = cadr(args), res; - if (!is_number(x)) - return(method_or_bust(sc, x, sc->expt_symbol, args, a_number_string, 1)); - if (!is_number(y)) - return(method_or_bust(sc, y, sc->expt_symbol, args, a_number_string, 2)); - - if (is_zero(x)) - { - if ((s7_is_integer(x)) && - (s7_is_integer(y)) && - (is_zero(y))) - return(int_one); - - if (is_real(y)) - { - if (is_negative(sc, y)) - division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); - } - else - if (is_negative(sc, real_part_p_p(sc, y))) /* handle big_complex as well as complex */ - division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); - - if ((is_rational(x)) && - (is_rational(y))) - return(int_zero); - return(real_zero); - } - - if (s7_is_integer(y)) - { - s7_int yval = s7_integer_clamped_if_gmp(sc, y); - if (yval == 0) - return((is_rational(x)) ? int_one : real_one); - - if (yval == 1) - return(x); - - if ((!is_big_number(x)) && - ((is_one(x)) || (is_zero(x)))) - return(x); - - if ((yval < S7_INT32_MAX) && - (yval > S7_INT32_MIN)) - { - /* (protect against gmp exception if for example (expt 1/9223372036854775807 -9223372036854775807) */ - if (s7_is_integer(x)) - { - if (is_t_big_integer(x)) - mpz_set(sc->mpz_2, big_integer(x)); - else mpz_set_si(sc->mpz_2, integer(x)); - if (yval >= 0) - { - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); - return(mpz_to_integer(sc, sc->mpz_2)); - } - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)(-yval)); - mpq_set_z(sc->mpq_1, sc->mpz_2); - mpq_inv(sc->mpq_1, sc->mpq_1); - if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); - return(mpq_to_big_ratio(sc, sc->mpq_1)); - } - - if (s7_is_ratio(x)) /* here y is an integer */ - { - if (is_t_big_ratio(x)) - { - mpz_set(sc->mpz_1, mpq_numref(big_ratio(x))); - mpz_set(sc->mpz_2, mpq_denref(big_ratio(x))); - } - else - { - mpz_set_si(sc->mpz_1, numerator(x)); - mpz_set_si(sc->mpz_2, denominator(x)); - } - if (yval >= 0) - { - mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval); - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); - mpq_set_num(sc->mpq_1, sc->mpz_1); - mpq_set_den(sc->mpq_1, sc->mpz_2); - } - else - { - yval = -yval; - mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval); - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); - mpq_set_num(sc->mpq_1, sc->mpz_2); - mpq_set_den(sc->mpq_1, sc->mpz_1); - mpq_canonicalize(sc->mpq_1); - } - if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); - return(mpq_to_big_ratio(sc, sc->mpq_1)); - } - - if (is_real(x)) - { - if (is_t_big_real(x)) - mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); - else mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_pow_si(sc->mpfr_1, sc->mpfr_1, yval, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - }}} - - if ((is_t_ratio(y)) && /* not s7_is_ratio which accepts bignums */ - (numerator(y) == 1)) - { - if (denominator(y) == 2) - return(sqrt_p_p(sc, x)); - - if ((is_real(x)) && - (denominator(y) == 3)) - { - any_real_to_mpfr(sc, x, sc->mpfr_1); - mpfr_cbrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - }} - - res = any_number_to_mpc(sc, y, sc->mpc_2); - if (res == real_infinity) - { - if (is_one(x)) return(int_one); - if (!is_real(x)) return((is_negative(sc, y)) ? real_zero : complex_NaN); - if (is_zero(x)) - { - if (is_negative(sc, y)) division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); - return(real_zero); - } - if (lt_b_pi(sc, x, 0)) - { - if (lt_b_pi(sc, x, -1)) - return((is_positive(sc, y)) ? real_infinity : real_zero); - return((is_positive(sc, y)) ? real_zero : real_infinity); - } - if (lt_b_pi(sc, x, 1)) - return((is_positive(sc, y)) ? real_zero : real_infinity); - return((is_positive(sc, y)) ? real_infinity : real_zero); - } - if (res) return(complex_NaN); - - if ((is_real(x)) && - (is_real(y)) && - (is_positive(sc, x))) - { - res = any_real_to_mpfr(sc, x, sc->mpfr_1); - if (res) - { - if (res == real_infinity) - { - if (is_negative(sc, y)) return(real_zero); - return((is_zero(y)) ? real_one : real_infinity); - } - return(complex_NaN); - } - mpfr_pow(sc->mpfr_1, sc->mpfr_1, mpc_realref(sc->mpc_2), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - - res = any_number_to_mpc(sc, x, sc->mpc_1); - if (res) - { - if ((res == real_infinity) && (is_real(y))) - { - if (is_negative(sc, y)) return(real_zero); - return((is_zero(y)) ? real_one : real_infinity); - } - return(complex_NaN); - } - if (mpc_cmp_si_si(sc->mpc_1, 0, 0) == 0) - return(int_zero); - if (mpc_cmp_si_si(sc->mpc_1, 1, 0) == 0) - return(int_one); - - mpc_pow(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - - if ((!mpfr_nan_p(mpc_imagref(sc->mpc_1))) && (mpfr_cmp_ui(mpc_imagref(sc->mpc_1), 0) == 0)) /* (expt -inf.0 1/3) -> +inf.0+nan.0i in mpc */ - { - if ((is_rational(car(args))) && - (is_rational(cadr(args))) && - (mpfr_integer_p(mpc_realref(sc->mpc_1)) != 0)) - { - /* mpfr_integer_p can be confused: (expt 2718/1000 (bignum 617/5)) returns an int32_t if precision=128, float if 512 */ - /* so first make sure we're within (say) 31 bits */ - mpfr_set_ui(sc->mpfr_1, S7_INT32_MAX, MPFR_RNDN); - if (mpfr_cmpabs(mpc_realref(sc->mpc_1), sc->mpfr_1) < 0) - { - mpfr_get_z(sc->mpz_1, mpc_realref(sc->mpc_1), MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_1)); - }} - mpfr_set(sc->mpfr_1, mpc_realref(sc->mpc_1), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - return(mpc_to_number(sc, sc->mpc_1)); -} -#endif - -static s7_pointer expt_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer pw) -{ - if (!is_number(n)) - return(method_or_bust_pp(sc, n, sc->expt_symbol, n, pw, a_number_string, 1)); - if (!is_number(pw)) - return(method_or_bust_pp(sc, pw, sc->expt_symbol, n, pw, a_number_string, 2)); - - if (is_zero(n)) - { - if (is_zero(pw)) - { - if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* (expt 0 0) -> 1 */ - return(int_one); - return(real_zero); /* (expt 0.0 0) -> 0.0 */ - } - if (is_real(pw)) - { - if (is_negative(sc, pw)) /* (expt 0 -1) */ - division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw); - /* (Clisp gives divide-by-zero error here, Guile returns inf.0) */ - - if (is_NaN(s7_real(pw))) /* (expt 0 +nan.0) */ - return(pw); - } - else - { /* (expt 0 a+bi) */ - if (real_part(pw) < 0.0) /* (expt 0 -1+i) */ - division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw); - if ((is_NaN(real_part(pw))) || /* (expt 0 0+1/0i) */ - (is_NaN(imag_part(pw)))) - return(pw); - } - if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* pw != 0, (expt 0 2312) */ - return(int_zero); - return(real_zero); /* (expt 0.0 123123) */ - } - - if (is_one(pw)) - { - if (s7_is_integer(pw)) /* (expt x 1) */ - return(n); - if (is_rational(n)) /* (expt ratio 1.0) */ - return(make_real(sc, rational_to_double(sc, n))); - return(n); - } - if (is_t_integer(pw)) - { - s7_int y = integer(pw); - if (y == 0) - { - if (is_rational(n)) /* (expt 3 0) */ - return(int_one); - if ((is_NaN(s7_real_part(n))) || /* (expt 1/0 0) -> NaN */ - (is_NaN(s7_imag_part(n)))) /* (expt (complex 0 1/0) 0) -> NaN */ - return(n); - return(real_one); /* (expt 3.0 0) */ - } - switch (type(n)) - { - case T_INTEGER: - { - s7_int x = integer(n); - if (x == 1) /* (expt 1 y) */ - return(n); - - if (x == -1) - { - if (y == S7_INT64_MIN) /* (expt -1 most-negative-fixnum) */ - return(int_one); - if (s7_int_abs(y) & 1) /* (expt -1 odd-int) */ - return(n); - return(int_one); /* (expt -1 even-int) */ - } - - if (y == S7_INT64_MIN) /* (expt x most-negative-fixnum) */ - return(int_zero); - if (x == S7_INT64_MIN) /* (expt most-negative-fixnum y) */ - return(make_real(sc, pow((double)x, (double)y))); - - if (int_pow_ok(x, s7_int_abs(y))) - { - if (y > 0) - return(make_integer(sc, int_to_int(x, y))); - return(make_ratio(sc, 1, int_to_int(x, -y))); - }} - break; - - case T_RATIO: - { - s7_int nm = numerator(n), dn = denominator(n); - if (y == S7_INT64_MIN) - { - if (s7_int_abs(nm) > dn) - return(int_zero); /* (expt 4/3 most-negative-fixnum) -> 0? */ - return(real_infinity); /* (expt 3/4 most-negative-fixnum) -> inf? */ - } - if ((int_pow_ok(nm, s7_int_abs(y))) && - (int_pow_ok(dn, s7_int_abs(y)))) - { - if (y > 0) - return(make_ratio(sc, int_to_int(nm, y), int_to_int(dn, y))); - return(make_ratio_with_div_check(sc, sc->expt_symbol, int_to_int(dn, -y), int_to_int(nm, -y))); - }} - break; - /* occasionally int^rat can be int32_t but it happens so infrequently it's probably not worth checking - * one possibly easy case: (expt 1 1/2) -> 1 (-1?) etc - */ - - case T_REAL: - /* (expt -1.0 most-positive-fixnum) should be -1.0 - * (expt -1.0 (+ (expt 2 53) 1)) -> -1.0 - * (expt -1.0 (- 1 (expt 2 54))) -> -1.0 - */ - if (real(n) == -1.0) - { - if (y == S7_INT64_MIN) - return(real_one); - return((s7_int_abs(y) & 1) ? n : real_one); - } - break; - - case T_COMPLEX: -#if HAVE_COMPLEX_NUMBERS - if ((s7_real_part(n) == 0.0) && - ((s7_imag_part(n) == 1.0) || - (s7_imag_part(n) == -1.0))) - { - bool yp = (y > 0), np = (s7_imag_part(n) > 0.0); - switch (s7_int_abs(y) % 4) - { - case 0: return(real_one); - case 1: return(make_complex_not_0i(sc, 0.0, (yp == np) ? 1.0 : -1.0)); - case 2: return(make_real(sc, -1.0)); - case 3: return(make_complex_not_0i(sc, 0.0, (yp == np) ? -1.0 : 1.0)); - }} -#else - out_of_range_error_nr(sc, sc->expt_symbol, int_two, n, no_complex_numbers_string); -#endif - break; - }} - - if ((is_real(n)) && - (is_real(pw))) - { - s7_double x, y; - - if ((is_t_ratio(pw)) && - (numerator(pw) == 1)) - { - if (denominator(pw) == 2) - return(sqrt_p_p(sc, n)); - if (denominator(pw) == 3) - return(make_real(sc, cbrt(s7_real(n)))); /* (expt 27 1/3) should be 3, not 3.0... */ - /* but: (expt 512/729 1/3) -> 0.88888888888889, and 4 -> sqrt(sqrt...) etc? */ - } - - x = s7_real(n); - y = s7_real(pw); - if (is_NaN(x)) return(n); - if (is_NaN(y)) return(pw); - if (y == 0.0) return(real_one); - /* I think pow(rl, inf) is ok */ - if (x > 0.0) - return(make_real(sc, pow(x, y))); /* tricky cases abound here: (expt -1 1/9223372036854775807) */ - } - - /* (expt 0+i 1e+16) = 0.98156860153485-0.19111012657867i ? - * (expt 0+i 1+1/0i) = 0.0 ?? - */ - return(c_complex_to_s7(sc, cpow(s7_to_c_complex(n), s7_to_c_complex(pw)))); -} - -static s7_pointer g_expt(s7_scheme *sc, s7_pointer args) -{ - #define H_expt "(expt z1 z2) returns z1^z2" - #define Q_expt sc->pcl_n -#if WITH_GMP - return(big_expt(sc, args)); - /* big_expt sometimes chooses a different value: g_expt (expt -1 1/3) is -1, but big_expt (expt -1 (bignum 1/3)) is (complex 1/2 (/ (sqrt 3) 2)) */ -#endif - return(expt_p_pp(sc, car(args), cadr(args))); -} - - -/* -------------------------------- lcm -------------------------------- */ -#if WITH_GMP -static s7_pointer big_lcm(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args) -{ - mpz_set_si(sc->mpz_3, num); - mpz_set_si(sc->mpz_4, den); - - for (s7_pointer x = args; is_pair(x); x = cdr(x)) - { - s7_pointer rat = car(x); - switch (type(rat)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(rat)); - mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); - mpz_set_si(sc->mpz_4, 1); - break; - case T_RATIO: - mpz_set_si(sc->mpz_1, numerator(rat)); - mpz_set_si(sc->mpz_2, denominator(rat)); - mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); - mpz_gcd(sc->mpz_4, sc->mpz_4, sc->mpz_2); - break; - case T_BIG_INTEGER: - mpz_lcm(sc->mpz_3, sc->mpz_3, big_integer(rat)); - mpz_set_si(sc->mpz_4, 1); - break; - case T_BIG_RATIO: - mpz_lcm(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); - mpz_gcd(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); - break; - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(x, args), rat, a_rational_string); - default: - return(method_or_bust(sc, rat, sc->lcm_symbol, - set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), - a_rational_string, position_of(x, args))); - }} - return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); -} -#endif - -static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args) -{ - /* (/ (* m n) (gcd m n)), (lcm a b c) -> (lcm a (lcm b c)) */ - #define H_lcm "(lcm ...) returns the least common multiple of its rational arguments" - #define Q_lcm sc->pcl_f - - s7_int n = 1, d = 0; - - if (!is_pair(args)) - return(int_one); - - if (!is_pair(cdr(args))) - { - if (!is_rational(car(args))) - return(method_or_bust(sc, car(args), sc->lcm_symbol, args, a_rational_string, 1)); - return(g_abs(sc, args)); - } - - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer x = car(p); - s7_int b; -#if HAVE_OVERFLOW_CHECKS - s7_int n1; -#endif - switch (type(x)) - { - case T_INTEGER: - d = 1; - if (integer(x) == 0) /* return 0 unless there's a wrong-type-arg (geez what a mess) */ - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - { - s7_pointer x1 = car(p); - if (is_number(x1)) - { - if (!is_rational(x1)) - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); - } - else - if (has_active_methods(sc, x1)) - { - s7_pointer f = find_method_with_let(sc, x1, sc->is_rational_symbol); - if ((f == sc->undefined) || - (is_false(sc, s7_apply_function(sc, f, set_plist_1(sc, x1))))) - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); - } - else wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); - } - return(int_zero); - } - b = integer(x); - if (b < 0) - { - if (b == S7_INT64_MIN) -#if WITH_GMP - return(big_lcm(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); -#endif - b = -b; - } -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(n / c_gcd(n, b), b, &n1)) -#if WITH_GMP - return(big_lcm(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, result_is_too_large_string); -#endif - n = n1; -#else - n = (n / c_gcd(n, b)) * b; -#endif - break; - - case T_RATIO: - b = numerator(x); - if (b < 0) - { - if (b == S7_INT64_MIN) -#if WITH_GMP - return(big_lcm(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); -#endif - b = -b; - } -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(n / c_gcd(n, b), b, &n1)) /* (lcm 92233720368547758/3 3005/2) */ -#if WITH_GMP - return(big_lcm(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, intermediate_too_large_string); -#endif - n = n1; -#else - n = (n / c_gcd(n, b)) * b; -#endif - if (d == 0) - d = (p == args) ? denominator(x) : 1; - else d = c_gcd(d, denominator(x)); - break; - -#if WITH_GMP - case T_BIG_INTEGER: - d = 1; - case T_BIG_RATIO: - return(big_lcm(sc, n, d, p)); -#endif - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x, a_rational_string); - - default: - return(method_or_bust(sc, x, sc->lcm_symbol, - set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio_with_div_check(sc, sc->lcm_symbol, n, d), p), - a_rational_string, position_of(p, args))); - }} - return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d)); -} - - -/* -------------------------------- gcd -------------------------------- */ -#if WITH_GMP -static s7_pointer big_gcd(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args) -{ - mpz_set_si(sc->mpz_3, num); - mpz_set_si(sc->mpz_4, den); - - for (s7_pointer x = args; is_pair(x); x = cdr(x)) - { - s7_pointer rat = car(x); - switch (type(rat)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(rat)); - mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); - break; - case T_RATIO: - mpz_set_si(sc->mpz_1, numerator(rat)); - mpz_set_si(sc->mpz_2, denominator(rat)); - mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); - mpz_lcm(sc->mpz_4, sc->mpz_4, sc->mpz_2); - break; - case T_BIG_INTEGER: - mpz_gcd(sc->mpz_3, sc->mpz_3, big_integer(rat)); - break; - case T_BIG_RATIO: - mpz_gcd(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); - mpz_lcm(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); - break; - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->gcd_symbol, position_of(x, args), rat, a_rational_string); - default: - return(method_or_bust(sc, rat, sc->gcd_symbol, - set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), - a_rational_string, position_of(x, args))); - }} - return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); -} -#endif - -static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args) -{ - #define H_gcd "(gcd ...) returns the greatest common divisor of its rational arguments" - #define Q_gcd sc->pcl_f - - s7_int n = 0, d = 1; - - if (!is_pair(args)) /* (gcd) */ - return(int_zero); - - if (!is_pair(cdr(args))) /* (gcd 3/4) */ - { - if (!is_rational(car(args))) - return(method_or_bust(sc, car(args), sc->gcd_symbol, args, a_rational_string, 1)); - return(abs_p_p(sc, car(args))); - } - - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer x = car(p); - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == S7_INT64_MIN) -#if WITH_GMP - return(big_gcd(sc, n, d, p)); -#else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); -#endif - n = c_gcd(n, integer(x)); - break; - - case T_RATIO: - { -#if HAVE_OVERFLOW_CHECKS - s7_int dn; -#endif - n = c_gcd(n, numerator(x)); - if (d == 1) - d = denominator(x); - else - { - s7_int b = denominator(x); -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(d / c_gcd(d, b), b, &dn)) /* (gcd 1/92233720368547758 1/3005) */ -#if WITH_GMP - return(big_gcd(sc, n, d, x)); -#else - sole_arg_out_of_range_error_nr(sc, sc->gcd_symbol, args, intermediate_too_large_string); -#endif - d = dn; -#else - d = (d / c_gcd(d, b)) * b; -#endif - }} - break; - -#if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: - return(big_gcd(sc, n, d, p)); -#endif - - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->gcd_symbol, position_of(p, args), x, a_rational_string); - - default: - return(method_or_bust(sc, x, sc->gcd_symbol, - set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio_with_div_check(sc, sc->gcd_symbol, n, d), p), - a_rational_string, position_of(p, args))); - }} - return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d)); -} - - -/* -------------------------------- floor -------------------------------- */ -static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - return(x); - case T_RATIO: - { - s7_int val = numerator(x) / denominator(x); - /* C "/" truncates? -- C spec says "truncation toward 0" */ - /* we're avoiding "floor" here because the int->double conversion introduces inaccuracies for big numbers - * but it's used by opt_i_d_c (via s7_number_to_real) so floor_i_7d below can return different results: - * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (floor 3441313796169221281/1720656898084610641)) (newline))) (func)): 1 - * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (/ (floor 3441313796169221281/1720656898084610641))) (newline))) (func)): 1/2 - */ - return(make_integer(sc, (numerator(x) < 0) ? (val - 1) : val)); /* not "val" because it might be truncated to 0 */ - } - case T_REAL: - { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_infinite_string); -#if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_too_large_string); -#endif - return(make_integer(sc, (s7_int)floor(z))); - /* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */ - } -#if WITH_GMP - case T_BIG_INTEGER: - return(x); - case T_BIG_RATIO: - mpz_fdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_nan_string); - if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_infinite_string); - mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDD); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_COMPLEX: -#endif - case T_COMPLEX: - sole_arg_wrong_type_error_nr(sc, sc->floor_symbol, x, sc->type_names[T_REAL]); - default: - return(method_or_bust_p(sc, x, sc->floor_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_floor(s7_scheme *sc, s7_pointer args) -{ - #define H_floor "(floor x) returns the integer closest to x toward -inf" - #define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - return(floor_p_p(sc, car(args))); -} - -static s7_int floor_i_i(s7_int i) {return(i);} - -#if (!WITH_GMP) -static s7_int floor_i_7d(s7_scheme *sc, s7_double x) -{ - if (is_NaN(x)) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, real_NaN, it_is_nan_string); - if (fabs(x) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, wrap_real(sc, x), it_is_too_large_string); - return((s7_int)floor(x)); -} - -static s7_int floor_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p)); - if (is_t_real(p)) return(floor_i_7d(sc, real(p))); - if (is_t_ratio(p)) /* for consistency with floor_p_p, don't use floor(fraction(p)) */ - { - s7_int val = numerator(p) / denominator(p); - return((numerator(p) < 0) ? val - 1 : val); - } - return(s7_integer(method_or_bust_p(sc, p, sc->floor_symbol, sc->type_names[T_REAL]))); -} - -static s7_pointer floor_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc,floor_i_7d(sc, x)));} -#endif - - -/* -------------------------------- ceiling -------------------------------- */ -static s7_pointer ceiling_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - return(x); - case T_RATIO: - { - s7_int val = numerator(x) / denominator(x); - return(make_integer(sc, (numerator(x) < 0) ? val : (val + 1))); - } - case T_REAL: - { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_infinite_string); -#if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDU); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_too_large_string); -#endif - return(make_integer(sc, (s7_int)ceil(real(x)))); - } -#if WITH_GMP - case T_BIG_INTEGER: - return(x); - case T_BIG_RATIO: - mpz_cdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_nan_string); - if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_infinite_string); - mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDU); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_COMPLEX: -#endif - case T_COMPLEX: - sole_arg_wrong_type_error_nr(sc, sc->ceiling_symbol, x, sc->type_names[T_REAL]); - default: - return(method_or_bust_p(sc, x, sc->ceiling_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args) -{ - #define H_ceiling "(ceiling x) returns the integer closest to x toward inf" - #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - return(ceiling_p_p(sc, car(args))); -} - -static s7_int ceiling_i_i(s7_int i) {return(i);} - -#if (!WITH_GMP) -static s7_int ceiling_i_7d(s7_scheme *sc, s7_double x) -{ - if (is_NaN(x)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, real_NaN, it_is_nan_string); - if ((is_inf(x)) || - (x > DOUBLE_TO_INT64_LIMIT) || (x < -DOUBLE_TO_INT64_LIMIT)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, wrap_real(sc, x), it_is_too_large_string); - return((s7_int)ceil(x)); -} - -static s7_int ceiling_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p)); - if (is_t_real(p)) return(ceiling_i_7d(sc, real(p))); - if (is_t_ratio(p)) return((s7_int)(ceil(fraction(p)))); - return(s7_integer(method_or_bust_p(sc, p, sc->ceiling_symbol, sc->type_names[T_REAL]))); -} - -static s7_pointer ceiling_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc, ceiling_i_7d(sc, x)));} -#endif - - -/* -------------------------------- truncate -------------------------------- */ -static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - return(x); - case T_RATIO: - return(make_integer(sc, (s7_int)(numerator(x) / denominator(x)))); /* C "/" already truncates (but this divide is not accurate over e13) */ - case T_REAL: - { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_infinite_string); -#if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDZ); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_too_large_string); -#endif - return(make_integer(sc, (z > 0.0) ? (s7_int)floor(z) : (s7_int)ceil(z))); - } -#if WITH_GMP - case T_BIG_INTEGER: - return(x); - case T_BIG_RATIO: - mpz_tdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_nan_string); - if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_infinite_string); - mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDZ); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_COMPLEX: -#endif - case T_COMPLEX: - sole_arg_wrong_type_error_nr(sc, sc->truncate_symbol, x, sc->type_names[T_REAL]); - default: - return(method_or_bust_p(sc, x, sc->truncate_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_truncate(s7_scheme *sc, s7_pointer args) -{ - #define H_truncate "(truncate x) returns the integer closest to x toward 0" - #define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - return(truncate_p_p(sc, car(args))); -} - -static s7_int truncate_i_i(s7_int i) {return(i);} - -#if (!WITH_GMP) -static s7_int truncate_i_7d(s7_scheme *sc, s7_double x) -{ - if (is_NaN(x)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, real_NaN, it_is_nan_string); - if (is_inf(x)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, wrap_real(sc, x), it_is_infinite_string); - if (fabs(x) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, wrap_real(sc, x), it_is_too_large_string); - return((x > 0.0) ? (s7_int)floor(x) : (s7_int)ceil(x)); -} - -static s7_pointer truncate_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc, truncate_i_7d(sc, x)));} -#endif - - -/* -------------------------------- round -------------------------------- */ -static s7_double r5rs_round(s7_double x) -{ - s7_double fl = floor(x), ce = ceil(x); - s7_double dfl = x - fl; - s7_double dce = ce - x; - if (dfl > dce) return(ce); - if (dfl < dce) return(fl); - return((fmod(fl, 2.0) == 0.0) ? fl : ce); -} - -static s7_pointer round_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - return(x); - case T_RATIO: - { - s7_int truncated = numerator(x) / denominator(x), remains = numerator(x) % denominator(x); - long_double frac = s7_fabsl((long_double)remains / (long_double)denominator(x)); - if ((frac > 0.5) || - ((frac == 0.5) && - (truncated % 2 != 0))) - return(make_integer(sc, (numerator(x) < 0) ? (truncated - 1) : (truncated + 1))); - return(make_integer(sc, truncated)); - } - case T_REAL: - { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_infinite_string); -#if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); - mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); /* mpfr_roundeven in mpfr 4.0.0 */ - mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_3)); - } -#else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_too_large_string); -#endif - return(make_integer(sc, (s7_int)r5rs_round(z))); - } -#if WITH_GMP - case T_BIG_INTEGER: - return(x); - case T_BIG_RATIO: - { - int32_t rnd; - mpz_fdiv_qr(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); - mpz_mul_ui(sc->mpz_2, sc->mpz_2, 2); - rnd = mpz_cmpabs(sc->mpz_2, mpq_denref(big_ratio(x))); - mpz_fdiv_q(sc->mpz_2, sc->mpz_2, mpq_denref(big_ratio(x))); - if (rnd > 0) - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - else - if ((rnd == 0) && - (mpz_odd_p(sc->mpz_1))) - mpz_add_ui(sc->mpz_1, sc->mpz_1, 1); - return(mpz_to_integer(sc, sc->mpz_1)); - } - case T_BIG_REAL: - if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_nan_string); - if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_infinite_string); - mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); - mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); - mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_3)); - case T_BIG_COMPLEX: -#endif - case T_COMPLEX: - sole_arg_wrong_type_error_nr(sc, sc->round_symbol, x, sc->type_names[T_REAL]); - default: - return(method_or_bust_p(sc, x, sc->round_symbol, sc->type_names[T_REAL])); - } -} - -static s7_pointer g_round(s7_scheme *sc, s7_pointer args) -{ - #define H_round "(round x) returns the integer closest to x" - #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol) - return(round_p_p(sc, car(args))); -} - -static s7_int round_i_i(s7_int i) {return(i);} - -#if (!WITH_GMP) -static s7_int round_i_7d(s7_scheme *sc, s7_double z) -{ - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, real_NaN, it_is_nan_string); - if ((is_inf(z)) || - (z > DOUBLE_TO_INT64_LIMIT) || (z < -DOUBLE_TO_INT64_LIMIT)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, wrap_real(sc, z), it_is_too_large_string); - return((s7_int)r5rs_round(z)); -} - -static s7_pointer round_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc,round_i_7d(sc, x)));} -#endif - - -/* ---------------------------------------- add ---------------------------------------- */ -static inline s7_pointer add_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if (add_overflow(x, y, &val)) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, x); - mpz_set_si(sc->mpz_2, y); - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - return(mpz_to_big_integer(sc, sc->mpz_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, y); - return(make_real(sc, (long_double)x + (long_double)y)); - } -#endif - return(make_integer(sc, val)); -#else - return(make_integer(sc, x + y)); -#endif -} - -static s7_pointer integer_ratio_add_if_overflow_to_real_or_rational(s7_scheme *sc, s7_pointer x, s7_pointer y) /* x: int, y:ratio */ -{ -#if HAVE_OVERFLOW_CHECKS - s7_int z; - if ((multiply_overflow(integer(x), denominator(y), &z)) || - (add_overflow(z, numerator(y), &z))) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, integer(x)); - mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y)); - mpz_set_si(sc->mpz_2, numerator(y)); - mpz_add(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1); - mpz_set_si(mpq_denref(sc->mpq_1), denominator(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer + ratio overflow: (+ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); - return(make_real(sc, (long_double)integer(x) + fraction(y))); - } -#endif - return(make_ratio(sc, z, denominator(y))); -#else - return(make_ratio(sc, integer(x) * denominator(y) + numerator(y), denominator(y))); -#endif -} - -#define parcel_out_fractions(X, Y) do {d1 = denominator(x); n1 = numerator(x); d2 = denominator(y); n2 = numerator(y);} while (0) -/* add_out_x|y here (as in lt_out_x|y) gives a small speed-up, say 3-7 callgrind units, about 2% */ - -static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - /* an experiment: try to avoid the switch statement */ - /* this wins in most s7 cases, not so much elsewhere? parallel subtract/multiply code is slower */ - if (is_t_integer(x)) - { - if (is_t_integer(y)) - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - } - else - if (is_t_real(x)) - { - if (is_t_real(y)) - return(make_real(sc, real(x) + real(y))); - } - else - if ((is_t_complex(x)) && (is_t_complex(y))) - return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - case T_RATIO: - return(integer_ratio_add_if_overflow_to_real_or_rational(sc, x, y)); - case T_REAL: -#if WITH_GMP - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) /* (+ 9223372036854775807 .1), >= needed for (+ 9007199254740992 1.0) */ - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (long_double)integer(x) + real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, integer(x)); - mpz_add(sc->mpz_1, sc->mpz_1, big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_add_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(integer_ratio_add_if_overflow_to_real_or_rational(sc, y, x)); - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); - if (d1 == d2) - { -#if HAVE_OVERFLOW_CHECKS - s7_int q; - if (add_overflow(n1, n2, &q)) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (/ (+ %" ld64 " %" ld64 ") %" ld64 ")\n", n1, n2, d1); - return(make_real(sc, ((long_double)n1 + (long_double)n2) / (long_double)d1)); - } -#endif - return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1)); -#else - return(make_ratio_with_div_check(sc, sc->add_symbol, n1 + n2, d1)); -#endif - } - -#if HAVE_OVERFLOW_CHECKS - { - s7_int n1d2, n2d1, d1d2, q; - if ((multiply_overflow(d1, d2, &d1d2)) || - (multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1)) || - (add_overflow(n1d2, n2d1, &q))) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (+ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, ((long_double)n1 / (long_double)d1) + ((long_double)n2 / (long_double)d2))); - } -#endif - return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1d2)); - } -#else - return(make_ratio_with_div_check(sc, sc->add_symbol, n1 * d2 + n2 * d1, d1 * d2)); -#endif - } - case T_REAL: - return(make_real(sc, fraction(x) + real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, fraction(x) + real_part(y), imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_z(sc->mpq_2, big_integer(y)); - mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_add_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: -#if WITH_GMP - if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) /* (+ .1 9223372036854775807) */ - { - mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); - mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, real(x) + (long_double)integer(y))); - case T_RATIO: - return(make_real(sc, real(x) + fraction(y))); - case T_REAL: - return(make_real(sc, real(x) + real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, real(x) + real_part(y), imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_add_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - return(make_complex_not_0i(sc, real_part(x) + integer(y), imag_part(x))); - case T_RATIO: - return(make_complex_not_0i(sc, real_part(x) + fraction(y), imag_part(x))); - case T_REAL: - return(make_complex_not_0i(sc, real_part(x) + real(y), imag_part(x))); - case T_COMPLEX: - return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(y)); - mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_add(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpz_add(sc->mpz_1, big_integer(x), big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_add_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_add(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_add_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - mpfr_add_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_add_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_add_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpfr_add_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_add_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_add(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_add_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_add_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_add(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } -#endif - default: - return(method_or_bust_pp(sc, x, sc->add_symbol, x, y, a_number_string, 1)); - } -} - -static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer p0, s7_pointer p1, s7_pointer p2) -{ - if ((is_t_integer(p0)) && (is_t_integer(p1)) && (is_t_integer(p2))) - { -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if ((!add_overflow(integer(p0), integer(p1), &val)) && - (!add_overflow(val, integer(p2), &val))) - return(make_integer(sc, val)); -#if WITH_GMP - mpz_set_si(sc->mpz_1, integer(p0)); - mpz_set_si(sc->mpz_2, integer(p1)); - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - mpz_set_si(sc->mpz_2, integer(p2)); - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - return(mpz_to_integer(sc, sc->mpz_1)); -#else - if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 ")\n", integer(p0), integer(p1), integer(p2)); - return(make_real(sc, (long_double)integer(p0) + (long_double)integer(p1) + (long_double)integer(p2))); -#endif -#else - return(make_integer(sc, integer(p0) + integer(p1) + integer(p2))); -#endif - } - if ((is_t_real(p0)) && (is_t_real(p1)) && (is_t_real(p2))) - return(make_real(sc, real(p0) + real(p1) + real(p2))); - { - s7_pointer p = add_p_pp(sc, p0, p1); - sc->error_argnum = 1; - p = add_p_pp(sc, p, p2); - sc->error_argnum = 0; - return(p); - } -} - -static s7_pointer g_add(s7_scheme *sc, s7_pointer args) -{ - #define H_add "(+ ...) adds its arguments" - #define Q_add sc->pcl_n - - s7_pointer x, p; - if (is_null(args)) - return(int_zero); - x = car(args); - p = cdr(args); - if (is_null(p)) - { - if (!is_number(x)) - return(sole_arg_method_or_bust_p(sc, x, sc->add_symbol, a_number_string)); - return(x); - } - if (is_null(cdr(p))) - return(add_p_pp(sc, x, car(p))); - for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) - x = add_p_pp(sc, x, car(p)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args) {return(add_p_pp(sc, car(args), cadr(args)));} -static s7_pointer g_add_3(s7_scheme *sc, s7_pointer args) {return(add_p_ppp(sc, car(args), cadr(args), caddr(args)));} - -static s7_pointer g_add_x1_1(s7_scheme *sc, s7_pointer x, int32_t pos) -{ - if (is_t_integer(x)) - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); - - switch (type(x)) - { - case T_RATIO: return(integer_ratio_add_if_overflow_to_real_or_rational(sc, int_one, x)); /* return(add_p_pp(sc, x, int_one)) */ - case T_REAL: return(make_real(sc, real(x) + 1.0)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, 1); - mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - case T_BIG_REAL: - case T_BIG_COMPLEX: - return(add_p_pp(sc, x, int_one)); -#endif - default: - return(method_or_bust(sc, x, sc->add_symbol, - (pos == 1) ? set_plist_2(sc, x, int_one) : set_plist_2(sc, int_one, x), - a_number_string, pos)); - } - return(x); -} - -#if WITH_GMP -static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, car(args), 1));} -#else -static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args); - if (is_t_integer(x)) return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); /* return(make_integer(sc, integer(x) + 1)); */ - if (is_t_real(x)) return(make_real(sc, real(x) + 1.0)); - if (is_t_complex(x)) return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x))); - return(add_p_pp(sc, x, int_one)); -} -#endif -static s7_pointer g_add_1x(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, cadr(args), 2));} - -static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y, int32_t loc) -{ - if (is_t_integer(x)) - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), y)); - - switch (type(x)) - { - case T_RATIO: return(add_p_pp(sc, x, wrap_integer(sc, y))); - case T_REAL: return(make_real(sc, real(x) + y)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, y); - mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - case T_BIG_REAL: - case T_BIG_COMPLEX: - return(add_p_pp(sc, x, wrap_integer(sc, y))); -#endif - default: return(method_or_bust_with_type_pi(sc, x, sc->add_symbol, x, y, a_number_string, loc)); - } - return(x); -} - -static s7_pointer add_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_add_xi(sc, p1, i1, 1));} - -static s7_pointer g_add_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t loc) -{ - if (is_t_real(x)) return(make_real(sc, real(x) + y)); - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, integer(x) + y)); - case T_RATIO: return(make_real(sc, fraction(x) + y)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(add_p_pp(sc, x, wrap_real(sc, y))); -#endif - default: return(method_or_bust_with_type_pf(sc, x, sc->add_symbol, x, y, a_number_string, loc)); - } - return(x); -} - -static s7_pointer g_add_2_ff(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - if ((is_t_real(car(args))) && (is_t_real(cadr(args)))) - return(make_real(sc, real(car(args)) + real(cadr(args)))); - return(add_p_pp(sc, car(args), cadr(args))); -#else - return(make_real(sc, real(car(args)) + real(cadr(args)))); -#endif -} - -static s7_pointer g_add_2_ii(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - if ((is_t_integer(car(args))) && (is_t_integer(cadr(args)))) -#endif - return(add_if_overflow_to_real_or_big_integer(sc, integer(car(args)), integer(cadr(args)))); -#if WITH_GMP - return(g_add(sc, args)); /* possibly bigint? */ -#endif -} - -#if WITH_GMP -static s7_pointer add_2_if(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if ((is_t_integer(x)) && (is_t_real(y))) - { - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - return(make_real(sc, integer(x) + real(y))); - } - return(add_p_pp(sc, x, y)); -} - -static s7_pointer g_add_2_if(s7_scheme *sc, s7_pointer args) {return(add_2_if(sc, car(args), cadr(args)));} -static s7_pointer g_add_2_fi(s7_scheme *sc, s7_pointer args) {return(add_2_if(sc, cadr(args), car(args)));} - -static s7_pointer g_add_2_xi(s7_scheme *sc, s7_pointer args) {if (is_t_integer(cadr(args))) return(g_add_xi(sc, car(args), integer(cadr(args)), 1)); return(g_add(sc, args));} -static s7_pointer g_add_2_ix(s7_scheme *sc, s7_pointer args) {if (is_t_integer(car(args))) return(g_add_xi(sc, cadr(args), integer(car(args)), 2)); return(g_add(sc, args));} -static s7_pointer g_add_2_xf(s7_scheme *sc, s7_pointer args) {if (is_t_real(cadr(args))) return(g_add_xf(sc, car(args), real(cadr(args)), 1)); return(g_add(sc, args));} -static s7_pointer g_add_2_fx(s7_scheme *sc, s7_pointer args) {if (is_t_real(car(args))) return(g_add_xf(sc, cadr(args), real(car(args)), 2)); return(g_add(sc, args));} - -#else - -static s7_pointer g_add_2_if(s7_scheme *sc, s7_pointer args) {return(make_real(sc, integer(car(args)) + real(cadr(args))));} -static s7_pointer g_add_2_fi(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) + integer(cadr(args))));} -static s7_pointer g_add_2_xi(s7_scheme *sc, s7_pointer args) {return(g_add_xi(sc, car(args), integer(cadr(args)), 1));} -static s7_pointer g_add_2_ix(s7_scheme *sc, s7_pointer args) {return(g_add_xi(sc, cadr(args), integer(car(args)), 2));} -static s7_pointer g_add_2_xf(s7_scheme *sc, s7_pointer args) {return(g_add_xf(sc, car(args), real(cadr(args)), 1));} -static s7_pointer g_add_2_fx(s7_scheme *sc, s7_pointer args) {return(g_add_xf(sc, cadr(args), real(car(args)), 2));} -#endif - -static s7_pointer add_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 + x2));} -static s7_pointer add_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_integer(sc, x1 + x2));} - -/* add_p_ii and add_d_id unhittable apparently -- this (d_id) is due to the order of d_dd_ok and d_id_ok in float_optimize, - * but d_dd is much more often hit, and the int arg (if constant) is turned into a float in d_dd - */ -static s7_double add_d_d(s7_double x) {return(x);} -static s7_double add_d_dd(s7_double x1, s7_double x2) {return(x1 + x2);} -static s7_double add_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 + x2 + x3);} -static s7_double add_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 + x2 + x3 + x4);} - -static s7_int add_i_ii(s7_int i1, s7_int i2) {return(i1 + i2);} -static s7_int add_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 + i2 + i3);} - -static s7_pointer argument_type(s7_scheme *sc, s7_pointer arg1) -{ - if (is_pair(arg1)) - { - if (car(arg1) == sc->quote_symbol) - return((is_pair(cdr(arg1))) ? s7_type_of(sc, cadr(arg1)) : NULL); /* arg1 = (quote) */ - - if ((is_h_optimized(arg1)) && - (is_safe_c_op(optimize_op(arg1))) && - (is_c_function(opt1_cfunc(arg1)))) - { - s7_pointer sig = c_function_signature(opt1_cfunc(arg1)); - if ((sig) && - (is_pair(sig)) && - (is_symbol(car(sig)))) - return(car(sig)); - } - /* perhaps add closure sig if we can depend on it (immutable func etc) */ - } - else - if (!is_symbol(arg1)) - return(s7_type_of(sc, arg1)); - return(NULL); -} - -static s7_pointer chooser_check_arg_types(s7_scheme *sc, s7_pointer arg1, s7_pointer arg2, s7_pointer fallback, - s7_pointer f_2_ff, s7_pointer f_2_ii, s7_pointer f_2_if, s7_pointer f_2_fi, - s7_pointer f_2_xi, s7_pointer f_2_ix, s7_pointer f_2_fx, s7_pointer f_2_xf) -{ - s7_pointer arg1_type = argument_type(sc, arg1); - s7_pointer arg2_type = argument_type(sc, arg2); - if ((arg1_type) || (arg2_type)) - { - if (arg1_type == sc->is_float_symbol) - { - if (arg2_type == sc->is_float_symbol) - return(f_2_ff); - return((arg2_type == sc->is_integer_symbol) ? f_2_fi : f_2_fx); - } - if (arg1_type == sc->is_integer_symbol) - { - if (arg2_type == sc->is_float_symbol) - return(f_2_if); - return((arg2_type == sc->is_integer_symbol) ? f_2_ii : f_2_ix); - } - if (arg2_type == sc->is_float_symbol) - return(f_2_xf); - if (arg2_type == sc->is_integer_symbol) - return(f_2_xi); - } - return(fallback); -} - -static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args); - -static s7_pointer add_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - /* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s)) */ - if (args != 2) return((args == 3) ? sc->add_3 : f); - if (ops) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if (arg2 == int_one) /* (+ ... 1) */ - return(sc->add_x1); - if ((is_t_integer(arg1)) && ((is_pair(arg2)) && (is_optimized(arg2)) && (is_h_safe_c_nc(arg2)) && (fn_proc(arg2) == g_random_i))) - { - set_opt3_int(cdr(expr), integer(cadr(arg2))); - set_safe_optimize_op(expr, HOP_SAFE_C_NC); /* op if r op? */ - return(sc->add_i_random); - } - if (arg1 == int_one) - return(sc->add_1x); - return(chooser_check_arg_types(sc, arg1, arg2, sc->add_2, - sc->add_2_ff, sc->add_2_ii, sc->add_2_if, sc->add_2_fi, - sc->add_2_xi, sc->add_2_ix, sc->add_2_fx, sc->add_2_xf)); - } - return(sc->add_2); -} - -/* ---------------------------------------- subtract ---------------------------------------- */ -static s7_pointer negate_p_p(s7_scheme *sc, s7_pointer p) /* can't use "negate" because it confuses C++! */ -{ - switch (type(p)) - { - case T_INTEGER: - if (integer(p) == S7_INT64_MIN) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, S7_INT64_MIN); - mpz_neg(sc->mpz_1, sc->mpz_1); - return(mpz_to_big_integer(sc, sc->mpz_1)); - } -#else - sole_arg_out_of_range_error_nr(sc, sc->subtract_symbol, p, wrap_string(sc, "most-negative-fixnum can't be negated", 37)); -#endif - return(make_integer(sc, -integer(p))); - - case T_RATIO: return(make_simple_ratio(sc, -numerator(p), denominator(p))); - case T_REAL: return(make_real(sc, -real(p))); - case T_COMPLEX: return(make_complex_not_0i(sc, -real_part(p), -imag_part(p))); - -#if WITH_GMP - case T_BIG_INTEGER: - mpz_neg(sc->mpz_1, big_integer(p)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_neg(sc->mpq_1, big_ratio(p)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_neg(sc->mpfr_1, big_real(p), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_neg(sc->mpc_1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->subtract_symbol, a_number_string)); - } -} - -static inline s7_pointer subtract_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if (subtract_overflow(x, y, &val)) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, x); - mpz_set_si(sc->mpz_2, y); - mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_2); - return(mpz_to_big_integer(sc, sc->mpz_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y); - return(make_real(sc, (long_double)x - (long_double)y)); - } -#endif - return(make_integer(sc, val)); -#else - return(make_integer(sc, x - y)); -#endif -} - -static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - switch (type(x)) - { - case T_INTEGER: - if (integer(x) == 0) - return(negate_p_p(sc, y)); - switch (type(y)) - { - case T_INTEGER: - return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - - case T_RATIO: - { -#if HAVE_OVERFLOW_CHECKS - s7_int z; - if ((multiply_overflow(integer(x), denominator(y), &z)) || - (subtract_overflow(z, numerator(y), &z))) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, integer(x)); - mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y)); - mpz_set_si(sc->mpz_2, numerator(y)); - mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_1, sc->mpz_2); - mpz_set_si(mpq_denref(sc->mpq_1), denominator(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer - ratio overflow: (- %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); - return(make_real(sc, (long_double)integer(x) - fraction(y))); - } -#endif - return(make_ratio(sc, z, denominator(y))); -#else - return(make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y))); -#endif - } - case T_REAL: -#if WITH_GMP - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) /* (- 9223372036854775807 .1) */ - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (long_double)integer(x) - real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, (long_double)integer(x) - real_part(y), -imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, integer(x)); - mpz_sub(sc->mpz_1, sc->mpz_1, big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_si_sub(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - { -#if HAVE_OVERFLOW_CHECKS - s7_int z; - if ((multiply_overflow(integer(y), denominator(x), &z)) || - (subtract_overflow(numerator(x), z, &z))) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, integer(y)); - mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(x)); - mpz_set_si(sc->mpz_2, numerator(x)); - mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1); - mpz_set_si(mpq_denref(sc->mpq_1), denominator(x)); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - integer overflow: (- %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); - return(make_real(sc, fraction(x) - (long_double)integer(y))); - } -#endif - return(make_ratio(sc, z, denominator(x))); -#else - return(make_ratio(sc, numerator(x) - (integer(y) * denominator(x)), denominator(x))); -#endif - } - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); - if (d1 == d2) - { -#if HAVE_OVERFLOW_CHECKS - s7_int q; - if (subtract_overflow(n1, n2, &q)) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, ((long_double)n1 - (long_double)n2) / (long_double)d1)); - } -#endif - return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1)); -#else - return(make_ratio(sc, numerator(x) - numerator(y), denominator(x))); -#endif - } - -#if HAVE_OVERFLOW_CHECKS - { - s7_int n1d2, n2d1, d1d2, q; - if ((multiply_overflow(d1, d2, &d1d2)) || - (multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1)) || - (subtract_overflow(n1d2, n2d1, &q))) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, ((long_double)n1 / (long_double)d1) - ((long_double)n2 / (long_double)d2))); - } -#endif - return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1d2)); - } -#else - return(make_ratio_with_div_check(sc, sc->subtract_symbol, n1 * d2 - n2 * d1, d1 * d2)); -#endif - } - case T_REAL: - return(make_real(sc, fraction(x) - real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, fraction(x) - real_part(y), -imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_z(sc->mpq_2, big_integer(y)); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: -#if WITH_GMP - if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) /* (- .1 92233720368547758071) */ - { - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_sub_si(sc->mpfr_1, sc->mpfr_1, integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, real(x) - (long_double)integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */ - case T_RATIO: - return(make_real(sc, real(x) - fraction(y))); - case T_REAL: - return(make_real(sc, real(x) - real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, real(x) - real_part(y), -imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_sub_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_sub_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_d_sub(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - return(make_complex_not_0i(sc, real_part(x) - integer(y), imag_part(x))); - case T_RATIO: - return(make_complex_not_0i(sc, real_part(x) - fraction(y), imag_part(x))); - case T_REAL: - return(make_complex_not_0i(sc, real_part(x) - real(y), imag_part(x))); - case T_COMPLEX: - return(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sub_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(y)); - mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_sub(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpz_sub(sc->mpz_1, big_integer(x), big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_sub(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - mpfr_sub_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_sub_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_sub_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_fr_sub(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpfr_sub_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_sub_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_sub(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_fr_sub(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - mpc_set_si(sc->mpc_2, integer(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_sub_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_sub(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } -#endif - default: - return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); - } -} - -static s7_pointer g_subtract(s7_scheme *sc, s7_pointer args) -{ - #define H_subtract "(- x1 ...) subtracts its trailing arguments from the first, or negates the first if only one it is given" - #define Q_subtract sc->pcl_n - - s7_pointer x = car(args), p = cdr(args); - if (is_null(p)) - return(negate_p_p(sc, x)); - for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) - x = subtract_p_pp(sc, x, car(p)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer g_subtract_1(s7_scheme *sc, s7_pointer args) {return(negate_p_p(sc, car(args)));} -static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args) {return(subtract_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_subtract_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args); - x = subtract_p_pp(sc, x, cadr(args)); - sc->error_argnum = 1; - x = subtract_p_pp(sc, x, caddr(args)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); - case T_RATIO: return(subtract_p_pp(sc, x, int_one)); - case T_REAL: return(make_real(sc, real(x) - 1.0)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - 1.0, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(subtract_p_pp(sc, x, int_one)); -#endif - default: - return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, int_one, a_number_string, 1)); - } - return(x); -} - -static s7_pointer g_subtract_x1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = car(args); -#if WITH_GMP - return(subtract_p_pp(sc, p, int_one)); -#endif - /* return((is_t_integer(p)) ? make_integer(sc, integer(p) - 1) : minus_c1(sc, p)); */ - return((is_t_integer(p)) ? subtract_if_overflow_to_real_or_big_integer(sc, integer(p), 1) : minus_c1(sc, p)); -} - -static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args) /* (- x f) */ -{ - s7_pointer x = car(args); - s7_double n = real(cadr(args)); /* checked below is_t_real */ - if (is_t_real(x)) return(make_real(sc, real(x) - n)); - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, integer(x) - n)); - case T_RATIO: return(make_real(sc, fraction(x) - n)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - n, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(subtract_p_pp(sc, x, cadr(args))); -#endif - default: - return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1)); - } - return(x); -} - -static s7_pointer g_subtract_f2(s7_scheme *sc, s7_pointer args) /* (- f x) */ -{ - s7_pointer x = cadr(args); - s7_double n = real(car(args)); /* checked below is_t_real */ - - if (is_t_real(x)) return(make_real(sc, n - real(x))); - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, n - integer(x))); - case T_RATIO: return(make_real(sc, n - fraction(x))); - case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(subtract_p_pp(sc, car(args), x)); -#endif - default: - return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1)); - } - return(x); -} - -static s7_int subtract_i_ii(s7_int i1, s7_int i2) {return(i1 - i2);} -static s7_int subtract_i_i(s7_int x) {return(-x);} -static s7_int subtract_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 - i2 - i3);} - -static s7_double subtract_d_d(s7_double x) {return(-x);} -static s7_double subtract_d_dd(s7_double x1, s7_double x2) {return(x1 - x2);} -static s7_double subtract_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 - x2 - x3);} -static s7_double subtract_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 - x2 - x3 - x4);} - -static s7_pointer subtract_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 - x2));} -static s7_pointer subtract_p_ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(make_integer(sc, i1 - i2));} - -static s7_pointer g_sub_xi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if (is_t_integer(x)) - return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), y)); - - switch (type(x)) - { - case T_RATIO: return(make_ratio(sc, numerator(x) - (y * denominator(x)), denominator(x))); - case T_REAL: return(make_real(sc, real(x) - y)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - y, imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, y); - mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - case T_BIG_REAL: - case T_BIG_COMPLEX: - return(subtract_p_pp(sc, x, wrap_integer(sc, y))); -#endif - default: return(method_or_bust_with_type_pi(sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); - } - return(x); -} - -static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args == 1) return(sc->subtract_1); - if (args != 2) return((args == 3) ? sc->subtract_3 : f); - if (ops) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if (arg2 == int_one) return(sc->subtract_x1); - if (is_t_real(arg1)) return(sc->subtract_f2); - if (is_t_real(arg2)) return(sc->subtract_2f); - } - return(sc->subtract_2); -} - - -/* ---------------------------------------- multiply ---------------------------------------- */ -#define QUOTIENT_FLOAT_LIMIT 1e13 -#define QUOTIENT_INT_LIMIT 10000000000000 -/* fraction(x) is not accurate enough if it involves numbers over e18 even when done with long_doubles */ - -static inline s7_pointer multiply_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if (multiply_overflow(x, y, &val)) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, x); - mpz_mul_si(sc->mpz_1, sc->mpz_1, y); - return(mpz_to_big_integer(sc, sc->mpz_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y); - return(make_real(sc, (s7_double)x * (s7_double)y)); - } -#endif - return(make_integer(sc, val)); -#else - return(make_integer(sc, x * y)); -#endif -} - -static s7_pointer integer_ratio_multiply_if_overflow_to_real_or_ratio(s7_scheme *sc, s7_int x, s7_pointer y) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int z; - if (multiply_overflow(x, numerator(y), &z)) -#if WITH_GMP - { - mpz_set_si(sc->mpz_1, x); - mpz_mul_si(sc->mpz_1, sc->mpz_1, numerator(y)); - mpq_set_si(sc->mpq_1, 1, denominator(y)); - mpq_set_num(sc->mpq_1, sc->mpz_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer * ratio overflow: (* %" ld64 " %" ld64 "/%" ld64 ")\n", x, numerator(y), denominator(y)); - return(make_real(sc, (s7_double)x * fraction(y))); - } -#endif - return(make_ratio(sc, z, denominator(y))); -#else - return(make_ratio(sc, x * numerator(y), denominator(y))); -#endif -} - -static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(multiply_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - case T_RATIO: - return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(x), y)); - case T_REAL: -#if WITH_GMP - if (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (long_double)integer(x) * real(y))); - case T_COMPLEX: - return(s7_make_complex(sc, (long_double)integer(x) * real_part(y), (long_double)integer(x) * imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_mul_si(sc->mpz_1, big_integer(y), integer(x)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_mul_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_mul_si(sc->mpc_1, big_complex(y), integer(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0 */ -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(y), x)); - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); -#if HAVE_OVERFLOW_CHECKS - { - s7_int n1n2, d1d2; - if ((multiply_overflow(d1, d2, &d1d2)) || - (multiply_overflow(n1, n2, &n1n2))) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio * ratio overflow: (* %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, fraction(x) * fraction(y))); - } -#endif - return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1n2, d1d2)); - } -#else - return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1 * n2, d1 * d2)); -#endif - } - case T_REAL: -#if WITH_GMP - if (numerator(x) > QUOTIENT_INT_LIMIT) - { - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, fraction(x) * real(y))); - case T_COMPLEX: - return(s7_make_complex(sc, fraction(x) * real_part(y), fraction(x) * imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_z(sc->mpq_2, big_integer(y)); - mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_mul_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: -#if WITH_GMP - if (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN); - mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, real(x) * (long_double)integer(y))); - case T_RATIO: -#if WITH_GMP - if (numerator(y) > QUOTIENT_INT_LIMIT) - { - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, fraction(y) * real(x))); - case T_REAL: - return(make_real(sc, real(x) * real(y))); - case T_COMPLEX: - return(make_complex(sc, real(x) * real_part(y), real(x) * imag_part(y))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_mul_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might = 0.0 */ -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - return(make_complex(sc, real_part(x) * integer(y), imag_part(x) * integer(y))); - case T_RATIO: - return(s7_make_complex(sc, real_part(x) * fraction(y), imag_part(x) * fraction(y))); - case T_REAL: - return(make_complex(sc, real_part(x) * real(y), imag_part(x) * real(y))); - case T_COMPLEX: - { - s7_double r1 = real_part(x), r2 = real_part(y), i1 = imag_part(x), i2 = imag_part(y); - return(make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1)); - } -#if WITH_GMP - case T_BIG_INTEGER: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - mpz_mul_si(sc->mpz_1, big_integer(x), integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_mul(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpz_mul(sc->mpz_1, big_integer(x), big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_mul_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_mul(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_mul_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - mpfr_mul_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_mul_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_mul_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpfr_mul_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_mul_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_mul(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_mul_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* 0.0? */ - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - mpc_mul_si(sc->mpc_1, big_complex(x), integer(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_mul_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_mul(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } -#endif - default: - return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, y, a_number_string, 1)); - } -} - -static s7_pointer multiply_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) -{ - x = multiply_p_pp(sc, x, y); - sc->error_argnum = 1; - x = multiply_p_pp(sc, x, z); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer multiply_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer args, s7_pointer typ, int32_t num) -{ - if (has_active_methods(sc, obj)) - return(find_and_apply_method(sc, obj, sc->multiply_symbol, args)); - if (num == 0) - sole_arg_wrong_type_error_nr(sc, sc->multiply_symbol, obj, typ); - wrong_type_error_nr(sc, sc->multiply_symbol, num, obj, typ); - return(NULL); -} - -static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args) -{ - #define H_multiply "(* ...) multiplies its arguments" - #define Q_multiply sc->pcl_n - - s7_pointer x, p; - if (is_null(args)) - return(int_one); - x = car(args); - p = cdr(args); - if (is_null(p)) - { - if (!is_number(x)) - return(multiply_method_or_bust(sc, x, args, a_number_string, 0)); - return(x); - } - for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) - x = multiply_p_pp(sc, x, car(p)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n, int32_t loc) -{ - switch (type(x)) - { - case T_INTEGER: return(multiply_if_overflow_to_real_or_big_integer(sc, integer(x), n)); - case T_RATIO: return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, n, x)); - case T_REAL: return(make_real(sc, real(x) * n)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * n, imag_part(x) * n)); -#if WITH_GMP - case T_BIG_INTEGER: - mpz_mul_si(sc->mpz_1, big_integer(x), n); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - case T_BIG_REAL: - case T_BIG_COMPLEX: - return(multiply_p_pp(sc, x, wrap_integer(sc, n))); -#endif - default: - /* we can get here from mul_2_xi for example so the non-integer argument might not be a symbol */ - return(method_or_bust_with_type_pi(sc, x, sc->multiply_symbol, x, n, a_number_string, loc)); - } - return(x); -} - -static s7_pointer multiply_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_mul_xi(sc, p1, i1, 1));} - -static s7_pointer g_mul_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t num) -{ - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, integer(x) * y)); - case T_RATIO: return(make_real(sc, numerator(x) * y / denominator(x))); - case T_REAL: return(make_real(sc, real(x) * y)); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * y, imag_part(x) * y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_mul_d(sc->mpfr_1, big_real(x), y, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpc_mul_fr(sc->mpc_1, big_complex(x), sc->mpfr_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: return(method_or_bust_with_type_pf(sc, x, sc->multiply_symbol, x, y, a_number_string, num)); - } - return(x); -} - -#if WITH_GMP -static s7_pointer g_mul_2_if(s7_scheme *sc, s7_pointer args) { - if ((is_t_integer(car(args))) && (is_t_real(cadr(args)))) - return(make_real(sc, integer(car(args)) * real(cadr(args)))); - return(multiply_p_pp(sc, car(args), cadr(args))); -} - -static s7_pointer g_mul_2_fi(s7_scheme *sc, s7_pointer args) -{ - if ((is_t_integer(cadr(args))) && (is_t_real(car(args)))) - return(make_real(sc, real(car(args)) * integer(cadr(args)))); - return(multiply_p_pp(sc, car(args), cadr(args))); -} - -static s7_pointer g_mul_2_xi(s7_scheme *sc, s7_pointer args) {if (is_t_integer(cadr(args))) return(g_mul_xi(sc, car(args), integer(cadr(args)), 1)); return(g_multiply(sc, args));} -static s7_pointer g_mul_2_ix(s7_scheme *sc, s7_pointer args) {if (is_t_integer(car(args))) return(g_mul_xi(sc, cadr(args), integer(car(args)), 2)); return(g_multiply(sc, args));} -static s7_pointer g_mul_2_xf(s7_scheme *sc, s7_pointer args) {if (is_t_real(cadr(args))) return(g_mul_xf(sc, car(args), real(cadr(args)), 1)); return(g_multiply(sc, args));} -static s7_pointer g_mul_2_fx(s7_scheme *sc, s7_pointer args) {if (is_t_real(car(args))) return(g_mul_xf(sc, cadr(args), real(car(args)), 2)); return(g_multiply(sc, args));} -static s7_pointer g_mul_2_ff(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));} -static s7_pointer g_mul_2_ii(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));} -#else -static s7_pointer g_mul_2_if(s7_scheme *sc, s7_pointer args) {return(make_real(sc, integer(car(args)) * real(cadr(args))));} -static s7_pointer g_mul_2_fi(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) * integer(cadr(args))));} -static s7_pointer g_mul_2_xi(s7_scheme *sc, s7_pointer args) {return(g_mul_xi(sc, car(args), integer(cadr(args)), 1));} -static s7_pointer g_mul_2_ix(s7_scheme *sc, s7_pointer args) {return(g_mul_xi(sc, cadr(args), integer(car(args)), 2));} -static s7_pointer g_mul_2_xf(s7_scheme *sc, s7_pointer args) {return(g_mul_xf(sc, car(args), real(cadr(args)), 1));} /* split out t_real is slower */ -static s7_pointer g_mul_2_fx(s7_scheme *sc, s7_pointer args) {return(g_mul_xf(sc, cadr(args), real(car(args)), 2));} -static s7_pointer g_mul_2_ff(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) * real(cadr(args))));} - -static s7_pointer g_mul_2_ii(s7_scheme *sc, s7_pointer args) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val, x = integer(car(args)), y = integer(cadr(args)); - if (multiply_overflow(x, y, &val)) - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y); - return(make_real(sc, (s7_double)x * (s7_double)y)); - } - return(make_integer(sc, val)); -#else - return(make_integer(sc, integer(car(args)) * integer(cadr(args)))); -#endif -} -#endif - -static s7_int multiply_i_ii(s7_int i1, s7_int i2) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val; - if (multiply_overflow(i1, i2, &val)) - { -#if WITH_WARNINGS - s7_warn(cur_sc, 64, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", i1, i2); -#endif - return(S7_INT64_MAX); /* this is inconsistent with other unopt cases where an overflow -> double result */ - } - /* (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((= j 1)) (even? (* (ash 1 43) (ash 1 43)))))) (define (hi) (func)) (hi)) */ - return(val); -#else - return(i1 * i2); -#endif -} - -static s7_int multiply_i_iii(s7_int i1, s7_int i2, s7_int i3) -{ -#if HAVE_OVERFLOW_CHECKS - s7_int val1, val2; - if ((multiply_overflow(i1, i2, &val1)) || - (multiply_overflow(val1, i3, &val2))) - { -#if WITH_WARNINGS - s7_warn(cur_sc, 64, "integer multiply overflow: (* %" ld64 " %" ld64 " %" ld64 ")\n", i1, i2, i3); -#endif - return(S7_INT64_MAX); - } - return(val2); -#else - return(i1 * i2 * i3); -#endif -} - -static s7_double multiply_d_d(s7_double x) {return(x);} -static s7_double multiply_d_dd(s7_double x1, s7_double x2) {return(x1 * x2);} -static s7_double multiply_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 * x2 * x3);} -static s7_double multiply_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 * x2 * x3 * x4);} -static s7_pointer mul_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 * x2));} - -static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - return(chooser_check_arg_types(sc, cadr(expr), caddr(expr), sc->multiply_2, - sc->mul_2_ff, sc->mul_2_ii, sc->mul_2_if, sc->mul_2_fi, - sc->mul_2_xi, sc->mul_2_ix, sc->mul_2_fx, sc->mul_2_xf)); - return(sc->multiply_2); -} - - -/* ---------------------------------------- divide ---------------------------------------- */ -static s7_pointer complex_invert(s7_scheme *sc, s7_pointer p) -{ - s7_double r2 = real_part(p), i2 = imag_part(p); - s7_double den = (r2 * r2 + i2 * i2); - /* here if p is, for example, -inf.0+i, den is +inf.0 so -i2/den is -0.0 (in gcc anyway), so the imag part is 0.0 */ - return(s7_make_complex(sc, r2 / den, -i2 / den)); -} - -static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer p) -{ -#if WITH_GMP - s7_pointer x; -#endif - switch (type(p)) - { - case T_INTEGER: -#if WITH_GMP && (!POINTER_32) - if (integer(p) == S7_INT64_MIN) /* (/ 1 (*s7* 'most-negative-fixnum)) -> -1/9223372036854775808 */ - { - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpz_set_si(sc->mpz_1, S7_INT64_MAX); - mpz_set_si(sc->mpz_2, 1); - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - mpq_set_si(big_ratio(x), -1, 1); - mpq_set_den(big_ratio(x), sc->mpz_1); /* geez... */ - return(x); - } -#endif - if (integer(p) == 0) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); - return(make_simple_ratio(sc, 1, integer(p))); /* this checks for int */ - case T_RATIO: - return(make_simple_ratio(sc, denominator(p), numerator(p))); - case T_REAL: - if (real(p) == 0.0) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); - return(make_real(sc, 1.0 / real(p))); - case T_COMPLEX: - return(complex_invert(sc, p)); - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(p), 0) == 0) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); - if ((mpz_cmp_ui(big_integer(p), 1) == 0) || (mpz_cmp_si(big_integer(p), -1) == 0)) - return(p); - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_set_si(big_ratio(x), 1, 1); - mpq_set_den(big_ratio(x), big_integer(p)); - mpq_canonicalize(big_ratio(x)); - return(x); - - case T_BIG_RATIO: - if (mpz_cmp_ui(mpq_numref(big_ratio(p)), 1) == 0) - return(mpz_to_integer(sc, mpq_denref(big_ratio(p)))); - if (mpz_cmp_si(mpq_numref(big_ratio(p)), -1) == 0) - { - mpz_neg(sc->mpz_1, mpq_denref(big_ratio(p))); - return(mpz_to_integer(sc, sc->mpz_1)); - } - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpq_inv(big_ratio(x), big_ratio(p)); - mpq_canonicalize(big_ratio(x)); - return(x); - - case T_BIG_REAL: - if (mpfr_zero_p(big_real(p))) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); - x = mpfr_to_big_real(sc, big_real(p)); - mpfr_ui_div(big_real(x), 1, big_real(x), MPFR_RNDN); - return(x); - - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(p)))) || (!mpfr_number_p(mpc_imagref(big_complex(p))))) - return(complex_NaN); - mpc_ui_div(sc->mpc_1, 1, big_complex(p), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0+0i if real-part is inf? */ -#endif - default: - check_method(sc, p, sc->divide_symbol, set_plist_1(sc, p)); - wrong_type_error_nr(sc, sc->divide_symbol, 1, p, a_number_string); - } - return(NULL); -} - -static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - /* splitting out real/real here saves very little */ - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - /* -------- integer x -------- */ - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - if (integer(x) == 1) /* mainly to handle (/ 1 -9223372036854775808) correctly! */ - return(invert_p_p(sc, y)); - return(make_ratio(sc, integer(x), integer(y))); - - case T_RATIO: -#if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow(integer(x), denominator(y), &dn)) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_set_si(sc->mpq_2, numerator(y), denominator(y)); - mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer / ratio overflow: (/ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); - return(make_real(sc, integer(x) * inverted_fraction(y))); - } -#endif - return(make_ratio_with_div_check(sc, sc->divide_symbol, dn, numerator(y))); - } -#else - return(make_ratio_with_div_check(sc, sc->divide_symbol, integer(x) * denominator(y), numerator(y))); -#endif - - case T_REAL: - if (is_NaN(real(y))) return(y); - if (is_inf(real(y))) return(real_zero); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); -#if WITH_GMP - if ((s7_int_abs(integer(x))) > QUOTIENT_INT_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (s7_double)(integer(x)) / real(y))); - - case T_COMPLEX: - { - s7_double den, r1 = (s7_double)integer(x), r2 = real_part(y), i2 = imag_part(y); - den = 1.0 / (r2 * r2 + i2 * i2); - /* we could avoid the squaring (see Knuth II p613 16), not a big deal: (/ 1.0e308+1.0e308i 2.0e308+2.0e308i) => nan, (gmp case is ok here) */ - return(s7_make_complex(sc, r1 * r2 * den, -(r1 * i2 * den))); - } - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_set_den(sc->mpq_1, big_integer(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_si_div(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0? */ -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - break; - - /* -------- ratio x -------- */ - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); -#if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow(denominator(x), integer(y), &dn)) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_si(sc->mpq_2, integer(y), 1); - mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) - s7_warn(sc, 128, "ratio / integer overflow: (/ %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); - return(make_real(sc, (long_double)numerator(x) / ((long_double)denominator(x) * (long_double)integer(y)))); - } -#endif - return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), dn)); - } -#else - return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), denominator(x) * integer(y))); -#endif - - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); - if (d1 == d2) - return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, n2)); -#if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow(n1, d2, &n1)) || - (multiply_overflow(n2, d1, &d1))) - { -#if WITH_GMP - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); /* not n1 and d1! they are garbage here */ - mpq_set_si(sc->mpq_2, n2, d2); - mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); -#else - s7_double r1, r2; - if (WITH_WARNINGS) - s7_warn(sc, 128, "ratio / ratio overflow: (/ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", numerator(x), denominator(x), numerator(y), denominator(y)); - r1 = fraction(x); - r2 = inverted_fraction(y); - return(make_real(sc, r1 * r2)); -#endif - } - return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, d1)); -#else - return(make_ratio_with_div_check(sc, sc->divide_symbol, n1 * d2, n2 * d1)); -#endif - } - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - return(make_real(sc, fraction(x) / real(y))); - - case T_COMPLEX: - { - s7_double rx = fraction(x), r2 = real_part(y), i2 = imag_part(y); - s7_double den = 1.0 / (r2 * r2 + i2 * i2); - return(s7_make_complex(sc, rx * r2 * den, -rx * i2 * den)); /* not unchecked: (/ 3/4 -inf.0+i) */ - } - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_set_si(sc->mpq_2, numerator(x), denominator(x)); - mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - - /* -------- real x -------- */ - case T_REAL: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - if (is_NaN(real(x))) return(x); /* what is (/ +nan.0 0)? */ - if (is_inf(real(x))) - return((real(x) > 0.0) ? ((integer(y) > 0) ? real_infinity : real_minus_infinity) : ((integer(y) > 0) ? real_minus_infinity : real_infinity)); - return(make_real(sc, (long_double)real(x) / (long_double)integer(y))); - - case T_RATIO: - if (is_NaN(real(x))) return(x); - if (is_inf(real(x))) - return((real(x) > 0) ? ((numerator(y) > 0) ? real_infinity : real_minus_infinity) : ((numerator(y) > 0) ? real_minus_infinity : real_infinity)); - return(make_real(sc, real(x) * inverted_fraction(y))); - - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - if (is_NaN(real(x))) return(x); - if (is_inf(real(y))) - return((is_inf(real(x))) ? real_NaN : real_zero); - return(make_real(sc, real(x) / real(y))); - - case T_COMPLEX: - { - s7_double den, r2, i2; - if (is_NaN(real(x))) return(complex_NaN); - r2 = real_part(y); - i2 = imag_part(y); - if ((is_NaN(r2)) || (is_inf(r2))) return(complex_NaN); - if ((is_NaN(i2)) || (is_inf(i2))) return(complex_NaN); - den = 1.0 / (r2 * r2 + i2 * i2); - return(s7_make_complex(sc, real(x) * r2 * den, -real(x) * i2 * den)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); - mpfr_d_div(sc->mpfr_1, real(x), sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_div_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_d_div(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((is_NaN(real(x))) || (!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - - /* -------- complex x -------- */ - case T_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - { - s7_double r1; - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - r1 = (long_double)1.0 / (long_double)integer(y); - return(s7_make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); - } - - case T_RATIO: - { - s7_double frac = inverted_fraction(y); - return(make_complex(sc, real_part(x) * frac, imag_part(x) * frac)); - } - - case T_REAL: - { - s7_double r1; - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - r1 = 1.0 / real(y); - return(make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); /* (/ 0.0+1.0i +inf.0) */ - } - - case T_COMPLEX: - { - s7_double r1 = real_part(x), r2, i1, i2, den; - if (is_NaN(r1)) return(x); - i1 = imag_part(x); - if (is_NaN(i1)) return(x); - r2 = real_part(y); - if (is_NaN(r2)) return(y); - if (is_inf(r2)) return(complex_NaN); - i2 = imag_part(y); - if (is_NaN(i2)) return(y); - den = 1.0 / (r2 * r2 + i2 * i2); - return(s7_make_complex(sc, (r1 * r2 + i1 * i2) * den, (r2 * i1 - r1 * i2) * den)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_div_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpz_set_si(sc->mpz_1, integer(y)); - mpq_set_num(sc->mpq_1, big_integer(x)); - mpq_set_den(sc->mpq_1, sc->mpz_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); /* can't invert here, mpq den=unsigned */ - mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_num(sc->mpq_1, big_integer(x)); - mpq_set_den(sc->mpq_1, big_integer(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, 0, 1); - mpq_set_num(sc->mpq_1, big_integer(x)); - mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_div(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_div_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_fr_div(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_div_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_fr_div(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_div_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_div(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } -#endif - - default: /* x is not a built-in number */ - return(method_or_bust_pp(sc, x, sc->divide_symbol, x, y, a_number_string, 1)); /* not args here! y = apply * to cdr(args) */ - } - return(NULL); /* make the compiler happy */ -} - -static s7_pointer g_divide(s7_scheme *sc, s7_pointer args) -{ - #define H_divide "(/ x1 ...) divides its first argument by the rest, or inverts the first if there is only one argument" - #define Q_divide sc->pcl_n - - s7_pointer x = car(args), p = cdr(args); - if (is_null(p)) /* (/ x) */ - { - if (!is_number(x)) - return(sole_arg_method_or_bust_p(sc, x, sc->divide_symbol, a_number_string)); - return(invert_p_p(sc, x)); - } - for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) - x = divide_p_pp(sc, x, car(p)); - sc->error_argnum = 0; - return(x); -} - -static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args) {return(invert_p_p(sc, car(args)));} -static s7_pointer g_divide_2(s7_scheme *sc, s7_pointer args) {return(divide_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) -{ - /* (/ x 2) */ - s7_pointer num = car(args); - if (is_t_integer(num)) - { - s7_int i = integer(num); - if (i & 1) - { - s7_pointer x; - new_cell(sc, x, T_RATIO); - numerator(x) = i; - denominator(x) = 2; - return(x); - } - return(make_integer(sc, i >> 1)); - } - switch (type(num)) - { - case T_RATIO: -#if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow(denominator(num), 2, &dn)) - { - if ((numerator(num) & 1) == 1) -#if WITH_GMP - { - mpq_set_si(sc->mpq_1, numerator(num), denominator(num)); - mpq_set_si(sc->mpq_2, 1, 2); - mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } -#else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio / 2 overflow: (/ %" ld64 "/%" ld64 " 2)\n", numerator(num), denominator(num)); - return(make_real(sc, ((long_double)numerator(num) * 0.5) / (long_double)denominator(num))); - } -#endif - return(make_ratio(sc, numerator(num) / 2, denominator(num))); - } - return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(num), dn)); - } -#else - return(make_ratio(sc, numerator(num), denominator(num) * 2)); -#endif - - case T_REAL: return(make_real(sc, real(num) * 0.5)); - case T_COMPLEX: return(make_complex_not_0i(sc, real_part(num) * 0.5, imag_part(num) * 0.5)); - -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(num)); - mpz_mul_ui(mpq_denref(sc->mpq_1), mpq_denref(sc->mpq_1), 2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, 2, 1); - mpq_div(sc->mpq_1, big_ratio(num), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_div_si(sc->mpfr_1, big_real(num), 2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_si(sc->mpc_1, 2, MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(num), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_pp(sc, num, sc->divide_symbol, num, int_two, a_number_string, 1)); - } -} - -static s7_pointer g_invert_x(s7_scheme *sc, s7_pointer args) -{ - /* (/ 1.0 x) */ - s7_pointer x = cadr(args); - if (is_t_real(x)) - { - s7_double rl = real(x); - if (rl == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, car(args), x); - return((is_NaN(rl)) ? x : make_real(sc, 1.0 / rl)); - } - return(g_divide(sc, args)); -} - -static s7_double divide_d_7d(s7_scheme *sc, s7_double x) -{ - if (x == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, real_zero); - return(1.0 / x); -} - -static s7_double divide_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) -{ - if (x2 == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, real_zero); - return(x1 / x2); -} - -static s7_pointer divide_p_ii(s7_scheme *sc, s7_int x, s7_int y) {return(make_ratio_with_div_check(sc, sc->divide_symbol, x, y));} -static s7_pointer divide_p_i(s7_scheme *sc, s7_int x) {return(make_ratio_with_div_check(sc, sc->divide_symbol, 1, x));} - -static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args == 1) - return(sc->invert_1); - if ((ops) && (args == 2)) - { - s7_pointer arg1 = cadr(expr); - if ((is_t_real(arg1)) && (real(arg1) == 1.0)) - return(sc->invert_x); - return(((is_t_integer(caddr(expr))) && (integer(caddr(expr)) == 2)) ? sc->divide_by_2 : sc->divide_2); - } - return(f); -} - - -/* -------------------------------- quotient -------------------------------- */ -static inline s7_int quotient_i_7ii(s7_scheme *sc, s7_int x, s7_int y) -{ - if ((y > 0) || (y < -1)) return(x / y); - if (y == 0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_integer(sc, x), int_zero); - if (x == S7_INT64_MIN) /* (quotient most-negative-fixnum -1) */ - sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, set_elist_2(sc, leastfix, minus_one), it_is_too_large_string); - return(-x); /* (quotient x -1) */ -} - -#if (!WITH_GMP) -static s7_pointer s7_truncate(s7_scheme *sc, s7_pointer caller, s7_double xf) /* can't use "truncate" -- it's in unistd.h */ -{ - if (fabs(xf) > QUOTIENT_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, caller, wrap_real(sc, xf), it_is_too_large_string); - return(make_integer(sc, (xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf))); -} - -static s7_int c_quo_dbl(s7_scheme *sc, s7_double x, s7_double y) -{ - s7_double xf; - if (y == 0.0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_real(sc, x), real_zero); - if ((is_inf(y)) || (is_NaN(y))) /* here we can't return NAN so I guess we should signal an error */ - wrong_type_error_nr(sc, sc->quotient_symbol, 2, wrap_real(sc, y), a_normal_real_string); - xf = x / y; - if (fabs(xf) > QUOTIENT_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, wrap_real(sc, xf), it_is_too_large_string); - return((xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf)); -} -#endif - -static s7_int quotient_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 / i2);} /* i2 > 0 */ - -static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ -#if WITH_GMP - if ((is_real(x)) && (is_real(y))) - { - if (is_zero(y)) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - if ((s7_is_integer(x)) && (s7_is_integer(y))) - { - if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x)); - if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y)); - mpz_tdiv_q(sc->mpz_1, sc->mpz_1, sc->mpz_2); - } - else - if ((!is_rational(x)) || (!is_rational(y))) - { - if (any_real_to_mpfr(sc, x, sc->mpfr_1)) return(real_NaN); - if (any_real_to_mpfr(sc, y, sc->mpfr_2)) return(real_NaN); - mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); - } - else - { - any_rational_to_mpq(sc, x, sc->mpq_1); - any_rational_to_mpq(sc, y, sc->mpq_2); - mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2); - mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); - } - return(mpz_to_integer(sc, sc->mpz_1)); - } - return(method_or_bust_pp(sc, (is_real(x)) ? y : x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], (is_real(x)) ? 2 : 1)); -#else - - s7_int d1, d2, n1, n2; - if ((is_t_integer(x)) && (is_t_integer(y))) - return(make_integer(sc, quotient_i_7ii(sc, integer(x), integer(y)))); - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(make_integer(sc, quotient_i_7ii(sc, integer(x), integer(y)))); - - case T_RATIO: - n1 = integer(x); - d1 = 1; - n2 = numerator(y); - d2 = denominator(y); - /* (quotient -9223372036854775808 -1/9223372036854775807): arithmetic exception in the no-overflow-checks case */ - goto RATIO_QUO_RATIO; - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - return(s7_truncate(sc, sc->quotient_symbol, (s7_double)integer(x) / real(y))); /* s7_truncate returns an integer */ - - default: - return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - n1 = numerator(x); - d1 = denominator(x); - n2 = integer(y); - d2 = 1; - goto RATIO_QUO_RATIO; - /* this can lose: - * (quotient 1 2305843009213693952/4611686018427387903) -> 2, not 1 - * (quotient 21053343141/6701487259 3587785776203/1142027682075) -> 1, not 0 - */ - - case T_RATIO: - parcel_out_fractions(x, y); - RATIO_QUO_RATIO: - if (d1 == d2) - return(make_integer(sc, n1 / n2)); /* (quotient 3/9223372036854775807 1/9223372036854775807) */ - if (n1 == n2) - return(make_integer(sc, d2 / d1)); /* (quotient 9223372036854775807/2 9223372036854775807/8) */ -#if HAVE_OVERFLOW_CHECKS - { - s7_int n1d2, n2d1; - if ((multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1))) - return(s7_truncate(sc, sc->quotient_symbol, ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1))); - return(make_integer(sc, n1d2 / n2d1)); - } -#else - return(make_integer(sc, (n1 * d2) / (n2 * d1))); -#endif - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - return(s7_truncate(sc, sc->quotient_symbol, (s7_double)fraction(x) / real(y))); - - default: - return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_REAL: - if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) - return(real_NaN); - /* if infs allowed we need to return infs/nans, else: - * (quotient inf.0 1e-309) -> -9223372036854775808 - * (quotient inf.0 inf.0) -> -9223372036854775808 - */ - - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - return(s7_truncate(sc, sc->quotient_symbol, (long_double)real(x) / (long_double)integer(y))); - - case T_RATIO: return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)fraction(y))); - case T_REAL: return(make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */ - default: return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - default: - return(method_or_bust_pp(sc, x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } -#endif -} - -static s7_pointer quotient_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if ((is_t_integer(x)) && ((y > 0) || (y < -1))) return(make_integer(sc, integer(x) / y)); - return(quotient_p_pp(sc, x, wrap_integer(sc, y))); -} - -static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args) -{ - #define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1" - #define Q_quotient sc->pcl_r - /* sig was '(integer? ...) but quotient can return NaN */ - /* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */ - return(quotient_p_pp(sc, car(args), cadr(args))); -} - - -/* -------------------------------- remainder -------------------------------- */ -#if WITH_GMP -static s7_pointer big_mod_or_rem(s7_scheme *sc, s7_pointer x, s7_pointer y, bool use_floor) -{ - if ((is_real(x)) && (is_real(y))) - { - if ((s7_is_integer(x)) && (s7_is_integer(y))) - { - if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x)); - if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y)); - if (use_floor) - mpz_fdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); - else mpz_tdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); - mpz_mul(sc->mpz_3, sc->mpz_3, sc->mpz_2); - mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_3); - return(mpz_to_integer(sc, sc->mpz_1)); - } - if ((!is_rational(x)) || (!is_rational(y))) - { - any_real_to_mpfr(sc, x, sc->mpfr_1); - any_real_to_mpfr(sc, y, sc->mpfr_2); - mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - if (use_floor) - mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDD); - else mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); - mpfr_mul_z(sc->mpfr_2, sc->mpfr_2, sc->mpz_1, MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } - any_rational_to_mpq(sc, x, sc->mpq_1); - any_rational_to_mpq(sc, y, sc->mpq_2); - mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2); - if (use_floor) - mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); - else mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); - mpz_mul(mpq_numref(sc->mpq_2), sc->mpz_1, mpq_numref(sc->mpq_2)); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } - return(method_or_bust_pp(sc, (is_real(x)) ? y : x, (use_floor) ? sc->modulo_symbol : sc->remainder_symbol, x, y, sc->type_names[T_REAL], (is_real(x)) ? 2 : 1)); -} -#endif - -#define REMAINDER_FLOAT_LIMIT 1e13 - -static inline s7_int remainder_i_7ii(s7_scheme *sc, s7_int x, s7_int y) -{ - if ((y > 1) || (y < -1)) return(x % y); /* avoid floating exception if (remainder -9223372036854775808 -1)! */ - if (y == 0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_integer(sc, x), int_zero); - return(0); -} - -static s7_double c_rem_dbl(s7_scheme *sc, s7_double x, s7_double y) -{ - s7_int quo; - s7_double pre_quo; - if ((is_inf(y)) || (is_NaN(y))) - return(NAN); - pre_quo = x / y; - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, wrap_real(sc, x), wrap_real(sc, y)), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(x - (y * quo)); -} - -static s7_int remainder_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 % i2);} /* i2 > 1 */ -static s7_double remainder_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) -{ - if (x2 == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_real(sc, x1), real_zero); - if ((is_inf(x1)) || (is_NaN(x1))) /* match remainder_p_pp */ - return(NAN); - return(c_rem_dbl(sc, x1, x2)); -} - -static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ -#if WITH_GMP - if (is_zero(y)) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - return(big_mod_or_rem(sc, x, y, false)); -#else - s7_int quo, d1, d2, n1, n2; - s7_double pre_quo; - - if ((is_t_integer(x)) && (is_t_integer(y))) - return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y)))); - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y)))); - - case T_RATIO: - n1 = integer(x); - d1 = 1; - n2 = numerator(y); - d2 = denominator(y); - goto RATIO_REM_RATIO; - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - pre_quo = (long_double)integer(x) / (long_double)real(y); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, integer(x) - real(y) * quo)); - - default: - return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - n2 = integer(y); - if (n2 == 0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - n1 = numerator(x); - d1 = denominator(x); - d2 = 1; - goto RATIO_REM_RATIO; - - case T_RATIO: - parcel_out_fractions(x, y); - RATIO_REM_RATIO: - if (d1 == d2) - quo = (s7_int)(n1 / n2); - else - { - if (n1 == n2) - quo = (s7_int)(d2 / d1); - else - { -#if HAVE_OVERFLOW_CHECKS - s7_int n1d2, n2d1; - if ((multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1))) - { - pre_quo = ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - } - else quo = n1d2 / n2d1; -#else - quo = (n1 * d2) / (n2 * d1); -#endif - }} - if (quo == 0) - return(x); - -#if HAVE_OVERFLOW_CHECKS - { - s7_int dn, nq; - if (!multiply_overflow(n2, quo, &nq)) - { - if ((d1 == d2) && - (!subtract_overflow(n1, nq, &dn))) - return(make_ratio_with_div_check(sc, sc->remainder_symbol, dn, d1)); - - if ((!multiply_overflow(n1, d2, &dn)) && - (!multiply_overflow(nq, d1, &nq)) && - (!subtract_overflow(dn, nq, &nq)) && - (!multiply_overflow(d1, d2, &d1))) - return(make_ratio_with_div_check(sc, sc->remainder_symbol, nq, d1)); - }} -#else - if (d1 == d2) - return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 - n2 * quo, d1)); - - return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 * d2 - n2 * d1 * quo, d1 * d2)); -#endif - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), intermediate_too_large_string); - - case T_REAL: - { - s7_double frac; - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - if (s7_int_abs(numerator(x)) > QUOTIENT_INT_LIMIT) - return(subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))); - frac = (s7_double)fraction(x); - pre_quo = frac / real(y); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, frac - real(y) * quo)); - } - - default: - return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_REAL: - if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) - { - if (is_zero(y)) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - return(real_NaN); - } - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - /* actually here (and elsewhere) if y > INT64_TO_DOUBLE_LIMIT, the result is probably wrong */ - pre_quo = (long_double)real(x) / (long_double)integer(y); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, real(x) - integer(y) * quo)); - /* but... (remainder 1e+18 9223372036854775807) -> 1e+18 */ - - case T_RATIO: - if (s7_int_abs(numerator(y)) > QUOTIENT_INT_LIMIT) - return(subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))); - { - s7_double frac = (s7_double)fraction(y); - pre_quo = real(x) / frac; - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, real(x) - frac * quo)); - } - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - return(make_real(sc, c_rem_dbl(sc, real(x), real(y)))); - /* see under sin -- this calculation is completely bogus if "a" is large - * (quotient 1e22 (* 2 pi)) -> -9223372036854775808 but it should be 1591549430918953357688, - * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 -- the "remainder" is greater than the original argument! - * Clisp gives 0.0 here, as does sbcl, currently s7 throws an error (out-of-range). - */ - - default: - return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - default: - return(method_or_bust_pp(sc, x, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 1)); - } -#endif -} - -static s7_pointer remainder_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if ((is_t_integer(x)) && ((y > 1) || (y < -1))) return(make_integer(sc, integer(x) % y)); - return(remainder_p_pp(sc, x, wrap_integer(sc, y))); -} - -static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args) -{ - #define H_remainder "(remainder x1 x2) returns the remainder of x1/x2; (remainder 10 3) = 1" - #define Q_remainder sc->pcl_r - /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib, if x2 is an integer (- x1 (truncate x1 x2)), fractional part: (remainder x 1) */ - - s7_pointer x = car(args), y = cadr(args); - if ((is_t_integer(x)) && (is_t_integer(y))) - return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y)))); - return(remainder_p_pp(sc, x, y)); -} - - -/* -------------------------------- modulo -------------------------------- */ -static s7_int modulo_i_ii(s7_int x, s7_int y) -{ - s7_int z; - if (y > 1) - { - z = x % y; - return((z >= 0) ? z : z + y); - } - if (y < -1) - { - z = x % y; - return((z > 0) ? z + y : z); - } - if (y == 0) return(x); /* else arithmetic exception */ - return(0); -} - -static s7_int modulo_i_ii_unchecked(s7_int i1, s7_int i2) /* here we know i2 > 1 */ -{ - s7_int z = i1 % i2; - return((z < 0) ? (z + i2) : z); -} - -static s7_double modulo_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) -{ - s7_double c; - if ((is_NaN(x1)) || (is_NaN(x2)) || (is_inf(x1)) || (is_inf(x2))) return(NAN); - if (x2 == 0.0) return(x1); - if (fabs(x1) > 1e17) - out_of_range_error_nr(sc, sc->modulo_symbol, int_one, wrap_real(sc, x1), it_is_too_large_string); - c = x1 / x2; - if ((c > 1e19) || (c < -1e19)) - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, wrap_real(sc, x1), wrap_real(sc, x2)), - intermediate_too_large_string); - return(x1 - x2 * (s7_int)floor(c)); -} - -static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ -#if WITH_GMP - /* as tricky as expt, so just use bignums; mpz_mod|_ui = mpz_fdiv_r_ui, but sign ignored -- probably not worth the code - * originally subtract_p_pp(sc, x, multiply_p_pp(sc, y, floor_p_p(sc, divide_p_pp(sc, x, y)))) - * quotient is truncate_p_p(sc, divide_p_pp(sc, x, y)) - * remainder is subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y))) - */ - if (!is_zero(y)) return(big_mod_or_rem(sc, x, y, true)); - if (is_real(x)) return(x); - return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 1)); -#else - s7_double a, b; - s7_int n1, n2, d1, d2; - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(make_integer(sc, modulo_i_ii(integer(x), integer(y)))); - - case T_RATIO: - n1 = integer(x); - d1 = 1; - n2 = numerator(y); - d2 = denominator(y); - if ((n1 == n2) && (d1 > d2)) return(x); /* signs match so this should be ok */ - goto RATIO_MOD_RATIO; - - case T_REAL: - if ((integer(x) == S7_INT64_MIN) || (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT)) - out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_too_large_string); - b = real(y); - if (b == 0.0) return(x); - if (is_NaN(b)) return(y); - if (is_inf(b)) return(real_NaN); - a = (s7_double)integer(x); - goto REAL_MOD; - - default: - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) return(x); - n1 = numerator(x); - d1 = denominator(x); - n2 = integer(y); - - if ((n2 > 0) && (n1 > 0) && (n2 > n1)) return(x); - if ((n2 < 0) && (n1 < 0) && (n2 < n1)) return(x); - if (n2 == S7_INT64_MIN) - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - /* the problem here is that (modulo 3/2 most-negative-fixnum) - * will segfault with signal SIGFPE, Arithmetic exception, so try to trap it. - */ - if ((n1 == n2) && (d1 > 1)) return(x); - d2 = 1; - goto RATIO_MOD_RATIO; - - case T_RATIO: - parcel_out_fractions(x, y); - if (d1 == d2) - return(make_ratio_with_div_check(sc, sc->modulo_symbol, modulo_i_ii(n1, n2), d1)); - if ((n1 == n2) && (d1 > d2)) return(x); - - RATIO_MOD_RATIO: -#if HAVE_OVERFLOW_CHECKS - { - s7_int n2d1, n1d2, d1d2, fl; - if (!multiply_overflow(n2, d1, &n2d1)) - { - if ((n2d1 == 1) || (n2d1 == -1)) /* (modulo 100 -1/2) */ - return(int_zero); - - if (!multiply_overflow(n1, d2, &n1d2)) - { - fl = (s7_int)(n1d2 / n2d1); - if (((n1 < 0) && (n2 > 0)) || - ((n1 > 0) && (n2 < 0))) - fl -= 1; - if (fl == 0) - return(x); - - if ((!multiply_overflow(d1, d2, &d1d2)) && - (!multiply_overflow(fl, n2d1, &fl)) && - (!subtract_overflow(n1d2, fl, &fl))) - return(make_ratio_with_div_check(sc, sc->modulo_symbol, fl, d1d2)); - }}} -#else - { - s7_int fl; - s7_int n1d2 = n1 * d2; - s7_int n2d1 = n2 * d1; - - if (n2d1 == 1) - return(int_zero); - - /* can't use "floor" here (float->int ruins everything) */ - fl = (s7_int)(n1d2 / n2d1); - if (((n1 < 0) && (n2 > 0)) || - ((n1 > 0) && (n2 < 0))) - fl -= 1; - - if (fl == 0) - return(x); - - return(make_ratio_with_div_check(sc, sc->modulo_symbol, n1d2 - (n2d1 * fl), d1 * d2)); - } -#endif - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - case T_REAL: - b = real(y); - if (is_inf(b)) return(real_NaN); - if (fabs(b) > 1e17) - out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_too_large_string); - if (b == 0.0) return(x); - if (is_NaN(b)) return(y); - a = fraction(x); - return(make_real(sc, a - b * (s7_int)floor(a / b))); - - default: - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - } - - case T_REAL: - { - s7_double c; - a = real(x); - if (!is_real(y)) - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - if (is_NaN(a)) return(x); - if (is_inf(a)) return(real_NaN); /* not b */ - if (fabs(a) > 1e17) - out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_too_large_string); - - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) return(x); - if ((integer(y) == S7_INT64_MIN) || (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT)) - out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_too_large_string); - b = (s7_double)integer(y); - goto REAL_MOD; - - case T_RATIO: - b = fraction(y); - goto REAL_MOD; - - case T_REAL: - b = real(y); - if (b == 0.0) return(x); - if (is_NaN(b)) return(y); - if (is_inf(b)) return(real_NaN); - REAL_MOD: - c = a / b; - if (fabs(c) > 1e19) - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - return(make_real(sc, a - b * (s7_int)floor(c))); - - default: - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - }} - - default: - return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 1)); - } -#endif -} - -static s7_pointer modulo_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if (is_t_integer(x)) return(make_integer(sc, modulo_i_ii(integer(x), y))); - return(modulo_p_pp(sc, x, wrap_integer(sc, y))); -} - -static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args) -{ - #define H_modulo "(modulo x1 x2) returns x1 mod x2; (modulo 4 3) = 1. The arguments can be real numbers." - #define Q_modulo sc->pcl_r - /* (define (mod x1 x2) (- x1 (* x2 (floor (/ x1 x2))))) from slib - * (mod x 0) = x according to "Concrete Mathematics" - */ - return(modulo_p_pp(sc, car(args), cadr(args))); -} - - -/* ---------------------------------------- max ---------------------------------------- */ -static bool is_real_via_method_1(s7_scheme *sc, s7_pointer p) -{ - s7_pointer f = find_method_with_let(sc, p, sc->is_real_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - return(false); -} - -#define is_real_via_method(sc, p) ((is_real(p)) || ((has_active_methods(sc, p)) && (is_real_via_method_1(sc, p)))) - -#define max_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->max_symbol, X, Y, sc->type_names[T_REAL], 1) -#define max_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->max_symbol, X, Y, sc->type_names[T_REAL], 2) - -static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - /* same basic code as lt_b_7_pp (or any relop) but max returns NaN if NaN encountered, and methods for < and max return - * different results, so it seems simpler to repeat the other code. - */ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return((integer(x) < integer(y)) ? y : x); - if (is_t_real(x)) - return(((is_NaN(real(x))) || (real(x) >= real(y))) ? x : y); - if (is_t_ratio(x)) - return((fraction(x) < fraction(y)) ? y : x); -#if WITH_GMP - if (is_t_big_integer(x)) - return((mpz_cmp(big_integer(x), big_integer(y)) < 0) ? y : x); - if (is_t_big_ratio(x)) - return((mpq_cmp(big_ratio(x), big_ratio(y)) < 0) ? y : x); - if (is_t_big_real(x)) - return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_greaterequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: - return((integer(x) < fraction(y)) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - return((integer(x) < real(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - return((mpz_cmp_si(big_integer(y), integer(x)) < 0) ? x : y); - case T_BIG_RATIO: - return((mpq_cmp_si(big_ratio(y), integer(x), 1) < 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_si(big_real(y), integer(x)) < 0) ? x : y); -#endif - default: - return(max_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - return((fraction(x) < integer(y)) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - return((fraction(x) < real(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpfr_cmp_q(big_real(y), sc->mpq_1) < 0) ? x : y); -#endif - default: - return(max_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: - if (is_NaN(real(x))) return(x); - return((real(x) < integer(y)) ? y : x); - case T_RATIO: - return((real(x) < fraction(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0) ? y : x); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0) ? y : x); - case T_BIG_REAL: - if (is_NaN(real(x))) return(x); - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_d(big_real(y), real(x)) < 0) ? x : y); -#endif - default: - return(max_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return((mpz_cmp_si(big_integer(x), integer(y)) < 0) ? y : x); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return((mpq_cmp_z(sc->mpq_1, big_integer(x)) < 0) ? x : y); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_z(big_ratio(y), big_integer(x)) < 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_z(big_real(y), big_integer(x)) < 0) ? x : y); - default: - return(max_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return((mpq_cmp_si(big_ratio(x), integer(y), 1) < 0) ? y : x); - case T_RATIO: - return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); - case T_BIG_INTEGER: - return((mpq_cmp_z(big_ratio(x), big_integer(y)) < 0) ? y : x); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_q(big_real(y), big_ratio(x)) < 0) ? x : y); - default: - return(max_out_y(sc, x, y)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_si(big_real(x), integer(y)) < 0) ? y : x); - case T_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return((mpfr_cmp_q(big_real(x), sc->mpq_1) < 0) ? y : x); - case T_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - if (is_NaN(real(y))) return(y); - return((mpfr_cmp_d(big_real(x), real(y)) < 0) ? y : x); - case T_BIG_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_z(big_real(x), big_integer(y)) < 0) ? y : x); - case T_BIG_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_q(big_real(x), big_ratio(y)) < 0) ? y : x); - default: - return(max_out_y(sc, x, y)); - } -#endif - default: - return(max_out_x(sc, x, y)); - } - return(x); -} - -static s7_pointer g_max(s7_scheme *sc, s7_pointer args) -{ - #define H_max "(max ...) returns the maximum of its arguments" - #define Q_max sc->pcl_r - - s7_pointer x = car(args); - if (is_null(cdr(args))) - { - if (is_real(x)) return(x); - return(method_or_bust_p(sc, x, sc->max_symbol, sc->type_names[T_REAL])); - } - for (s7_pointer p = cdr(args); is_pair(p); p = cdr(p)) - x = max_p_pp(sc, x, car(p)); - return(x); -} - -static s7_pointer g_max_2(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, car(args), cadr(args)));} -static s7_pointer g_max_3(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, max_p_pp(sc, car(args), cadr(args)), caddr(args)));} - -static s7_pointer max_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : f)); -} - -static s7_int max_i_ii(s7_int i1, s7_int i2) {return((i1 > i2) ? i1 : i2);} -static s7_int max_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 > i2) ? ((i1 > i3) ? i1 : i3) : ((i2 > i3) ? i2 : i3));} -static s7_double max_d_dd(s7_double x1, s7_double x2) {if (is_NaN(x1)) return(x1); return((x1 > x2) ? x1 : x2);} -static s7_double max_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(max_d_dd(x1, max_d_dd(x2, x3)));} -static s7_double max_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(max_d_dd(x1, max_d_ddd(x2, x3, x4)));} - - -/* ---------------------------------------- min ---------------------------------------- */ -#define min_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->min_symbol, X, Y, sc->type_names[T_REAL], 1) -#define min_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->min_symbol, X, Y, sc->type_names[T_REAL], 2) - -static s7_pointer min_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return((integer(x) > integer(y)) ? y : x); - if (is_t_real(x)) - return(((is_NaN(real(x))) || (real(x) <= real(y))) ? x : y); - if (is_t_ratio(x)) - return((fraction(x) > fraction(y)) ? y : x); -#if WITH_GMP - if (is_t_big_integer(x)) - return((mpz_cmp(big_integer(x), big_integer(y)) > 0) ? y : x); - if (is_t_big_ratio(x)) - return((mpq_cmp(big_ratio(x), big_ratio(y)) > 0) ? y : x); - if (is_t_big_real(x)) - return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_lessequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return((integer(x) > fraction(y)) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - return((integer(x) > real(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: return((mpz_cmp_si(big_integer(y), integer(x)) > 0) ? x : y); - case T_BIG_RATIO: return((mpq_cmp_si(big_ratio(y), integer(x), 1) > 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_si(big_real(y), integer(x)) > 0) ? x : y); -#endif - default: - return(min_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: - return((fraction(x) > integer(y)) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - return((fraction(x) > real(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpfr_cmp_q(big_real(y), sc->mpq_1) > 0) ? x : y); -#endif - default: - return(min_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: - if (is_NaN(real(x))) return(x); - return((real(x) > integer(y)) ? y : x); - case T_RATIO: - return((real(x) > fraction(y)) ? y : x); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0) ? y : x); - - case T_BIG_RATIO: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0) ? y : x); - - case T_BIG_REAL: - if (is_NaN(real(x))) return(x); - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_d(big_real(y), real(x)) > 0) ? x : y); -#endif - default: - return(min_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return((mpz_cmp_si(big_integer(x), integer(y)) > 0) ? y : x); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return((mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_z(big_ratio(y), big_integer(x)) > 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_z(big_real(y), big_integer(x)) > 0) ? x : y); - default: - return(min_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return((mpq_cmp_si(big_ratio(x), integer(y), 1) > 0) ? y : x); - case T_RATIO: - return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); - case T_BIG_INTEGER: - return((mpq_cmp_z(big_ratio(x), big_integer(y)) > 0) ? y : x); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_q(big_real(y), big_ratio(x)) > 0) ? x : y); - default: - return(min_out_y(sc, x, y)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_si(big_real(x), integer(y)) > 0) ? y : x); - case T_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return((mpfr_cmp_q(big_real(x), sc->mpq_1) > 0) ? y : x); - case T_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - if (is_NaN(real(y))) return(y); - return((mpfr_cmp_d(big_real(x), real(y)) > 0) ? y : x); - case T_BIG_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_z(big_real(x), big_integer(y)) > 0) ? y : x); - case T_BIG_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_q(big_real(x), big_ratio(y)) > 0) ? y : x); - default: - return(min_out_y(sc, x, y)); - } -#endif - default: - return(min_out_x(sc, x, y)); - } - return(x); -} - -static s7_pointer g_min(s7_scheme *sc, s7_pointer args) -{ - #define H_min "(min ...) returns the minimum of its arguments" - #define Q_min sc->pcl_r - - s7_pointer x = car(args); - if (is_null(cdr(args))) - { - if (is_real(x)) return(x); - return(method_or_bust_p(sc, x, sc->min_symbol, sc->type_names[T_REAL])); - } - for (s7_pointer p = cdr(args); is_pair(p); p = cdr(p)) - x = min_p_pp(sc, x, car(p)); - return(x); -} - -static s7_pointer g_min_2(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, car(args), cadr(args)));} -static s7_pointer g_min_3(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, min_p_pp(sc, car(args), cadr(args)), caddr(args)));} - -static s7_pointer min_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : f)); -} - -static s7_int min_i_ii(s7_int i1, s7_int i2) {return((i1 < i2) ? i1 : i2);} -static s7_int min_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 < i2) ? ((i1 < i3) ? i1 : i3) : ((i2 < i3) ? i2 : i3));} -static s7_double min_d_dd(s7_double x1, s7_double x2) {if (is_NaN(x1)) return(x1); return((x1 < x2) ? x1 : x2);} -static s7_double min_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(min_d_dd(x1, min_d_dd(x2, x3)));} -static s7_double min_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(min_d_dd(x1, min_d_ddd(x2, x3, x4)));} - - -/* ---------------------------------------- = ---------------------------------------- */ -static bool eq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->num_eq_symbol, 1, x, a_number_string); - return(false); -} - -static bool eq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->num_eq_symbol, 2, y, a_number_string); - return(false); -} - -static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) == integer(y)); - if (is_t_real(x)) - return(real(x) == real(y)); - if (is_t_complex(x)) - return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))); - if (is_t_ratio(x)) - return((numerator(x) == numerator(y)) && (denominator(x) == denominator(y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) == 0); - if (is_t_big_ratio(x)) - return(mpq_equal(big_ratio(x), big_ratio(y))); - if (is_t_big_real(x)) - return(mpfr_equal_p(big_real(x), big_real(y))); - if (is_t_big_complex(x)) /* mpc_cmp can't handle NaN */ - { - if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x)))) || - (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) - return(false); - return(mpc_cmp(big_complex(x), big_complex(y)) == 0); - } -#endif - } - - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: - return(false); - case T_REAL: -#if WITH_GMP - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) - { - if (is_NaN(real(y))) return(false); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_cmp_si(sc->mpfr_1, integer(x)) == 0); - } -#endif - return(integer(x) == real(y)); - case T_COMPLEX: - return(false); -#if WITH_GMP - case T_BIG_INTEGER: - return((mpz_fits_slong_p(big_integer(y))) && (integer(x) == mpz_get_si(big_integer(y)))); - case T_BIG_RATIO: - return(false); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) == 0)); - case T_BIG_COMPLEX: - return(false); -#endif - default: return(eq_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(false); - case T_REAL: return(fraction(x) == real(y)); - case T_COMPLEX: return(false); -#if WITH_GMP - case T_BIG_INTEGER: - return(false); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_equal(sc->mpq_1, big_ratio(y))); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(false); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) == 0); - case T_BIG_COMPLEX: - return(false); -#endif - default: return(eq_out_y(sc, x, y)); - } - break; - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: - return(real(x) == integer(y)); - case T_RATIO: - return(real(x) == fraction(y)); - case T_COMPLEX: - return(false); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) == 0); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) == 0); - case T_BIG_REAL: - if (is_NaN(real(x))) return(false); - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) == 0)); - case T_BIG_COMPLEX: - return(false); -#endif - default: return(eq_out_y(sc, x, y)); - } - break; - - case T_COMPLEX: - if (is_real(y)) return(false); -#if WITH_GMP - if (is_t_big_complex(y)) - { - if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) || - (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) - return(false); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - return(mpc_cmp(big_complex(y), sc->mpc_1) == 0); - } -#endif - return(eq_out_y(sc, x, y)); - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return((mpz_fits_slong_p(big_integer(x))) && (integer(y) == mpz_get_si(big_integer(x)))); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(x)) == 0); - case T_RATIO: case T_COMPLEX: case T_BIG_RATIO: case T_BIG_COMPLEX: - return(false); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) == 0)); - default: return(eq_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpq_equal(sc->mpq_1, big_ratio(x))); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) == 0); - case T_INTEGER: case T_BIG_INTEGER: case T_COMPLEX: case T_BIG_COMPLEX: - return(false); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) == 0)); - default: return(eq_out_y(sc, x, y)); - } - - case T_BIG_REAL: - if ((is_number(y)) && (mpfr_nan_p(big_real(x)))) return(false); - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) == 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) == 0); - case T_REAL: - return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) == 0)); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) == 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) == 0); - case T_COMPLEX: case T_BIG_COMPLEX: - return(false); - default: return(eq_out_y(sc, x, y)); - } - - case T_BIG_COMPLEX: - switch (type(y)) - { - case T_RATIO: case T_REAL: case T_INTEGER: case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(false); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x))))) - return(false); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - return(mpc_cmp(big_complex(x), sc->mpc_1) == 0); /* NaN's not allowed! */ - default: return(eq_out_y(sc, x, y)); - } -#endif - default: return(eq_out_x(sc, x, y)); - } - return(false); -} - -static bool is_number_via_method(s7_scheme *sc, s7_pointer p) -{ - if (is_number(p)) - return(true); - if (has_active_methods(sc, p)) - { - s7_pointer f = find_method_with_let(sc, p, sc->is_number_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - } - return(false); -} - -static s7_pointer g_num_eq(s7_scheme *sc, s7_pointer args) -{ - #define H_num_eq "(= z1 ...) returns #t if all its arguments are equal" - #define Q_num_eq s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol) - - s7_pointer x = car(args), p = cdr(args); - if (is_null(cdr(p))) - return(make_boolean(sc, num_eq_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); p = cdr(p)) - if (!num_eq_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_number_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->num_eq_symbol, position_of(p, args), car(p), a_number_string); - return(sc->F); - } - return(sc->T); -} - -static bool num_eq_b_ii(s7_int i1, s7_int i2) {return(i1 == i2);} -static bool num_eq_b_dd(s7_double i1, s7_double i2) {return(i1 == i2);} - -static s7_pointer num_eq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 == x2));} -static s7_pointer num_eq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 == x2));} -static s7_pointer num_eq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, num_eq_b_7pp(sc, x, y)));} - -static s7_pointer num_eq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) - return((integer(p1) == p2) ? sc->T : sc->F); - if (is_t_real(p1)) - return((real(p1) == p2) ? sc->T : sc->F); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(((mpz_fits_slong_p(big_integer(p1))) && (p2 == mpz_get_si(big_integer(p1)))) ? sc->T : sc->F); - if (is_t_big_real(p1)) - return((mpfr_cmp_si(big_real(p1), p2) == 0) ? sc->T : sc->F); -#endif - return((is_number(p1)) ? sc->F : make_boolean(sc, eq_out_x(sc, p1, make_integer(sc, p2)))); -} - -static bool num_eq_b_pi(s7_scheme *sc, s7_pointer x, s7_int y) -{ - if (is_t_integer(x)) - return(integer(x) == y); - if (is_t_real(x)) - return(real(x) == y); -#if WITH_GMP - if (is_t_big_integer(x)) - return((mpz_fits_slong_p(big_integer(x))) && (y == mpz_get_si(big_integer(x)))); - if (is_t_big_real(x)) - return(mpfr_cmp_si(big_real(x), y) == 0); -#endif - if (!is_number(x)) /* complex/ratio */ - sole_arg_wrong_type_error_nr(sc, sc->num_eq_symbol, x, a_number_string); - /* return(eq_out_x(sc, x, make_integer(sc, y))); */ /* much slower? see thash */ - return(false); -} - -static s7_pointer g_num_eq_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args), y = cadr(args); - if ((is_t_integer(x)) && (is_t_integer(y))) /* this is by far the most common case (ratios aren't used much, and = with floats is frowned upon) */ - return(make_boolean(sc, integer(x) == integer(y))); - return(make_boolean(sc, num_eq_b_7pp(sc, x, y))); -} - -static inline s7_pointer num_eq_xx(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) == integer(y))); - if (is_t_real(x)) - return(make_boolean(sc, real(x) == integer(y))); - if (!is_number(x)) - return(make_boolean(sc, eq_out_x(sc, x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), integer(y)) == 0)); - if (is_t_big_real(x)) - { - if (mpfr_nan_p(big_real(x))) return(sc->F); - return(make_boolean(sc, mpfr_cmp_si(big_real(x), integer(y)) == 0)); - } - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), integer(y), 1) == 0)); -#endif - return(sc->F); -} - -static s7_pointer g_num_eq_xi(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, car(args), cadr(args)));} -static s7_pointer g_num_eq_ix(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, cadr(args), car(args)));} - -static s7_pointer num_eq_chooser(s7_scheme *sc, s7_pointer ur_f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(ur_f); - if ((ops) && (is_t_integer(caddr(expr)))) - return(sc->num_eq_xi); - return(((ops) && (is_t_integer(cadr(expr)))) ? sc->num_eq_ix : sc->num_eq_2); -} - - -/* ---------------------------------------- < ---------------------------------------- */ -static bool lt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->lt_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ - wrong_type_error_nr(sc, sc->lt_symbol, 1, x, sc->type_names[T_REAL]); - return(false); -} - -static bool lt_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->lt_symbol, list_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->lt_symbol, 2, y, sc->type_names[T_REAL]); - return(false); -} - -static bool lt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) < integer(y)); - if (is_t_real(x)) - return(real(x) < real(y)); - if (is_t_ratio(x)) - return(fraction(x) < fraction(y)); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) < 0); - if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) < 0); - if (is_t_big_real(x)) - return(mpfr_less_p(big_real(x), big_real(y))); -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(integer(x) < fraction(y)); /* ?? */ - case T_REAL: return(integer(x) < real(y)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) > 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) > 0); - case T_BIG_REAL: return(mpfr_cmp_si(big_real(y), integer(x)) > 0); -#endif - default: return(lt_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(fraction(x) < integer(y)); - case T_REAL: return(fraction(x) < real(y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) > 0); -#endif - default: return(lt_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(real(x) < integer(y)); - case T_RATIO: return(real(x) < fraction(y)); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0); - case T_BIG_REAL: - return(mpfr_cmp_d(big_real(y), real(x)) > 0); -#endif - default: return(lt_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) < 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) < 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) > 0); - case T_BIG_REAL: - return(mpfr_cmp_z(big_real(y), big_integer(x)) > 0); - default: return(lt_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) < 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) < 0); - case T_BIG_REAL: - return(mpfr_cmp_q(big_real(y), big_ratio(x)) > 0); - default: return(lt_out_y(sc, x, y)); - } - - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) < 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) < 0); - case T_REAL: - return(mpfr_cmp_d(big_real(x), real(y)) < 0); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) < 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) < 0); - default: return(lt_out_y(sc, x, y)); - } -#endif - default: return(lt_out_x(sc, x, y)); - } - return(true); -} - -static s7_pointer g_less(s7_scheme *sc, s7_pointer args) -{ - #define H_less "(< x1 ...) returns #t if its arguments are in increasing order" - #define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) - - s7_pointer x = car(args), p = cdr(args); - if (is_null(cdr(p))) - return(make_boolean(sc, lt_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); p = cdr(p)) - { - if (!lt_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->lt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); - } - x = car(p); - } - return(sc->T); -} - -static bool ratio_lt_pi(s7_pointer x, s7_int y) -{ - if ((y >= 0) && (numerator(x) < 0)) - return(true); - if ((y <= 0) && (numerator(x) > 0)) - return(false); - if (denominator(x) < S7_INT32_MAX) - return(numerator(x) < (y * denominator(x))); - return(fraction(x) < y); -} - -static s7_pointer g_less_x0(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = car(args); - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) < 0)); - if (is_small_real(x)) - return(make_boolean(sc, is_negative(sc, x))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), 0) < 0)); - if (is_t_big_real(x)) - return(make_boolean(sc, mpfr_cmp_si(big_real(x), 0) < 0)); - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), 0, 1) < 0)); -#endif - return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); -} - -static s7_pointer g_less_xi(s7_scheme *sc, s7_pointer args) -{ - s7_int y = integer(cadr(args)); - s7_pointer x = car(args); - - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) < y)); - if (is_t_real(x)) - return(make_boolean(sc, real(x) < y)); - if (is_t_ratio(x)) - return(make_boolean(sc, ratio_lt_pi(x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) < 0)); - if (is_t_big_real(x)) - return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) < 0)); - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) < 0)); -#endif - return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); -} - -static s7_pointer g_less_xf(s7_scheme *sc, s7_pointer args) -{ - s7_double y = real(cadr(args)); /* chooser below checks is_t_real(y) */ - s7_pointer x = car(args); - - if (is_t_real(x)) - return(make_boolean(sc, real(x) < y)); - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) < y)); - if (is_t_ratio(x)) - return(make_boolean(sc, fraction(x) < y)); -#if WITH_GMP - if (is_t_big_real(x)) - return(make_boolean(sc, mpfr_cmp_d(big_real(x), y) < 0)); - if (is_t_big_integer(x)) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - return(make_boolean(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) > 0)); - } - if (is_t_big_ratio(x)) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - return(make_boolean(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) > 0)); - } -#endif - return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); -} - -static inline s7_pointer lt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, lt_b_7pp(sc, p1, p2)));} -static bool lt_b_ii(s7_int i1, s7_int i2) {return(i1 < i2);} -static bool lt_b_dd(s7_double i1, s7_double i2) {return(i1 < i2);} -static s7_pointer lt_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 < x2));} -static s7_pointer lt_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 < x2));} - -static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) return(integer(p1) < p2); - if (is_t_real(p1)) return(real(p1) < p2); - if (is_t_ratio(p1)) return(ratio_lt_pi(p1, p2)); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(mpz_cmp_si(big_integer(p1), p2) < 0); - if (is_t_big_real(p1)) - return(mpfr_cmp_si(big_real(p1), p2) < 0); - if (is_t_big_ratio(p1)) - return(mpq_cmp_si(big_ratio(p1), p2, 1) < 0); -#endif - return(lt_out_x(sc, p1, make_integer(sc, p2))); -} - -static s7_pointer g_less_2(s7_scheme *sc, s7_pointer args) {return(lt_p_pp(sc, car(args), cadr(args)));} -static s7_pointer lt_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, lt_b_pi(sc, p1, p2)));} - -static s7_pointer less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - { - s7_pointer arg2 = caddr(expr); - if (is_t_integer(arg2)) - { - if (integer(arg2) == 0) - return(sc->less_x0); - - if ((integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->less_xi); - } - if (is_t_real(arg2)) - return(sc->less_xf); - } - return(sc->less_2); -} - - -/* ---------------------------------------- <= ---------------------------------------- */ -static bool leq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->leq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ - wrong_type_error_nr(sc, sc->leq_symbol, 1, x, sc->type_names[T_REAL]); - return(false); -} - -static bool leq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->leq_symbol, list_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->leq_symbol, 2, y, sc->type_names[T_REAL]); - return(false); -} - -static bool leq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) <= integer(y)); - if (is_t_real(x)) - return(real(x) <= real(y)); - if (is_t_ratio(x)) - return(fraction(x) <= fraction(y)); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) <= 0); - if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) <= 0); - if (is_t_big_real(x)) - return(mpfr_lessequal_p(big_real(x), big_real(y))); -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(integer(x) <= fraction(y)); /* ?? */ - case T_REAL: return(integer(x) <= real(y)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) >= 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) >= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) >= 0)); -#endif - default: return(leq_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(fraction(x) <= integer(y)); - case T_REAL: return(fraction(x) <= real(y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) <= 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) >= 0); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(false); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) >= 0); -#endif - default: return(leq_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(real(x) <= integer(y)); - case T_RATIO: return(real(x) <= fraction(y)); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) <= 0); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) <= 0); - case T_BIG_REAL: - if (is_NaN(real(x))) return(false); - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) >= 0)); -#endif - default: return(leq_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) <= 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) <= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) >= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) >= 0)); - default: return(leq_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) <= 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) <= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) <= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) >= 0)); - default: return(leq_out_y(sc, x, y)); - } - - case T_BIG_REAL: - if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) return(false); - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) <= 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) <= 0); - case T_REAL: - return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) <= 0)); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) <= 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) <= 0); - default: return(leq_out_y(sc, x, y)); - } -#endif - default: return(leq_out_x(sc, x, y)); - } - return(true); -} - -static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_less_or_equal "(<= x1 ...) returns #t if its arguments are in non-decreasing order" - #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) - - s7_pointer x = car(args), p = cdr(args); - - if (is_null(cdr(p))) - return(make_boolean(sc, leq_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); x = car(p), p = cdr(p)) - if (!leq_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->leq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); - } - return(sc->T); -} - -static inline s7_pointer leq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, leq_b_7pp(sc, p1, p2)));} -static bool leq_b_ii(s7_int i1, s7_int i2) {return(i1 <= i2);} -static bool leq_b_dd(s7_double i1, s7_double i2) {return(i1 <= i2);} -static s7_pointer leq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 <= x2));} -static s7_pointer leq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 <= x2));} - -static bool ratio_leq_pi(s7_pointer x, s7_int y) -{ - if ((y >= 0) && (numerator(x) <= 0)) - return(true); - if ((y <= 0) && (numerator(x) > 0)) - return(false); - if (denominator(x) < S7_INT32_MAX) - return(numerator(x) <= (y * denominator(x))); - return(fraction(x) <= y); -} - -static s7_pointer g_leq_xi(s7_scheme *sc, s7_pointer args) -{ - s7_int y = integer(cadr(args)); - s7_pointer x = car(args); - - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) <= y)); - if (is_t_real(x)) - return(make_boolean(sc, real(x) <= y)); - if (is_t_ratio(x)) - return(make_boolean(sc, ratio_leq_pi(x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) <= 0)); - if (is_t_big_real(x)) - { - if (mpfr_nan_p(big_real(x))) return(sc->F); - return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) <= 0)); - } - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) <= 0)); -#endif - return(method_or_bust(sc, x, sc->leq_symbol, args, sc->type_names[T_REAL], 1)); -} - -static bool leq_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) return(integer(p1) <= p2); - if (is_t_real(p1)) return(real(p1) <= p2); - if (is_t_ratio(p1)) return(ratio_leq_pi(p1, p2)); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(mpz_cmp_si(big_integer(p1), p2) <= 0); - if (is_t_big_real(p1)) - return(mpfr_cmp_si(big_real(p1), p2) <= 0); - if (is_t_big_ratio(p1)) - return(mpq_cmp_si(big_ratio(p1), p2, 1) <= 0); -#endif - return(leq_out_x(sc, p1, make_integer(sc, p2))); -} - -static s7_pointer leq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, leq_b_pi(sc, p1, p2)));} -static s7_pointer g_leq_2(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, leq_b_7pp(sc, car(args), cadr(args))));} -static s7_pointer g_leq_ixx(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = cdr(args); - if (is_t_integer(car(p))) - { - if (integer(car(args)) > integer(car(p))) - { - if (!is_real_via_method(sc, cadr(p))) - wrong_type_error_nr(sc, sc->leq_symbol, 3, cadr(p), sc->type_names[T_REAL]); - return(sc->F); - } - if (is_t_integer(cadr(p))) - return((integer(car(p)) > integer(cadr(p))) ? sc->F : sc->T); - } - return(g_less_or_equal(sc, args)); -} - -static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args == 2) - { - if (ops) - { - s7_pointer arg2 = caddr(expr); - if ((is_t_integer(arg2)) && - (integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->leq_xi); - } - return(sc->leq_2); - } - if ((args == 3) && (is_t_integer(cadr(expr)))) - return(sc->leq_ixx); - return(f); -} - - -/* ---------------------------------------- > ---------------------------------------- */ -static bool gt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, x)) - return(find_and_apply_method(sc, x, sc->gt_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ - wrong_type_error_nr(sc, sc->gt_symbol, 1, x, sc->type_names[T_REAL]); - return(false); -} - -static bool gt_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (has_active_methods(sc, y)) - return(find_and_apply_method(sc, y, sc->gt_symbol, list_2(sc, x, y)) != sc->F); - wrong_type_error_nr(sc, sc->gt_symbol, 2, y, sc->type_names[T_REAL]); - return(false); -} - -static bool gt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) > integer(y)); - if (is_t_real(x)) - return(real(x) > real(y)); - if (is_t_ratio(x)) - return(fraction(x) > fraction(y)); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) > 0); - if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) > 0); - if (is_t_big_real(x)) - return(mpfr_greater_p(big_real(x), big_real(y))); -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(integer(x) > fraction(y)); /* ?? */ - case T_REAL: return(integer(x) > real(y)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) < 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) < 0); - case T_BIG_REAL: return(mpfr_cmp_si(big_real(y), integer(x)) < 0); -#endif - default: return(gt_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(fraction(x) > integer(y)); - case T_REAL: return(fraction(x) > real(y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) < 0); -#endif - default: return(gt_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(real(x) > integer(y)); - case T_RATIO: return(real(x) > fraction(y)); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0); - case T_BIG_REAL: - return(mpfr_cmp_d(big_real(y), real(x)) < 0); -#endif - default: return(gt_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) > 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) < 0); - case T_BIG_REAL: - return(mpfr_cmp_z(big_real(y), big_integer(x)) < 0); - default: return(gt_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) > 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) > 0); - case T_BIG_REAL: - return(mpfr_cmp_q(big_real(y), big_ratio(x)) < 0); - default: return(gt_out_y(sc, x, y)); - } - case T_BIG_REAL: - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) > 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) > 0); - case T_REAL: - return(mpfr_cmp_d(big_real(x), real(y)) > 0); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) > 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) > 0); - default: return(gt_out_y(sc, x, y)); - } -#endif - default: return(gt_out_x(sc, x, y)); - } - return(true); -} - -static s7_pointer g_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order" - #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) - - s7_pointer x = car(args), p = cdr(args); - - if (is_null(cdr(p))) - return(make_boolean(sc, gt_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); x = car(p), p = cdr(p)) - if (!gt_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->gt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); - } - return(sc->T); -} - -static s7_pointer g_greater_xi(s7_scheme *sc, s7_pointer args) -{ - s7_int y = integer(cadr(args)); - s7_pointer x = car(args); - - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) > y)); - if (is_t_real(x)) - return(make_boolean(sc, real(x) > y)); - if (is_t_ratio(x)) - return(make_boolean(sc, !ratio_leq_pi(x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) > 0)); - if (is_t_big_real(x)) - return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) > 0)); - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) > 0)); -#endif - return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1)); -} - -static s7_pointer g_greater_xf(s7_scheme *sc, s7_pointer args) -{ - s7_double y = real(cadr(args)); - s7_pointer x = car(args); - - if (is_t_real(x)) - return(make_boolean(sc, real(x) > y)); - - switch (type(x)) - { - case T_INTEGER: return(make_boolean(sc, integer(x) > y)); - - case T_RATIO: - /* (> 9223372036854775807/9223372036854775806 1.0) */ - if (denominator(x) < S7_INT32_MAX) /* y range check was handled in greater_chooser */ - return(make_boolean(sc, (numerator(x) > (y * denominator(x))))); - return(make_boolean(sc, fraction(x) > y)); - -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - return(make_boolean(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) < 0)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - return(make_boolean(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) < 0)); - case T_BIG_REAL: - return(make_boolean(sc, mpfr_cmp_d(big_real(x), y) > 0)); -#endif - default: - return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1)); - } - return(sc->T); -} - -static inline s7_pointer gt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, gt_b_7pp(sc, p1, p2)));} -static bool gt_b_ii(s7_int i1, s7_int i2) {return(i1 > i2);} -static bool gt_b_dd(s7_double i1, s7_double i2) {return(i1 > i2);} -static s7_pointer gt_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 > x2));} -static s7_pointer gt_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 > x2));} - -static bool gt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) return(integer(p1) > p2); - if (is_t_real(p1)) return(real(p1) > p2); - if (is_t_ratio(p1)) return(!ratio_leq_pi(p1, p2)); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(mpz_cmp_si(big_integer(p1), p2) > 0); - if (is_t_big_real(p1)) - return(mpfr_cmp_si(big_real(p1), p2) > 0); - if (is_t_big_ratio(p1)) - return(mpq_cmp_si(big_ratio(p1), p2, 1) > 0); -#endif - return(gt_out_x(sc, p1, make_integer(sc, p2))); -} - -static s7_pointer gt_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, gt_b_pi(sc, p1, p2)));} - -static s7_pointer g_greater_2(s7_scheme *sc, s7_pointer args) -{ - /* ridiculous repetition, but overheads are killing this poor thing */ - s7_pointer x = car(args), y = cadr(args); - if (type(x) == type(y)) - { - if (is_t_integer(x)) return(make_boolean(sc, integer(x) > integer(y))); - if (is_t_real(x)) return(make_boolean(sc, real(x) > real(y))); - if (is_t_ratio(x)) return(make_boolean(sc, fraction(x) > fraction(y))); - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(gt_p_pp(sc, x, y)); - case T_REAL: return(make_boolean(sc, integer(x) > real(y))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(gt_p_pp(sc, x, y)); -#endif - default: return(make_boolean(sc, gt_out_y(sc, x, y))); - } - break; - - case T_RATIO: return(gt_p_pp(sc, x, y)); - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(make_boolean(sc, real(x) > integer(y))); - case T_RATIO: return(make_boolean(sc, real(x) > fraction(y))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(gt_p_pp(sc, x, y)); -#endif - default: return(make_boolean(sc, gt_out_y(sc, x, y))); - } - break; -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(gt_p_pp(sc, x, y)); -#endif - - default: return(make_boolean(sc, gt_out_x(sc, x, y))); - } - return(sc->T); -} - -static s7_pointer greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - { - s7_pointer arg2 = caddr(expr); - if ((is_t_integer(arg2)) && - (integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->greater_xi); - if ((is_t_real(arg2)) && - (real(arg2) < S7_INT32_MAX) && - (real(arg2) > S7_INT32_MIN)) - return(sc->greater_xf); - } - return(sc->greater_2); -} - - -/* ---------------------------------------- >= ---------------------------------------- */ -static bool geq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (!has_active_methods(sc, x)) - wrong_type_error_nr(sc, sc->geq_symbol, 1, x, sc->type_names[T_REAL]); - return(find_and_apply_method(sc, x, sc->geq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ -} - -static bool geq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (!has_active_methods(sc, y)) - wrong_type_error_nr(sc, sc->geq_symbol, 2, y, sc->type_names[T_REAL]); - return(find_and_apply_method(sc, y, sc->geq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */ -} - -static bool geq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - if (type(x) == type(y)) - { - if (is_t_integer(x)) - return(integer(x) >= integer(y)); - if (is_t_real(x)) - return(real(x) >= real(y)); - if (is_t_ratio(x)) - return(fraction(x) >= fraction(y)); -#if WITH_GMP - if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) >= 0); - if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) >= 0); - if (is_t_big_real(x)) - return(mpfr_greaterequal_p(big_real(x), big_real(y))); -#endif - } - switch (type(x)) - { - case T_INTEGER: - switch (type(y)) - { - case T_RATIO: return(integer(x) >= fraction(y)); /* ?? */ - case T_REAL: return(integer(x) >= real(y)); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) <= 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) <= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) <= 0)); -#endif - default: return(geq_out_y(sc, x, y)); - } - break; - - case T_RATIO: - switch (type(y)) - { - case T_INTEGER: return(fraction(x) >= integer(y)); - case T_REAL: return(fraction(x) >= real(y)); -#if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) >= 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) <= 0); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(false); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) <= 0); -#endif - default: return(geq_out_y(sc, x, y)); - } - - case T_REAL: - switch (type(y)) - { - case T_INTEGER: return(real(x) >= integer(y)); - case T_RATIO: return(real(x) >= fraction(y)); -#if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) >= 0); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) >= 0); - case T_BIG_REAL: - if (is_NaN(real(x))) return(false); - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) <= 0)); -#endif - default: return(geq_out_y(sc, x, y)); - } - break; - -#if WITH_GMP - case T_BIG_INTEGER: - switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) >= 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) >= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) <= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) <= 0)); - default: return(geq_out_y(sc, x, y)); - } - case T_BIG_RATIO: - switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) >= 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) >= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) >= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) <= 0)); - default: return(geq_out_y(sc, x, y)); - } - - case T_BIG_REAL: - if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) return(false); - switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) >= 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) >= 0); - case T_REAL: - return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) >= 0)); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) >= 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) >= 0); - default: return(geq_out_y(sc, x, y)); - } -#endif - default: return(geq_out_x(sc, x, y)); - } - return(true); -} - -static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_greater_or_equal "(>= x1 ...) returns #t if its arguments are in non-increasing order" - #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol) - - s7_pointer x = car(args), p = cdr(args); - if (is_null(cdr(p))) - return(make_boolean(sc, geq_b_7pp(sc, x, car(p)))); - - for (; is_pair(p); x = car(p), p = cdr(p)) - if (!geq_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->geq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); - } - return(sc->T); -} - -static inline s7_pointer geq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, geq_b_7pp(sc, p1, p2)));} -static bool geq_b_ii(s7_int i1, s7_int i2) {return(i1 >= i2);} -static bool geq_b_dd(s7_double i1, s7_double i2) {return(i1 >= i2);} -static s7_pointer geq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 >= x2));} -static s7_pointer geq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 >= x2));} - -static s7_pointer g_geq_2(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, geq_b_7pp(sc, car(args), cadr(args))));} - -static s7_pointer g_geq_xf(s7_scheme *sc, s7_pointer args) -{ - s7_double y = real(cadr(args)); - s7_pointer x = car(args); - return(make_boolean(sc, ((is_t_real(x)) ? (real(x) >= y) : geq_b_7pp(sc, car(args), cadr(args))))); -} - -static s7_pointer g_geq_xi(s7_scheme *sc, s7_pointer args) -{ - s7_int y = integer(cadr(args)); - s7_pointer x = car(args); - - if (is_t_integer(x)) - return(make_boolean(sc, integer(x) >= y)); - if (is_t_real(x)) - return(make_boolean(sc, real(x) >= y)); - if (is_t_ratio(x)) - return(make_boolean(sc, !ratio_lt_pi(x, y))); -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) >= 0)); - if (is_t_big_real(x)) - { - if (mpfr_nan_p(big_real(x))) return(sc->F); - return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) >= 0)); - } - if (is_t_big_ratio(x)) - return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) >= 0)); -#endif - return(method_or_bust(sc, x, sc->geq_symbol, args, sc->type_names[T_REAL], 1)); -} - -static bool geq_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) -{ - if (is_t_integer(p1)) return(integer(p1) >= p2); - if (is_t_real(p1)) return(real(p1) >= p2); - if (is_t_ratio(p1)) return(!ratio_lt_pi(p1, p2)); -#if WITH_GMP - if (is_t_big_integer(p1)) - return(mpz_cmp_si(big_integer(p1), p2) >= 0); - if (is_t_big_real(p1)) - return((!mpfr_nan_p(big_real(p1))) && (mpfr_cmp_si(big_real(p1), p2) >= 0)); - if (is_t_big_ratio(p1)) - return(mpq_cmp_si(big_ratio(p1), p2, 1) >= 0); -#endif - return(geq_out_x(sc, p1, make_integer(sc, p2))); -} - -static s7_pointer geq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, geq_b_pi(sc, p1, p2)));} - -static s7_pointer geq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - { - s7_pointer arg2 = caddr(expr); - if ((is_t_integer(arg2)) && - (integer(arg2) < S7_INT32_MAX) && - (integer(arg2) > S7_INT32_MIN)) - return(sc->geq_xi); - if ((is_t_real(arg2)) && - (real(arg2) < S7_INT32_MAX) && - (real(arg2) > S7_INT32_MIN)) - return(sc->geq_xf); - } - return(sc->geq_2); -} - - -/* ---------------------------------------- real-part ---------------------------------------- */ -s7_double s7_real_part(s7_pointer x) -{ - switch(type(x)) - { - case T_INTEGER: return((s7_double)integer(x)); - case T_RATIO: return(fraction(x)); - case T_REAL: return(real(x)); - case T_COMPLEX: return(real_part(x)); -#if WITH_GMP - case T_BIG_INTEGER: return((s7_double)mpz_get_si(big_integer(x))); - case T_BIG_RATIO: return((s7_double)((long_double)mpz_get_si(mpq_numref(big_ratio(x))) / - (long_double)mpz_get_si(mpq_denref(big_ratio(x))))); - case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); - case T_BIG_COMPLEX: return((s7_double)mpfr_get_d(mpc_realref(big_complex(x)), MPFR_RNDN)); -#endif - } - return(0.0); -} - -static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_complex(p)) return(make_real(sc, real_part(p))); - switch (type(p)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - return(p); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(p); - case T_BIG_COMPLEX: - { - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpc_real(big_real(x), big_complex(p), MPFR_RNDN); - return(x); - } -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->real_part_symbol, a_number_string)); - } -} - -static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args) -{ - #define H_real_part "(real-part num) returns the real part of num" - #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - return(real_part_p_p(sc, car(args))); -} - - -/* ---------------------------------------- imag-part ---------------------------------------- */ -s7_double s7_imag_part(s7_pointer x) -{ - if (is_t_complex(x)) - return(imag_part(x)); -#if WITH_GMP - if (is_t_big_complex(x)) - return((s7_double)mpfr_get_d(mpc_imagref(big_complex(x)), MPFR_RNDN)); -#endif - return(0.0); -} - -static s7_pointer imag_part_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_complex(p)) return(make_real(sc, imag_part(p))); - switch (type(p)) - { - case T_INTEGER: case T_RATIO: - return(int_zero); - case T_REAL: - return(real_zero); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: - return(int_zero); - case T_BIG_REAL: - return(real_zero); - case T_BIG_COMPLEX: - { - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpc_imag(big_real(x), big_complex(p), MPFR_RNDN); - return(x); - } -#endif - default: - return(sole_arg_method_or_bust_p(sc, p, sc->imag_part_symbol, a_number_string)); - } -} - -static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args) -{ - #define H_imag_part "(imag-part num) returns the imaginary part of num" - #define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol) - /* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */ - return(imag_part_p_p(sc, car(args))); -} - - -/* ---------------------------------------- numerator denominator ---------------------------------------- */ -static s7_int numerator_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_ratio(p)) return(numerator(p)); - if (is_t_integer(p)) return(integer(p)); -#if WITH_GMP - if (is_t_big_ratio(p)) return(mpz_get_si(mpq_numref(big_ratio(p)))); - if (is_t_big_integer(p)) return(mpz_get_si(big_integer(p))); -#endif - return(integer(sole_arg_method_or_bust_p(sc, p, sc->numerator_symbol, a_rational_string))); -} - -static s7_pointer g_numerator(s7_scheme *sc, s7_pointer args) -{ - #define H_numerator "(numerator rat) returns the numerator of the rational number rat" - #define Q_numerator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol) - - s7_pointer x = car(args); - switch (type(x)) - { - case T_RATIO: return(make_integer(sc, numerator(x))); - case T_INTEGER: return(x); -#if WITH_GMP - case T_BIG_INTEGER: return(x); - case T_BIG_RATIO: return(mpz_to_integer(sc, mpq_numref(big_ratio(x)))); -#endif - default: return(sole_arg_method_or_bust_p(sc, x, sc->numerator_symbol, a_rational_string)); - } -} - - -static s7_pointer g_denominator(s7_scheme *sc, s7_pointer args) -{ - #define H_denominator "(denominator rat) returns the denominator of the rational number rat" - #define Q_denominator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol) - - s7_pointer x = car(args); - switch (type(x)) - { - case T_RATIO: return(make_integer(sc, denominator(x))); - case T_INTEGER: return(int_one); -#if WITH_GMP - case T_BIG_INTEGER: return(int_one); - case T_BIG_RATIO: return(mpz_to_integer(sc, mpq_denref(big_ratio(x)))); -#endif - default: return(sole_arg_method_or_bust_p(sc, x, sc->denominator_symbol, a_rational_string)); - } -} - -static s7_int denominator_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_ratio(p)) return(denominator(p)); - if (is_t_integer(p)) return(1); -#if WITH_GMP - if (is_t_big_ratio(p)) return(mpz_get_si(mpq_denref(big_ratio(p)))); - if (is_t_big_integer(p)) return(1); -#endif - return(integer(sole_arg_method_or_bust_p(sc, p, sc->denominator_symbol, a_rational_string))); -} - - -/* ---------------------------------------- number? bignum? complex? integer? byte? rational? real? ---------------------------------------- */ -static s7_pointer g_is_number(s7_scheme *sc, s7_pointer args) -{ - #define H_is_number "(number? obj) returns #t if obj is a number" - #define Q_is_number sc->pl_bt - check_boolean_method(sc, is_number, sc->is_number_symbol, args); -} - -bool s7_is_bignum(s7_pointer obj) {return(is_big_number(obj));} - -static s7_pointer g_is_bignum(s7_scheme *sc, s7_pointer args) -{ - #define H_is_bignum "(bignum? obj) returns #t if obj is a multiprecision number." - #define Q_is_bignum sc->pl_bt - return(s7_make_boolean(sc, is_big_number(car(args)))); -} - -static s7_pointer g_is_integer(s7_scheme *sc, s7_pointer args) -{ - #define H_is_integer "(integer? obj) returns #t if obj is an integer" - #define Q_is_integer sc->pl_bt - check_boolean_method(sc, s7_is_integer, sc->is_integer_symbol, args); -} - -static bool is_byte(s7_pointer p) {return((s7_is_integer(p)) && (s7_integer(p) >= 0) && (s7_integer(p) < 256));} -static s7_pointer g_is_byte(s7_scheme *sc, s7_pointer args) -{ - #define H_is_byte "(byte? obj) returns #t if obj is a byte (an integer between 0 and 255)" - #define Q_is_byte sc->pl_bt - check_boolean_method(sc, is_byte, sc->is_byte_symbol, args); -} - -static s7_pointer g_is_real(s7_scheme *sc, s7_pointer args) -{ - #define H_is_real "(real? obj) returns #t if obj is a real number" - #define Q_is_real sc->pl_bt - check_boolean_method(sc, is_real, sc->is_real_symbol, args); -} - -static s7_pointer g_is_complex(s7_scheme *sc, s7_pointer args) -{ - #define H_is_complex "(complex? obj) returns #t if obj is a number" - #define Q_is_complex sc->pl_bt - check_boolean_method(sc, is_number, sc->is_complex_symbol, args); -} - -static s7_pointer g_is_rational(s7_scheme *sc, s7_pointer args) -{ - #define H_is_rational "(rational? obj) returns #t if obj is a rational number (either an integer or a ratio)" - #define Q_is_rational sc->pl_bt - check_boolean_method(sc, is_rational, sc->is_rational_symbol, args); - /* in the non-gmp case, (rational? 455702434782048082459/86885567283849955830) -> #f, not #t, and similarly for exact? etc */ -} - -static s7_pointer g_is_float(s7_scheme *sc, s7_pointer args) -{ - #define H_is_float "(float? x) returns #t is x is real and not rational." - #define Q_is_float sc->pl_bt - s7_pointer p = car(args); -#if WITH_GMP - return(make_boolean(sc, (is_t_real(p)) || (is_t_big_real(p)))); /* (float? pi) */ -#else - return(make_boolean(sc, is_t_real(p))); -#endif -} - -#if WITH_GMP -static bool is_float_b(s7_pointer p) {return((is_t_real(p)) || (is_t_big_real(p)));} -#else -static bool is_float_b(s7_pointer p) {return(is_t_real(p));} -#endif - - -/* ---------------------------------------- nan? ---------------------------------------- */ -static bool is_nan_b_7p(s7_scheme *sc, s7_pointer x) -{ - if (is_t_real(x)) return(is_NaN(real(x))); - switch (type(x)) - { - case T_INTEGER: - case T_RATIO: return(false); - /* case T_REAL: return(is_NaN(real(x))); */ - case T_COMPLEX: return((is_NaN(real_part(x))) || (is_NaN(imag_part(x)))); -#if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: return(false); - case T_BIG_REAL: return(mpfr_nan_p(big_real(x)) != 0); - case T_BIG_COMPLEX: return((mpfr_nan_p(mpc_realref(big_complex(x))) != 0) || (mpfr_nan_p(mpc_imagref(big_complex(x))) != 0)); -#endif - default: - if (is_number(x)) - return(sole_arg_method_or_bust_p(sc, x, sc->is_nan_symbol, a_number_string) != sc->F); - } - return(false); -} - -static s7_pointer g_is_nan(s7_scheme *sc, s7_pointer args) -{ - #define H_is_nan "(nan? obj) returns #t if obj is a NaN" - #define Q_is_nan sc->pl_bt - return(make_boolean(sc, is_nan_b_7p(sc, car(args)))); -} - - -/* ---------------------------------------- infinite? ---------------------------------------- */ -static bool is_infinite_b_7p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: - case T_RATIO: return(false); - case T_REAL: return(is_inf(real(x))); - case T_COMPLEX: return((is_inf(real_part(x))) || (is_inf(imag_part(x)))); -#if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: return(false); - case T_BIG_REAL: return(mpfr_inf_p(big_real(x)) != 0); - case T_BIG_COMPLEX: - return((mpfr_inf_p(mpc_realref(big_complex(x))) != 0) || - (mpfr_inf_p(mpc_imagref(big_complex(x))) != 0)); -#endif - default: - if (is_number(x)) - return(sole_arg_method_or_bust_p(sc, x, sc->is_infinite_symbol, a_number_string) != sc->F); - } - return(false); -} - -static s7_pointer g_is_infinite(s7_scheme *sc, s7_pointer args) -{ - #define H_is_infinite "(infinite? obj) returns #t if obj is an infinite real" - #define Q_is_infinite sc->pl_bt - return(make_boolean(sc, is_infinite_b_7p(sc, car(args)))); -} - - -/* ---------------------------------------- even? odd?---------------------------------------- */ -static bool is_even_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) - return((integer(p) & 1) == 0); -#if WITH_GMP - if (is_t_big_integer(p)) - return(mpz_even_p(big_integer(p))); -#endif - return(method_or_bust_p(sc, p, sc->is_even_symbol, sc->type_names[T_INTEGER]) != sc->F); -} - -static s7_pointer is_even_p_p(s7_scheme *sc, s7_pointer x) -{ - if (is_t_integer(x)) - return(make_boolean(sc, (integer(x) & 1) == 0)); - return(make_boolean(sc, is_even_b_7p(sc, x))); -} - -static bool is_even_i(s7_int i1) {return((i1 & 1) == 0);} - -static s7_pointer g_is_even(s7_scheme *sc, s7_pointer args) -{ - #define H_is_even "(even? int) returns #t if the integer int32_t is even" - #define Q_is_even s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol) - return(make_boolean(sc, is_even_b_7p(sc, car(args)))); -} - - -static bool is_odd_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) - return((integer(p) & 1) == 1); -#if WITH_GMP - if (is_t_big_integer(p)) - return(mpz_odd_p(big_integer(p))); -#endif - return(method_or_bust_p(sc, p, sc->is_odd_symbol, sc->type_names[T_INTEGER]) != sc->F); -} - -static s7_pointer is_odd_p_p(s7_scheme *sc, s7_pointer x) -{ - if (is_t_integer(x)) - return(make_boolean(sc, (integer(x) & 1) == 1)); - return(make_boolean(sc, is_odd_b_7p(sc, x))); -} - -static bool is_odd_i(s7_int i1) {return((i1 & 1) == 1);} - -static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args) -{ - #define H_is_odd "(odd? int) returns #t if the integer int32_t is odd" - #define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol) - return(make_boolean(sc, is_odd_b_7p(sc, car(args)))); -} - - -/* ---------------------------------------- zero? ---------------------------------------- */ -static bool is_zero(s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x) == 0); - case T_REAL: return(real(x) == 0.0); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) == 0); - case T_BIG_REAL: return(mpfr_zero_p(big_real(x))); -#endif - default: - return(false); /* ratios and complex numbers here are already collapsed into integers and reals */ - } -} - -static bool is_zero_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p) == 0); - if (is_t_real(p)) return(real(p) == 0.0); -#if WITH_GMP - if (is_number(p)) return(is_zero(p)); -#else - if (is_number(p)) return(false); -#endif - return(sole_arg_method_or_bust_p(sc, p, sc->is_zero_symbol, a_number_string) != sc->F); -} - -static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args) -{ - #define H_is_zero "(zero? num) returns #t if the number num is zero" - #define Q_is_zero sc->pl_bn - return(make_boolean(sc, is_zero_b_7p(sc, car(args)))); -} - -static s7_pointer is_zero_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_zero_b_7p(sc, p)));} -static bool is_zero_i(s7_int p) {return(p == 0);} -static bool is_zero_d(s7_double p) {return(p == 0.0);} - - -/* -------------------------------- positive? -------------------------------- */ -static bool is_positive(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x) > 0); - case T_RATIO: return(numerator(x) > 0); - case T_REAL: return(real(x) > 0.0); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) > 0); - case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(x), 0, 1) > 0); - case T_BIG_REAL: return(mpfr_cmp_ui(big_real(x), 0) > 0); -#endif - default: - sole_arg_wrong_type_error_nr(sc, sc->is_positive_symbol, x, sc->type_names[T_REAL]); - } - return(false); -} - -static bool is_positive_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p) > 0); - if (is_t_real(p)) return(real(p) > 0.0); -#if WITH_GMP - if (is_number(p)) return(is_positive(sc, p)); -#else - if (is_t_ratio(p)) return(numerator(p) > 0); -#endif - return(method_or_bust_p(sc, p, sc->is_positive_symbol, sc->type_names[T_REAL]) != sc->F); -} - -static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args) -{ - #define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)" - #define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) - return(make_boolean(sc, is_positive_b_7p(sc, car(args)))); -} - -static s7_pointer is_positive_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_positive_b_7p(sc, p)));} -static bool is_positive_i(s7_int p) {return(p > 0);} -static bool is_positive_d(s7_double p) {return(p > 0.0);} - - -/* -------------------------------- negative? -------------------------------- */ -static bool is_negative(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: return(integer(x) < 0); - case T_RATIO: return(numerator(x) < 0); - case T_REAL: return(real(x) < 0.0); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) < 0); - case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(x), 0, 1) < 0); - case T_BIG_REAL: return(mpfr_cmp_ui(big_real(x), 0) < 0); -#endif - default: - sole_arg_wrong_type_error_nr(sc, sc->is_negative_symbol, x, sc->type_names[T_REAL]); - } - return(false); -} - -static bool is_negative_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (is_t_integer(p)) return(integer(p) < 0); - if (is_t_real(p)) return(real(p) < 0.0); -#if WITH_GMP - if (is_number(p)) return(is_negative(sc, p)); -#else - if (is_t_ratio(p)) return(numerator(p) < 0); -#endif - return(method_or_bust_p(sc, p, sc->is_negative_symbol, sc->type_names[T_REAL]) != sc->F); -} - -static s7_pointer g_is_negative(s7_scheme *sc, s7_pointer args) -{ - #define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)" - #define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol) - return(make_boolean(sc, is_negative_b_7p(sc, car(args)))); -} - -static s7_pointer is_negative_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_negative_b_7p(sc, p)));} -static bool is_negative_i(s7_int p) {return(p < 0);} -static bool is_negative_d(s7_double p) {return(p < 0.0);} - - -#if (!WITH_PURE_S7) -/* ---------------------------------------- exact<->inexact exact? inexact? ---------------------------------------- */ -static s7_pointer exact_to_inexact_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: -#if WITH_GMP - if ((integer(x) > INT64_TO_DOUBLE_LIMIT) || (integer(x) < -INT64_TO_DOUBLE_LIMIT)) - return(s7_number_to_big_real(sc, x)); -#endif - return(make_real(sc, (s7_double)(integer(x)))); - - case T_RATIO: -#if WITH_GMP - if ((numerator(x) > INT64_TO_DOUBLE_LIMIT) || (numerator(x) < -INT64_TO_DOUBLE_LIMIT) || - (denominator(x) > INT64_TO_DOUBLE_LIMIT)) /* just a guess */ - return(s7_number_to_big_real(sc, x)); -#endif - return(make_real(sc, (s7_double)(fraction(x)))); - -#if WITH_GMP - case T_BIG_INTEGER: - return(big_integer_to_big_real(sc, x)); - case T_BIG_RATIO: - return(big_ratio_to_big_real(sc, x)); -#endif - case T_REAL: case T_BIG_REAL: - case T_COMPLEX: case T_BIG_COMPLEX: - return(x); /* apparently (exact->inexact 1+i) is not an error */ - default: - return(sole_arg_method_or_bust_p(sc, x, sc->exact_to_inexact_symbol, a_number_string)); - } -} - -static s7_pointer g_exact_to_inexact(s7_scheme *sc, s7_pointer args) -{ - #define H_exact_to_inexact "(exact->inexact num) converts num to an inexact number; (exact->inexact 3/2) = 1.5" - #define Q_exact_to_inexact s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol) - /* arg can be complex -> itself! */ - return(exact_to_inexact_p_p(sc, car(args))); -} - -static s7_pointer inexact_to_exact_p_p(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_INTEGER: case T_BIG_INTEGER: - case T_RATIO: case T_BIG_RATIO: - return(x); - -#if WITH_GMP - case T_BIG_REAL: - return(big_rationalize(sc, set_plist_1(sc, x))); -#endif - - case T_REAL: - { - s7_int numer = 0, denom = 1; - s7_double val = real(x); - if ((is_inf(val)) || (is_NaN(val))) - sole_arg_wrong_type_error_nr(sc, sc->inexact_to_exact_symbol, x, a_normal_real_string); - - if ((val > DOUBLE_TO_INT64_LIMIT) || (val < -(DOUBLE_TO_INT64_LIMIT))) - { -#if WITH_GMP - return(big_rationalize(sc, set_plist_1(sc, x))); /* this can handle t_real as well as t_big_real */ -#else - sole_arg_out_of_range_error_nr(sc, sc->inexact_to_exact_symbol, x, it_is_too_large_string); -#endif - } - /* c_rationalize limit is RATIONALIZE_LIMIT=1e12 currently so this is a tighter limit than DOUBLE_TO_INT64_LIMIT */ - if (c_rationalize(val, sc->default_rationalize_error, &numer, &denom)) - return(make_ratio(sc, numer, denom)); - } - - default: - return(method_or_bust_p(sc, x, sc->inexact_to_exact_symbol, sc->type_names[T_REAL])); - } - return(x); -} - -static s7_pointer g_inexact_to_exact(s7_scheme *sc, s7_pointer args) -{ - #define H_inexact_to_exact "(inexact->exact num) converts num to an exact number; (inexact->exact 1.5) = 3/2" - #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol) - return(inexact_to_exact_p_p(sc, car(args))); -} - -static s7_pointer g_is_exact(s7_scheme *sc, s7_pointer args) -{ - #define H_is_exact "(exact? num) returns #t if num is exact (an integer or a ratio)" - #define Q_is_exact sc->pl_bn - - s7_pointer x = car(args); - switch (type(x)) - { - case T_INTEGER: case T_BIG_INTEGER: - case T_RATIO: case T_BIG_RATIO: - return(sc->T); - case T_REAL: case T_BIG_REAL: - case T_COMPLEX: case T_BIG_COMPLEX: - return(sc->F); - default: - return(sole_arg_method_or_bust_p(sc, x, sc->is_exact_symbol, a_number_string)); - } -} - -static bool is_exact_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_number(p)) - return(sole_arg_method_or_bust_p(sc, p, sc->is_exact_symbol, a_number_string) != sc->F); - return(is_rational(p)); -} - - -static s7_pointer g_is_inexact(s7_scheme *sc, s7_pointer args) -{ - #define H_is_inexact "(inexact? num) returns #t if num is inexact (neither an integer nor a ratio)" - #define Q_is_inexact sc->pl_bn - - s7_pointer x = car(args); - switch (type(x)) - { - case T_INTEGER: case T_BIG_INTEGER: - case T_RATIO: case T_BIG_RATIO: - return(sc->F); - case T_REAL: case T_BIG_REAL: - case T_COMPLEX: case T_BIG_COMPLEX: - return(sc->T); - default: - return(sole_arg_method_or_bust_p(sc, x, sc->is_inexact_symbol, a_number_string)); - } -} - -static bool is_inexact_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_number(p)) - return(sole_arg_method_or_bust_p(sc, p, sc->is_inexact_symbol, a_number_string) != sc->F); - return(!is_rational(p)); -} - - -/* ---------------------------------------- integer-length ---------------------------------------- */ -static int32_t integer_length(s7_int a) -{ - if (a < 0) - { - if (a == S7_INT64_MIN) return(63); - a = -a; - } - if (a < 256LL) return(intlen_bits[a]); /* in gmp, sbcl and clisp (integer-length 0) is 0 */ - if (a < 65536LL) return(8 + intlen_bits[a >> 8]); - if (a < 16777216LL) return(16 + intlen_bits[a >> 16]); - if (a < 4294967296LL) return(24 + intlen_bits[a >> 24]); - if (a < 1099511627776LL) return(32 + intlen_bits[a >> 32]); - if (a < 281474976710656LL) return(40 + intlen_bits[a >> 40]); - if (a < 72057594037927936LL) return(48 + intlen_bits[a >> 48]); - return(56 + intlen_bits[a >> 56]); -} - -static s7_pointer g_integer_length(s7_scheme *sc, s7_pointer args) -{ - #define H_integer_length "(integer-length arg) returns the number of bits required to represent the integer 'arg': \ -(ceiling (log (if (< arg 0) (- arg) (+ arg 1)) 2))" - #define Q_integer_length sc->pcl_i - - s7_pointer p = car(args); - if (is_t_integer(p)) - { - s7_int x = integer(p); - return((x < 0) ? small_int(integer_length(-(x + 1))) : small_int(integer_length(x))); - } -#if WITH_GMP - if (is_t_big_integer(p)) - return(make_integer(sc, mpz_sizeinbase(big_integer(p), 2))); -#endif - return(sole_arg_method_or_bust(sc, p, sc->integer_length_symbol, args, sc->type_names[T_INTEGER])); -} - -static s7_int integer_length_i_i(s7_int x) {return((x < 0) ? integer_length(-(x + 1)) : integer_length(x));} -#endif /* !pure s7 */ - - -/* ---------------------------------------- integer-decode-float ---------------------------------------- */ -static s7_pointer g_integer_decode_float(s7_scheme *sc, s7_pointer args) -{ - #define H_integer_decode_float "(integer-decode-float x) returns a list containing the significand, exponent, and \ -sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)" - #define Q_integer_decode_float s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_float_symbol) - - decode_float_t num; - s7_pointer x = car(args); - if (is_t_real(x)) - { - if (real(x) == 0.0) - return(list_3(sc, int_zero, int_zero, int_one)); - num.fx = (double)real(x); - return(list_3(sc, - make_integer_unchecked(sc, (s7_int)((num.ix & 0xfffffffffffffLL) | 0x10000000000000LL)), - make_integer(sc, (s7_int)(((num.ix & 0x7fffffffffffffffLL) >> 52) - 1023 - 52)), - ((num.ix & 0x8000000000000000LL) != 0) ? minus_one : int_one)); - } -#if WITH_GMP - if (is_t_big_real(x)) - { - mp_exp_t exp_n; - bool neg; - exp_n = mpfr_get_z_exp(sc->mpz_1, big_real(x)); - neg = (mpz_cmp_ui(sc->mpz_1, 0) < 0); - if (neg) mpz_abs(sc->mpz_1, sc->mpz_1); - return(list_3(sc, mpz_to_integer(sc, sc->mpz_1), make_integer(sc, exp_n), (neg) ? minus_one : int_one)); - /* not gmp: (integer-decode-float +nan.0): (6755399441055744 972 1), gmp: (integer-decode-float (bignum +nan.0)): (0 -1073741823 1) */ - } -#endif - return(sole_arg_method_or_bust_p(sc, x, sc->integer_decode_float_symbol, wrap_string(sc, "a non-rational real", 19))); -} - - -/* -------------------------------- logior -------------------------------- */ -#if WITH_GMP -static s7_pointer big_logior(s7_scheme *sc, s7_int start, s7_pointer args) -{ - mpz_set_si(sc->mpz_1, start); - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { - s7_pointer i = car(x); - switch (type(i)) - { - case T_BIG_INTEGER: - mpz_ior(sc->mpz_1, sc->mpz_1, big_integer(i)); - break; - case T_INTEGER: - mpz_set_si(sc->mpz_2, integer(i)); - mpz_ior(sc->mpz_1, sc->mpz_1, sc->mpz_2); - break; - default: - if (!is_integer_via_method(sc, i)) - wrong_type_error_nr(sc, sc->logior_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, i, sc->logior_symbol, - set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), - sc->type_names[T_INTEGER], position_of(x, args))); - }} - return(mpz_to_integer(sc, sc->mpz_1)); -} -#endif - -static s7_pointer g_logior(s7_scheme *sc, s7_pointer args) -{ - #define H_logior "(logior int32_t ...) returns the OR of its integer arguments (the bits that are on in any of the arguments)" - #define Q_logior sc->pcl_i - - s7_int result = 0; - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { -#if WITH_GMP - if (is_t_big_integer(car(x))) - return(big_logior(sc, result, x)); -#endif - if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logior_symbol, - (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), - sc->type_names[T_INTEGER], position_of(x, args))); - result |= integer(car(x)); - } - return(make_integer(sc, result)); -} - -static s7_int logior_i_ii(s7_int i1, s7_int i2) {return(i1 | i2);} -static s7_int logior_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 | i2 | i3);} - - -/* -------------------------------- logxor -------------------------------- */ -#if WITH_GMP -static s7_pointer big_logxor(s7_scheme *sc, s7_int start, s7_pointer args) -{ - mpz_set_si(sc->mpz_1, start); - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { - s7_pointer i = car(x); - switch (type(i)) - { - case T_BIG_INTEGER: - mpz_xor(sc->mpz_1, sc->mpz_1, big_integer(i)); - break; - case T_INTEGER: - mpz_set_si(sc->mpz_2, integer(i)); - mpz_xor(sc->mpz_1, sc->mpz_1, sc->mpz_2); - break; - default: - if (!is_integer_via_method(sc, i)) - wrong_type_error_nr(sc, sc->logxor_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, i, sc->logxor_symbol, - set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), - sc->type_names[T_INTEGER], position_of(x, args))); - }} - return(mpz_to_integer(sc, sc->mpz_1)); -} -#endif - -static s7_pointer g_logxor(s7_scheme *sc, s7_pointer args) -{ - #define H_logxor "(logxor int32_t ...) returns the XOR of its integer arguments (the bits that are on in an odd number of the arguments)" - #define Q_logxor sc->pcl_i - - s7_int result = 0; - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { -#if WITH_GMP - if (is_t_big_integer(car(x))) - return(big_logxor(sc, result, x)); -#endif - if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logxor_symbol, - (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), - sc->type_names[T_INTEGER], position_of(x, args))); - result ^= integer(car(x)); - } - return(make_integer(sc, result)); -} - -static s7_int logxor_i_ii(s7_int i1, s7_int i2) {return(i1 ^ i2);} -static s7_int logxor_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 ^ i2 ^ i3);} - - -/* -------------------------------- logand -------------------------------- */ -#if WITH_GMP -static s7_pointer big_logand(s7_scheme *sc, s7_int start, s7_pointer args) -{ - mpz_set_si(sc->mpz_1, start); - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { - s7_pointer i = car(x); - switch (type(i)) - { - case T_BIG_INTEGER: - mpz_and(sc->mpz_1, sc->mpz_1, big_integer(i)); - break; - case T_INTEGER: - mpz_set_si(sc->mpz_2, integer(i)); - mpz_and(sc->mpz_1, sc->mpz_1, sc->mpz_2); - break; - default: - if (!is_integer_via_method(sc, i)) - wrong_type_error_nr(sc, sc->logand_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, i, sc->logand_symbol, - set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), - sc->type_names[T_INTEGER], position_of(x, args))); - }} - return(mpz_to_integer(sc, sc->mpz_1)); -} -#endif - -static s7_pointer g_logand(s7_scheme *sc, s7_pointer args) -{ - #define H_logand "(logand int32_t ...) returns the AND of its integer arguments (the bits that are on in every argument)" - #define Q_logand sc->pcl_i - - s7_int result = -1; - for (s7_pointer x = args; is_not_null(x); x = cdr(x)) - { -#if WITH_GMP - if (is_t_big_integer(car(x))) - return(big_logand(sc, result, x)); -#endif - if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logand_symbol, - (result == -1) ? x : set_ulist_1(sc, make_integer(sc, result), x), - sc->type_names[T_INTEGER], position_of(x, args))); - result &= integer(car(x)); - } - return(make_integer(sc, result)); -} - -static s7_int logand_i_ii(s7_int i1, s7_int i2) {return(i1 & i2);} -static s7_int logand_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 & i2 & i3);} - - -/* -------------------------------- lognot -------------------------------- */ -static s7_pointer g_lognot(s7_scheme *sc, s7_pointer args) -{ - #define H_lognot "(lognot num) returns the negation of num (its complement, the bits that are not on): (lognot 0) -> -1" - #define Q_lognot sc->pcl_i - - s7_pointer x = car(args); - if (is_t_integer(x)) - return(make_integer(sc, ~integer(x))); - -#if WITH_GMP - if (is_t_big_integer(x)) - { - mpz_com(sc->mpz_1, big_integer(x)); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#endif - return(sole_arg_method_or_bust(sc, x, sc->lognot_symbol, args, sc->type_names[T_INTEGER])); -} - -static s7_int lognot_i_i(s7_int i1) {return(~i1);} - - -/* -------------------------------- logbit? -------------------------------- */ -/* logbit? CL is (logbitp index int) using 2^index, but that order strikes me as backwards - * at least gmp got the arg order right! - */ - -static s7_pointer g_logbit(s7_scheme *sc, s7_pointer args) -{ - #define H_logbit "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f. The argument \ -order here follows gmp, and is the opposite of the CL convention. (logbit? int bit) is the same as (not (zero? (logand int (ash 1 bit))))." - #define Q_logbit s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol) - - s7_pointer x = car(args), y = cadr(args); - s7_int index; /* index in gmp is mp_bitcnt which is an unsigned long int */ - - if (!s7_is_integer(x)) - return(method_or_bust(sc, x, sc->logbit_symbol, args, sc->type_names[T_INTEGER], 1)); - if (!s7_is_integer(y)) - return(method_or_bust(sc, y, sc->logbit_symbol, args, sc->type_names[T_INTEGER], 2)); - - index = s7_integer_clamped_if_gmp(sc, y); - if (index < 0) - out_of_range_error_nr(sc, sc->logbit_symbol, int_two, y, it_is_negative_string); - -#if WITH_GMP - if (is_t_big_integer(x)) - return(make_boolean(sc, (mpz_tstbit(big_integer(x), index) != 0))); -#endif - - if (index >= S7_INT_BITS) /* not sure about the >: (logbit? -1 64) ?? */ - return(make_boolean(sc, integer(x) < 0)); - /* (zero? (logand most-positive-fixnum (ash 1 63))) -> ash argument 2, 63, is out of range (shift is too large) - * so logbit? has a wider range than the logand/ash shuffle above. - */ - - /* all these int64_ts are necessary, else C turns it into an int, gets confused about signs etc */ - return(make_boolean(sc, ((((int64_t)(1LL << (int64_t)index)) & (int64_t)integer(x)) != 0))); -} - -static bool logbit_b_7ii(s7_scheme *sc, s7_int i1, s7_int i2) -{ - if (i2 < 0) - { - out_of_range_error_nr(sc, sc->logbit_symbol, int_two, wrap_integer(sc, i1), it_is_negative_string); - return(false); - } - if (i2 >= S7_INT_BITS) return(i1 < 0); - return((((int64_t)(1LL << (int64_t)i2)) & (int64_t)i1) != 0); -} - -static bool logbit_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (is_t_integer(p1)) - { - if (is_t_integer(p2)) - return(logbit_b_7ii(sc, integer(p1), integer(p2))); - return(method_or_bust(sc, p2, sc->logbit_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_INTEGER], 2) != sc->F); - } -#if WITH_GMP - return(g_logbit(sc, set_plist_2(sc, p1, p2))); -#else - return(method_or_bust(sc, p1, sc->logbit_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_INTEGER], 1) != sc->F); -#endif -} - - -/* -------------------------------- ash -------------------------------- */ -static s7_int c_ash(s7_scheme *sc, s7_int arg1, s7_int arg2) -{ - if (arg1 == 0) return(0); - if (arg2 >= S7_INT_BITS) - { - if ((arg1 == -1) && (arg2 == 63)) /* (ash -1 63): most-negative-fixnum */ - return(S7_INT64_MIN); - out_of_range_error_nr(sc, sc->ash_symbol, int_two, wrap_integer(sc, arg2), it_is_too_large_string); - } - if (arg2 < -S7_INT_BITS) - return((arg1 < 0) ? -1 : 0); /* (ash -31 -100) */ - - /* I can't see any point in protecting this: (ash 9223372036854775807 1) -> -2, but anyone using ash must know something about bits */ - if (arg2 < 0) - return(arg1 >> -arg2); - if (arg1 < 0) - { - uint64_t z = (uint64_t)arg1; - return((s7_int)(z << arg2)); - } - return(arg1 << arg2); -} - -static s7_pointer g_ash(s7_scheme *sc, s7_pointer args) -{ - #define H_ash "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 3) -> 8, (ash 8 -3) -> 1" - #define Q_ash sc->pcl_i - -#if WITH_GMP - /* here, as in expt, there are cases like (ash 1 63) which need to be handled as bignums */ - s7_pointer p0 = car(args), p1 = cadr(args); - - /* here, as in expt, there are cases like (ash 1 63) which need to be bignums so there's no easy way to tell when it's safe to drop into g_ash instead */ - if ((s7_is_integer(p0)) && /* this includes bignum ints... */ - (s7_is_integer(p1))) - { - s7_int shift; - bool p0_is_big = is_big_number(p0); - int32_t p0_compared_to_zero = 0; - - if (p0_is_big) - p0_compared_to_zero = mpz_cmp_ui(big_integer(p0), 0); - else - if (integer(p0) > 0) - p0_compared_to_zero = 1; - else p0_compared_to_zero = (integer(p0) < 0) ? -1 : 0; - - if (p0_compared_to_zero == 0) - return(int_zero); - - if (is_big_number(p1)) - { - if (!mpz_fits_sint_p(big_integer(p1))) - { - if (mpz_cmp_ui(big_integer(p1), 0) > 0) - out_of_range_error_nr(sc, sc->ash_symbol, int_two, p1, it_is_too_large_string); - - /* here if p0 is negative, we need to return -1 */ - return((p0_compared_to_zero == 1) ? int_zero : minus_one); - } - shift = mpz_get_si(big_integer(p1)); - } - else - { - shift = integer(p1); - if (shift < S7_INT32_MIN) - return((p0_compared_to_zero == 1) ? int_zero : minus_one); - } - if (shift > S7_INT32_MAX) - out_of_range_error_nr(sc, sc->ash_symbol, int_two, p1, it_is_too_large_string); /* gmp calls abort if overflow here */ - - if (is_t_big_integer(p0)) - mpz_set(sc->mpz_1, big_integer(p0)); - else mpz_set_si(sc->mpz_1, integer(p0)); - - if (shift > 0) /* left */ - mpz_mul_2exp(sc->mpz_1, sc->mpz_1, shift); - else - if (shift < 0) /* right */ - mpz_fdiv_q_2exp(sc->mpz_1, sc->mpz_1, (uint32_t)(-shift)); - - return(mpz_to_integer(sc, sc->mpz_1)); - } - /* else fall through */ -#endif - s7_pointer x = car(args), y = cadr(args); - - if (!s7_is_integer(x)) - return(method_or_bust(sc, x, sc->ash_symbol, args, sc->type_names[T_INTEGER], 1)); - if (!s7_is_integer(y)) - return(method_or_bust(sc, y, sc->ash_symbol, args, sc->type_names[T_INTEGER], 2)); - return(make_integer(sc, c_ash(sc, s7_integer_clamped_if_gmp(sc, x), s7_integer_clamped_if_gmp(sc, y)))); -} - -#if (!WITH_GMP) - static s7_int ash_i_7ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(c_ash(sc, i1, i2));} -#endif -static s7_int lsh_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 << i2);} /* this may need gmp special handling, and out-of-range as in c_ash */ -static s7_int rsh_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 >> (-i2));} -static s7_int rsh_i_i2_direct(s7_int i1, s7_int unused_i2) {return(i1 >> 1);} - - -/* -------------------------------- random-state -------------------------------- */ -/* random numbers. The simple version used in clm.c is probably adequate, but here I'll use Marsaglia's MWC algorithm. - * (random num) -> a number (0..num), if num == 0 return 0, use global default state - * (random num state) -> same but use this state - * (random-state seed) -> make a new state - * to save the current seed, use copy, to save it across load, random-state->list and list->random-state. - * random-state? returns #t if its arg is one of these guys - */ - -static s7_pointer random_state_copy(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - return(sc->F); /* I can't find a way to copy a gmp random generator */ -#else - s7_pointer new_r, obj = car(args); - if (!is_random_state(obj)) return(sc->F); - new_cell(sc, new_r, T_RANDOM_STATE); - random_seed(new_r) = random_seed(obj); - random_carry(new_r) = random_carry(obj); - return(new_r); -#endif -} -#if S7_DEBUGGING && (!WITH_GMP) - static s7_int last_carry = 0; - /* 2083801278 */ -#endif - -s7_pointer s7_random_state(s7_scheme *sc, s7_pointer args) -{ - #define H_random_state "(random-state seed (carry plausible-default)) returns a new random number state initialized with 'seed'. \ -Pass this as the second argument to 'random' to get a repeatable random number sequence:\n\ - (let ((seed (random-state 1234))) (random 1.0 seed))" - #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol) - -#if WITH_GMP - s7_pointer r, seed; - if (is_null(args)) - return(sc->F); /* how to find current state, if any? */ - - seed = car(args); - if (!s7_is_integer(seed)) - return(sole_arg_method_or_bust(sc, seed, sc->random_state_symbol, args, sc->type_names[T_INTEGER])); - - if (is_t_integer(seed)) - seed = s7_int_to_big_integer(sc, integer(seed)); - - new_cell(sc, r, T_RANDOM_STATE); - gmp_randinit_default(random_gmp_state(r)); /* Mersenne twister */ - gmp_randseed(random_gmp_state(r), big_integer(seed)); /* this is ridiculously slow! */ - add_big_random_state(sc, r); - return(r); -#else - s7_pointer r1, r2, p; - s7_int i1, i2; - if (is_null(args)) - return(sc->default_random_state); - - r1 = car(args); - if (!s7_is_integer(r1)) - return(method_or_bust(sc, r1, sc->random_state_symbol, args, sc->type_names[T_INTEGER], 1)); - i1 = integer(r1); - if (i1 < 0) - out_of_range_error_nr(sc, sc->random_state_symbol, int_one, r1, it_is_negative_string); - if (is_null(cdr(args))) - { - new_cell(sc, p, T_RANDOM_STATE); - random_seed(p) = (uint64_t)i1; - random_carry(p) = 1675393560; /* should this be dependent on the seed? */ -#if S7_DEBUGGING - last_carry = 1675393560; -#endif - return(p); - } - - r2 = cadr(args); - if (!s7_is_integer(r2)) - return(method_or_bust(sc, r2, sc->random_state_symbol, args, sc->type_names[T_INTEGER], 2)); - i2 = integer(r2); - if (i2 < 0) - out_of_range_error_nr(sc, sc->random_state_symbol, int_two, r2, it_is_negative_string); - - new_cell(sc, p, T_RANDOM_STATE); - random_seed(p) = (uint64_t)i1; - random_carry(p) = (uint64_t)i2; -#if S7_DEBUGGING - last_carry = i2; -#endif - return(p); -#endif -} - -#define g_random_state s7_random_state - -static s7_pointer random_state_getter(s7_scheme *sc, s7_pointer r, s7_int loc) -{ -#if (!WITH_GMP) - if (loc == 0) return(make_integer(sc, random_seed(r))); - if (loc == 1) return(make_integer(sc, random_carry(r))); -#endif - return(sc->F); -} - -static s7_pointer random_state_setter(s7_scheme *sc, s7_pointer r, s7_int loc, s7_pointer val) -{ -#if (!WITH_GMP) - if (is_t_integer(val)) - { - s7_int i = s7_integer_clamped_if_gmp(sc, val); - if (loc == 0) random_seed(r) = i; - if (loc == 1) random_carry(r) = i; - } -#endif - return(sc->F); -} - - -/* -------------------------------- random-state? -------------------------------- */ -static s7_pointer g_is_random_state(s7_scheme *sc, s7_pointer args) -{ - #define H_is_random_state "(random-state? obj) returns #t if obj is a random-state object (from random-state)." - #define Q_is_random_state sc->pl_bt - check_boolean_method(sc, is_random_state, sc->is_random_state_symbol, args); -} - -bool s7_is_random_state(s7_pointer p) {return(type(p) == T_RANDOM_STATE);} - - -/* -------------------------------- random-state->list -------------------------------- */ -s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_random_state_to_list "(random-state->list r) returns the random state object as a list.\ -You can later apply random-state to this list to continue a random number sequence from any point." - #define Q_random_state_to_list s7_make_signature(sc, 2, (WITH_GMP) ? sc->is_list_symbol : sc->is_pair_symbol, sc->is_random_state_symbol) - -#if WITH_GMP - if ((is_pair(args)) && - (!is_random_state(car(args)))) - return(method_or_bust(sc, car(args), sc->random_state_to_list_symbol, args, a_random_state_object_string, 1)); - return(sc->nil); -#else - s7_pointer r = (is_null(args)) ? sc->default_random_state : car(args); - if (!is_random_state(r)) - return(method_or_bust(sc, r, sc->random_state_to_list_symbol, args, a_random_state_object_string, 1)); - return(list_2(sc, make_integer(sc, random_seed(r)), make_integer_unchecked(sc, random_carry(r)))); -#endif -} - -#define g_random_state_to_list s7_random_state_to_list - -void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry) -{ -#if (!WITH_GMP) - s7_pointer p; - new_cell(sc, p, T_RANDOM_STATE); - random_seed(p) = (uint64_t)seed; - random_carry(p) = (uint64_t)carry; - sc->default_random_state = p; -#endif -} - - -/* -------------------------------- random -------------------------------- */ -#if WITH_GMP -static double next_random(s7_scheme *sc) -#else -static double next_random(s7_pointer r) -#endif -{ -#if (!WITH_GMP) - /* The multiply-with-carry generator for 32-bit integers: - * x(n)=a*x(n-1) + carry mod 2^32 - * Choose multiplier a from this list: - * 1791398085 1929682203 1683268614 1965537969 1675393560 1967773755 1517746329 1447497129 1655692410 1606218150 - * 2051013963 1075433238 1557985959 1781943330 1893513180 1631296680 2131995753 2083801278 1873196400 1554115554 - * ( or any 'a' for which both a*2^32-1 and a*2^31-1 are prime) - */ - #define RAN_MULT 2131995753UL - - double result; - uint64_t temp = random_seed(r) * RAN_MULT + random_carry(r); - random_seed(r) = (temp & 0xffffffffUL); - random_carry(r) = (temp >> 32); - result = (double)((uint32_t)(random_seed(r))) / 4294967295.5; - /* divisor was 2^32-1 = 4294967295.0, but somehow this can round up once in a billion tries? - * do we want the double just less than 2^32? - * can the multiply-add+logand above return 0? I'm getting 0's from (random (expt 2 62)) - */ - - /* (let ((mx 0) (mn 1000)) (do ((i 0 (+ i 1))) ((= i 10000)) (let ((val (random 123))) (set! mx (max mx val)) (set! mn (min mn val)))) (list mn mx)) */ - return(result); -#else - mpfr_urandomb(sc->mpfr_1, random_gmp_state(sc->default_random_state)); - return(mpfr_get_d(sc->mpfr_1, MPFR_RNDN)); -#endif -} - -static s7_pointer g_random(s7_scheme *sc, s7_pointer args) -{ - #define H_random "(random num (state #f)) returns a random number of the same type as num between zero and num, equalling num only if num is zero" - #define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol) - s7_pointer r, num; - - /* if we disallow (random 0) the programmer has to protect every call on random with (if (eqv? x 0) 0 (random x)). If - * we claim we're using a half-open interval, then we should also disallow (random 0.0); otherwise the following - * must be true: (let* ((x 0.0) (y (random x))) (and (>= y 0.0) (< y x))). The definition above is consistent - * with (random 0) -> 0, simpler to use in practice, and certainly no worse than (/ 0 0) -> 1. - */ - if (is_null(cdr(args))) - r = sc->default_random_state; - else - { - r = cadr(args); - if (!is_random_state(r)) - return(method_or_bust(sc, r, sc->random_symbol, args, a_random_state_object_string, 2)); - } - num = car(args); - switch (type(num)) - { -#if (!WITH_GMP) - case T_INTEGER: - return(make_integer(sc, (s7_int)(integer(num) * next_random(r)))); - case T_RATIO: - { - s7_double x = fraction(num), error; - s7_int numer = 0, denom = 1; - /* the error here needs to take the size of the fraction into account. Otherwise, if - * error is (say) 1e-6 and the fraction is (say) 9000000/9223372036854775807, - * c_rationalize will always return 0. But even that isn't foolproof: - * (random 1/562949953421312) -> 1/376367230475000 - */ - if ((x < 1.0e-10) && (x > -1.0e-10)) - { - /* 1e-12 is not tight enough: - * (random 1/2251799813685248) -> 1/2250240579436280 - * (random -1/4503599627370496) -> -1/4492889778435526 - * (random 1/140737488355328) -> 1/140730223985746 - * (random -1/35184372088832) -> -1/35183145492420 - * (random -1/70368744177664) -> -1/70366866392738 - * (random 1/4398046511104) -> 1/4398033095756 - * (random 1/137438953472) -> 1/137438941127 - */ - if (numerator(num) < -10) - numer = -(s7_int)(floor(-numerator(num) * next_random(r))); - else - if (numerator(num) > 10) - numer = (s7_int)floor(numerator(num) * next_random(r)); - else - { - int64_t diff = S7_INT64_MAX - denominator(num); - numer = numerator(num); - if (diff < 100) - return(make_ratio(sc, numer, denominator(num))); - denom = denominator(num) + (s7_int)floor(diff * next_random(r)); - return(make_ratio_with_div_check(sc, sc->random_symbol, numer, denom)); - } - return(make_ratio(sc, numer, denominator(num))); - } - error = ((x < 1e-6) && (x > -1e-6)) ? 1e-18 : 1e-12; - c_rationalize(x * next_random(r), error, &numer, &denom); - return(make_ratio(sc, numer, denom)); - } - case T_REAL: - return(make_real(sc, real(num) * next_random(r))); - case T_COMPLEX: - return(s7_make_complex(sc, real_part(num) * next_random(r), imag_part(num) * next_random(r))); -#else - case T_INTEGER: - if (integer(num) == 0) return(int_zero); - mpz_set_si(sc->mpz_1, integer(num)); - mpz_urandomm(sc->mpz_1, random_gmp_state(r), sc->mpz_1); - if (integer(num) < 0) mpz_neg(sc->mpz_1, sc->mpz_1); - return(make_integer(sc, mpz_get_si(sc->mpz_1))); - case T_BIG_INTEGER: - if (mpz_cmp_si(big_integer(num), 0) == 0) return(int_zero); - mpz_urandomm(sc->mpz_1, random_gmp_state(r), big_integer(num)); - /* this does not work if num is a negative number -- you get positive results. so check num for sign, and negate result if necessary */ - if (mpz_cmp_ui(big_integer(num), 0) < 0) - mpz_neg(sc->mpz_1, sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); - mpq_set_si(sc->mpq_1, numerator(num), denominator(num)); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, MPFR_RNDN); - return(big_rationalize(sc, set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), mpfr_to_big_real(sc, sc->mpfr_2)))); - case T_BIG_RATIO: - mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(num), MPFR_RNDN); - mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, MPFR_RNDN); - return(big_rationalize(sc, set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), mpfr_to_big_real(sc, sc->mpfr_2)))); - case T_REAL: - mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); - mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(num), MPFR_RNDN); - return(make_real(sc, mpfr_get_d(sc->mpfr_1, MPFR_RNDN))); - case T_BIG_REAL: - mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); - mpfr_mul(sc->mpfr_1, sc->mpfr_1, big_real(num), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_urandom(sc->mpc_1, random_gmp_state(r)); - mpfr_mul_d(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), real_part(num), MPFR_RNDN); - mpfr_mul_d(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), imag_part(num), MPFR_RNDN); - return(s7_make_complex(sc, mpfr_get_d(mpc_realref(sc->mpc_1), MPFR_RNDN), mpfr_get_d(mpc_imagref(sc->mpc_1), MPFR_RNDN))); - case T_BIG_COMPLEX: - mpc_urandom(sc->mpc_1, random_gmp_state(r)); - mpfr_mul(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), mpc_realref(big_complex(num)), MPFR_RNDN); - mpfr_mul(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), mpc_imagref(big_complex(num)), MPFR_RNDN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust(sc, num, sc->random_symbol, args, a_number_string, 1)); - } - return(sc->F); -} - -s7_double s7_random(s7_scheme *sc, s7_pointer state) -{ -#if WITH_GMP - mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN); - mpfr_urandomb(sc->mpfr_1, random_gmp_state((state) ? state : sc->default_random_state)); - return((s7_double)mpfr_get_d(sc->mpfr_1, MPFR_RNDN)); -#else - return(next_random((state) ? state : sc->default_random_state)); -#endif -} - -static s7_double random_d_7d(s7_scheme *sc, s7_double x) -{ -#if WITH_GMP - return(real(g_random(sc, set_plist_1(sc, wrap_real(sc, x))))); -#else - return(x * next_random(sc->default_random_state)); -#endif -} - -static s7_int random_i_7i(s7_scheme *sc, s7_int i) -{ -#if WITH_GMP - return(integer(g_random(sc, set_plist_1(sc, wrap_integer(sc, i))))); -#else - return((s7_int)(i * next_random(sc->default_random_state))); -#endif -} - -static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - return(g_random(sc, args)); -#else - return(make_integer(sc, (s7_int)(integer(car(args)) * next_random(sc->default_random_state)))); -#endif -} - -static s7_pointer g_random_f(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - return(g_random(sc, args)); -#else - return(make_real(sc, real(car(args)) * next_random(sc->default_random_state))); -#endif -} - -static s7_pointer g_random_1(s7_scheme *sc, s7_pointer args) -{ -#if (!WITH_GMP) - s7_pointer num = car(args), r = sc->default_random_state; - if (is_t_integer(num)) - return(make_integer(sc, (s7_int)(integer(num) * next_random(r)))); - if (is_t_real(num)) - return(make_real(sc, real(num) * next_random(r))); -#endif - return(g_random(sc, args)); -} - -static s7_pointer random_p_p(s7_scheme *sc, s7_pointer num) -{ -#if (!WITH_GMP) - if (is_t_integer(num)) - return(make_integer(sc, (s7_int)(integer(num) * next_random(sc->default_random_state)))); - if (is_t_real(num)) - return(make_real(sc, real(num) * next_random(sc->default_random_state))); -#endif - return(g_random(sc, set_plist_1(sc, num))); -} - -static s7_pointer random_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if ((ops) && (args == 1)) - { - s7_pointer arg1 = cadr(expr); - if (is_t_integer(arg1)) - return(sc->random_i); - return((is_t_real(arg1)) ? sc->random_f : sc->random_1); - } - return(f); -} - -static s7_pointer g_add_i_random(s7_scheme *sc, s7_pointer args) -{ -#if WITH_GMP - return(add_p_pp(sc, car(args), random_p_p(sc, cadadr(args)))); -#else - s7_int x = integer(car(args)), y = opt3_int(args); /* cadadr */ - return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */ -#endif -} - - -/* -------------------------------- char<->integer -------------------------------- */ -static s7_pointer g_char_to_integer(s7_scheme *sc, s7_pointer args) -{ - #define H_char_to_integer "(char->integer c) converts the character c to an integer" - #define Q_char_to_integer s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol) - - if (!is_character(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->char_to_integer_symbol, args, sc->type_names[T_CHARACTER])); - return(small_int(character(car(args)))); -} - -static s7_int char_to_integer_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_character(p)) - return(integer(method_or_bust_p(sc, p, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER]))); - return(character(p)); -} - -static s7_pointer char_to_integer_p_p(s7_scheme *sc, s7_pointer p) -{ - if (!is_character(p)) - return(method_or_bust_p(sc, p, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER])); - return(make_integer(sc, character(p))); -} - -static s7_pointer integer_to_char_p_p(s7_scheme *sc, s7_pointer x) -{ - s7_int ind; - if (!s7_is_integer(x)) - return(method_or_bust_p(sc, x, sc->integer_to_char_symbol, sc->type_names[T_INTEGER])); - ind = s7_integer_clamped_if_gmp(sc, x); - if ((ind < 0) || (ind >= NUM_CHARS)) - sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, x, wrap_string(sc, "it doen't fit in an unsigned byte", 33)); - return(chars[(uint8_t)ind]); -} - -static s7_pointer g_integer_to_char(s7_scheme *sc, s7_pointer args) -{ - #define H_integer_to_char "(integer->char i) converts the non-negative integer i to a character" - #define Q_integer_to_char s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol) - return(integer_to_char_p_p(sc, car(args))); -} - -static s7_pointer integer_to_char_p_i(s7_scheme *sc, s7_int ind) -{ - if ((ind < 0) || (ind >= NUM_CHARS)) - sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, wrap_integer(sc, ind), - wrap_string(sc, "it doen't fit in an unsigned byte", 33)); /* int2 s7_out... uses 1 */ - return(chars[(uint8_t)ind]); -} - - -static uint8_t uppers[256], lowers[256]; -static void init_uppers(void) -{ - for (int32_t i = 0; i < 256; i++) - { - uppers[i] = (uint8_t)toupper(i); - lowers[i] = (uint8_t)tolower(i); - } -} - -static void init_chars(void) -{ - s7_cell *cells = (s7_cell *)Calloc(NUM_CHARS + 1, sizeof(s7_cell)); - - chars = (s7_pointer *)Malloc((NUM_CHARS + 1) * sizeof(s7_pointer)); /* chars is declared far above */ - chars[0] = &cells[0]; - eof_object = chars[0]; - set_full_type(eof_object, T_EOF | T_IMMUTABLE | T_UNHEAP); - eof_name_length(eof_object) = 6; - eof_name(eof_object) = "#"; - chars++; /* now chars[EOF] == chars[-1] == # */ - cells++; - - for (int32_t i = 0; i < NUM_CHARS; i++) - { - s7_pointer cp = &cells[i]; - uint8_t c = (uint8_t)i; - - set_type_bit(cp, T_IMMUTABLE | T_CHARACTER | T_UNHEAP); - set_optimize_op(cp, OP_CONSTANT); - character(cp) = c; - upper_character(cp) = (uint8_t)toupper(i); - is_char_alphabetic(cp) = (bool)isalpha(i); - is_char_numeric(cp) = (bool)isdigit(i); - is_char_whitespace(cp) = white_space[i]; - is_char_uppercase(cp) = (((bool)isupper(i)) || ((i >= 192) && (i < 208))); - is_char_lowercase(cp) = (bool)islower(i); - chars[i] = cp; - - #define make_character_name(S) memcpy((void *)(&(character_name(cp))), (const void *)(S), character_name_length(cp) = strlen(S)) - switch (c) - { - case ' ': make_character_name("#\\space"); break; - case '\n': make_character_name("#\\newline"); break; - case '\r': make_character_name("#\\return"); break; - case '\t': make_character_name("#\\tab"); break; - case '\0': make_character_name("#\\null"); break; - case (char)0x1b: make_character_name("#\\escape"); break; - case (char)0x7f: make_character_name("#\\delete"); break; - case (char)7: make_character_name("#\\alarm"); break; - case (char)8: make_character_name("#\\backspace"); break; - default: - #define P_SIZE 12 - character_name_length(cp) = snprintf((char *)(&(character_name(cp))), P_SIZE, ((c < 32) || (c >= 127)) ? "#\\x%x" : "#\\%c", c); - break; - }} -} - - -/* -------------------------------- char-upcase, char-downcase ----------------------- */ -static s7_pointer char_upcase_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(method_or_bust_p(sc, c, sc->char_upcase_symbol, sc->type_names[T_CHARACTER])); - return(chars[upper_character(c)]); -} - -static s7_pointer char_upcase_p_p_unchecked(s7_scheme *unused_sc, s7_pointer c) {return(chars[upper_character(c)]);} - -static s7_pointer g_char_upcase(s7_scheme *sc, s7_pointer args) -{ - #define H_char_upcase "(char-upcase c) converts the character c to upper case" - #define Q_char_upcase sc->pcl_c - return(char_upcase_p_p(sc, car(args))); -} - -static s7_pointer g_char_downcase(s7_scheme *sc, s7_pointer args) -{ - #define H_char_downcase "(char-downcase c) converts the character c to lower case" - #define Q_char_downcase sc->pcl_c - if (!is_character(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->char_downcase_symbol, args, sc->type_names[T_CHARACTER])); - return(chars[lowers[character(car(args))]]); -} - - -/* -------------------------------- char-alphabetic? char-numeric? char-whitespace? -------------------------------- */ -static s7_pointer g_is_char_alphabetic(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_alphabetic "(char-alphabetic? c) returns #t if the character c is alphabetic" - #define Q_is_char_alphabetic sc->pl_bc - if (!is_character(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->is_char_alphabetic_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_alphabetic(car(args)))); - /* isalpha returns #t for (integer->char 226) and others in that range */ -} - -static bool is_char_alphabetic_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - sole_arg_wrong_type_error_nr(sc, sc->is_char_alphabetic_symbol, c, sc->type_names[T_CHARACTER]); - /* return(sole_arg_method_or_bust(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); */ /* slower? see tmisc */ - return(is_char_alphabetic(c)); -} - -static s7_pointer is_char_alphabetic_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_alphabetic(c))); -} - -static s7_pointer g_is_char_numeric(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_numeric "(char-numeric? c) returns #t if the character c is a digit" - #define Q_is_char_numeric sc->pl_bc - - s7_pointer arg = car(args); - if (!is_character(arg)) - return(sole_arg_method_or_bust(sc, arg, sc->is_char_numeric_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_numeric(arg))); -} - -static bool is_char_numeric_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - sole_arg_wrong_type_error_nr(sc, sc->is_char_numeric_symbol, c, sc->type_names[T_CHARACTER]); - /* return(sole_arg_method_or_bust(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); */ /* as above */ - return(is_char_numeric(c)); -} - -static s7_pointer is_char_numeric_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_numeric(c))); -} - - -static s7_pointer g_is_char_whitespace(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_whitespace "(char-whitespace? c) returns #t if the character c is non-printing character" - #define Q_is_char_whitespace sc->pl_bc - - s7_pointer arg = car(args); - if (!is_character(arg)) - return(sole_arg_method_or_bust(sc, arg, sc->is_char_whitespace_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_whitespace(arg))); -} - -static bool is_char_whitespace_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - sole_arg_wrong_type_error_nr(sc, sc->is_char_whitespace_symbol, c, sc->type_names[T_CHARACTER]); - return(is_char_whitespace(c)); -} - -static s7_pointer is_char_whitespace_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_whitespace_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_whitespace(c))); -} - -static s7_pointer is_char_whitespace_p_p_unchecked(s7_scheme *sc, s7_pointer c) {return(make_boolean(sc, is_char_whitespace(c)));} - - -/* -------------------------------- char-upper-case? char-lower-case? -------------------------------- */ -static s7_pointer g_is_char_upper_case(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_upper_case "(char-upper-case? c) returns #t if the character c is in upper case" - #define Q_is_char_upper_case sc->pl_bc - - s7_pointer arg = car(args); - if (!is_character(arg)) - return(sole_arg_method_or_bust(sc, arg, sc->is_char_upper_case_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_uppercase(arg))); -} - -static bool is_char_upper_case_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_upper_case_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); - return(is_char_uppercase(c)); -} - -static s7_pointer g_is_char_lower_case(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_lower_case "(char-lower-case? c) returns #t if the character c is in lower case" - #define Q_is_char_lower_case sc->pl_bc - - s7_pointer arg = car(args); - if (!is_character(arg)) - return(sole_arg_method_or_bust(sc, arg, sc->is_char_lower_case_symbol, args, sc->type_names[T_CHARACTER])); - return(make_boolean(sc, is_char_lowercase(arg))); -} - -static bool is_char_lower_case_b_7p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(sole_arg_method_or_bust(sc, c, sc->is_char_lower_case_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); - return(is_char_lowercase(c)); -} - - -/* -------------------------------- char? -------------------------------- */ -static s7_pointer g_is_char(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char "(char? obj) returns #t if obj is a character" - #define Q_is_char sc->pl_bt - check_boolean_method(sc, is_character, sc->is_char_symbol, args); -} - -static s7_pointer is_char_p_p(s7_scheme *sc, s7_pointer p) {return((is_character(p)) ? sc->T : sc->F);} - -s7_pointer s7_make_character(s7_scheme *sc, uint8_t c) {return(chars[c]);} - -bool s7_is_character(s7_pointer p) {return(is_character(p));} - -uint8_t s7_character(s7_pointer p) {return(character(p));} - - -/* -------------------------------- char? char>=? char=? -------------------------------- */ -static int32_t charcmp(uint8_t c1, uint8_t c2) -{ - return((c1 == c2) ? 0 : (c1 < c2) ? -1 : 1); - /* not tolower here -- the single case is apparently supposed to be upper case - * this matters in a case like (char-ciis_char_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - } - return(false); -} - -static s7_pointer char_with_error_check(s7_scheme *sc, s7_pointer x, s7_pointer args, s7_pointer caller) -{ - for (s7_pointer y = cdr(x); is_pair(y); y = cdr(y)) /* before returning #f, check for bad trailing arguments */ - if (!is_character_via_method(sc, car(y))) - wrong_type_error_nr(sc, caller, position_of(y, args), car(y), sc->type_names[T_CHARACTER]); - return(sc->F); -} - -static s7_pointer g_char_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1)); - for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (charcmp(character(y), character(car(x))) != val) - return(char_with_error_check(sc, x, args, sym)); - } - return(sc->T); -} - -static s7_pointer g_char_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1)); - for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (charcmp(character(y), character(car(x))) == val) - return(char_with_error_check(sc, x, args, sym)); - } - return(sc->T); -} - -static s7_pointer g_chars_are_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_equal "(char=? char ...) returns #t if all the character arguments are equal" - #define Q_chars_are_equal sc->pcl_bc - - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1)); - for (s7_pointer x = cdr(args); is_pair(x); x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sc->char_eq_symbol, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (car(x) != y) - return(char_with_error_check(sc, x, args, sc->char_eq_symbol)); - } - return(sc->T); -} - - -static s7_pointer g_chars_are_less(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_less "(charpcl_bc - return(g_char_cmp(sc, args, -1, sc->char_lt_symbol)); -} - -static s7_pointer g_chars_are_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_greater "(char>? char ...) returns #t if all the character arguments are decreasing" - #define Q_chars_are_greater sc->pcl_bc - return(g_char_cmp(sc, args, 1, sc->char_gt_symbol)); -} - -static s7_pointer g_chars_are_geq(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_geq "(char>=? char ...) returns #t if all the character arguments are equal or decreasing" - #define Q_chars_are_geq sc->pcl_bc - return(g_char_cmp_not(sc, args, -1, sc->char_geq_symbol)); -} - -static s7_pointer g_chars_are_leq(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_leq "(char<=? char ...) returns #t if all the character arguments are equal or increasing" - #define Q_chars_are_leq sc->pcl_bc - return(g_char_cmp_not(sc, args, 1, sc->char_leq_symbol)); -} - -static s7_pointer g_simple_char_eq(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, car(args) == cadr(args)));} /* chooser checks types */ - -#define check_char2_args(Sc, Caller, P1, P2) \ - do { \ - if (!is_character(P1)) return(method_or_bust(Sc, P1, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_CHARACTER], 1) != sc->F); \ - if (!is_character(P2)) return(method_or_bust(Sc, P2, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_CHARACTER], 2) != sc->F); \ - } while (0) - -static bool char_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 < p2);} -static bool char_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_lt_symbol, p1, p2); - return(p1 < p2); -} - -static bool char_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 <= p2);} -static bool char_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_leq_symbol, p1, p2); - return(p1 <= p2); -} - -static bool char_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 > p2);} -static bool char_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_gt_symbol, p1, p2); - return(p1 > p2); -} - -static bool char_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 >= p2);} -static bool char_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_geq_symbol, p1, p2); - return(p1 >= p2); -} - -static bool char_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 == p2);} - -static bool char_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_character(p1)) return(method_or_bust(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 1) != sc->F); - if (p1 == p2) return(true); - if (!is_character(p2)) return(method_or_bust(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 2) != sc->F); - return(false); -} - -static s7_pointer char_eq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_character(p1)) return(method_or_bust(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 1)); - if (p1 == p2) return(sc->T); - if (!is_character(p2)) return(method_or_bust(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 2)); - return(sc->F); -} - -static s7_pointer g_char_equal_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1)); - if (car(args) == cadr(args)) - return(sc->T); - if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 2)); - return(sc->F); -} - -static s7_pointer g_char_less_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_lt_symbol, args, sc->type_names[T_CHARACTER], 1)); - if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_lt_symbol, args, sc->type_names[T_CHARACTER], 2)); - return(make_boolean(sc, character(car(args)) < character(cadr(args)))); -} - -static s7_pointer g_char_greater_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_gt_symbol, args, sc->type_names[T_CHARACTER], 1)); - if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_gt_symbol, args, sc->type_names[T_CHARACTER], 2)); - return(make_boolean(sc, character(car(args)) > character(cadr(args)))); -} - -static bool returns_char(s7_scheme *sc, s7_pointer arg) {return(argument_type(sc, arg) == sc->is_char_symbol);} - -static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args != 2) return(f); - if (ops) - { - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if ((returns_char(sc, arg1)) && (returns_char(sc, arg2))) - return(sc->simple_char_eq); - } - return(sc->char_equal_2); -} - -static s7_pointer char_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->char_less_2 : f); -} - -static s7_pointer char_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->char_greater_2 : f); -} - - -/* -------------------------------- char-ci? char-ci>=? char-ci=? -------------------------------- */ -#if (!WITH_PURE_S7) -static s7_pointer g_char_cmp_ci(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1)); - - for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (charcmp(upper_character(y), upper_character(car(x))) != val) - return(char_with_error_check(sc, x, args, sym)); - } - return(sc->T); -} - -static s7_pointer g_char_cmp_ci_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_character(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1)); - for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) - { - if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); - if (charcmp(upper_character(y), upper_character(car(x))) == val) - return(char_with_error_check(sc, x, args, sym)); - } - return(sc->T); -} - -static s7_pointer g_chars_are_ci_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_equal "(char-ci=? char ...) returns #t if all the character arguments are equal, ignoring case" - #define Q_chars_are_ci_equal sc->pcl_bc - return(g_char_cmp_ci(sc, args, 0, sc->char_ci_eq_symbol)); -} - -static s7_pointer g_chars_are_ci_less(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_less "(char-cipcl_bc - return(g_char_cmp_ci(sc, args, -1, sc->char_ci_lt_symbol)); -} - -static s7_pointer g_chars_are_ci_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_greater "(char-ci>? char ...) returns #t if all the character arguments are decreasing, ignoring case" - #define Q_chars_are_ci_greater sc->pcl_bc - return(g_char_cmp_ci(sc, args, 1, sc->char_ci_gt_symbol)); -} - -static s7_pointer g_chars_are_ci_geq(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_geq "(char-ci>=? char ...) returns #t if all the character arguments are equal or decreasing, ignoring case" - #define Q_chars_are_ci_geq sc->pcl_bc - return(g_char_cmp_ci_not(sc, args, -1, sc->char_ci_geq_symbol)); -} - -static s7_pointer g_chars_are_ci_leq(s7_scheme *sc, s7_pointer args) -{ - #define H_chars_are_ci_leq "(char-ci<=? char ...) returns #t if all the character arguments are equal or increasing, ignoring case" - #define Q_chars_are_ci_leq sc->pcl_bc - return(g_char_cmp_ci_not(sc, args, 1, sc->char_ci_leq_symbol)); -} - - -static bool char_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) < upper_character(p2));} -static bool char_ci_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_lt_symbol, p1, p2); - return(upper_character(p1) < upper_character(p2)); -} - -static bool char_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) <= upper_character(p2));} -static bool char_ci_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_leq_symbol, p1, p2); - return(upper_character(p1) <= upper_character(p2)); -} - -static bool char_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) > upper_character(p2));} -static bool char_ci_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_gt_symbol, p1, p2); - return(upper_character(p1) > upper_character(p2)); -} - -static bool char_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) >= upper_character(p2));} -static bool char_ci_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_geq_symbol, p1, p2); - return(upper_character(p1) >= upper_character(p2)); -} - -static bool char_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) == upper_character(p2));} -static bool char_ci_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_char2_args(sc, sc->char_ci_eq_symbol, p1, p2); - return(upper_character(p1) == upper_character(p2)); -} - -#endif /* not pure s7 */ - - -/* -------------------------------- char-position -------------------------------- */ -static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args) -{ - #define H_char_position "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f" - #define Q_char_position s7_make_signature(sc, 4, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_string_symbol), \ - sc->is_string_symbol, sc->is_integer_symbol) - const char *porig, *pset; - s7_int start, pos, len; /* not "int" because start arg might be most-negative-fixnum */ - s7_pointer arg1 = car(args), arg2; - - if ((!is_character(arg1)) && - (!is_string(arg1))) - return(method_or_bust(sc, arg1, sc->char_position_symbol, args, sc->type_names[T_CHARACTER], 1)); - - arg2 = cadr(args); - if (!is_string(arg2)) - return(method_or_bust(sc, arg2, sc->char_position_symbol, args, sc->type_names[T_STRING], 2)); - - if (is_pair(cddr(args))) - { - s7_pointer arg3 = caddr(args); - if (!s7_is_integer(arg3)) - return(method_or_bust(sc, arg3, sc->char_position_symbol, args, sc->type_names[T_INTEGER], 3)); - start = s7_integer_clamped_if_gmp(sc, arg3); - if (start < 0) - wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string); - } - else start = 0; - - porig = string_value(arg2); - len = string_length(arg2); - if (start >= len) return(sc->F); - - if (is_character(arg1)) - { - char c = character(arg1); - const char *p = strchr((const char *)(porig + start), (int)c); /* use strchrnul in Gnu C to catch embedded null case */ - return((p) ? make_integer(sc, p - porig) : sc->F); - } - if (string_length(arg1) == 0) - return(sc->F); - pset = string_value(arg1); - - pos = strcspn((const char *)(porig + start), (const char *)pset); - if ((pos + start) < len) - return(make_integer(sc, pos + start)); - - /* if the string has an embedded null, we can get erroneous results here -- - * perhaps check for null at pos+start? What about a searched-for string that also has embedded nulls? - */ - return(sc->F); -} - -static s7_pointer char_position_p_ppi(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int start) -{ - /* p1 is char, p2 is string */ - const char *porig, *p; - s7_int len; - char c; - - if (!is_string(p2)) - wrong_type_error_nr(sc, sc->char_position_symbol, 2, p2, sc->type_names[T_STRING]); - if (start < 0) - wrong_type_error_nr(sc, sc->char_position_symbol, 3, wrap_integer(sc, start), a_non_negative_integer_string); - - c = character(p1); - len = string_length(p2); - porig = string_value(p2); - if (start >= len) return(sc->F); - p = strchr((const char *)(porig + start), (int)c); - if (p) return(make_integer(sc, p - porig)); - return(sc->F); -} - -static s7_pointer g_char_position_csi(s7_scheme *sc, s7_pointer args) -{ - /* assume char arg1, no end */ - const char *porig, *p; - char c = character(car(args)); - s7_pointer arg2 = cadr(args); - s7_int start, len; - - if (!is_string(arg2)) - return(g_char_position(sc, args)); - - len = string_length(arg2); /* can't return #f here if len==0 -- need start error check first */ - porig = string_value(arg2); - - if (is_pair(cddr(args))) - { - s7_pointer arg3 = caddr(args); - if (!s7_is_integer(arg3)) - return(g_char_position(sc, args)); - start = s7_integer_clamped_if_gmp(sc, arg3); - if (start < 0) - wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string); - if (start >= len) return(sc->F); - } - else start = 0; - - if (len == 0) return(sc->F); - p = strchr((const char *)(porig + start), (int)c); - return((p) ? make_integer(sc, p - porig) : sc->F); -} - -static s7_pointer char_position_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((is_character(cadr(expr))) && ((args == 2) || (args == 3))) - return(sc->char_position_csi); - return(f); -} - - -/* -------------------------------- string-position -------------------------------- */ -static s7_pointer g_string_position(s7_scheme *sc, s7_pointer args) -{ - #define H_string_position "(string-position str1 str2 (start 0)) returns the starting position of str1 in str2 or #f" - #define Q_string_position s7_make_signature(sc, 4, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), \ - sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol) - const char *s1, *s2, *p2; - s7_int start = 0; - s7_pointer s1p = car(args), s2p = cadr(args); - - if (!is_string(s1p)) - return(method_or_bust(sc, s1p, sc->string_position_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_string(s2p)) - return(method_or_bust(sc, s2p, sc->string_position_symbol, args, sc->type_names[T_STRING], 2)); - - if (is_pair(cddr(args))) - { - s7_pointer arg3 = caddr(args); - if (!s7_is_integer(arg3)) - return(method_or_bust(sc, arg3, sc->string_position_symbol, args, sc->type_names[T_INTEGER], 3)); - start = s7_integer_clamped_if_gmp(sc, arg3); - if (start < 0) - wrong_type_error_nr(sc, sc->string_position_symbol, 3, caddr(args), a_non_negative_integer_string); - } - - if (string_length(s1p) == 0) - return(sc->F); - s1 = string_value(s1p); - s2 = string_value(s2p); - if (start >= string_length(s2p)) - return(sc->F); - - p2 = strstr((const char *)(s2 + start), s1); - return((p2) ? make_integer(sc, p2 - s2) : sc->F); -} - - -/* -------------------------------- strings -------------------------------- */ -bool s7_is_string(s7_pointer p) {return(is_string(p));} - -static s7_pointer g_is_string(s7_scheme *sc, s7_pointer args) -{ - #define H_is_string "(string? obj) returns #t if obj is a string" - #define Q_is_string sc->pl_bt - check_boolean_method(sc, is_string, sc->is_string_symbol, args); -} - - -static s7_pointer nil_string; /* permanent "" */ - -s7_int s7_string_length(s7_pointer str) {return(string_length(str));} - - -#define NUM_STRING_WRAPPERS 8 - -static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len) -{ - s7_pointer x = car(sc->string_wrappers); - sc->string_wrappers = cdr(sc->string_wrappers); - string_value(x) = (char *)str; - string_length(x) = len; - return(x); -} - -s7_pointer s7_make_string_wrapper(s7_scheme *sc, const char *str) {return(wrap_string(sc, str, safe_strlen(str)));} -s7_pointer s7_make_string_wrapper_with_length(s7_scheme *sc, const char *str, s7_int len) {return(wrap_string(sc, str, len));} - -static Inline s7_pointer inline_make_empty_string(s7_scheme *sc, s7_int len, char fill) -{ - s7_pointer x; - block_t *b; - if (len == 0) return(nil_string); - new_cell(sc, x, T_STRING); - b = inline_mallocate(sc, len + 1); - string_block(x) = b; - string_value(x) = (char *)block_data(b); - if (fill != '\0') - local_memset((void *)(string_value(x)), fill, len); - string_value(x)[len] = 0; - string_hash(x) = 0; - string_length(x) = len; - add_string(sc, x); - return(x); -} - -static s7_pointer make_empty_string(s7_scheme *sc, s7_int len, char fill) {return(inline_make_empty_string(sc, len, fill));} - -s7_pointer s7_make_string(s7_scheme *sc, const char *str) {return((str) ? make_string_with_length(sc, str, safe_strlen(str)) : nil_string);} - -static char *make_semipermanent_c_string(s7_scheme *sc, const char *str) /* strcpy but avoid malloc */ -{ - s7_int len = safe_strlen(str); - char *x = (char *)permalloc(sc, len + 1); - memcpy((void *)x, (void *)str, len); - x[len] = 0; - return(x); -} - -s7_pointer s7_make_semipermanent_string(s7_scheme *sc, const char *str) /* for (s7) string permanent within one s7 instance (freed upon s7_free) */ -{ - s7_pointer x; - s7_int len; - if (!str) return(nil_string); - x = alloc_pointer(sc); - set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP); - set_optimize_op(x, OP_CONSTANT); - len = safe_strlen(str); - string_length(x) = len; - string_block(x) = NULL; - string_value(x) = (char *)permalloc(sc, len + 1); - memcpy((void *)string_value(x), (void *)str, len); - string_value(x)[len] = 0; - string_hash(x) = 0; - return(x); -} - -static s7_pointer make_permanent_string(const char *str) /* for (s7) strings outside all s7 GC's */ -{ - s7_pointer x = (s7_pointer)Calloc(1, sizeof(s7_cell)); - s7_int len = safe_strlen(str); - set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP); - set_optimize_op(x, OP_CONSTANT); - string_length(x) = len; - string_block(x) = NULL; - string_value(x) = (char *)str; - string_hash(x) = 0; - return(x); -} - -s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str) /* keep s7_scheme* arg for backwards compatibility */ -{ - return(make_permanent_string(str)); -} - -static void init_strings(void) -{ - nil_string = make_permanent_string(""); - nil_string->tf.flag = T_STRING | T_UNHEAP; - set_optimize_op(nil_string, OP_CONSTANT); - - car_a_list_string = make_permanent_string("a pair whose car is also a pair"); - cdr_a_list_string = make_permanent_string("a pair whose cdr is also a pair"); - - caar_a_list_string = make_permanent_string("a pair whose caar is also a pair"); - cadr_a_list_string = make_permanent_string("a pair whose cadr is also a pair"); - cdar_a_list_string = make_permanent_string("a pair whose cdar is also a pair"); - cddr_a_list_string = make_permanent_string("a pair whose cddr is also a pair"); - - caaar_a_list_string = make_permanent_string("a pair whose caaar is also a pair"); - caadr_a_list_string = make_permanent_string("a pair whose caadr is also a pair"); - cadar_a_list_string = make_permanent_string("a pair whose cadar is also a pair"); - caddr_a_list_string = make_permanent_string("a pair whose caddr is also a pair"); - cdaar_a_list_string = make_permanent_string("a pair whose cdaar is also a pair"); - cdadr_a_list_string = make_permanent_string("a pair whose cdadr is also a pair"); - cddar_a_list_string = make_permanent_string("a pair whose cddar is also a pair"); - cdddr_a_list_string = make_permanent_string("a pair whose cdddr is also a pair"); - - a_list_string = make_permanent_string("a list"); - an_eq_func_string = make_permanent_string("a procedure that can take two arguments"); - an_association_list_string = make_permanent_string("an association list"); - a_normal_real_string = make_permanent_string("a normal real"); - a_rational_string = make_permanent_string("an integer or a ratio"); - a_number_string = make_permanent_string("a number"); - a_procedure_string = make_permanent_string("a procedure"); - a_procedure_or_a_macro_string = make_permanent_string("a procedure or a macro"); - a_normal_procedure_string = make_permanent_string("a normal procedure"); - a_let_string = make_permanent_string("a let (environment)"); - a_proper_list_string = make_permanent_string("a proper list"); - a_boolean_string = make_permanent_string("a boolean"); - a_byte_vector_string = make_permanent_string("a byte-vector"); - an_input_port_string = make_permanent_string("an input port"); - an_open_input_port_string = make_permanent_string("an open input port"); - an_open_output_port_string = make_permanent_string("an open output port"); - an_output_port_string = make_permanent_string("an output port"); - an_output_port_or_f_string = make_permanent_string("an output port or #f"); - an_input_string_port_string = make_permanent_string("an input string port"); - an_input_file_port_string = make_permanent_string("an input file port"); - an_output_string_port_string = make_permanent_string("an output string port"); - an_output_file_port_string = make_permanent_string("an output file port"); - a_thunk_string = make_permanent_string("a thunk"); - a_symbol_string = make_permanent_string("a symbol"); - a_non_negative_integer_string = make_permanent_string("a non-negative integer"); - an_unsigned_byte_string = make_permanent_string("an unsigned byte"); - something_applicable_string = make_permanent_string("a procedure or something applicable"); - a_random_state_object_string = make_permanent_string("a random-state object"); - a_format_port_string = make_permanent_string("#f, #t, (), or an open output port"); - a_non_constant_symbol_string = make_permanent_string("a non-constant symbol"); - a_sequence_string = make_permanent_string("a sequence"); - a_valid_radix_string = make_permanent_string("it should be between 2 and 16"); - result_is_too_large_string = make_permanent_string("result is too large"); - it_is_too_large_string = make_permanent_string("it is too large"); - it_is_too_small_string = make_permanent_string("it is less than the start position"); - it_is_negative_string = make_permanent_string("it is negative"); - it_is_nan_string = make_permanent_string("NaN usually indicates a numerical error"); - it_is_infinite_string = make_permanent_string("it is infinite"); - too_many_indices_string = make_permanent_string("too many indices"); - parameter_set_twice_string = make_permanent_string("parameter set twice, ~S in ~S"); - immutable_error_string = make_permanent_string("can't ~S ~S (it is immutable)"); - cant_bind_immutable_string = make_permanent_string("~A: can't bind an immutable object: ~S"); - intermediate_too_large_string = make_permanent_string("intermediate result is too large"); -#if (!HAVE_COMPLEX_NUMBERS) - no_complex_numbers_string = make_permanent_string("this version of s7 does not support complex numbers"); -#endif - keyword_value_missing_string = make_permanent_string("~A: keyword argument's value is missing: ~S in ~S"); - - format_string_1 = make_permanent_string("format: ~S ~{~S~^ ~}: ~A"); - format_string_2 = make_permanent_string("format: ~S: ~A"); - format_string_3 = make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A"); - format_string_4 = make_permanent_string("format: ~S~&~NT^: ~A"); - - too_many_arguments_string = make_permanent_string("~S: too many arguments: ~A"); - not_enough_arguments_string = make_permanent_string("~S: not enough arguments: ~A"); -} - - -/* -------------------------------- make-string -------------------------------- */ -s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) {return(make_string_with_length(sc, str, len));} - -static s7_pointer g_make_string(s7_scheme *sc, s7_pointer args) -{ - #define H_make_string "(make-string len (val #\\space)) makes a string of length len filled with the character val (default: space)" - #define Q_make_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol) - - s7_pointer n = car(args); - s7_int len; - char fill; - if (!s7_is_integer(n)) - { - check_method(sc, n, sc->make_string_symbol, args); - wrong_type_error_nr(sc, sc->make_string_symbol, 1, n, sc->type_names[T_INTEGER]); - } - if ((is_pair(cdr(args))) && - (!is_character(cadr(args)))) - return(method_or_bust(sc, cadr(args), sc->make_string_symbol, args, sc->type_names[T_CHARACTER], 2)); - - len = s7_integer_clamped_if_gmp(sc, n); - if (len == 0) return(nil_string); - if ((len < 0) || (len > sc->max_string_length)) - out_of_range_error_nr(sc, sc->make_string_symbol, int_one, n, (len < 0) ? it_is_negative_string : it_is_too_large_string); - if (is_null(cdr(args))) - return(make_empty_string(sc, len, '\0')); /* #\null here means "don't fill/clear" */ - fill = s7_character(cadr(args)); - n = make_empty_string(sc, len, fill); - if (fill == '\0') - memclr((void *)string_value(n), (size_t)len); - return(n); -} - -static s7_pointer make_string_p_i(s7_scheme *sc, s7_int len) -{ - if (len == 0) return(nil_string); - if ((len < 0) || (len > sc->max_string_length)) - out_of_range_error_nr(sc, sc->make_string_symbol, int_one, wrap_integer(sc, len), (len < 0) ? it_is_negative_string : it_is_too_large_string); - return(make_empty_string(sc, len, '\0')); -} - - -#if (!WITH_PURE_S7) -/* -------------------------------- string-length -------------------------------- */ -static s7_pointer g_string_length(s7_scheme *sc, s7_pointer args) -{ - #define H_string_length "(string-length str) returns the length of the string str" - #define Q_string_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol) - s7_pointer p = car(args); - if (!is_string(p)) - return(sole_arg_method_or_bust(sc, p, sc->string_length_symbol, args, sc->type_names[T_STRING])); - return(make_integer(sc, string_length(p))); -} - -static s7_int string_length_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_string(p)) - return(integer(method_or_bust_p(sc, p, sc->string_length_symbol, sc->type_names[T_STRING]))); - return(string_length(p)); -} -#endif - - -/* -------------------------------- string-up|downcase -------------------------------- */ -static s7_pointer g_string_downcase(s7_scheme *sc, s7_pointer args) -{ - #define H_string_downcase "(string-downcase str) returns the lower case version of str." - #define Q_string_downcase sc->pcl_s - - s7_pointer p = car(args), newstr; - s7_int i, len; - uint8_t *nstr; - const uint8_t *ostr; - - if (!is_string(p)) - return(method_or_bust_p(sc, p, sc->string_downcase_symbol, sc->type_names[T_STRING])); - len = string_length(p); - newstr = make_empty_string(sc, len, 0); - - ostr = (const uint8_t *)string_value(p); - nstr = (uint8_t *)string_value(newstr); - if (len >= 128) - { - i = len - 1; - while (i >= 8) - LOOP_8(nstr[i] = lowers[(uint8_t)ostr[i]]; i--); - while (i >= 0) {nstr[i] = lowers[(uint8_t)ostr[i]]; i--;} - } - else - for (i = 0; i < len; i++) nstr[i] = lowers[(uint8_t)ostr[i]]; - return(newstr); -} - -static s7_pointer g_string_upcase(s7_scheme *sc, s7_pointer args) -{ - #define H_string_upcase "(string-upcase str) returns the upper case version of str." - #define Q_string_upcase sc->pcl_s - - s7_pointer p = car(args), newstr; - s7_int i, len; - uint8_t *nstr; - const uint8_t *ostr; - - if (!is_string(p)) - return(method_or_bust_p(sc, p, sc->string_upcase_symbol, sc->type_names[T_STRING])); - len = string_length(p); - newstr = make_empty_string(sc, len, 0); - - ostr = (const uint8_t *)string_value(p); - nstr = (uint8_t *)string_value(newstr); - if (len >= 128) - { - i = len - 1; - while (i >= 8) - LOOP_8(nstr[i] = uppers[(uint8_t)ostr[i]]; i--); - while (i >= 0) {nstr[i] = uppers[(uint8_t)ostr[i]]; i--;} - } - else - for (i = 0; i < len; i++) nstr[i] = uppers[(uint8_t)ostr[i]]; - return(newstr); -} - - -/* -------------------------------- string-ref -------------------------------- */ -static s7_pointer string_ref_1(s7_scheme *sc, s7_pointer strng, s7_pointer index) -{ - char *str; - s7_int ind; - - if (!s7_is_integer(index)) - return(method_or_bust_pp(sc, index, sc->string_ref_symbol, strng, index, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if (ind < 0) - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, index, it_is_negative_string); - if (ind >= string_length(strng)) - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, index, it_is_too_large_string); - - str = string_value(strng); - return(chars[((uint8_t *)str)[ind]]); -} - -static s7_pointer g_string_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_string_ref "(string-ref str index) returns the character at the index-th element of the string str" - #define Q_string_ref s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol) - - s7_pointer strng = car(args); - if (!is_string(strng)) - return(method_or_bust(sc, strng, sc->string_ref_symbol, args, sc->type_names[T_STRING], 1)); - return(string_ref_1(sc, strng, cadr(args))); -} - -static s7_pointer string_ref_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - if (!is_string(p1)) - return(method_or_bust(sc, p1, sc->string_ref_symbol, set_plist_2(sc, p1, make_integer(sc, i1)), sc->type_names[T_STRING], 1)); - if ((i1 >= 0) && (i1 < string_length(p1))) - return(chars[((uint8_t *)string_value(p1))[i1]]); - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return(p1); -} - -static s7_pointer string_ref_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer i1) -{ - if (!is_string(p1)) - return(method_or_bust_pp(sc, p1, sc->string_ref_symbol, p1, i1, sc->type_names[T_STRING], 1)); - return(string_ref_1(sc, p1, i1)); -} - -static s7_pointer string_ref_p_p0(s7_scheme *sc, s7_pointer p1, s7_pointer unused_i1) -{ - if (!is_string(p1)) - return(method_or_bust_pp(sc, p1, sc->string_ref_symbol, p1, int_zero, sc->type_names[T_STRING], 1)); - if (string_length(p1) > 0) - return(chars[((uint8_t *)string_value(p1))[0]]); - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, int_zero, it_is_too_large_string); - return(p1); -} - -static s7_pointer string_plast_via_method(s7_scheme *sc, s7_pointer p1) -{ - s7_pointer len = method_or_bust_p(sc, p1, sc->length_symbol, sc->type_names[T_STRING]); - return(method_or_bust_with_type_pi(sc, p1, sc->string_ref_symbol, p1, integer(len) - 1, sc->type_names[T_STRING], 1)); -} - -static s7_pointer string_ref_p_plast(s7_scheme *sc, s7_pointer p1, s7_pointer unused_i1) -{ - if (!is_string(p1)) - return(string_plast_via_method(sc, p1)); - if (string_length(p1) > 0) - return(chars[((uint8_t *)string_value(p1))[string_length(p1) - 1]]); - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, string_length(p1) - 1), it_is_too_large_string); - return(p1); -} - -static inline s7_pointer string_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - if ((i1 >= 0) && (i1 < string_length(p1))) - return(chars[((uint8_t *)string_value(p1))[i1]]); - out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return(p1); -} - -static s7_pointer string_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1) {return(chars[((uint8_t *)string_value(p1))[i1]]);} - - -/* -------------------------------- string-set! -------------------------------- */ -static s7_pointer g_string_set(s7_scheme *sc, s7_pointer args) -{ - #define H_string_set "(string-set! str index chr) sets the index-th element of the string str to the character chr" - #define Q_string_set s7_make_signature(sc, 4, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol) - - s7_pointer strng = car(args), c, index = cadr(args); - char *str; - s7_int ind; - - if (!is_mutable_string(strng)) - return(mutable_method_or_bust(sc, strng, sc->string_set_symbol, args, sc->type_names[T_STRING], 1)); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->string_set_symbol, args, sc->type_names[T_INTEGER], 2)); - - ind = s7_integer_clamped_if_gmp(sc, index); - if (ind < 0) - out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, a_non_negative_integer_string); - if (ind >= string_length(strng)) - out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, it_is_too_large_string); - - str = string_value(strng); - c = caddr(args); - if (!is_character(c)) - return(method_or_bust(sc, c, sc->string_set_symbol, args, sc->type_names[T_CHARACTER], 3)); - - str[ind] = (char)s7_character(c); - return(c); -} - -static s7_pointer string_set_p_pip(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - if (!is_string(p1)) - wrong_type_error_nr(sc, sc->string_set_symbol, 1, p1, sc->type_names[T_STRING]); - if (!is_character(p2)) - wrong_type_error_nr(sc, sc->string_set_symbol, 2, p2, sc->type_names[T_CHARACTER]); - if ((i1 >= 0) && (i1 < string_length(p1))) - string_value(p1)[i1] = s7_character(p2); - else out_of_range_error_nr(sc, sc->string_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return(p2); -} - -static s7_pointer string_set_p_pip_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - if ((i1 >= 0) && (i1 < string_length(p1))) - string_value(p1)[i1] = s7_character(p2); - else out_of_range_error_nr(sc, sc->string_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return(p2); -} - -static s7_pointer string_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1, s7_pointer p2) {string_value(p1)[i1] = s7_character(p2); return(p2);} - - -/* -------------------------------- string-append -------------------------------- */ -static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj); - -static bool sequence_is_empty(s7_scheme *sc, s7_pointer obj) /* "is_empty" is some C++ struct?? */ -{ - switch (type(obj)) - { - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: - case T_VECTOR: return(vector_length(obj) == 0); - case T_NIL: return(true); - case T_PAIR: return(false); - case T_STRING: return(string_length(obj) == 0); - case T_HASH_TABLE: return(hash_table_entries(obj) == 0); - case T_C_OBJECT: return(s7_is_eqv(sc, c_object_length(sc, obj), int_zero)); - case T_LET: if (obj != sc->rootlet) return(!tis_slot(let_slots(obj))); /* (append (rootlet) #f) */ - default: return(false); - } -} - -static s7_int sequence_length(s7_scheme *sc, s7_pointer lst) -{ - switch (type(lst)) - { - case T_PAIR: - { - s7_int len = s7_list_length(sc, lst); - return((len == 0) ? -1 : len); - } - case T_NIL: return(0); - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: - case T_VECTOR: return(vector_length(lst)); - case T_STRING: return(string_length(lst)); - case T_HASH_TABLE: return(hash_table_entries(lst)); - case T_LET: return(let_length(sc, lst)); - case T_C_OBJECT: - { - s7_pointer x = c_object_length(sc, lst); - if (s7_is_integer(x)) - return(s7_integer_clamped_if_gmp(sc, x)); - }} - return(-1); -} - -static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args); - -static void string_append_2(s7_scheme *sc, s7_pointer newstr, s7_pointer args, s7_pointer stop_arg, s7_pointer caller) -{ - s7_int len; - char *pos; - s7_pointer x; - for (pos = string_value(newstr), x = args; x != stop_arg; x = cdr(x)) - if (is_string(car(x))) - { - len = string_length(car(x)); - if (len > 0) - { - memcpy(pos, string_value(car(x)), len); - pos += len; - }} - else - if (!sequence_is_empty(sc, car(x))) - { - char *old_str = string_value(newstr); - string_value(newstr) = pos; - len = sequence_length(sc, car(x)); - s7_copy_1(sc, caller, set_plist_2(sc, car(x), newstr)); - string_value(newstr) = old_str; - pos += len; - } -} - -static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - #define H_string_append "(string-append str1 ...) appends all its string arguments into one string" - #define Q_string_append sc->pcl_s - - s7_int len = 0; - s7_pointer x, newstr; - bool just_strings = true; - - if (is_null(args)) - return(nil_string); - - s7_gc_protect_via_stack(sc, args); - /* get length for new string */ - for (x = args; is_not_null(x); x = cdr(x)) - { - s7_pointer p = car(x); - if (is_string(p)) - len += string_length(p); - else - { - s7_int newlen; - if (!is_sequence(p)) - { - unstack(sc); - wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); - } - if (has_active_methods(sc, p)) /* look for string-append and if found, cobble up a plausible intermediate call */ - { - s7_pointer func = find_method_with_let(sc, p, caller); - if (func != sc->undefined) - { - if (len == 0) - { - unstack(sc); - return(s7_apply_function(sc, func, x)); /* not args (string-append "" "" ...) */ - } - newstr = make_empty_string(sc, len, 0); - string_append_2(sc, newstr, args, x, caller); - unstack(sc); - return(s7_apply_function(sc, func, set_ulist_1(sc, newstr, x))); - }} - if ((caller == sc->string_append_symbol) || (caller == sc->symbol_symbol)) - { - unstack(sc); - wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); - } - newlen = sequence_length(sc, p); - if (newlen < 0) - { - unstack(sc); - wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); - } - just_strings = false; - len += newlen; - }} - if (len == 0) - { - unstack(sc); - return(nil_string); - } - if (len > sc->max_string_length) - { - unstack(sc); - error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70), - caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); - } - newstr = inline_make_empty_string(sc, len, 0); - if (just_strings) - { - x = args; - for (char *pos = string_value(newstr); is_not_null(x); x = cdr(x)) - { - len = string_length(car(x)); - if (len > 0) - { - memcpy(pos, string_value(car(x)), len); - pos += len; - }}} - else string_append_2(sc, newstr, args, sc->nil, caller); - unstack(sc); - return(newstr); -} - -static s7_pointer g_string_append(s7_scheme *sc, s7_pointer args) {return(g_string_append_1(sc, args, sc->string_append_symbol));} - -static inline s7_pointer string_append_1(s7_scheme *sc, s7_pointer s1, s7_pointer s2) -{ - if ((is_string(s1)) && (is_string(s2))) - { - s7_int len, pos = string_length(s1); - s7_pointer newstr; - if (pos == 0) return(make_string_with_length(sc, string_value(s2), string_length(s2))); - len = pos + string_length(s2); - if (len == pos) return(make_string_with_length(sc, string_value(s1), string_length(s1))); - if (len > sc->max_string_length) - error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70), - sc->string_append_symbol, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); - newstr = make_empty_string(sc, len, 0); /* len+1 0-terminated */ - memcpy(string_value(newstr), string_value(s1), pos); - memcpy((char *)(string_value(newstr) + pos), string_value(s2), string_length(s2)); - return(newstr); - } - return(g_string_append_1(sc, list_2(sc, s1, s2), sc->string_append_symbol)); -} - -static s7_pointer string_append_p_pp(s7_scheme *sc, s7_pointer s1, s7_pointer s2) {return(string_append_1(sc, s1, s2));} - -static s7_pointer g_string_append_2(s7_scheme *sc, s7_pointer args) {return(string_append_1(sc, car(args), cadr(args)));} - -static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr); - -static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return((args == 2) ? sc->string_append_2 : f); -} - - -/* -------------------------------- substring -------------------------------- */ -static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer args, int32_t position, s7_pointer index_args, s7_int *start, s7_int *end) -{ - /* we assume that *start=0 and *end=length, that end is "exclusive", return true if the start/end points are not changed */ - s7_pointer pstart = car(index_args); - s7_int index; - - if (!s7_is_integer(pstart)) - return(method_or_bust(sc, pstart, caller, args, sc->type_names[T_INTEGER], position)); - index = s7_integer_clamped_if_gmp(sc, pstart); - if ((index < 0) || - (index > *end)) /* *end == length here */ - out_of_range_error_nr(sc, caller, small_int(position), pstart, (index < 0) ? it_is_negative_string : it_is_too_large_string); - *start = index; - - if (is_pair(cdr(index_args))) - { - s7_pointer pend = cadr(index_args); - if (!s7_is_integer(pend)) - return(method_or_bust(sc, pend, caller, args, sc->type_names[T_INTEGER], position + 1)); - index = s7_integer_clamped_if_gmp(sc, pend); - if ((index < *start) || - (index > *end)) - out_of_range_error_nr(sc, caller, small_int(position + 1), pend, (index < *start) ? it_is_too_small_string : it_is_too_large_string); - *end = index; - } - return(sc->unused); -} - -static s7_pointer g_substring(s7_scheme *sc, s7_pointer args) -{ - #define H_substring "(substring str start (end (length str))) returns the portion of the string str between start and \ -end: (substring \"01234\" 1 2) -> \"1\"" - #define Q_substring s7_make_circular_signature(sc, 2, 3, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol) - - s7_pointer x, str = car(args); - s7_int start = 0, end, len; - char *s; - - if (!is_string(str)) - return(method_or_bust(sc, str, sc->substring_symbol, args, sc->type_names[T_STRING], 1)); - end = string_length(str); - if (!is_null(cdr(args))) - { - x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end); - if (x != sc->unused) return(x); - } - s = string_value(str); - len = end - start; - if (len == 0) return(nil_string); - x = inline_make_string_with_length(sc, (char *)(s + start), len); - string_value(x)[len] = 0; - return(x); -} - -static s7_pointer g_substring_uncopied(s7_scheme *sc, s7_pointer args) -{ - s7_pointer str = car(args); - s7_int start = 0, end; - - if (!is_string(str)) - return(method_or_bust(sc, str, sc->substring_symbol, args, sc->type_names[T_STRING], 1)); - end = string_length(str); - if (!is_null(cdr(args))) - { - s7_pointer x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end); - if (x != sc->unused) return(x); - } - return(wrap_string(sc, (char *)(string_value(str) + start), end - start)); -} - -static s7_pointer substring_uncopied_p_pii(s7_scheme *sc, s7_pointer str, s7_int start, s7_int end) -{ - /* is_string arg1 checked in opt */ - if ((end < start) || (end > string_length(str))) - out_of_range_error_nr(sc, sc->substring_symbol, int_three, wrap_integer(sc, end), (end < start) ? it_is_too_small_string : it_is_too_large_string); - if (start < 0) - out_of_range_error_nr(sc, sc->substring_symbol, int_two, wrap_integer(sc, start), it_is_negative_string); - return(wrap_string(sc, (char *)(string_value(str) + start), end - start)); -} - -static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args); - -static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr) -{ - int32_t substrs = 0; - /* don't use substring_uncopied for arg if arg is returned: (reverse! (write-string (substring x ...))) */ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - { - s7_pointer arg = car(p); - if ((is_pair(arg)) && - (is_symbol(car(arg))) && - (is_safely_optimized(arg)) && - (has_fn(arg))) - { - if (fn_proc(arg) == g_substring) - { - if (substrs < NUM_STRING_WRAPPERS) - set_c_function(arg, sc->substring_uncopied); - substrs++; - } - else - if (fn_proc(arg) == g_symbol_to_string) - set_c_function(arg, sc->symbol_to_string_uncopied); - else - if ((fn_proc(arg) == g_get_output_string) && (is_null(cddr(arg)))) - set_c_function(arg, sc->get_output_string_uncopied); - }} -} - -static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - /* used by several string functions */ - check_for_substring_temp(sc, expr); - return(f); -} - - -/* -------------------------------- string-copy -------------------------------- */ -static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args) -{ - #define H_string_copy "(string-copy str dest-str (dest-start 0) dest-end) returns a copy of its string argument. If dest-str is given, \ - string-copy copies its first argument into the second, starting at dest-start in the second string and returns dest-str" - #define Q_string_copy s7_make_signature(sc, 5, sc->is_string_symbol, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol) - - s7_pointer source = car(args), p, dest; - s7_int start, end; - - if (!is_string(source)) - return(method_or_bust(sc, source, sc->string_copy_symbol, args, sc->type_names[T_STRING], 1)); - if (is_null(cdr(args))) - return(make_string_with_length(sc, string_value(source), string_length(source))); - - dest = cadr(args); - if (!is_string(dest)) - wrong_type_error_nr(sc, sc->string_copy_symbol, 2, dest, sc->type_names[T_STRING]); - if (is_immutable(dest)) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't string-copy to ~S; it is immutable", 40), dest)); - - end = string_length(dest); - p = cddr(args); - if (is_null(p)) - start = 0; - else - { - if (!s7_is_integer(car(p))) - wrong_type_error_nr(sc, sc->string_copy_symbol, 3, car(p), sc->type_names[T_INTEGER]); - start = s7_integer_clamped_if_gmp(sc, car(p)); - if (start < 0) start = 0; - p = cdr(p); - if (is_null(p)) - end = start + string_length(source); - else - { - if (!s7_is_integer(car(p))) - wrong_type_error_nr(sc, sc->string_copy_symbol, 4, car(p), sc->type_names[T_INTEGER]); - end = s7_integer_clamped_if_gmp(sc, car(p)); - if (end < 0) end = start; - }} - if (end > string_length(dest)) end = string_length(dest); - if (end <= start) return(dest); - if ((end - start) > string_length(source)) end = start + string_length(source); - memmove((void *)(string_value(dest) + start), (void *)(string_value(source)), end - start); - /* although I haven't tracked down a case, libasan+auto-tester reported sourcechar #xf0)) (string (integer->char #x70))) - * and null or lack thereof does not say anything about the string end - */ - size_t len1 = (size_t)string_length(s1); - size_t len2 = (size_t)string_length(s2); - size_t len = (len1 > len2) ? len2 : len1; - char *str1 = string_value(s1); - char *str2 = string_value(s2); - - if (len < sizeof(size_t)) - for (size_t i = 0; i < len; i++) - { - if ((uint8_t)(str1[i]) < (uint8_t )(str2[i])) - return(-1); - if ((uint8_t)(str1[i]) > (uint8_t)(str2[i])) - return(1); - } - else - { - /* this algorithm from stackoverflow(?), with various changes (original did not work for large strings, etc) */ - size_t i = 0, last = len / sizeof(size_t); - for (size_t *ptr1 = (size_t *)str1, *ptr2 = (size_t *)str2; i < last; i++) - if (ptr1[i] != ptr2[i]) - break; - for (size_t pos = i * sizeof(size_t); pos < len; pos++) - { - if ((uint8_t)str1[pos] < (uint8_t)str2[pos]) - return(-1); - if ((uint8_t)str1[pos] > (uint8_t)str2[pos]) - return(1); - }} - if (len1 < len2) - return(-1); - return((len1 > len2) ? 1 : 0); -} - -static bool is_string_via_method(s7_scheme *sc, s7_pointer p) -{ - if (s7_is_string(p)) - return(true); - if (has_active_methods(sc, p)) - { - s7_pointer f = find_method_with_let(sc, p, sc->is_string_symbol); - if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); - } - return(false); -} - -static s7_pointer g_string_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_string(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1)); - for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) - { - if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (scheme_strcmp(y, car(x)) != val) - { - for (y = cdr(x); is_pair(y); y = cdr(y)) - if (!is_string_via_method(sc, car(y))) - wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); - return(sc->F); - }} - return(sc->T); -} - -static s7_pointer g_string_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - if (!is_string(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1)); - for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) - { - if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (scheme_strcmp(y, car(x)) == val) - { - for (y = cdr(x); is_pair(y); y = cdr(y)) - if (!is_string_via_method(sc, car(y))) - wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); - return(sc->F); - }} - return(sc->T); -} - -static bool scheme_strings_are_equal(s7_pointer x, s7_pointer y) -{ - return((string_length(x) == string_length(y)) && - (strings_are_equal_with_length(string_value(x), string_value(y), string_length(x)))); -} - -static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_equal "(string=? str ...) returns #t if all the string arguments are equal" - #define Q_strings_are_equal sc->pcl_bs - - /* C-based check stops at null, but we can have embedded nulls. - * (let ((s1 "1234") (s2 "1245")) (string-set! s1 1 #\null) (string-set! s2 1 #\null) (string=? s1 s2)) - */ - s7_pointer y = car(args); - bool happy = true; - - if (!is_string(y)) - return(method_or_bust(sc, y, sc->string_eq_symbol, args, sc->type_names[T_STRING], 1)); - for (s7_pointer x = cdr(args); is_pair(x); x = cdr(x)) - { - s7_pointer p = car(x); - if (y != p) - { - if (!is_string(p)) - return(method_or_bust(sc, p, sc->string_eq_symbol, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (happy) - happy = scheme_strings_are_equal(p, y); - }} - return((happy) ? sc->T : sc->F); -} - -static s7_pointer g_strings_are_less(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_less "(stringpcl_bs - return(g_string_cmp(sc, args, -1, sc->string_lt_symbol)); -} - -static s7_pointer g_strings_are_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_greater "(string>? str ...) returns #t if all the string arguments are decreasing" - #define Q_strings_are_greater sc->pcl_bs - return(g_string_cmp(sc, args, 1, sc->string_gt_symbol)); -} - -static s7_pointer g_strings_are_geq(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_geq "(string>=? str ...) returns #t if all the string arguments are equal or decreasing" - #define Q_strings_are_geq sc->pcl_bs - return(g_string_cmp_not(sc, args, -1, sc->string_geq_symbol)); -} - -static s7_pointer g_strings_are_leq(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_leq "(string<=? str ...) returns #t if all the string arguments are equal or increasing" - #define Q_strings_are_leq sc->pcl_bs - return(g_string_cmp_not(sc, args, 1, sc->string_leq_symbol)); -} - -static s7_pointer g_string_equal_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_string(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args)))); -} - -static s7_pointer g_string_equal_2c(s7_scheme *sc, s7_pointer args) -{ - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 1)); - return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args)))); -} - -static s7_pointer string_eq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_string(p1)) - return(method_or_bust(sc, p1, sc->string_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 1)); - if (!is_string(p2)) - return(method_or_bust(sc, p2, sc->string_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strings_are_equal(p1, p2))); -} - -static s7_pointer g_string_less_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->string_lt_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_string(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->string_lt_symbol, args, sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == -1)); -} - -static s7_pointer string_lt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_string(p1)) - return(method_or_bust(sc, p1, sc->string_lt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 1)); - if (!is_string(p2)) - return(method_or_bust(sc, p2, sc->string_lt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strcmp(p1, p2) == -1)); -} - -static s7_pointer g_string_greater_2(s7_scheme *sc, s7_pointer args) -{ - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->string_gt_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_string(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->string_gt_symbol, args, sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1)); -} - -static s7_pointer string_gt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_string(p1)) - return(method_or_bust(sc, p1, sc->string_gt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 1)); - if (!is_string(p2)) - return(method_or_bust(sc, p2, sc->string_gt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 2)); - return(make_boolean(sc, scheme_strcmp(p1, p2) == 1)); -} - -#define check_string2_args(Sc, Caller, P1, P2) \ - do { \ - if (!is_string(p1)) return(method_or_bust(sc, P1, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_STRING], 1) != Sc->F); \ - if (!is_string(p2)) return(method_or_bust(sc, P2, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_STRING], 2) != Sc->F); \ - } while (0) - -static bool string_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) == -1);} -static bool string_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_lt_symbol, p1, p2); - return(scheme_strcmp(p1, p2) == -1); -} - -static bool string_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) != 1);} -static bool string_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_leq_symbol, p1, p2); - return(scheme_strcmp(p1, p2) != 1); -} - -static bool string_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) == 1);} -static bool string_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_gt_symbol, p1, p2); - return(scheme_strcmp(p1, p2) == 1); -} - -static bool string_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) != -1);} -static bool string_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_geq_symbol, p1, p2); - return(scheme_strcmp(p1, p2) != -1); -} - -static bool string_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strings_are_equal(p1, p2));} -static bool string_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_eq_symbol, p1, p2); - return(scheme_strings_are_equal(p1, p2)); -} - -static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return((args == 2) ? ((is_string(caddr(expr))) ? sc->string_equal_2c : sc->string_equal_2) : f); -} - -static s7_pointer string_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return((args == 2) ? sc->string_less_2 : f); -} - -static s7_pointer string_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return((args == 2) ? sc->string_greater_2 : f); -} - - -#if (!WITH_PURE_S7) -static int32_t scheme_strcasecmp(s7_pointer s1, s7_pointer s2) -{ - /* same as scheme_strcmp -- watch out for unwanted sign! and lack of trailing null (length sets string end). - */ - s7_int len1 = string_length(s1); - s7_int len2 = string_length(s2); - s7_int len = (len1 > len2) ? len2 : len1; - const uint8_t *str1 = (const uint8_t *)string_value(s1); - const uint8_t *str2 = (const uint8_t *)string_value(s2); - - for (s7_int i = 0; i < len; i++) - { - if (uppers[(int32_t)str1[i]] < uppers[(int32_t)str2[i]]) - return(-1); - if (uppers[(int32_t)str1[i]] > uppers[(int32_t)str2[i]]) - return(1); - } - if (len1 < len2) - return(-1); - return((len1 > len2) ? 1 : 0); -} - -static bool scheme_strequal_ci(s7_pointer s1, s7_pointer s2) -{ - /* same as scheme_strcmp -- watch out for unwanted sign! */ - s7_int len = string_length(s1); - s7_int len2 = string_length(s2); - const uint8_t *str1, *str2; - - if (len != len2) return(false); - str1 = (const uint8_t *)string_value(s1); - str2 = (const uint8_t *)string_value(s2); - for (s7_int i = 0; i < len; i++) - if (uppers[(int32_t)str1[i]] != uppers[(int32_t)str2[i]]) - return(false); - return(true); -} - -static s7_pointer check_rest_are_strings(s7_scheme *sc, s7_pointer sym, s7_pointer x, s7_pointer args) -{ - for (s7_pointer y = x; is_pair(y); y = cdr(y)) - if (!is_string_via_method(sc, car(y))) - wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); - return(sc->F); -} - -static s7_pointer g_string_ci_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - - if (!is_string(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1)); - - for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) - { - if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (val == 0) - { - if (!scheme_strequal_ci(y, car(x))) - return(check_rest_are_strings(sc, sym, cdr(x), args)); - } - else - if (scheme_strcasecmp(y, car(x)) != val) - return(check_rest_are_strings(sc, sym, cdr(x), args)); - } - return(sc->T); -} - -static s7_pointer g_string_ci_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) -{ - s7_pointer y = car(args); - - if (!is_string(y)) - return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1)); - for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) - { - if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (scheme_strcasecmp(y, car(x)) == val) - return(check_rest_are_strings(sc, sym, cdr(x), args)); - } - return(sc->T); -} - -static s7_pointer g_strings_are_ci_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_equal "(string-ci=? str ...) returns #t if all the string arguments are equal, ignoring case" - #define Q_strings_are_ci_equal sc->pcl_bs - return(g_string_ci_cmp(sc, args, 0, sc->string_ci_eq_symbol)); -} - -static s7_pointer g_strings_are_ci_less(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_less "(string-cipcl_bs - return(g_string_ci_cmp(sc, args, -1, sc->string_ci_lt_symbol)); -} - -static s7_pointer g_strings_are_ci_greater(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_greater "(string-ci>? str ...) returns #t if all the string arguments are decreasing, ignoring case" - #define Q_strings_are_ci_greater sc->pcl_bs - return(g_string_ci_cmp(sc, args, 1, sc->string_ci_gt_symbol)); -} - -static s7_pointer g_strings_are_ci_geq(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_geq "(string-ci>=? str ...) returns #t if all the string arguments are equal or decreasing, ignoring case" - #define Q_strings_are_ci_geq sc->pcl_bs - return(g_string_ci_cmp_not(sc, args, -1, sc->string_ci_geq_symbol)); -} - -static s7_pointer g_strings_are_ci_leq(s7_scheme *sc, s7_pointer args) -{ - #define H_strings_are_ci_leq "(string-ci<=? str ...) returns #t if all the string arguments are equal or increasing, ignoring case" - #define Q_strings_are_ci_leq sc->pcl_bs - return(g_string_ci_cmp_not(sc, args, 1, sc->string_ci_leq_symbol)); -} - -static bool string_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) == -1);} -static bool string_ci_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_lt_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) == -1); -} - -static bool string_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) != 1);} -static bool string_ci_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_leq_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) != 1); -} - -static bool string_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) == 1);} -static bool string_ci_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_gt_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) == 1); -} - -static bool string_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) != -1);} -static bool string_ci_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_geq_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) != -1); -} - -static bool string_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) == 0);} -static bool string_ci_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - check_string2_args(sc, sc->string_ci_eq_symbol, p1, p2); - return(scheme_strcasecmp(p1, p2) == 0); -} -#endif /* pure s7 */ - -static s7_pointer g_string_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) -{ - s7_pointer x = car(args), chr; - s7_int start = 0, end; - - if (!is_string(x)) - return(method_or_bust(sc, x, caller, args, sc->type_names[T_STRING], 1)); /* not two methods here */ - if (is_immutable_string(x)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, x)); - - chr = cadr(args); - if (!is_character(chr)) - return(method_or_bust(sc, chr, caller, args, sc->type_names[T_CHARACTER], 2)); - - end = string_length(x); - if (!is_null(cddr(args))) - { - s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); - if (p != sc->unused) - return(p); - if (start == end) return(chr); - } - if (end == 0) return(chr); - local_memset((void *)(string_value(x) + start), (int32_t)character(chr), end - start); /* not memclr even if chr=#\null! */ - return(chr); -} - -#if (!WITH_PURE_S7) -/* -------------------------------- string-fill! -------------------------------- */ -static s7_pointer g_string_fill(s7_scheme *sc, s7_pointer args) -{ - #define H_string_fill "(string-fill! str chr start end) fills the string str with the character chr" - #define Q_string_fill s7_make_signature(sc, 5, \ - s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol), \ - sc->is_string_symbol, sc->is_char_symbol, sc->is_integer_symbol, sc->is_integer_symbol) - return(g_string_fill_1(sc, sc->string_fill_symbol, args)); -} -#endif - - -/* -------------------------------- string -------------------------------- */ -const char *s7_string(s7_pointer p) {return(string_value(p));} - -static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym) -{ - int32_t i, len; - s7_pointer x, newstr; - char *str; - if (is_null(args)) return(nil_string); - - /* get length for new string and check arg types */ - for (len = 0, x = args; is_not_null(x); len++, x = cdr(x)) - { - s7_pointer p = car(x); - if (!is_character(p)) - { - if (has_active_methods(sc, p)) - { - s7_pointer func = find_method_with_let(sc, p, sym); - if (func != sc->undefined) - { - s7_pointer y; - if (len == 0) - return(s7_apply_function(sc, func, args)); - newstr = make_empty_string(sc, len, 0); - str = string_value(newstr); - for (i = 0, y = args; y != x; i++, y = cdr(y)) - str[i] = character(car(y)); - return(g_string_append_1(sc, set_plist_2(sc, newstr, s7_apply_function(sc, func, x)), sym)); - }} - wrong_type_error_nr(sc, sym, len + 1, car(x), sc->type_names[T_CHARACTER]); - }} - newstr = inline_make_empty_string(sc, len, 0); - str = string_value(newstr); - for (i = 0, x = args; is_not_null(x); i++, x = cdr(x)) - str[i] = character(car(x)); - return(newstr); -} - -static s7_pointer g_string(s7_scheme *sc, s7_pointer args) -{ - #define H_string "(string chr...) appends all its character arguments into one string" - #define Q_string s7_make_circular_signature(sc, 1, 2, sc->is_string_symbol, sc->is_char_symbol) - return((is_null(args)) ? nil_string : g_string_1(sc, args, sc->string_symbol)); -} - -static s7_pointer g_string_c1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer c = car(args), str; - /* no multiple values here because no pairs below */ - if (!is_character(c)) - return(method_or_bust(sc, c, sc->string_symbol, args, sc->type_names[T_CHARACTER], 1)); - str = inline_make_empty_string(sc, 1, 0); /* can't put character(c) here because null is handled specially */ - string_value(str)[0] = character(c); - return(str); -} - -static s7_pointer string_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - return(((args == 1) && (!is_pair(cadr(expr)))) ? sc->string_c1 : f); -} - -static s7_pointer string_p_p(s7_scheme *sc, s7_pointer p) -{ - s7_pointer str; - if (!is_character(p)) return(g_string_1(sc, set_plist_1(sc, p), sc->string_symbol)); - str = inline_make_empty_string(sc, 1, 0); - string_value(str)[0] = character(p); - return(str); -} - - -/* -------------------------------- list->string -------------------------------- */ -#if (!WITH_PURE_S7) -static s7_pointer g_list_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_list_to_string "(list->string lst) appends all the list's characters into one string; (apply string lst)" - #define Q_list_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_proper_list_symbol) - - if (is_null(car(args))) - return(nil_string); - if (!s7_is_proper_list(sc, car(args))) - return(sole_arg_method_or_bust_p(sc, car(args), sc->list_to_string_symbol, - wrap_string(sc, "a (proper, non-circular) list of characters", 43))); - return(g_string_1(sc, car(args), sc->list_to_string_symbol)); -} -#endif - - -/* -------------------------------- string->list -------------------------------- */ -static s7_pointer string_to_list(s7_scheme *sc, const char *str, s7_int len) -{ - s7_pointer result; - if (len == 0) - return(sc->nil); - check_free_heap_size(sc, len); - init_temp(sc->y, sc->nil); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, chars[((uint8_t)str[i])], sc->y); - result = sc->y; - sc->y = sc->unused; - return(result); -} - -#if (!WITH_PURE_S7) -static s7_pointer g_string_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_list "(string->list str start end) returns the elements of the string str in a list; (map values str)" - #define Q_string_to_list s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_string_symbol, sc->is_integer_symbol) - - s7_int start = 0, end; - s7_pointer p, str = car(args); - - if (!is_string(str)) - return(sole_arg_method_or_bust(sc, str, sc->string_to_list_symbol, args, sc->type_names[T_STRING])); - end = string_length(str); - if (!is_null(cdr(args))) - { - p = start_and_end(sc, sc->string_to_list_symbol, args, 2, cdr(args), &start, &end); - if (p != sc->unused) return(p); - if (start == end) return(sc->nil); - } - else - if (end == 0) return(sc->nil); - if ((end - start) > sc->max_list_length) - out_of_range_error_nr(sc, sc->string_to_list_symbol, int_one, car(args), it_is_too_large_string); - - sc->w = sc->nil; - check_free_heap_size(sc, end - start); - for (s7_int i = end - 1; i >= start; i--) - sc->w = cons_unchecked(sc, chars[((uint8_t)string_value(str)[i])], sc->w); - p = sc->w; - sc->w = sc->unused; - return(p); -} - -static s7_pointer string_to_list_p_p(s7_scheme *sc, s7_pointer str) -{ - s7_int i, len; - s7_pointer p; - const uint8_t *val; - if (!is_string(str)) return(sole_arg_method_or_bust(sc, str, sc->string_to_list_symbol, set_plist_1(sc, str), sc->type_names[T_STRING])); - len = string_length(str); - if (len == 0) return(sc->nil); - check_free_heap_size(sc, len); - val = (const uint8_t *)string_value(str); - for (p = sc->nil, i = len - 1; i >= 0; i--) p = cons_unchecked(sc, chars[val[i]], p); - return(p); -} -#endif - - -/* -------------------------------- port-closed? -------------------------------- */ -static s7_pointer g_is_port_closed(s7_scheme *sc, s7_pointer args) -{ - #define H_is_port_closed "(port-closed? p) returns #t if the port p is closed." - #define Q_is_port_closed s7_make_signature(sc, 2, sc->is_boolean_symbol, \ - s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_output_port_symbol, sc->not_symbol)) - s7_pointer x = car(args); - if ((is_input_port(x)) || (is_output_port(x))) - return(make_boolean(sc, port_is_closed(x))); - if ((x == current_output_port(sc)) && (x == sc->F)) - return(sc->F); - return(sole_arg_method_or_bust_p(sc, x, sc->is_port_closed_symbol, wrap_string(sc, "a port", 6))); -} - -static bool is_port_closed_b_7p(s7_scheme *sc, s7_pointer x) -{ - if ((is_input_port(x)) || (is_output_port(x))) - return(port_is_closed(x)); - if ((x == current_output_port(sc)) && (x == sc->F)) - return(false); - return(sole_arg_method_or_bust_p(sc, x, sc->is_port_closed_symbol, wrap_string(sc, "a port", 6)) != sc->F); -} - - -/* -------------------------------- port-position -------------------------------- */ -static s7_pointer g_port_position(s7_scheme *sc, s7_pointer args) -{ - #define H_port_position "(port-position input-port) returns the current location (in bytes) \ -in the port's data where the next read will take place." - #define Q_port_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol) - - s7_pointer port = car(args); - if (!(is_input_port(port))) - sole_arg_wrong_type_error_nr(sc, sc->port_position_symbol, port, sc->type_names[T_INPUT_PORT]); - if (port_is_closed(port)) - sole_arg_wrong_type_error_nr(sc, sc->port_position_symbol, port, an_open_input_port_string); - if (is_string_port(port)) - return(make_integer(sc, port_position(port))); -#if (!MS_WINDOWS) - if (is_file_port(port)) - return(make_integer(sc, ftell(port_file(port)))); -#endif - return(int_zero); -} - -static s7_pointer g_set_port_position(s7_scheme *sc, s7_pointer args) -{ - s7_pointer port = car(args), pos; - s7_int position; - - if (!(is_input_port(port))) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, an_input_port_string); - if (port_is_closed(port)) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, an_open_input_port_string); - - pos = cadr(args); - if (!is_t_integer(pos)) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 2, pos, sc->type_names[T_INTEGER]); - position = s7_integer_clamped_if_gmp(sc, pos); - if (position < 0) - out_of_range_error_nr(sc, sc->port_position_symbol, int_two, pos, it_is_negative_string); - if (is_string_port(port)) - port_position(port) = (position > port_data_size(port)) ? port_data_size(port) : position; -#if (!MS_WINDOWS) - else - if (is_file_port(port)) - { - rewind(port_file(port)); - fseek(port_file(port), (long)position, SEEK_SET); - } -#endif - return(pos); -} - - -/* -------------------------------- port-file -------------------------------- */ -static s7_pointer g_port_file(s7_scheme *sc, s7_pointer args) -{ - #define H_port_file "(port-file port) returns the FILE* pointer associated with the port, wrapped in a c-pointer object" - #define Q_port_file s7_make_signature(sc, 2, sc->is_c_pointer_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol)) - - s7_pointer port = car(args); - if ((!is_input_port(port)) && - (!is_output_port(port))) - sole_arg_wrong_type_error_nr(sc, sc->port_file_symbol, port, wrap_string(sc, "a port", 6)); - if (port_is_closed(port)) - sole_arg_wrong_type_error_nr(sc, sc->port_file_symbol, port, wrap_string(sc, "an open port", 12)); -#if (!MS_WINDOWS) - if (is_file_port(port)) - return(s7_make_c_pointer_with_type(sc, (void *)(port_file(port)), sc->file__symbol, sc->F)); -#endif - return(s7_make_c_pointer(sc, NULL)); -} - - -/* -------------------------------- port-line-number -------------------------------- */ -static s7_pointer port_line_number_p_p(s7_scheme *sc, s7_pointer x) -{ - if ((!(is_input_port(x))) || - (port_is_closed(x))) - return(sole_arg_method_or_bust_p(sc, x, sc->port_line_number_symbol, an_input_port_string)); - return(make_integer(sc, port_line_number(x))); -} - -static s7_pointer g_port_line_number(s7_scheme *sc, s7_pointer args) -{ - #define H_port_line_number "(port-line-number input-file-port) returns the current read line number of port" - #define Q_port_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol) - return(port_line_number_p_p(sc, (is_null(args)) ? current_input_port(sc) : car(args))); -} - -s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p) -{ - if (!(is_input_port(p))) - sole_arg_wrong_type_error_nr(sc, sc->port_line_number_symbol, p, sc->type_names[T_INPUT_PORT]); - return(port_line_number(p)); -} - -static s7_pointer g_set_port_line_number(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p, line; - if ((is_null(car(args))) || - ((is_null(cdr(args))) && (is_t_integer(car(args))))) - p = current_input_port(sc); - else - { - p = car(args); - if (!(is_input_port(p))) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 1, p, an_input_port_string); - } - line = (is_null(cdr(args)) ? car(args) : cadr(args)); - if (!is_t_integer(line)) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 2, line, sc->type_names[T_INTEGER]); - port_line_number(p) = integer(line); - return(line); -} - - -/* -------------------------------- port-filename -------------------------------- */ -const char *s7_port_filename(s7_scheme *sc, s7_pointer x) -{ - if (((is_input_port(x)) || - (is_output_port(x))) && - (!port_is_closed(x))) - return(port_filename(x)); - return(NULL); -} - -static s7_pointer port_filename_p_p(s7_scheme *sc, s7_pointer x) -{ - if (((is_input_port(x)) || (is_output_port(x))) && - (!port_is_closed(x))) - { - if (port_filename(x)) - return(make_string_with_length(sc, port_filename(x), port_filename_length(x))); /* not wrapper here! */ - return(nil_string); - /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */ - } - return(sole_arg_method_or_bust_p(sc, x, sc->port_filename_symbol, wrap_string(sc, "an open port", 12))); -} - -static s7_pointer g_port_filename(s7_scheme *sc, s7_pointer args) -{ - #define H_port_filename "(port-filename file-port) returns the filename associated with port" - #define Q_port_filename s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol)) - return(port_filename_p_p(sc, (is_null(args)) ? current_input_port(sc) : car(args))); -} - - -/* -------------------------------- pair-line-number -------------------------------- */ -static s7_pointer pair_line_number_p_p(s7_scheme *sc, s7_pointer p) -{ - if (!is_pair(p)) - return(method_or_bust_p(sc, p, sc->pair_line_number_symbol, sc->type_names[T_PAIR])); - return((has_location(p)) ? make_integer(sc, pair_line_number(p)) : sc->F); -} - -static s7_pointer g_pair_line_number(s7_scheme *sc, s7_pointer args) -{ - #define H_pair_line_number "(pair-line-number pair) returns the line number at which it read 'pair', or #f if no such number is available" - #define Q_pair_line_number s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), sc->is_pair_symbol) - return(pair_line_number_p_p(sc, car(args))); -} - - -/* -------------------------------- pair-filename -------------------------------- */ -static s7_pointer g_pair_filename(s7_scheme *sc, s7_pointer args) -{ - #define H_pair_filename "(pair-filename pair) returns the name of the file containing 'pair'" - #define Q_pair_filename s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_pair_symbol) - - s7_pointer p = car(args); - if (is_pair(p)) - return((has_location(p)) ? sc->file_names[pair_file_number(p)] : sc->F); /* maybe also pair_file_number(p) > 0 */ - check_method(sc, p, sc->pair_filename_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->pair_filename_symbol, p, sc->type_names[T_PAIR]); - return(NULL); -} - - -/* -------------------------------- input-port? -------------------------------- */ -bool s7_is_input_port(s7_scheme *sc, s7_pointer p) {return(is_input_port(p));} -static bool is_input_port_b(s7_pointer p) {return(is_input_port(p));} - -static s7_pointer g_is_input_port(s7_scheme *sc, s7_pointer args) -{ - #define H_is_input_port "(input-port? p) returns #t if p is an input port" - #define Q_is_input_port sc->pl_bt - check_boolean_method(sc, is_input_port, sc->is_input_port_symbol, args); -} - - -/* -------------------------------- output-port? -------------------------------- */ -bool s7_is_output_port(s7_scheme *sc, s7_pointer p) {return(is_output_port(p));} -static bool is_output_port_b(s7_pointer p) {return(is_output_port(p));} - -static s7_pointer g_is_output_port(s7_scheme *sc, s7_pointer args) -{ - #define H_is_output_port "(output-port? p) returns #t if p is an output port" - #define Q_is_output_port sc->pl_bt - check_boolean_method(sc, is_output_port, sc->is_output_port_symbol, args); -} - - -/* -------------------------------- current-input-port -------------------------------- */ -s7_pointer s7_current_input_port(s7_scheme *sc) {return(current_input_port(sc));} - -static s7_pointer g_current_input_port(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_current_input_port "(current-input-port) returns the current input port" - #define Q_current_input_port s7_make_signature(sc, 1, sc->is_input_port_symbol) - return(current_input_port(sc)); -} - -static s7_pointer g_set_current_input_port(s7_scheme *sc, s7_pointer args) -{ - #define H_set_current_input_port "(set-current-input-port port) sets the current-input port to port and returns the previous value of the input port" - #define Q_set_current_input_port s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_input_port_symbol) - - s7_pointer port = car(args), old_port = current_input_port(sc); - if ((is_input_port(port)) && - (!port_is_closed(port))) - set_current_input_port(sc, port); - else - { - check_method(sc, port, sc->set_current_input_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->set_current_input_port_symbol, port, an_open_input_port_string); - } - return(old_port); -} - -s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer port) -{ - s7_pointer old_port = current_input_port(sc); - set_current_input_port(sc, port); - return(old_port); -} - - -/* -------------------------------- current-output-port -------------------------------- */ -s7_pointer s7_current_output_port(s7_scheme *sc) {return(current_output_port(sc));} - -s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer port) -{ - s7_pointer old_port = current_output_port(sc); - set_current_output_port(sc, port); - return(old_port); -} - -static s7_pointer g_current_output_port(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_current_output_port "(current-output-port) returns the current output port" - #define Q_current_output_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - return(current_output_port(sc)); -} - -static s7_pointer g_set_current_output_port(s7_scheme *sc, s7_pointer args) -{ - #define H_set_current_output_port "(set-current-output-port port) sets the current-output port to port and returns the previous value of the output port" - #define Q_set_current_output_port s7_make_signature(sc, 2, \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - s7_pointer port = car(args); - s7_pointer old_port = current_output_port(sc); - if (((is_output_port(port)) && - (!port_is_closed(port))) || (port == sc->F)) - set_current_output_port(sc, port); - else - { - check_method(sc, port, sc->set_current_output_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->set_current_output_port_symbol, port, an_output_port_or_f_string); - } - return(old_port); -} - - -/* -------------------------------- current-error-port -------------------------------- */ -s7_pointer s7_current_error_port(s7_scheme *sc) {return(sc->error_port);} - -s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port) -{ - s7_pointer old_port = sc->error_port; - sc->error_port = port; - return(old_port); -} - -static s7_pointer g_current_error_port(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_current_error_port "(current-error-port) returns the current error port" - #define Q_current_error_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - return(sc->error_port); -} - -static s7_pointer g_set_current_error_port(s7_scheme *sc, s7_pointer args) -{ - #define H_set_current_error_port "(set-current-error-port port) sets the current-error port to port and returns the previous value of the error port" - #define Q_set_current_error_port s7_make_signature(sc, 2, \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - s7_pointer port = car(args); - s7_pointer old_port = sc->error_port; - if (((is_output_port(port)) && - (!port_is_closed(port))) || (port == sc->F)) - sc->error_port = port; - else - { - check_method(sc, port, sc->set_current_error_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->set_current_error_port_symbol, port, an_output_port_or_f_string); - } - return(old_port); -} - - -/* -------------------------------- char-ready? -------------------------------- */ -#if (!WITH_PURE_S7) -static s7_pointer g_is_char_ready(s7_scheme *sc, s7_pointer args) -{ - #define H_is_char_ready "(char-ready? (port (current-input-port))) returns #t if a character is ready for input on the given port" - #define Q_is_char_ready s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_input_port_symbol) - s7_pointer pt, res; - - if (is_null(args)) - return(make_boolean(sc, (is_input_port(current_input_port(sc))) && (is_string_port(current_input_port(sc))))); - - pt = car(args); - if (!is_input_port(pt)) - return(sole_arg_method_or_bust_p(sc, pt, sc->is_char_ready_symbol, an_input_port_string)); - if (port_is_closed(pt)) - sole_arg_wrong_type_error_nr(sc, sc->is_char_ready_symbol, pt, an_open_input_port_string); - if (!is_function_port(pt)) - return(make_boolean(sc, is_string_port(pt))); - - res = (*(port_input_function(pt)))(sc, S7_IS_CHAR_READY, pt); - if (is_multiple_value(res)) /* can only happen if more than one value in res */ - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port char-ready? returned: ~S", 44), res)); - } - return(make_boolean(sc, (res != sc->F))); /* char-ready? returns a boolean */ -} -#endif - -/* -------- ports -------- */ -static int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port); -static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol); -static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port); -static void closed_port_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port); -static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port); - -static void close_closed_port(s7_scheme *sc, s7_pointer port) {return;} - -static port_functions_t closed_port_functions = - {closed_port_read_char, closed_port_write_char, closed_port_write_string, NULL, NULL, NULL, NULL, - closed_port_read_line, closed_port_display, close_closed_port}; - - -static void close_input_file(s7_scheme *sc, s7_pointer p) -{ - if (port_filename(p)) /* for string ports, this is the original input file name */ - { - liberate(sc, port_filename_block(p)); - port_filename(p) = NULL; - } - if (port_file(p)) - { - fclose(port_file(p)); - port_file(p) = NULL; - } - if (port_needs_free(p)) - free_port_data(sc, p); - - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -static void close_input_string(s7_scheme *sc, s7_pointer p) -{ - if (port_filename(p)) /* for string ports, this is the original input file name */ - { - liberate(sc, port_filename_block(p)); - port_filename(p) = NULL; - } - if (port_needs_free(p)) - free_port_data(sc, p); - - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -static void close_simple_input_string(s7_scheme *sc, s7_pointer p) -{ -#if S7_DEBUGGING - if (port_filename(p)) fprintf(stderr, "%s: port has a filename\n", __func__); - if (port_needs_free(p)) fprintf(stderr, "%s: port needs free\n", __func__); -#endif - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -void s7_close_input_port(s7_scheme *sc, s7_pointer p) {port_close(p)(sc, p);} - - -/* -------------------------------- close-input-port -------------------------------- */ -static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args) -{ - #define H_close_input_port "(close-input-port port) closes the port" - #define Q_close_input_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, sc->is_input_port_symbol) - - s7_pointer pt = car(args); - if (!is_input_port(pt)) - return(sole_arg_method_or_bust_p(sc, pt, sc->close_input_port_symbol, an_input_port_string)); - if ((!is_immutable_port(pt)) && /* (close-input-port *stdin*) */ - (!is_loader_port(pt))) /* top-level unmatched (close-input-port (current-input-port)) should not clobber the loader's input port */ - s7_close_input_port(sc, pt); - return(sc->unspecified); -} - - -/* -------------------------------- flush-output-port -------------------------------- */ -static noreturn void file_error_nr(s7_scheme *sc, const char *caller, const char *descr, const char *name) -{ - error_nr(sc, sc->io_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: ~A ~S", 9), - s7_make_string_wrapper(sc, caller), - s7_make_string_wrapper(sc, descr), - s7_make_string_wrapper(sc, name))); -} - -bool s7_flush_output_port(s7_scheme *sc, s7_pointer p) -{ - bool result = true; - if ((is_output_port(p)) && /* type=T_OUTPUT_PORT, so this excludes #f */ - (is_file_port(p)) && - (!port_is_closed(p)) && - (port_file(p))) - { - if (port_position(p) > 0) - { - result = (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) == (size_t)port_position(p)); - port_position(p) = 0; - } - if (fflush(port_file(p)) == -1) - file_error_nr(sc, "flush-output-port", strerror(errno), port_filename(p)); - } - return(result); -} - -static s7_pointer g_flush_output_port(s7_scheme *sc, s7_pointer args) -{ - #define H_flush_output_port "(flush-output-port port) flushes the file port (that is, it writes any accumulated output to the output file)" - #define Q_flush_output_port s7_make_signature(sc, 2, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - - s7_pointer pt = (is_null(args)) ? current_output_port(sc) : car(args); - if (!is_output_port(pt)) - { - if (pt == sc->F) return(pt); - check_method(sc, pt, sc->flush_output_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->flush_output_port_symbol, pt, an_output_port_or_f_string); - } - if (!s7_flush_output_port(sc, pt)) - error_nr(sc, sc->io_error_symbol, set_elist_2(sc, wrap_string(sc, "flush-output-port ~S failed", 27), pt)); - return(pt); -} - - -/* -------------------------------- close-output-port -------------------------------- */ -static void close_output_file(s7_scheme *sc, s7_pointer p) -{ - if (port_filename(p)) /* only a file output port has a filename(?) */ - { - liberate(sc, port_filename_block(p)); - port_filename(p) = NULL; - port_filename_length(p) = 0; - } - if (port_file(p)) - { -#if (WITH_WARNINGS) - if ((port_position(p) > 0) && - (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != (size_t)port_position(p))) - s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); -#else - if (port_position(p) > 0) - fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)); -#endif - if (fflush(port_file(p)) == -1) - s7_warn(sc, 64, "fflush in close-output-port: %s\n", strerror(errno)); - fclose(port_file(p)); - port_file(p) = NULL; - } - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -static void close_output_string(s7_scheme *sc, s7_pointer p) -{ - if (port_data(p)) - { - port_data(p) = NULL; - port_data_size(p) = 0; - } - port_port(p)->pf = &closed_port_functions; - port_set_closed(p, true); - port_position(p) = 0; -} - -static void close_output_port(s7_scheme *sc, s7_pointer p) {port_close(p)(sc, p);} - -void s7_close_output_port(s7_scheme *sc, s7_pointer p) -{ - if ((p == sc->F) || (is_immutable_port(p))) return; /* can these happen? */ - close_output_port(sc, p); -} - -static s7_pointer g_close_output_port(s7_scheme *sc, s7_pointer args) -{ - #define H_close_output_port "(close-output-port port) closes the port" - #define Q_close_output_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - - s7_pointer pt = car(args); - if (!is_output_port(pt)) - { - if (pt == sc->F) return(sc->unspecified); - check_method(sc, pt, sc->close_output_port_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->close_output_port_symbol, pt, an_output_port_or_f_string); - } - s7_close_output_port(sc, pt); - return(sc->unspecified); -} - - -/* -------- read character functions -------- */ - -static int32_t file_read_char(s7_scheme *sc, s7_pointer port) {return(fgetc(port_file(port)));} - -static int32_t function_read_char(s7_scheme *sc, s7_pointer port) -{ - s7_pointer res = (*(port_input_function(port)))(sc, S7_READ_CHAR, port); - if (is_eof(res)) return(EOF); - if (!is_character(res)) /* port_input_function might return some non-character */ - { - if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), res)); - } - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), res)); - } - return((int32_t)character(res)); /* kinda nutty -- we return chars[this] in g_read_char! */ -} - -static int32_t string_read_char(s7_scheme *sc, s7_pointer port) -{ - return((port_data_size(port) <= port_position(port)) ? EOF : (uint8_t)port_data(port)[port_position(port)++]); /* port_string_length is 0 if no port string */ -} - -static int32_t output_read_char(s7_scheme *sc, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, an_input_port_string); - return(0); -} - -static int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, an_open_input_port_string); - return(0); -} - - -/* -------- read line functions -------- */ - -static s7_pointer output_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, an_input_port_string); - return(NULL); -} - -static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, an_open_input_port_string); - return(NULL); -} - -static s7_pointer function_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - s7_pointer res = (*(port_input_function(port)))(sc, S7_READ_LINE, port); - if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-line returned: ~S", 42), res)); - } - return(res); -} - -static s7_pointer stdin_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - if (!sc->read_line_buf) - { - sc->read_line_buf_size = 1024; - sc->read_line_buf = (char *)Malloc(sc->read_line_buf_size); - } - if (fgets(sc->read_line_buf, sc->read_line_buf_size, stdin)) - return(s7_make_string(sc, sc->read_line_buf)); /* fgets adds the trailing '\0' */ - return(nil_string); /* make_string_with_length(sc, NULL, 0)); */ -} - -static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - /* read into read_line_buf concatenating reads until newline found. string is read_line_buf to pos-of-newline. - * reset file position to reflect newline pos. - */ - int32_t reads = 0; - char *str; - s7_int read_size; - if (!sc->read_line_buf) - { - sc->read_line_buf_size = 1024; - sc->read_line_buf = (char *)Malloc(sc->read_line_buf_size); - } - read_size = sc->read_line_buf_size; - str = fgets(sc->read_line_buf, read_size, port_file(port)); /* reads size-1 at most, EOF and newline also terminate read */ - if (!str) return(eof_object); /* EOF or error with no char read */ - - while (true) - { - s7_int cur_size; - char *buf, *snew = strchr(sc->read_line_buf, (int)'\n'); /* or maybe just strlen + end-of-string=newline */ - if (snew) - { - s7_int pos = (s7_int)(snew - sc->read_line_buf); - port_line_number(port)++; - return(inline_make_string_with_length(sc, sc->read_line_buf, (with_eol) ? (pos + 1) : pos)); - } - reads++; - cur_size = strlen(sc->read_line_buf); - if ((cur_size + reads) < read_size) /* end of data, no newline */ - return(make_string_with_length(sc, sc->read_line_buf, cur_size)); - - /* need more data */ - sc->read_line_buf_size *= 2; - sc->read_line_buf = (char *)Realloc(sc->read_line_buf, sc->read_line_buf_size); - buf = (char *)(sc->read_line_buf + cur_size); - str = fgets(buf, read_size, port_file(port)); - if (!str) return(eof_object); - read_size = sc->read_line_buf_size; - } - return(eof_object); -} - -static s7_pointer string_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) -{ - s7_int i; - const char *port_str = (const char *)port_data(port); - s7_int port_start = port_position(port); - const char *start = port_str + port_start; - const char *cur = (const char *)strchr(start, (int)'\n'); /* this can run off the end making valgrind unhappy, but I think it's innocuous */ - if (cur) - { - port_line_number(port)++; - i = cur - port_str; - port_position(port) = i + 1; - return(inline_make_string_with_length(sc, start, ((with_eol) ? i + 1 : i) - port_start)); - } - i = port_data_size(port); - port_position(port) = i; - if (i <= port_start) /* the < part can happen -- if not caught we try to create a string of length - 1 -> segfault */ - return(eof_object); - return(make_string_with_length(sc, start, i - port_start)); -} - - -/* -------- write character functions -------- */ - -static void resize_port_data(s7_scheme *sc, s7_pointer pt, s7_int new_size) -{ - s7_int loc = port_data_size(pt); - block_t *nb; - - if (new_size < loc) return; - if (new_size > sc->max_port_data_size) - error_nr(sc, make_symbol(sc, "port-too-big", 12), - set_elist_1(sc, wrap_string(sc, "port data size has grown past (*s7* 'max-port-data-size)", 56))); - - nb = reallocate(sc, port_data_block(pt), new_size); - port_data_block(pt) = nb; - port_data(pt) = (uint8_t *)(block_data(nb)); - port_data_size(pt) = new_size; -} - -static void string_write_char_resized(s7_scheme *sc, uint8_t c, s7_pointer pt) -{ - /* this division looks repetitive, but it is much faster */ - resize_port_data(sc, pt, port_data_size(pt) * 2); - port_data(pt)[port_position(pt)++] = c; -} - -static void string_write_char(s7_scheme *sc, uint8_t c, s7_pointer pt) -{ - if (port_position(pt) < port_data_size(pt)) - port_data(pt)[port_position(pt)++] = c; - else string_write_char_resized(sc, c, pt); -} - -static void stdout_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {fputc(c, stdout);} -static void stderr_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {fputc(c, stderr);} - -static void function_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - push_stack_direct(sc, OP_NO_VALUES); - /* sc->args = sc->nil; */ - (*(port_output_function(port)))(sc, c, port); - unstack_with(sc, OP_NO_VALUES); -#if 1 - memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ -#else - sc->code = sc->stack_end[0]; - sc->args = sc->stack_end[2]; -#endif -} - -static Inline void inline_file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - if (port_position(port) == sc->output_port_data_size) - { - fwrite((void *)(port_data(port)), 1, sc->output_port_data_size, port_file(port)); - port_position(port) = 0; - } - port_data(port)[port_position(port)++] = c; -} - -static void file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {inline_file_write_char(sc, c, port);} - -static void input_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, an_output_port_string); -} - -static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, an_open_output_port_string); -} - - -/* -------- write string functions -------- */ - -static void input_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->write_symbol, port, an_output_port_string); -} - -static void closed_port_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->write_symbol, port, an_open_output_port_string); -} - -static void input_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, an_output_port_string); -} - -static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, an_open_output_port_string); -} - -static void stdout_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) -{ - if (str[len] == '\0') - fputs(str, stdout); - else - for (s7_int i = 0; i < len; i++) - fputc(str[i], stdout); -} - -static void stderr_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) -{ - if (str[len] == '\0') - fputs(str, stderr); - else - for (s7_int i = 0; i < len; i++) - fputc(str[i], stderr); -} - -static void string_write_string_resized(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) -{ - s7_int new_len = port_position(pt) + len; /* len is known to be non-zero, str might not be 0-terminated */ - resize_port_data(sc, pt, new_len * 2); - memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len); - port_position(pt) = new_len; -} - -static void string_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) -{ - if ((S7_DEBUGGING) && (len == 0)) {fprintf(stderr, "string_write_string len == 0\n"); abort();} - if (port_position(pt) + len < port_data_size(pt)) - { - memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len); - /* memcpy is much faster than the equivalent while loop, and faster than using the 4-bytes-at-a-time shuffle */ - port_position(pt) += len; - } - else string_write_string_resized(sc, str, len, pt); -} - -static void file_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) -{ - s7_int new_len = port_position(pt) + len; - if (new_len >= sc->output_port_data_size) - { - if (port_position(pt) > 0) - { -#if (WITH_WARNINGS) - if (fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)) != (size_t)port_position(pt)) - s7_warn(sc, 64, "fwrite trouble in write-string\n"); -#else - fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)); -#endif - port_position(pt) = 0; - } - fwrite((void *)str, 1, len, port_file(pt)); - } - else - { - memcpy((void *)(port_data(pt) + port_position(pt)), (void *)str, len); - port_position(pt) = new_len; - } -} - -static void string_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - if (s) string_write_string(sc, s, safe_strlen(s), port); -} - -static void file_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - if (s) - { - if (port_position(port) > 0) - { -#if (WITH_WARNINGS) - if (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != (size_t)port_position(port)) - s7_warn(sc, 64, "fwrite trouble in display\n"); -#else - fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)); -#endif - port_position(port) = 0; - } -#if (WITH_WARNINGS) - if (fputs(s, port_file(port)) == EOF) - s7_warn(sc, 64, "write to %s: %s\n", port_filename(port), strerror(errno)); -#else - fputs(s, port_file(port)); -#endif - } -} - -static void function_display(s7_scheme *sc, const char *s, s7_pointer port) -{ - if (!s) return; - push_stack_direct(sc, OP_NO_VALUES); - /* sc->args = sc->nil; */ /* is this needed? */ - for (; *s; s++) - (*(port_output_function(port)))(sc, *s, port); - unstack_with(sc, OP_NO_VALUES); -#if 1 - memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ -#else - sc->code = sc->stack_end[0]; /* sc->curlet = sc->stack_end[1] */ - sc->args = sc->stack_end[2]; -#endif -} - -static void function_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt) -{ - push_stack_direct(sc, OP_NO_VALUES); - /* sc->args = sc->nil; */ /* is this needed? */ - for (s7_int i = 0; i < len; i++) - (*(port_output_function(pt)))(sc, str[i], pt); - unstack_with(sc, OP_NO_VALUES); -#if 1 - memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ -#else - sc->code = sc->stack_end[0]; - sc->args = sc->stack_end[2]; -#endif -} - -static void stdout_display(s7_scheme *sc, const char *s, s7_pointer port) {if (s) fputs(s, stdout);} -static void stderr_display(s7_scheme *sc, const char *s, s7_pointer port) {if (s) fputs(s, stderr);} - - -/* -------------------------------- write-string -------------------------------- */ -static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args) -{ - #define H_write_string "(write-string str port start end) writes str to port." - #define Q_write_string s7_make_circular_signature(sc, 3, 4, \ - sc->is_string_symbol, sc->is_string_symbol, \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol),\ - sc->is_integer_symbol) - s7_pointer str = car(args), port; - s7_int start = 0, end; - if (!is_string(str)) - return(method_or_bust(sc, str, sc->write_string_symbol, args, sc->type_names[T_STRING], 1)); - - end = string_length(str); - if (!is_null(cdr(args))) - { - s7_pointer inds = cddr(args); - port = cadr(args); - if (!is_null(inds)) - { - s7_pointer p = start_and_end(sc, sc->write_string_symbol, args, 3, inds, &start, &end); - if (p != sc->unused) return(p); - }} - else port = current_output_port(sc); - if (!is_output_port(port)) - { - if (port == sc->F) - { - s7_int len; - if ((start == 0) && (end == string_length(str))) - return(str); - len = (s7_int)(end - start); - return(make_string_with_length(sc, (char *)(string_value(str) + start), len)); - } - check_method(sc, port, sc->write_string_symbol, args); - wrong_type_error_nr(sc, sc->write_string_symbol, 2, port, an_output_port_or_f_string); - } - if (port_is_closed(port)) wrong_type_error_nr(sc, sc->write_string_symbol, 2, port, an_open_output_port_string); - if (start == end) return(str); - port_write_string(port)(sc, (char *)(string_value(str) + start), (end - start), port); - return(str); -} - -static s7_pointer write_string_p_pp(s7_scheme *sc, s7_pointer str, s7_pointer port) -{ - if (!is_string(str)) - return(method_or_bust_pp(sc, str, sc->write_string_symbol, str, port, sc->type_names[T_STRING], 1)); - if (!is_output_port(port)) - { - if (port == sc->F) return(str); - return(method_or_bust_pp(sc, port, sc->write_string_symbol, str, port, an_output_port_string, 2)); - } - if (string_length(str) > 0) - port_write_string(port)(sc, string_value(str), string_length(str), port); - return(str); -} - - -/* -------- skip to newline readers -------- */ -static token_t token(s7_scheme *sc); - -static token_t file_read_semicolon(s7_scheme *sc, s7_pointer pt) -{ - int32_t c; - do (c = fgetc(port_file(pt))); while ((c != '\n') && (c != EOF)); - port_line_number(pt)++; - return((c == EOF) ? TOKEN_EOF : token(sc)); -} - -static token_t string_read_semicolon(s7_scheme *sc, s7_pointer pt) -{ - const char *str = (const char *)(port_data(pt) + port_position(pt)); - const char *orig_str = strchr(str, (int)'\n'); - if (!orig_str) - { - port_position(pt) = port_data_size(pt); - return(TOKEN_EOF); - } - port_position(pt) += (orig_str - str + 1); /* + 1 because strchr leaves orig_str pointing at the newline */ - port_line_number(pt)++; - return(token(sc)); -} - - -/* -------- white space readers -------- */ - -static int32_t file_read_white_space(s7_scheme *sc, s7_pointer port) -{ - int32_t c; - while (is_white_space(c = fgetc(port_file(port)))) - if (c == '\n') - port_line_number(port)++; - return(c); -} - -static int32_t terminated_string_read_white_space(s7_scheme *sc, s7_pointer pt) -{ - const uint8_t *str = (const uint8_t *)(port_data(pt) + port_position(pt)); - uint8_t c; - /* here we know we have null termination and white_space[#\null] is false */ - while (white_space[c = *str++]) /* 255 is not -1 = EOF */ - if (c == '\n') - port_line_number(pt)++; - port_position(pt) = (c) ? str - port_data(pt) : port_data_size(pt); - return((int32_t)c); -} - - -/* -------- name readers -------- */ -#define BASE_10 10 - -static s7_pointer file_read_name_or_sharp(s7_scheme *sc, s7_pointer pt, bool atom_case) -{ - int32_t c; - s7_int i = 1; /* sc->strbuf[0] has the first char of the string we're reading */ - do { - c = fgetc(port_file(pt)); /* might return EOF */ - if (c == '\n') - port_line_number(pt)++; - - sc->strbuf[i++] = (unsigned char)c; - if (i >= sc->strbuf_size) - resize_strbuf(sc, i); - } while ((c != EOF) && (char_ok_in_a_name[c])); - - if ((i == 2) && - (sc->strbuf[0] == '\\')) - sc->strbuf[2] = '\0'; - else - { - if (c != EOF) - { - if (c == '\n') - port_line_number(pt)--; - ungetc(c, port_file(pt)); - } - sc->strbuf[i - 1] = '\0'; - } - if (atom_case) - return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR)); - return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); -} - -static s7_pointer file_read_name(s7_scheme *sc, s7_pointer pt) {return(file_read_name_or_sharp(sc, pt, true));} -static s7_pointer file_read_sharp(s7_scheme *sc, s7_pointer pt) {return(file_read_name_or_sharp(sc, pt, false));} - -static s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer pt) -{ - /* sc->strbuf[0] has the first char of the string we're reading */ - s7_pointer result; - uint8_t *str = (uint8_t *)(port_data(pt) + port_position(pt)); - - if (char_ok_in_a_name[*str]) - { - s7_int k; - uint8_t *orig_str = str - 1; - str++; - while (char_ok_in_a_name[*str]) str++; - k = str - orig_str; - if (*str != 0) - port_position(pt) += (k - 1); - else port_position(pt) = port_data_size(pt); - /* this is equivalent to: - * str = strpbrk(str, "(); \"\t\r\n"); - * if (!str) {k = strlen(orig_str); str = (char *)(orig_str + k);} else k = str - orig_str; - * but slightly faster. - */ - if (!number_table[*orig_str]) - return(inline_make_symbol(sc, (const char *)orig_str, k)); - - /* eval_c_string string is a constant so we can't set and unset the token's end char */ - if ((k + 1) >= sc->strbuf_size) - resize_strbuf(sc, k + 1); - - memcpy((void *)(sc->strbuf), (void *)orig_str, k); - sc->strbuf[k] = '\0'; - return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR)); - } - result = sc->singletons[(uint8_t)(sc->strbuf[0])]; - if (!result) - { - sc->strbuf[1] = '\0'; - result = make_symbol(sc, sc->strbuf, 1); - sc->singletons[(uint8_t)(sc->strbuf[0])] = result; - } - return(result); -} - -static s7_pointer string_read_sharp(s7_scheme *sc, s7_pointer pt) -{ - /* sc->strbuf[0] has the first char of the string we're reading. - * since a *#readers* function might want to get further input, we can't mess with the input even when it is otherwise safe - */ - char *str = (char *)(port_data(pt) + port_position(pt)); - if (char_ok_in_a_name[(uint8_t)*str]) - { - s7_int k; - char *orig_str = (char *)(str - 1); - str++; - while (char_ok_in_a_name[(uint8_t)(*str)]) {str++;} - k = str - orig_str; - port_position(pt) += (k - 1); - if ((k + 1) >= sc->strbuf_size) - resize_strbuf(sc, k + 1); - memcpy((void *)(sc->strbuf), (void *)orig_str, k); - sc->strbuf[k] = '\0'; - return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); - } - if (sc->strbuf[0] == 'f') - return(sc->F); - if (sc->strbuf[0] == 't') - return(sc->T); - if (sc->strbuf[0] == '\\') - { - /* must be from #\( and friends -- a character that happens to be not ok-in-a-name */ - sc->strbuf[1] = str[0]; - sc->strbuf[2] = '\0'; - port_position(pt)++; - } - else sc->strbuf[1] = '\0'; - return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); -} - -static s7_pointer string_read_name(s7_scheme *sc, s7_pointer pt) -{ - /* port_string was allocated (and read from a file) so we can mess with it directly */ - s7_pointer result; - uint8_t *str = (uint8_t *)(port_data(pt) + port_position(pt)); - if (char_ok_in_a_name[*str]) - { - s7_int k; - uint8_t endc; - uint8_t *orig_str = str - 1; - str++; - while (char_ok_in_a_name[*str]) str++; - k = str - orig_str; - port_position(pt) += (k - 1); - if (!number_table[*orig_str]) - return(inline_make_symbol(sc, (const char *)orig_str, k)); - endc = *str; - *str = 0; - result = make_atom(sc, (char *)orig_str, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR); - *str = endc; - return(result); - } - result = sc->singletons[(uint8_t)(sc->strbuf[0])]; - if (!result) - { - sc->strbuf[1] = '\0'; - result = make_symbol(sc, sc->strbuf, 1); - sc->singletons[(uint8_t)(sc->strbuf[0])] = result; - } - return(result); -} - -static void port_set_filename(s7_scheme *sc, s7_pointer p, const char *name, size_t len) -{ - block_t *b = inline_mallocate(sc, len + 1); - port_filename_block(p) = b; - port_filename(p) = (char *)block_data(b); - memcpy((void *)block_data(b), (void *)name, len); - port_filename(p)[len] = '\0'; -} - -static block_t *mallocate_port(s7_scheme *sc) -{ - #define PORT_LIST 8 /* sizeof(port_t): 160 */ - block_t *p = sc->block_lists[PORT_LIST]; - if (p) - sc->block_lists[PORT_LIST] = (block_t *)block_next(p); - else - { /* this is mallocate without the index calc */ - p = mallocate_block(sc); - block_data(p) = (void *)permalloc(sc, (size_t)(1 << PORT_LIST)); - block_set_index(p, PORT_LIST); - } - block_set_size(p, sizeof(port_t)); - return(p); -} - -static port_functions_t input_file_functions = - {file_read_char, input_write_char, input_write_string, file_read_semicolon, file_read_white_space, - file_read_name, file_read_sharp, file_read_line, input_display, close_input_file}; - -static port_functions_t input_string_functions_1 = - {string_read_char, input_write_char, input_write_string, string_read_semicolon, terminated_string_read_white_space, - string_read_name, string_read_sharp, string_read_line, input_display, close_input_string}; - -static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int max_size, const char *caller) -{ - s7_pointer port; -#if (!MS_WINDOWS) - s7_int size; -#endif - s7_int port_loc; - block_t *b = mallocate_port(sc); - - new_cell(sc, port, T_INPUT_PORT); - port_loc = gc_protect_1(sc, port); - port_block(port) = b; - port_port(port) = (port_t *)block_data(b); - port_set_closed(port, false); - port_set_string_or_function(port, sc->nil); - /* if we're constantly opening files, and each open saves the file name in permanent memory, we gradually core-up */ - port_filename_length(port) = safe_strlen(name); - port_set_filename(sc, port, name, port_filename_length(port)); - port_line_number(port) = 1; /* first line is numbered 1 */ - port_file_number(port) = 0; - add_input_port(sc, port); - -#if (!MS_WINDOWS) - /* this doesn't work in MS C */ - fseek(fp, 0, SEEK_END); - size = ftell(fp); - rewind(fp); - - /* pseudo files (under /proc for example) have size=0, but we can read them, so don't assume a 0 length file is empty */ - - if ((size > 0) && /* if (size != 0) we get (open-input-file "/dev/tty") -> (open "/dev/tty") read 0 bytes of an expected -1? */ - ((max_size < 0) || (size < max_size))) /* load uses max_size = -1 */ - { - block_t *block = mallocate(sc, size + 2); - uint8_t *content = (uint8_t *)(block_data(block)); - size_t bytes = fread(content, sizeof(uint8_t), size, fp); - if (bytes != (size_t)size) - { - if (current_output_port(sc) != sc->F) - { - char tmp[256]; - int32_t len = snprintf(tmp, 256, "(%s \"%s\") read %ld bytes of an expected %" ld64 "?", caller, name, (long)bytes, size); - port_write_string(current_output_port(sc))(sc, tmp, clamp_length(len, 256), current_output_port(sc)); - } - size = bytes; - } - content[size] = '\0'; - content[size + 1] = '\0'; - fclose(fp); - - port_file(port) = NULL; /* make valgrind happy */ - port_type(port) = STRING_PORT; - port_data(port) = content; - port_data_block(port) = block; - port_data_size(port) = size; - port_position(port) = 0; - port_needs_free(port) = true; - port_port(port)->pf = &input_string_functions_1; - } - else - { - port_file(port) = fp; - port_type(port) = FILE_PORT; - port_data(port) = NULL; - port_data_block(port) = NULL; - port_data_size(port) = 0; - port_position(port) = 0; - port_needs_free(port) = false; - port_port(port)->pf = &input_file_functions; - } -#else - /* _stat64 is no better than the fseek/ftell route, and - * GetFileSizeEx and friends requires Windows.h which makes hash of everything else. - * fread until done takes too long on big files, so use a file port - */ - port_file(port) = fp; - port_type(port) = FILE_PORT; - port_needs_free(port) = false; - port_data(port) = NULL; - port_data_block(port) = NULL; - port_data_size(port) = 0; - port_position(port) = 0; - port_port(port)->pf = &input_file_functions; -#endif - s7_gc_unprotect_at(sc, port_loc); - return(port); -} - - -/* -------------------------------- open-input-file -------------------------------- */ -static int32_t remember_file_name(s7_scheme *sc, const char *file) -{ - for (int32_t i = 0; i <= sc->file_names_top; i++) - if (safe_strcmp(file, string_value(sc->file_names[i]))) - return(i); - - sc->file_names_top++; - if (sc->file_names_top >= sc->file_names_size) - { - int32_t old_size = 0; - /* what if file_names_size is greater than file_bits in pair|profile_file? */ - if (sc->file_names_size == 0) - { - sc->file_names_size = INITIAL_FILE_NAMES_SIZE; - sc->file_names = (s7_pointer *)Malloc(sc->file_names_size * sizeof(s7_pointer)); - } - else - { - old_size = sc->file_names_size; - sc->file_names_size *= 2; - sc->file_names = (s7_pointer *)Realloc(sc->file_names, sc->file_names_size * sizeof(s7_pointer)); - } - for (int32_t i = old_size; i < sc->file_names_size; i++) - sc->file_names[i] = sc->F; - } - sc->file_names[sc->file_names_top] = s7_make_semipermanent_string(sc, file); - return(sc->file_names_top); -} - - -#ifndef MAX_SIZE_FOR_STRING_PORT - #define MAX_SIZE_FOR_STRING_PORT 10000000 -#endif - -static s7_pointer make_input_file(s7_scheme *sc, const char *name, FILE *fp) -{ - return(read_file(sc, fp, name, MAX_SIZE_FOR_STRING_PORT, "open")); -} - - -#if (!MS_WINDOWS) -#include -#endif - -static bool is_directory(const char *filename) -{ -#if (!MS_WINDOWS) - #ifdef S_ISDIR - struct stat statbuf; - return((stat(filename, &statbuf) >= 0) && - (S_ISDIR(statbuf.st_mode))); - #endif -#endif - return(false); -} - -static s7_pointer open_input_file_1(s7_scheme *sc, const char *name, const char *mode, const char *caller) -{ - FILE *fp; - /* see if we can open this file before allocating a port */ - if (is_directory(name)) - file_error_nr(sc, caller, "file is a directory:", name); - errno = 0; - fp = fopen(name, mode); - if (fp) - return(make_input_file(sc, name, fp)); - -#if (!MS_WINDOWS) - if (errno == EINVAL) - file_error_nr(sc, caller, "invalid mode", mode); -#if WITH_GCC - if ((!name) || (!*name)) - file_error_nr(sc, caller, strerror(errno), name); - if ((name[0] == '~') && (name[1] == '/')) /* catch one special case, "~/..." */ - { - char *home = getenv("HOME"); - if (home) - { - s7_int len = safe_strlen(name) + safe_strlen(home) + 1; - block_t *b = mallocate(sc, len); - char *filename = (char *)block_data(b); - filename[0] = '\0'; - catstrs(filename, len, home, (char *)(name + 1), (char *)NULL); - fp = fopen(filename, "r"); - liberate(sc, b); - if (fp) - return(make_input_file(sc, name, fp)); - }} -#endif -#endif - file_error_nr(sc, caller, strerror(errno), name); - return(sc->io_error_symbol); -} - -s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode) -{ - return(open_input_file_1(sc, name, mode, "open-input-file")); -} - -static s7_pointer g_open_input_file(s7_scheme *sc, s7_pointer args) -{ - #define H_open_input_file "(open-input-file filename (mode \"r\")) opens filename for reading" - #define Q_open_input_file s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_string_symbol, sc->is_string_symbol) - - s7_pointer mode, name = car(args); - /* open-input-file can create a new output file if the file to be opened does not exist, and the "a" mode is given */ - - if (!is_string(name)) - return(method_or_bust(sc, name, sc->open_input_file_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_pair(cdr(args))) - return(open_input_file_1(sc, string_value(name), "r", "open-input-file")); - - mode = cadr(args); - if (!is_string(mode)) - return(method_or_bust(sc, mode, sc->open_input_file_symbol, args, wrap_string(sc, "a string (a mode such as \"r\")", 29), 2)); - /* since scheme allows embedded nulls, dumb stuff is accepted here: (open-input-file file "a\x00b") -- should this be an error? */ - return(open_input_file_1(sc, string_value(name), string_value(mode), "open-input-file")); -} - -static void close_stdin(s7_scheme *sc, s7_pointer port) {return;} -static void close_stdout(s7_scheme *sc, s7_pointer port) {return;} -static void close_stderr(s7_scheme *sc, s7_pointer port) {return;} - -static const port_functions_t stdin_functions = - {file_read_char, input_write_char, input_write_string, file_read_semicolon, file_read_white_space, - file_read_name, file_read_sharp, stdin_read_line, input_display, close_stdin}; - -static const port_functions_t stdout_functions = - {output_read_char, stdout_write_char, stdout_write_string, NULL, NULL, NULL, NULL, output_read_line, stdout_display, close_stdout}; - -static const port_functions_t stderr_functions = - {output_read_char, stderr_write_char, stderr_write_string, NULL, NULL, NULL, NULL, output_read_line, stderr_display, close_stderr}; - -static void init_standard_ports(s7_scheme *sc) -{ - s7_pointer x; - - /* standard output */ - x = alloc_pointer(sc); - set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP); - port_port(x) = (port_t *)Calloc(1, sizeof(port_t)); - port_type(x) = FILE_PORT; - port_data(x) = NULL; - port_data_block(x) = NULL; - port_set_closed(x, false); - port_filename_length(x) = 8; - port_set_filename(sc, x, "*stdout*", 8); - port_file_number(x) = remember_file_name(sc, port_filename(x)); /* these numbers need to be correct for the evaluator (*function* data) */ - port_line_number(x) = 0; - port_file(x) = stdout; - port_needs_free(x) = false; - port_port(x)->pf = &stdout_functions; - sc->standard_output = x; - - /* standard error */ - x = alloc_pointer(sc); - set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP); - port_port(x) = (port_t *)Calloc(1, sizeof(port_t)); - port_type(x) = FILE_PORT; - port_data(x) = NULL; - port_data_block(x) = NULL; - port_set_closed(x, false); - port_filename_length(x) = 8; - port_set_filename(sc, x, "*stderr*", 8); - port_file_number(x) = remember_file_name(sc, port_filename(x)); - port_line_number(x) = 0; - port_file(x) = stderr; - port_needs_free(x) = false; - port_port(x)->pf = &stderr_functions; - sc->standard_error = x; - - /* standard input */ - x = alloc_pointer(sc); - set_full_type(x, T_INPUT_PORT | T_IMMUTABLE | T_UNHEAP); - port_port(x) = (port_t *)Calloc(1, sizeof(port_t)); - port_type(x) = FILE_PORT; - port_set_closed(x, false); - port_set_string_or_function(x, sc->nil); - port_filename_length(x) = 7; - port_set_filename(sc, x, "*stdin*", 7); - port_file_number(x) = remember_file_name(sc, port_filename(x)); - port_line_number(x) = 0; - port_file(x) = stdin; - port_data_block(x) = NULL; - port_needs_free(x) = false; - port_port(x)->pf = &stdin_functions; - sc->standard_input = x; - - s7_define_variable_with_documentation(sc, "*stdin*", sc->standard_input, "*stdin* is the built-in input port, C's stdin"); - s7_define_variable_with_documentation(sc, "*stdout*", sc->standard_output, "*stdout* is the built-in buffered output port, C's stdout"); - s7_define_variable_with_documentation(sc, "*stderr*", sc->standard_error, "*stderr* is the built-in unbuffered output port, C's stderr"); - - set_current_input_port(sc, sc->standard_input); - set_current_output_port(sc, sc->standard_output); - sc->error_port = sc->standard_error; - sc->current_file = NULL; - sc->current_line = -1; -} - - -/* -------------------------------- open-output-file -------------------------------- */ -static const port_functions_t output_file_functions = - {output_read_char, file_write_char, file_write_string, NULL, NULL, NULL, NULL, output_read_line, file_display, close_output_file}; - -s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode) -{ - FILE *fp; - s7_pointer x; - block_t *block, *b; - /* see if we can open this file before allocating a port */ - - errno = 0; - fp = fopen(name, mode); - if (!fp) - { -#if (!MS_WINDOWS) - if (errno == EINVAL) - file_error_nr(sc, "open-output-file", "invalid mode", mode); -#endif - file_error_nr(sc, "open-output-file", strerror(errno), name); - } - new_cell(sc, x, T_OUTPUT_PORT); - b = mallocate_port(sc); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - port_type(x) = FILE_PORT; - port_set_closed(x, false); - port_filename_length(x) = safe_strlen(name); - port_set_filename(sc, x, name, port_filename_length(x)); - port_line_number(x) = 1; - port_file_number(x) = 0; - port_file(x) = fp; - port_needs_free(x) = true; /* hmm -- I think these are freed via s7_close_output_port -> close_output_port */ - port_position(x) = 0; - port_data_size(x) = sc->output_port_data_size; - block = mallocate(sc, sc->output_port_data_size); - port_data_block(x) = block; - port_data(x) = (uint8_t *)(block_data(block)); - port_port(x)->pf = &output_file_functions; - add_output_port(sc, x); - return(x); -} - -static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer args) -{ - #define H_open_output_file "(open-output-file filename (mode \"w\")) opens filename for writing" - #define Q_open_output_file s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_string_symbol, sc->is_string_symbol) - - s7_pointer name = car(args); - if (!is_string(name)) - return(method_or_bust(sc, name, sc->open_output_file_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_pair(cdr(args))) - return(s7_open_output_file(sc, string_value(name), "w")); - if (!is_string(cadr(args))) - return(method_or_bust(sc, cadr(args), sc->open_output_file_symbol, args, wrap_string(sc, "a string (a mode such as \"w\")", 29), 2)); - return(s7_open_output_file(sc, string_value(name), string_value(cadr(args)))); -} - - -/* -------------------------------- open-input-string -------------------------------- */ - /* a version of string ports using a pointer to the current location and a pointer to the end - * (rather than an integer for both, indexing from the base string) was not faster. - */ - -static const port_functions_t input_string_functions = - {string_read_char, input_write_char, input_write_string, string_read_semicolon, terminated_string_read_white_space, - string_read_name_no_free, string_read_sharp, string_read_line, input_display, close_simple_input_string}; - -static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_int len) -{ - s7_pointer x; - block_t *b = mallocate_port(sc); - new_cell(sc, x, T_INPUT_PORT); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - port_type(x) = STRING_PORT; - port_set_closed(x, false); - port_set_string_or_function(x, sc->nil); - port_data(x) = (uint8_t *)input_string; - port_data_block(x) = NULL; - port_data_size(x) = len; - port_position(x) = 0; - port_filename_block(x) = NULL; - port_filename_length(x) = 0; - port_filename(x) = NULL; - port_file_number(x) = 0; - port_line_number(x) = 0; - port_file(x) = NULL; - port_needs_free(x) = false; -#if S7_DEBUGGING - if ((len > 0) && (input_string[len] != '\0')) - { - fprintf(stderr, "%s[%d]: read_white_space string is not terminated: len: %" ld64 ", at end: %c%c, str: %s", - __func__, __LINE__, len, input_string[len - 1], input_string[len], input_string); - abort(); - } -#endif - port_port(x)->pf = &input_string_functions; - add_input_string_port(sc, x); - return(x); -} - -static /* inline */ s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str) /* why inline here? */ -{ - s7_pointer p = open_input_string(sc, string_value(str), string_length(str)); - port_set_string_or_function(p, str); - return(p); -} - -s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string) -{ - return(open_input_string(sc, input_string, safe_strlen(input_string))); -} - -static s7_pointer g_open_input_string(s7_scheme *sc, s7_pointer args) -{ - #define H_open_input_string "(open-input-string str) opens an input port reading str" - #define Q_open_input_string s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_string_symbol) - - s7_pointer input_string = car(args), port; - if (!is_string(input_string)) - return(sole_arg_method_or_bust(sc, input_string, sc->open_input_string_symbol, args, sc->type_names[T_STRING])); - port = open_and_protect_input_string(sc, input_string); - return(port); -} - - -/* -------------------------------- open-output-string -------------------------------- */ -#define FORMAT_PORT_LENGTH 128 -/* the large majority (> 99% in my tests) of the output strings have less than 128 chars when the port is finally closed - * 256 is slightly slower (the calloc time below dominates the realloc time in string_write_string) - * 64 is much slower (realloc dominates) - */ - -static const port_functions_t output_string_functions = - {output_read_char, string_write_char, string_write_string, NULL, NULL, NULL, NULL, output_read_line, string_display, close_output_string}; - -s7_pointer s7_open_output_string(s7_scheme *sc) -{ - s7_pointer x; - block_t *b = mallocate_port(sc); - block_t *block = inline_mallocate(sc, sc->initial_string_port_length); - new_cell(sc, x, T_OUTPUT_PORT); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - port_type(x) = STRING_PORT; - port_set_closed(x, false); - port_data_size(x) = sc->initial_string_port_length; - port_data_block(x) = block; - port_data(x) = (uint8_t *)(block_data(block)); - port_data(x)[0] = '\0'; /* in case s7_get_output_string before any output */ - port_position(x) = 0; - port_needs_free(x) = true; - port_filename_block(x) = NULL; - port_filename_length(x) = 0; /* protect against (port-filename (open-output-string)) */ - port_filename(x) = NULL; - port_port(x)->pf = &output_string_functions; - add_output_port(sc, x); - return(x); -} - -static s7_pointer g_open_output_string(s7_scheme *sc, s7_pointer unused_args) -{ - #define H_open_output_string "(open-output-string) opens an output string port" - #define Q_open_output_string s7_make_signature(sc, 1, sc->is_output_port_symbol) - return(s7_open_output_string(sc)); -} - - -/* -------------------------------- get-output-string -------------------------------- */ -const char *s7_get_output_string(s7_scheme *sc, s7_pointer p) -{ - port_data(p)[port_position(p)] = '\0'; - return((const char *)port_data(p)); -} - -s7_pointer s7_output_string(s7_scheme *sc, s7_pointer p) -{ - port_data(p)[port_position(p)] = '\0'; - return(make_string_with_length(sc, (const char *)port_data(p), port_position(p))); -} - -static inline void check_get_output_string_port(s7_scheme *sc, s7_pointer p) -{ - if (port_is_closed(p)) - wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, p, wrap_string(sc, "an active (open) string port", 28)); - if (port_position(p) > sc->max_string_length) - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "get-output-string port-position ~D is greater than (*s7* 'max-string-length)", 76), - wrap_integer(sc, port_position(p)))); -} -/* if pos>max and clear, where should the clear be? Not here because we might want to see output in error handler. - * similarly below if pos>size how can we call make_string (out-of-bounds) and ignore error? - * if pos>size shouldn't we raise an error somewhere? - */ - -static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args) -{ - #define H_get_output_string "(get-output-string port clear-port) returns the output accumulated in port. \ -If the optional 'clear-port' is #t, the current string is flushed." - #define Q_get_output_string s7_make_signature(sc, 3, sc->is_string_symbol, \ - s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), sc->is_boolean_symbol) - s7_pointer p; - bool clear_port = false; - - if (is_pair(cdr(args))) - { - p = cadr(args); - if (!is_boolean(p)) - wrong_type_error_nr(sc, sc->get_output_string_symbol, 2, p, sc->type_names[T_BOOLEAN]); - clear_port = (p == sc->T); - } - p = car(args); - if ((!is_output_port(p)) || (!is_string_port(p))) - { - if (p == sc->F) return(nil_string); - check_method(sc, p, sc->get_output_string_symbol, args); - wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, p, wrap_string(sc, "an open string output port or #f", 32)); - } - check_get_output_string_port(sc, p); - - if ((clear_port) && - (port_position(p) < port_data_size(p))) - { - block_t *block; - s7_pointer result = block_to_string(sc, port_data_block(p), port_position(p)); - /* this is slightly faster than make_string_with_length(sc, (char *)(port_data(p)), port_position(p)): we're trading a mallocate for a memcpy */ - port_data_size(p) = sc->initial_string_port_length; - block = inline_mallocate(sc, port_data_size(p)); - port_data_block(p) = block; - port_data(p) = (uint8_t *)(block_data(block)); - port_position(p) = 0; - port_data(p)[0] = '\0'; - return(result); - } - return(make_string_with_length(sc, (const char *)port_data(p), port_position(p))); -} - -static void op_get_output_string(s7_scheme *sc) -{ - s7_pointer port = sc->code; - if (!is_output_port(port)) - wrong_type_error_nr(sc, sc->with_output_to_string_symbol, 1, port, wrap_string(sc, "an open string output port", 26)); - check_get_output_string_port(sc, port); - - if (port_position(port) >= port_data_size(port)) /* can the > part happen? */ - sc->value = block_to_string(sc, reallocate(sc, port_data_block(port), port_position(port) + 1), port_position(port)); - else sc->value = block_to_string(sc, port_data_block(port), port_position(port)); - - port_data(port) = NULL; - port_data_size(port) = 0; - port_data_block(port) = NULL; - port_needs_free(port) = false; -} - -static s7_pointer g_get_output_string_uncopied(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = car(args); - if ((!is_output_port(p)) || (!is_string_port(p))) - { - if (p == sc->F) return(nil_string); - return(sole_arg_method_or_bust_p(sc, p, sc->get_output_string_symbol, wrap_string(sc, "an output string port", 21))); - } - check_get_output_string_port(sc, p); - return(wrap_string(sc, (const char *)port_data(p), port_position(p))); -} - - -/* -------------------------------- open-input-function -------------------------------- */ -static s7_pointer g_closed_input_function_port(s7_scheme *sc, s7_pointer unused_args) -{ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_1(sc, wrap_string(sc, "attempt to read from a closed input-function port", 49))); - return(NULL); -} - -static void close_input_function(s7_scheme *sc, s7_pointer p) -{ - port_port(p)->pf = &closed_port_functions; - port_set_string_or_function(p, sc->closed_input_function); /* from s7_make_function so it is GC-protected */ - port_set_closed(p, true); -} - -static const port_functions_t input_function_functions = - {function_read_char, input_write_char, input_write_string, NULL, NULL, NULL, NULL, function_read_line, input_display, close_input_function}; - -static void function_port_set_defaults(s7_pointer x) -{ - port_type(x) = FUNCTION_PORT; - port_data(x) = NULL; - port_data_block(x) = NULL; - port_set_closed(x, false); - port_needs_free(x) = false; - port_filename_block(x) = NULL; /* next three protect against port-filename misunderstandings */ - port_filename(x) = NULL; - port_filename_length(x) = 0; - port_file_number(x) = 0; - port_line_number(x) = 0; - port_file(x) = NULL; -} - -s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port)) -{ - s7_pointer x; - block_t *b = mallocate_port(sc); - new_cell(sc, x, T_INPUT_PORT); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - function_port_set_defaults(x); - port_set_string_or_function(x, sc->nil); - port_input_function(x) = function; - port_port(x)->pf = &input_function_functions; - add_input_port(sc, x); - return(x); -} - -static void init_open_input_function_choices(s7_scheme *sc) -{ - sc->open_input_function_choices[S7_READ] = sc->read_symbol; - sc->open_input_function_choices[S7_READ_CHAR] = sc->read_char_symbol; - sc->open_input_function_choices[S7_READ_LINE] = sc->read_line_symbol; - sc->open_input_function_choices[S7_PEEK_CHAR] = sc->peek_char_symbol; -#if (!WITH_PURE_S7) - sc->open_input_function_choices[S7_IS_CHAR_READY] = sc->is_char_ready_symbol; -#endif -} - -static s7_pointer input_scheme_function_wrapper(s7_scheme *sc, s7_read_t read_choice, s7_pointer port) -{ - return(s7_apply_function(sc, port_string_or_function(port), set_plist_1(sc, sc->open_input_function_choices[(int)read_choice]))); -} - -static s7_pointer g_open_input_function(s7_scheme *sc, s7_pointer args) -{ - #define H_open_input_function "(open-input-function func) opens an input function port" - #define Q_open_input_function s7_make_signature(sc, 2, sc->is_input_port_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - s7_pointer port, func = car(args); - - if (!is_any_procedure(func)) /* is_procedure is too lenient: we need to flag (open-input-function (block)) for example */ - sole_arg_wrong_type_error_nr(sc, sc->open_input_function_symbol, func, a_procedure_string); - if (!s7_is_aritable(sc, func, 1)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "input-function-port function, ~A, should take one argument", 58), func)); - - port = s7_open_input_function(sc, input_scheme_function_wrapper); - port_set_string_or_function(port, func); - return(port); -} - - -/* -------------------------------- open-output-function -------------------------------- */ -static s7_pointer g_closed_output_function_port(s7_scheme *sc, s7_pointer unused_args) -{ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_1(sc, wrap_string(sc, "attempt to write to a closed output-function port", 49))); - return(NULL); -} - -static void close_output_function(s7_scheme *sc, s7_pointer p) -{ - port_port(p)->pf = &closed_port_functions; - port_set_string_or_function(p, sc->closed_output_function); - port_set_closed(p, true); -} - -static const port_functions_t output_function_functions = - {output_read_char, function_write_char, function_write_string, NULL, NULL, NULL, NULL, output_read_line, function_display, close_output_function}; - -s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port)) -{ - s7_pointer x; - block_t *b = mallocate_port(sc); - new_cell(sc, x, T_OUTPUT_PORT); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - function_port_set_defaults(x); - port_output_function(x) = function; - port_set_string_or_function(x, sc->nil); - port_port(x)->pf = &output_function_functions; - add_output_port(sc, x); - return(x); -} - -static void output_scheme_function_wrapper(s7_scheme *sc, uint8_t c, s7_pointer port) -{ - s7_apply_function(sc, port_string_or_function(port), set_plist_1(sc, make_integer(sc, c))); -} - -static s7_pointer g_open_output_function(s7_scheme *sc, s7_pointer args) -{ - #define H_open_output_function "(open-output-function func) opens an output function port" - #define Q_open_output_function s7_make_signature(sc, 2, sc->is_output_port_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - s7_pointer port, func = car(args); - - if (!is_any_procedure(func)) - sole_arg_wrong_type_error_nr(sc, sc->open_output_function_symbol, func, a_procedure_string); - if (!s7_is_aritable(sc, func, 1)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "output-function-port function, ~A, should take one argument", 59), func)); - - port = s7_open_output_function(sc, output_scheme_function_wrapper); - port_set_string_or_function(port, func); - mark_function[T_OUTPUT_PORT] = mark_output_port; - return(port); -} - - -/* -------- current-input-port stack -------- */ -#define INPUT_PORT_STACK_INITIAL_SIZE 4 - -static inline void push_input_port(s7_scheme *sc, s7_pointer new_port) -{ - if (sc->input_port_stack_loc >= sc->input_port_stack_size) - { - sc->input_port_stack_size *= 2; - sc->input_port_stack = (s7_pointer *)Realloc(sc->input_port_stack, sc->input_port_stack_size * sizeof(s7_pointer)); - } - sc->input_port_stack[sc->input_port_stack_loc++] = current_input_port(sc); - set_current_input_port(sc, new_port); -} - -static void pop_input_port(s7_scheme *sc) -{ - set_current_input_port(sc, (sc->input_port_stack_loc > 0) ? sc->input_port_stack[--(sc->input_port_stack_loc)] : sc->standard_input); -} - -static s7_pointer input_port_if_not_loading(s7_scheme *sc) -{ - s7_pointer port = current_input_port(sc); - int32_t c; - if (!is_loader_port(port)) /* this flag is turned off by the reader macros, so we aren't in that context */ - return(port); - c = port_read_white_space(port)(sc, port); - if (c > 0) /* we can get either EOF or NULL at the end */ - { - backchar(c, port); - return(NULL); - } - return(sc->standard_input); -} - - -/* -------------------------------- read-char -------------------------------- */ -s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port) -{ - int32_t c = port_read_character(port)(sc, port); - return((c == EOF) ? eof_object : chars[c]); -} - -static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args) -{ - #define H_read_char "(read-char (port (current-input-port))) returns the next character in the input port" - #define Q_read_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol) - - s7_pointer port; - if (is_not_null(args)) - port = car(args); - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string)); - return(chars[port_read_character(port)(sc, port)]); -} - -static s7_pointer read_char_p_p(s7_scheme *sc, s7_pointer port) -{ - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string)); - return(chars[port_read_character(port)(sc, port)]); -} - -static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer port = car(args); - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string)); - return(chars[port_read_character(port)(sc, port)]); -} - -static s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 1) ? sc->read_char_1 : f); -} - - -/* -------------------------------- write-char -------------------------------- */ -s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer pt) -{ - if (pt != sc->F) - port_write_character(pt)(sc, s7_character(c), pt); - return(c); -} - -static s7_pointer write_char_p_pp(s7_scheme *sc, s7_pointer c, s7_pointer port) -{ - if (!is_character(c)) - return(method_or_bust_pp(sc, c, sc->write_char_symbol, c, port, sc->type_names[T_CHARACTER], 1)); - if (!is_output_port(port)) - { - if (port == sc->F) return(c); - check_method(sc, port, sc->write_char_symbol, set_mlist_2(sc, c, port)); - wrong_type_error_nr(sc, sc->write_char_symbol, 2, port, an_output_port_or_f_string); - } - port_write_character(port)(sc, s7_character(c), port); - return(c); -} - -static s7_pointer g_write_char(s7_scheme *sc, s7_pointer args) -{ - #define H_write_char "(write-char char (port (current-output-port))) writes char to the output port" - #define Q_write_char s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - return(write_char_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc))); -} - -static s7_pointer write_char_p_p(s7_scheme *sc, s7_pointer c) -{ - if (!is_character(c)) - return(method_or_bust_p(sc, c, sc->write_char_symbol, sc->type_names[T_CHARACTER])); - if (current_output_port(sc) == sc->F) return(c); - port_write_character(current_output_port(sc))(sc, s7_character(c), current_output_port(sc)); - return(c); -} - -/* (with-output-to-string (lambda () (write-char #\space))) -> " " - * (with-output-to-string (lambda () (write #\space))) -> "#\\space" - * (with-output-to-string (lambda () (display #\space))) -> " " - * is this correct? It's what Guile does. write-char is actually display-char. - */ - - -/* -------------------------------- peek-char -------------------------------- */ -s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port) -{ - int32_t c; /* needs to be an int32_t so EOF=-1, but not 255 */ - if (is_string_port(port)) - return((port_data_size(port) <= port_position(port)) ? chars[EOF] : chars[(uint8_t)port_data(port)[port_position(port)]]); - c = port_read_character(port)(sc, port); - if (c == EOF) return(eof_object); - backchar(c, port); - return(chars[c]); -} - -static s7_pointer g_peek_char(s7_scheme *sc, s7_pointer args) -{ - #define H_peek_char "(peek-char (port (current-input-port))) returns the next character in the input port, but does not remove it from the input stream" - #define Q_peek_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol) - - s7_pointer res, port = (is_not_null(args)) ? car(args) : current_input_port(sc); - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->peek_char_symbol, an_input_port_string)); - if (port_is_closed(port)) - sole_arg_wrong_type_error_nr(sc, sc->peek_char_symbol, port, an_open_input_port_string); - if (!is_function_port(port)) - return(s7_peek_char(sc, port)); - - res = (*(port_input_function(port)))(sc, S7_PEEK_CHAR, port); - if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, - set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned multiple values: ~S", 58), res)); - } - if (!is_character(res)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned: ~S", 42), res)); - return(res); -} - - -/* -------------------------------- read-byte -------------------------------- */ -static s7_pointer g_read_byte(s7_scheme *sc, s7_pointer args) -{ - #define H_read_byte "(read-byte (port (current-input-port))): reads a byte from the input port" - #define Q_read_byte s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol) - - s7_pointer port; - int32_t c; - - if (is_not_null(args)) - port = car(args); - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_byte_symbol, an_input_port_string)); - if (port_is_closed(port)) /* avoid reporting caller here as read-char */ - sole_arg_wrong_type_error_nr(sc, sc->read_byte_symbol, port, an_open_input_port_string); - c = port_read_character(port)(sc, port); - return((c == EOF) ? eof_object : small_int(c)); -} - - -/* -------------------------------- write-byte -------------------------------- */ -static s7_pointer g_write_byte(s7_scheme *sc, s7_pointer args) -{ - #define H_write_byte "(write-byte byte (port (current-output-port))): writes byte to the output port" - #define Q_write_byte s7_make_signature(sc, 3, sc->is_byte_symbol, sc->is_byte_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - - s7_pointer port, b = car(args); - s7_int val; - if (!s7_is_integer(b)) - return(method_or_bust(sc, car(args), sc->write_byte_symbol, args, sc->type_names[T_INTEGER], 1)); - - val = s7_integer_clamped_if_gmp(sc, b); - if ((val < 0) || (val > 255)) /* need to check this before port==#f, else (write-byte most-positive-fixnum #f) is not an error */ - wrong_type_error_nr(sc, sc->write_byte_symbol, 1, b, an_unsigned_byte_string); - - port = (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc); - if (!is_output_port(port)) - { - if (port == sc->F) return(car(args)); - check_method(sc, port, sc->write_byte_symbol, args); - wrong_type_error_nr(sc, sc->write_byte_symbol, 2, port, an_output_port_or_f_string); - } - if (port_is_closed(port)) /* avoid reporting caller here as write-char */ - wrong_type_error_nr(sc, sc->write_byte_symbol, 2, port, an_open_output_port_string); - - port_write_character(port)(sc, (uint8_t)val, port); - return(b); -} - - -/* -------------------------------- read-line -------------------------------- */ -static s7_pointer g_read_line(s7_scheme *sc, s7_pointer args) -{ - #define H_read_line "(read-line port (with-eol #f)) returns the next line from port, or #. \ -If 'with-eol' is not #f, read-line includes the trailing end-of-line character." - #define Q_read_line s7_make_signature(sc, 3, \ - s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), \ - sc->is_input_port_symbol, sc->is_boolean_symbol) - s7_pointer port; - bool with_eol = false; - if (is_not_null(args)) - { - port = car(args); - if (!is_input_port(port)) - return(method_or_bust(sc, port, sc->read_line_symbol, args, an_input_port_string, 1)); - - if (is_not_null(cdr(args))) - with_eol = (cadr(args) != sc->F); /* perhaps this should insist on #t: (read-line port (c-pointer 0)) */ - } - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - return(port_read_line(port)(sc, port, with_eol)); -} - -static s7_pointer read_line_p_pp(s7_scheme *sc, s7_pointer port, s7_pointer with_eol) -{ - if (!is_input_port(port)) - return(method_or_bust_pp(sc, port, sc->read_line_symbol, port, with_eol, an_input_port_string, 1)); - return(port_read_line(port)(sc, port, with_eol != sc->F)); -} - -static s7_pointer read_line_p_p(s7_scheme *sc, s7_pointer port) -{ - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_line_symbol, an_input_port_string)); - return(port_read_line(port)(sc, port, false)); /* with_eol default is #f */ -} - - -/* -------------------------------- read-string -------------------------------- */ -static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args) -{ - /* read-chars would be a better name -- read-string could mean CL-style read-from-string (like eval-string) - * similarly read-bytes could return a byte-vector (rather than r7rs's read-bytevector) - * and write-string -> write-chars, write-bytevector -> write-bytes - */ - #define H_read_string "(read-string k port) reads k characters from port into a new string and returns it." - #define Q_read_string s7_make_signature(sc, 3, \ - s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), \ - sc->is_integer_symbol, sc->is_input_port_symbol) - s7_pointer k = car(args), port, s; - s7_int nchars; - uint8_t *str; - - if (!s7_is_integer(k)) - return(method_or_bust(sc, k, sc->read_string_symbol, args, sc->type_names[T_INTEGER], 1)); - nchars = s7_integer_clamped_if_gmp(sc, k); - if ((nchars < 0) || (nchars > sc->max_string_length)) - out_of_range_error_nr(sc, sc->read_string_symbol, int_one, k, (nchars < 0) ? it_is_negative_string : it_is_too_large_string); - - if (!is_null(cdr(args))) - port = cadr(args); - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - if (!is_input_port(port)) - return(method_or_bust_pp(sc, port, sc->read_string_symbol, k, port, an_input_port_string, 2)); - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->read_string_symbol, 2, port, an_open_input_port_string); - - s = make_empty_string(sc, nchars, 0); - if (nchars == 0) return(s); - str = (uint8_t *)string_value(s); - if (is_string_port(port)) - { - s7_int pos = port_position(port); - s7_int end = port_data_size(port); - s7_int len = end - pos; - if (len > nchars) len = nchars; - if (len <= 0) return(eof_object); - memcpy((void *)str, (void *)(port_data(port) + pos), len); - string_length(s) = len; - str[len] = '\0'; - port_position(port) += len; - return(s); - } - if (is_file_port(port)) - { - size_t len = fread((void *)str, 1, nchars, port_file(port)); - str[len] = '\0'; - string_length(s) = len; - return(s); - } - for (s7_int i = 0; i < nchars; i++) - { - int32_t c = port_read_character(port)(sc, port); - if (c == EOF) - { - if (i == 0) - return(eof_object); - string_length(s) = i; - return(s); - } - str[i] = (uint8_t)c; - } - return(s); -} - - -/* -------------------------------- read -------------------------------- */ -#define declare_jump_info() bool old_longjmp; int32_t old_jump_loc, jump_loc; Jmp_Buf *old_goto_start; Jmp_Buf new_goto_start - -#define store_jump_info(Sc) \ - do { \ - old_longjmp = Sc->longjmp_ok; \ - old_jump_loc = Sc->setjmp_loc; \ - old_goto_start = Sc->goto_start; \ - } while (0) - -#define restore_jump_info(Sc) \ - do { \ - Sc->longjmp_ok = old_longjmp; \ - Sc->setjmp_loc = old_jump_loc; \ - Sc->goto_start = old_goto_start; \ - if ((jump_loc == ERROR_JUMP) && \ - (Sc->longjmp_ok)) \ - LongJmp(*(Sc->goto_start), ERROR_JUMP); \ - } while (0) - -#define set_jump_info(Sc, Tag) \ - do { \ - Sc->longjmp_ok = true; \ - Sc->setjmp_loc = Tag; \ - jump_loc = SetJmp(new_goto_start, 1); \ - Sc->goto_start = &new_goto_start; \ - } while (0) - -s7_pointer s7_read(s7_scheme *sc, s7_pointer port) -{ - if (is_input_port(port)) - { - s7_pointer old_let = sc->curlet; - declare_jump_info(); - sc->curlet = sc->nil; - push_input_port(sc, port); - store_jump_info(sc); - set_jump_info(sc, READ_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - } - else - { - push_stack_no_let_no_code(sc, OP_BARRIER, port); - push_stack_direct(sc, OP_EVAL_DONE); - eval(sc, OP_READ_INTERNAL); - if (sc->tok == TOKEN_EOF) - sc->value = eof_object; - if ((sc->cur_op == OP_EVAL_DONE) && /* pushed above */ - (stack_op(sc->stack, current_stack_top(sc) - 1) == OP_BARRIER)) - pop_stack(sc); - } - pop_input_port(sc); - set_curlet(sc, old_let); - restore_jump_info(sc); - return(sc->value); - } - sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, an_input_port_string); - return(NULL); -} - -static s7_pointer g_read(s7_scheme *sc, s7_pointer args) -{ - #define H_read "(read (port (current-input-port))) returns the next object in the input port, or # at the end" - #define Q_read s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol) - - s7_pointer port; - if (is_not_null(args)) - port = car(args); - else - { - port = input_port_if_not_loading(sc); - if (!port) return(eof_object); - } - if (!is_input_port(port)) - return(sole_arg_method_or_bust_p(sc, port, sc->read_symbol, an_input_port_string)); - - if (is_function_port(port)) - { - s7_pointer res = (*(port_input_function(port)))(sc, S7_READ, port); - if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), res)); - } - return(res); - } - if ((is_string_port(port)) && - (port_data_size(port) <= port_position(port))) - return(eof_object); - - push_input_port(sc, port); - push_stack_op_let(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */ - push_stack_op_let(sc, OP_READ_INTERNAL); - return(port); -} - - -/* -------------------------------- load -------------------------------- */ -#if WITH_MULTITHREAD_CHECKS -typedef struct { - s7_scheme* sc; - const int32_t lock_count; /* Remember lock count in case we have skipped calls to leave_track_scope by longjmp-ing */ -} lock_scope_t; - -static lock_scope_t enter_lock_scope(s7_scheme *sc) -{ - int32_t result = pthread_mutex_trylock(&sc->lock); - if (result != 0) - { - fprintf(stderr, "pthread_mutex_trylock failed: %d (EBUSY: %d)", result, EBUSY); - abort(); - } - sc->lock_count++; - { - lock_scope_t st = {.sc = sc, .lock_count = sc->lock_count}; - return(st); - } -} - -static void leave_lock_scope(lock_scope_t *st) -{ - while (st->sc->lock_count > st->lock_count) - { - st->sc->lock_count--; - pthread_mutex_unlock(&st->sc->lock); - } -} - -#define TRACK(Sc) lock_scope_t lock_scope __attribute__ ((__cleanup__(leave_lock_scope))) = enter_lock_scope(Sc) -#else -#define TRACK(Sc) -#endif - -/* various changes in this section courtesy of Woody Douglass 12-Jul-19 */ - -static block_t *search_load_path(s7_scheme *sc, const char *name) -{ - s7_pointer lst = s7_load_path(sc); - if (is_pair(lst)) - { -#if MS_WINDOWS || defined(__linux__) - #define S7_FILENAME_MAX 4096 /* so we can handle 4095 chars (need trailing null) -- this limit could be added to *s7* */ -#else - #define S7_FILENAME_MAX 1024 -#endif - /* linux: PATH_MAX: 4096, windows: MAX_PATH: unlimited?, Mac: 1016?, BSD: MAX_PATH_LENGTH: 1024 */ - block_t *b = mallocate(sc, S7_FILENAME_MAX); - char *filename = (char *)block_data(b); - s7_int name_len = safe_strlen(name); - for (s7_pointer dir_names = lst; is_pair(dir_names); dir_names = cdr(dir_names)) - { - const char *new_dir = string_value(car(dir_names)); - if (new_dir) - { - if ((WITH_WARNINGS) && (string_length(car(dir_names)) + name_len >= S7_FILENAME_MAX)) - s7_warn(sc, 256, "load: file + directory name too long: %" ld64 " + %" ld64 " > %d\n", - name_len, string_length(car(dir_names)), S7_FILENAME_MAX); - filename[0] = '\0'; - if (new_dir[strlen(new_dir) - 1] == '/') - catstrs(filename, S7_FILENAME_MAX, new_dir, name, (char *)NULL); - else catstrs(filename, S7_FILENAME_MAX, new_dir, "/", name, (char *)NULL); -#ifdef _MSC_VER - if (_access(filename, 0) != -1) - return(b); -#else - if (access(filename, F_OK) == 0) - return(b); -#endif - }} - liberate(sc, b); - } - return(NULL); -} - -#if WITH_C_LOADER -#include - -static block_t *full_filename(s7_scheme *sc, const char *filename) -{ - char *rtn; - block_t *block; - if ((S7_DEBUGGING) && ((!filename) || (!*filename))) fprintf(stderr, "%s[%d]: filename is %s\n", __func__, __LINE__, filename); - if (filename[0] == '/') - { - s7_int len = safe_strlen(filename); - block = mallocate(sc, len + 1); - rtn = (char *)block_data(block); - memcpy((void *)rtn, (void *)filename, len); - rtn[len] = '\0'; - } - else - { - char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */ - size_t pwd_len = safe_strlen(pwd); - size_t filename_len = safe_strlen(filename); - s7_int len = pwd_len + filename_len + 2; /* not 1! we need room for the '/' and the terminating 0 */ - block = mallocate(sc, len); - rtn = (char *)block_data(block); - if (pwd) - { - memcpy((void *)rtn, (void *)pwd, pwd_len); - rtn[pwd_len] = '/'; - memcpy((void *)(rtn + pwd_len + 1), (void *)filename, filename_len); - rtn[pwd_len + filename_len + 1] = '\0'; - free(pwd); - } - else /* isn't this an error? -- perhaps warn about getcwd, strerror(errno) */ - { - memcpy((void *)rtn, (void *)filename, filename_len); - rtn[filename_len] = '\0'; - }} - return(block); -} - -static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointer let) -{ - /* if fname ends in .so|.dylib, try loading it as a C shared object: (load "/home/bil/cl/m_j0.so" (inlet 'init_func 'init_m_j0)) */ - s7_int fname_len = safe_strlen(fname); - if (((fname_len > 3) && - (local_strcmp((const char *)(fname + (fname_len - 3)), ".so"))) || /* linux */ - ((fname_len > 6) && - (local_strcmp((const char *)(fname + (fname_len - 3)), ".dylib")))) /* mac */ - { - void *library; - char *pwd_name = NULL; - block_t *pname = NULL; - - if ((access(fname, F_OK) == 0) || (fname[0] == '/')) - { - pname = full_filename(sc, fname); - pwd_name = (char *)block_data(pname); - } - else - { - block_t *searched = search_load_path(sc, fname); /* returns NULL if *load-path* is nil, or if nothing matches */ - if (searched) - { - if (((const char *)block_data(searched))[0] == '/') - pname = searched; - else - { /* this is necessary, at least in Linux -- we can't blithely dlopen whatever is passed to us */ - pname = full_filename(sc, (const char *)block_data(searched)); - liberate(sc, searched); - } - pwd_name = (char *)block_data(pname); - } - else /* perhaps no *load-path* entries */ - { - pname = full_filename(sc, fname); - pwd_name = (char *)block_data(pname); - }} - if ((S7_DEBUGGING) && (!pname)) fprintf(stderr, "pname is null\n"); - library = dlopen((pname) ? pwd_name : fname, RTLD_NOW); - if (!library) - s7_warn(sc, 512, "load %s failed: %s\n", (pname) ? pwd_name : fname, dlerror()); - else - if (let) /* look for 'init_func in let */ - { - s7_pointer init = let_ref(sc, let, make_symbol(sc, "init_func", 9)); - /* init is a symbol (surely not a gensym?), so it should not need to be protected */ - if (!is_symbol(init)) - s7_warn(sc, 512, "can't load %s: no init function\n", fname); - else - { - const char *init_name; - void *init_func; - - if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, (pname) ? (const char *)pwd_name : fname))); - - init_name = symbol_name(init); - init_func = dlsym(library, init_name); - if (init_func) - { - typedef void (*dl_func)(s7_scheme *sc); - typedef s7_pointer (*dl_func_with_args)(s7_scheme *sc, s7_pointer args); - s7_pointer init_args = let_ref(sc, let, make_symbol(sc, "init_args", 9)); - s7_pointer p; - gc_protect_via_stack(sc, init_args); - if (is_pair(init_args)) - { - p = ((dl_func_with_args)init_func)(sc, init_args); - set_stack_protected2(sc, p); - } - /* if caller includes init_args, but init_func is actually a dl_func, it seems to be ok, - * but the returned value is whatever was last computed in the init_func. - */ - else - { - /* if the init_func is expecting args, but caller forgets init_args, this gives a segfault when - * init_func accesses the forgotten args. s7_is_valid can't catch this currently -- - * we need a better way to tell that a random value can't be a cell pointer (scan permallocs and use heap_location?) - */ - ((dl_func)init_func)(sc); - p = sc->F; - } - unstack(sc); - if (pname) liberate(sc, pname); - return(p); - } - s7_warn(sc, 512, "loaded %s, but can't find init_func %s, dlerror: %s, let: %s\n", - fname, init_name, dlerror(), display(let)); - dlclose(library); - } - if (S7_DEBUGGING) fprintf(stderr, "init_func trouble in %s, %s\n", fname, display(init)); - if (pname) liberate(sc, pname); - return(sc->undefined); - } - if (pname) liberate(sc, pname); - } - return(NULL); -} -#endif - -static s7_pointer load_file_1(s7_scheme *sc, const char *filename) -{ - char *local_file_name = (char *)filename; - FILE* fp = fopen(filename, "r"); -#if WITH_GCC - if ((!fp) && /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors */ - (filename[0] == '~') && (filename[1] == '/')) - { - char *home = getenv("HOME"); - if (home) - { - s7_int file_len = safe_strlen(filename); - s7_int home_len = safe_strlen(home); - s7_int len = file_len + home_len; - block_t *b = mallocate(sc, len); - char *fname = (char *)block_data(b); - memcpy((void *)fname, home, home_len); - memcpy((void *)(fname + home_len), (char *)(filename + 1), file_len - 1); - fname[len - 1] = '\0'; - fp = fopen(fname, "r"); - if (fp) local_file_name = copy_string_with_length(fname, len - 1); - liberate(sc, b); - }} -#endif - if (!fp) - { - const char *fname; - block_t *b = search_load_path(sc, filename); - if (!b) return(NULL); - fname = (const char *)block_data(b); - fp = fopen(fname, "r"); - if (fp) local_file_name = copy_string_with_length(fname, safe_strlen(fname)); - liberate(sc, b); - } - if (fp) - { - s7_pointer port; - if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, local_file_name))); - port = read_file(sc, fp, local_file_name, -1, "load"); /* -1 = read entire file into string, this is currently not tweakable */ - port_file_number(port) = remember_file_name(sc, local_file_name); - if (filename != local_file_name) free(local_file_name); - set_loader_port(port); - push_input_port(sc, port); - return(port); - } - return(NULL); -} - -s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e) -{ - /* returns either the value of the load or NULL if filename not found */ - s7_pointer port; - declare_jump_info(); - TRACK(sc); - if (e == sc->s7_starlet) return(NULL); - -#if WITH_C_LOADER - port = load_shared_object(sc, filename, (is_null(e)) ? sc->rootlet : e); - if (port) return(port); -#endif - - if (is_directory(filename)) return(NULL); - port = load_file_1(sc, filename); - if (!port) return(NULL); - - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); - - store_jump_info(sc); - set_jump_info(sc, LOAD_SET_JUMP); - if (jump_loc == NO_JUMP) - eval(sc, OP_READ_INTERNAL); - else - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - pop_input_port(sc); - if (is_input_port(port)) - s7_close_input_port(sc, port); - restore_jump_info(sc); - - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); -} - -s7_pointer s7_load(s7_scheme *sc, const char *filename) {return(s7_load_with_environment(sc, filename, sc->nil));} - -s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e) -{ - s7_pointer port; - s7_int port_loc; - declare_jump_info(); - TRACK(sc); - - if (content[bytes] != 0) - error_nr(sc, make_symbol(sc, "bad-data", 8), set_elist_1(sc, wrap_string(sc, "s7_load_c_string content is not terminated", 42))); - port = open_input_string(sc, content, bytes); - port_loc = gc_protect_1(sc, port); - set_loader_port(port); - push_input_port(sc, port); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); - s7_gc_unprotect_at(sc, port_loc); - - store_jump_info(sc); - set_jump_info(sc, LOAD_SET_JUMP); - if (jump_loc == NO_JUMP) - eval(sc, OP_READ_INTERNAL); - else - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - pop_input_port(sc); - if (is_input_port(port)) - s7_close_input_port(sc, port); - restore_jump_info(sc); - - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); -} - -s7_pointer s7_load_c_string(s7_scheme *sc, const char *content, s7_int bytes) -{ - return(s7_load_c_string_with_environment(sc, content, bytes, sc->nil)); -} - -static s7_pointer g_load(s7_scheme *sc, s7_pointer args) -{ - #define H_load "(load file (let (rootlet))) loads the scheme file 'file'. The 'let' argument \ -defaults to the rootlet. To load into the current environment instead, pass (curlet)." - #define Q_load s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol) - - s7_pointer name = car(args); - const char *fname; - - if (!is_string(name)) - return(method_or_bust(sc, name, sc->load_symbol, args, sc->type_names[T_STRING], 1)); - - if (is_pair(cdr(args))) - { - s7_pointer e = cadr(args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->load_symbol, 2, e, a_let_string); - if (e == sc->s7_starlet) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "can't load ~S into *s7*", 23), name)); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - } - else sc->curlet = sc->nil; - - fname = string_value(name); - if ((!fname) || (!(*fname))) /* fopen("", "r") returns a file pointer?? */ - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "load's first argument, ~S, should be a filename", 47), name)); - - if (is_directory(fname)) - error_nr(sc, sc->io_error_symbol, - set_elist_2(sc, wrap_string(sc, "load: ~S is a directory", 23), wrap_string(sc, fname, safe_strlen(fname)))); -#if WITH_C_LOADER - { - s7_pointer p = load_shared_object(sc, fname, (is_null(sc->curlet)) ? sc->rootlet : sc->curlet); - if (p) return(p); - } -#endif - errno = 0; - if (!load_file_1(sc, fname)) - file_error_nr(sc, "load", strerror(errno), fname); - - push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was pushing args and code, but I don't think they're used later */ - push_stack_op_let(sc, OP_READ_INTERNAL); - return(sc->unspecified); -} - - -/* -------- *load-path* -------- */ -s7_pointer s7_load_path(s7_scheme *sc) {return(s7_symbol_value(sc, sc->load_path_symbol));} - -s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir) -{ - s7_symbol_set_value(sc, sc->load_path_symbol, cons(sc, s7_make_string(sc, dir), s7_symbol_value(sc, sc->load_path_symbol))); - return(s7_symbol_value(sc, sc->load_path_symbol)); -} - -static s7_pointer g_load_path_set(s7_scheme *sc, s7_pointer args) -{ - /* new value must be either () or a proper list of strings */ - s7_pointer x; - if (is_null(cadr(args))) return(cadr(args)); - if (!is_pair(cadr(args))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args))); - for (x = cadr(args); is_pair(x); x = cdr(x)) - if (!is_string(car(x))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args))); - if (!is_null(x)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args))); - return(cadr(args)); -} - -/* -------- *cload-directory* -------- */ -static s7_pointer g_cload_directory_set(s7_scheme *sc, s7_pointer args) -{ - /* this sets the directory for cload.scm's output */ - s7_pointer cl_dir = cadr(args); - if (!is_string(cl_dir)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *cload-directory* to ~S", 33), cadr(args))); - s7_symbol_set_value(sc, sc->cload_directory_symbol, cl_dir); - if (string_length(cl_dir) > 0) /* was strlen(string_value)? */ - s7_add_to_load_path(sc, (const char *)(string_value(cl_dir))); - /* should this remove the previous *cload-directory* name first? or not affect *load-path* at all? */ - return(cl_dir); -} - - -/* ---------------- autoload ---------------- */ -#define INITIAL_AUTOLOAD_NAMES_SIZE 4 - -void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size) -{ - /* names should be sorted alphabetically by the symbol name (the even indexes in the names array) - * size is the number of symbol names (half the size of the names array( - * the idea here is that by sticking to string constants we can handle 90% of the work at compile-time, - * with less start-up memory. Then eventually we'll add C libraries and every name in those libraries - * will come as an import once dlopen has picked up the library. - */ - if (sc->safety > 1) - for (int32_t i = 0, k = 2; k < (size * 2); i += 2, k += 2) - if ((names[i]) && (names[k]) && (strcmp(names[i], names[k]) > 0)) - { - s7_warn(sc, 256, "%s: names[%d]: %s is out of order\n", __func__, k, names[k]); - break; - } - if (!sc->autoload_names) - { - sc->autoload_names = (const char ***)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(const char **)); - sc->autoload_names_sizes = (s7_int *)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(s7_int)); - sc->autoloaded_already = (bool **)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(bool *)); - sc->autoload_names_top = INITIAL_AUTOLOAD_NAMES_SIZE; - sc->autoload_names_loc = 0; - } - else - if (sc->autoload_names_loc >= sc->autoload_names_top) - { - sc->autoload_names_top *= 2; - sc->autoload_names = (const char ***)Realloc(sc->autoload_names, sc->autoload_names_top * sizeof(const char **)); - sc->autoload_names_sizes = (s7_int *)Realloc(sc->autoload_names_sizes, sc->autoload_names_top * sizeof(s7_int)); - sc->autoloaded_already = (bool **)Realloc(sc->autoloaded_already, sc->autoload_names_top * sizeof(bool *)); - for (s7_int i = sc->autoload_names_loc; i < sc->autoload_names_top; i++) - { - sc->autoload_names[i] = NULL; - sc->autoload_names_sizes[i] = 0; - sc->autoloaded_already[i] = NULL; - }} - sc->autoload_names[sc->autoload_names_loc] = names; - sc->autoload_names_sizes[sc->autoload_names_loc] = size; - sc->autoloaded_already[sc->autoload_names_loc] = (bool *)Calloc(size, sizeof(bool)); - sc->autoload_names_loc++; -} - -static const char *find_autoload_name(s7_scheme *sc, s7_pointer symbol, bool *already_loaded, bool loading) -{ - s7_int l = 0, libs = sc->autoload_names_loc; - const char *name = symbol_name(symbol); - for (s7_int lib = 0; lib < libs; lib++) - { - s7_int u = sc->autoload_names_sizes[lib] - 1; - const char **names = sc->autoload_names[lib]; - while (true) - { - s7_int comp, pos; - const char *this_name; - if (u < l) break; - pos = (l + u) / 2; - this_name = names[pos * 2]; - comp = strcmp(this_name, name); - if (comp == 0) - { - *already_loaded = sc->autoloaded_already[lib][pos]; - if (loading) sc->autoloaded_already[lib][pos] = true; - return(names[pos * 2 + 1]); /* file name given func name */ - } - if (comp < 0) - l = pos + 1; - else u = pos - 1; - }} - return(NULL); -} - -s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function) -{ - /* add '(symbol . file) to s7's autoload table */ - if (is_null(sc->autoload_table)) - sc->autoload_table = s7_make_hash_table(sc, sc->default_hash_table_length); /* add_hash_table here, perhaps sc->hash_tables->loc-- */ - if (sc->safety >= MORE_SAFETY_WARNINGS) - { - s7_pointer p = s7_hash_table_ref(sc, sc->autoload_table, symbol); - if ((p != sc->F) && (p != file_or_function)) - s7_warn(sc, 256, "'%s autoload value changed\n", symbol_name(symbol)); - } - s7_hash_table_set(sc, sc->autoload_table, symbol, file_or_function); - return(file_or_function); -} - -static s7_pointer g_autoload(s7_scheme *sc, s7_pointer args) -{ - #define H_autoload "(autoload symbol file-or-function) adds the symbol to its table of autoloadable symbols. \ -If that symbol is encountered as an unbound variable, s7 either loads the file (following *load-path*), or calls \ -the function. The function takes one argument, the calling environment. Presumably the symbol is defined \ -in the file, or by the function." - #define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T) - - s7_pointer sym = car(args), value; - if (is_string(sym)) - { - if (string_length(sym) == 0) /* (autoload "" ...) */ - wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a symbol-name or a symbol", 25)); - sym = make_symbol(sc, string_value(sym), string_length(sym)); - } - if (!is_symbol(sym)) - { - check_method(sc, sym, sc->autoload_symbol, args); - wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a string (symbol-name) or a symbol", 34)); - } - if (is_keyword(sym)) - wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a normal symbol (a keyword is never unbound)", 44)); - - value = cadr(args); - if (is_string(value)) - return(s7_autoload(sc, sym, s7_immutable(make_string_with_length(sc, string_value(value), string_length(value))))); - if (((is_closure(value)) || (is_closure_star(value))) && - (s7_is_aritable(sc, value, 1))) - return(s7_autoload(sc, sym, value)); - - check_method(sc, value, sc->autoload_symbol, args); - wrong_type_error_nr(sc, sc->autoload_symbol, 2, value, wrap_string(sc, "a string (file-name) or a thunk", 31)); - return(NULL); /* make tcc happy */ -} - - -/* -------------------------------- *autoload* -------------------------------- */ -static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args) /* the *autoload* function */ -{ - #define H_autoloader "(*autoload* sym) returns the autoload info for the symbol sym, or #f." - #define Q_autoloader s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol) - - s7_pointer sym = car(args); - if (!is_symbol(sym)) - { - check_method(sc, sym, sc->autoloader_symbol, set_plist_1(sc, sym)); - wrong_type_error_nr(sc, wrap_string(sc, "*autoload*", 10), 1, sym, sc->type_names[T_SYMBOL]); - } - if (sc->autoload_names) - { - bool loaded = false; - const char *file = find_autoload_name(sc, sym, &loaded, false); - if (file) - return(s7_make_string(sc, file)); - } - if (is_hash_table(sc->autoload_table)) - return(s7_hash_table_ref(sc, sc->autoload_table, sym)); - return(sc->F); -} - - -/* ---------------- require ---------------- */ -static bool is_memq(const s7_pointer sym, s7_pointer lst) -{ - for (s7_pointer x = lst; is_pair(x); x = cdr(x)) - if (sym == car(x)) - return(true); - return(false); -} - -static s7_pointer g_require(s7_scheme *sc, s7_pointer args) -{ - #define H_require "(require symbol . symbols) loads each file associated with each symbol if it has not been loaded already.\ -The symbols refer to the argument to \"provide\". (require lint.scm)" - /* #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->is_symbol_symbol) */ - - s7_gc_protect_via_stack(sc, args); - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer sym; - if (is_symbol(car(p))) - sym = car(p); - else - if ((is_proper_quote(sc, car(p))) && - (is_symbol(cadar(p)))) - sym = cadar(p); - else - { - unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "require: ~S is not a symbol", 27), car(p))); - } - if ((!is_memq(sym, s7_symbol_value(sc, sc->features_symbol))) && - (sc->is_autoloading)) - { - s7_pointer f = g_autoloader(sc, set_plist_1(sc, sym)); - if (is_false(sc, f)) - { - unstack(sc); - error_nr(sc, sc->autoload_error_symbol, - set_elist_2(sc, wrap_string(sc, "require: no autoload info for ~S", 32), sym)); - } - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, f)); - if (is_string(f)) - s7_load_with_environment(sc, string_value(f), sc->curlet); - else - if (is_closure(f)) /* f should be a function of one argument, the current (calling) environment */ - s7_call(sc, f, set_ulist_1(sc, sc->curlet, sc->nil)); - }} - if (((opcode_t)sc->stack_end[-1]) == OP_GC_PROTECT) /* op_error_quit if load failed in scheme in Snd */ - unstack(sc); - return(sc->T); -} - - -/* ---------------- provided? ---------------- */ -static s7_pointer g_is_provided(s7_scheme *sc, s7_pointer args) -{ - #define H_is_provided "(provided? symbol) returns #t if symbol is a member of the *features* list" - #define Q_is_provided s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_symbol_symbol) - - s7_pointer sym = car(args), topf, x; - if (!is_symbol(sym)) - return(method_or_bust_p(sc, sym, sc->is_provided_symbol, sc->type_names[T_SYMBOL])); - - /* here the *features* list is spread out (or can be anyway) along the curlet chain, - * so we need to travel back all the way to the top level checking each *features* list in turn. - * Since *features* grows via cons (newest first), we can stop the scan if we hit the shared - * top-level at least. - */ - topf = global_value(sc->features_symbol); - if (is_memq(sym, topf)) - return(sc->T); - - if (is_global(sc->features_symbol)) - return(sc->F); - for (x = sc->curlet; symbol_id(sc->features_symbol) < let_id(x); x = let_outlet(x)); - for (; is_let(x); x = let_outlet(x)) - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if ((slot_symbol(y) == sc->features_symbol) && - (slot_value(y) != topf) && - (is_memq(sym, slot_value(y)))) - return(sc->T); - return(sc->F); -} - -bool s7_is_provided(s7_scheme *sc, const char *feature) -{ - return(is_memq(make_symbol_with_strlen(sc, feature), s7_symbol_value(sc, sc->features_symbol))); /* this goes from local outward */ -} - -static bool is_provided_b_7p(s7_scheme *sc, s7_pointer sym) -{ - if (!is_symbol(sym)) - return(method_or_bust_p(sc, sym, sc->is_provided_symbol, sc->type_names[T_SYMBOL]) != sc->F); - return(is_memq(sym, s7_symbol_value(sc, sc->features_symbol))); -} - - -/* ---------------- provide ---------------- */ -static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) -{ - /* this has to be relative to the curlet: (load file env) - * the things loaded are only present in env, and go away with it, so should not be in the global *features* list - */ - s7_pointer p; - if (!is_symbol(sym)) - return(method_or_bust_p(sc, sym, sc->provide_symbol, sc->type_names[T_SYMBOL])); - - if ((S7_DEBUGGING) && (sc->curlet == sc->rootlet)) fprintf(stderr, "%s[%d]: curlet==rootlet!\n", __func__, __LINE__); - if ((sc->curlet == sc->nil) || (sc->curlet == sc->shadow_rootlet)) - p = global_slot(sc->features_symbol); - else p = symbol_to_local_slot(sc, sc->features_symbol, sc->curlet); /* if sc->curlet is nil, this returns the global slot, else local slot */ - if ((is_slot(p)) && (is_immutable(p))) - s7_warn(sc, 256, "provide: *features* is immutable!\n"); - else - { - s7_pointer lst = slot_value(lookup_slot_from(sc->features_symbol, sc->curlet)); /* in either case, we want the current *features* list */ - if (p == sc->undefined) - add_slot_checked_with_id(sc, sc->curlet, sc->features_symbol, cons(sc, sym, lst)); - else - if ((!is_memq(sym, lst)) && (!is_memq(sym, slot_value(p)))) - slot_set_value(p, cons(sc, sym, slot_value(p))); - } - return(sym); -} - -static s7_pointer g_provide(s7_scheme *sc, s7_pointer args) -{ - #define H_provide "(provide symbol) adds symbol to the *features* list" - #define Q_provide s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_symbol_symbol) - - if ((is_immutable(sc->curlet)) && - (sc->curlet != sc->nil)) - error_nr(sc, sc->immutable_error_symbol, - set_elist_2(sc, wrap_string(sc, "can't provide '~S (current environment is immutable)", 52), car(args))); - return(c_provide(sc, car(args))); -} - -void s7_provide(s7_scheme *sc, const char *feature) {c_provide(sc, make_symbol_with_strlen(sc, feature));} - - -static s7_pointer g_features_set(s7_scheme *sc, s7_pointer args) /* *features* setter */ -{ - s7_pointer nf = cadr(args); - if (is_null(nf)) - return(sc->nil); - if ((!is_pair(nf)) || - (s7_list_length(sc, nf) <= 0)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *features* to ~S", 26), nf)); - for (s7_pointer p = nf; is_pair(p); p = cdr(p)) - if (!is_symbol(car(p))) - sole_arg_wrong_type_error_nr(sc, sc->features_symbol, car(p), sc->type_names[T_SYMBOL]); - return(nf); -} - -static s7_pointer g_libraries_set(s7_scheme *sc, s7_pointer args) /* *libraries* setter */ -{ - s7_pointer nf = cadr(args); - if (is_null(nf)) - return(sc->nil); - if ((!is_pair(nf)) || - (s7_list_length(sc, nf) <= 0)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *libraries* to ~S", 27), nf)); - for (s7_pointer p = nf; is_pair(p); p = cdr(p)) - if ((!is_pair(car(p))) || - (!is_string(caar(p))) || - (!is_let(cdar(p)))) - sole_arg_wrong_type_error_nr(sc, sc->libraries_symbol, car(p), wrap_string(sc, "a list of conses of the form (string . let)", 43)); - return(nf); -} - - -/* -------------------------------- eval-string -------------------------------- */ -s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e) -{ - s7_pointer code, port, result; - TRACK(sc); - push_stack_direct(sc, OP_GC_PROTECT); /* not gc protection here, but restoration of original context */ - port = s7_open_input_string(sc, str); - code = s7_read(sc, port); - s7_close_input_port(sc, port); - result = s7_eval(sc, T_Ext(code), e); - if (((opcode_t)sc->stack_end[-1]) == OP_GC_PROTECT) - unstack(sc); /* pop_stack(sc); */ - return(result); -} - -s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str) {return(s7_eval_c_string_with_environment(sc, str, sc->nil));} - -static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args) -{ - #define H_eval_string "(eval-string str (let (curlet))) returns the result of evaluating the string str as Scheme code" - #define Q_eval_string s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol) - - s7_pointer port, str = car(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->eval_string_symbol, args, sc->type_names[T_STRING], 1)); - if (string_length(str) == 0) - return(sc->F); /* (eval-string "") -> #f */ - - if (is_not_null(cdr(args))) - { - s7_pointer e = cadr(args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->eval_string_symbol, 2, e, a_let_string); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - } - sc->temp3 = sc->args; /* see t101-aux-17.scm */ - push_stack(sc, OP_EVAL_STRING, args, sc->code); - port = open_and_protect_input_string(sc, str); - push_input_port(sc, port); - push_stack_op_let(sc, OP_READ_INTERNAL); - return(sc->F); /* I think this means that sc->value defaults to #f in op_eval_string below, so (eval-string "") mimics (eval) -> #f */ -} - -static s7_pointer eval_string_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - check_for_substring_temp(sc, expr); - return(f); -} - -static s7_pointer op_eval_string(s7_scheme *sc) -{ - while (s7_peek_char(sc, current_input_port(sc)) != eof_object) /* (eval-string "(+ 1 2) this is a mistake") */ - { - int32_t tk = token(sc); /* (eval-string "(+ 1 2) ; a comment (not a mistake)") */ - if (tk != TOKEN_EOF) - { - s7_pointer trail_data; - s7_int trail_len = port_data_size(current_input_port(sc)) - port_position(current_input_port(sc)) + 1; - if (trail_len > 32) trail_len = 32; - trail_data = make_string_with_length(sc, (const char *)(port_data(current_input_port(sc)) + port_position(current_input_port(sc)) - 1), trail_len); - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - error_nr(sc, sc->read_error_symbol, set_elist_2(sc, wrap_string(sc, "eval-string trailing junk: ~S", 29), trail_data)); - }} - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - sc->code = sc->value; - set_current_code(sc, sc->code); - return(NULL); -} - - -/* -------------------------------- call-with-input-string -------------------------------- */ -static s7_pointer call_with_input(s7_scheme *sc, s7_pointer port, s7_pointer args) -{ - s7_pointer p = cadr(args); - port_set_string_or_function(port, car(args)); - push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); /* # here is a marker (needed) */ - push_stack(sc, OP_APPLY, list_1(sc, port), p); - return(sc->F); -} - -static s7_pointer g_call_with_input_string(s7_scheme *sc, s7_pointer args) -{ - #define H_call_with_input_string "(call-with-input-string str proc) opens a string port for str and applies proc to it" - #define Q_call_with_input_string sc->pl_sf - /* (call-with-input-string "44" (lambda (p) (+ 1 (read p)))) -> 45 */ - - s7_pointer str = car(args), proc = cadr(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->call_with_input_string_symbol, args, sc->type_names[T_STRING], 1)); - - if (is_let(proc)) - check_method(sc, proc, sc->call_with_input_string_symbol, args); - - if (!s7_is_aritable(sc, proc, 1)) - wrong_type_error_nr(sc, sc->call_with_input_string_symbol, 2, proc, - wrap_string(sc, "a procedure of one argument (the port)", 38)); - if ((is_continuation(proc)) || (is_goto(proc))) - wrong_type_error_nr(sc, sc->call_with_input_string_symbol, 2, proc, a_normal_procedure_string); - return(call_with_input(sc, open_and_protect_input_string(sc, str), args)); -} - - -/* -------------------------------- call-with-input-file -------------------------------- */ -static s7_pointer g_call_with_input_file(s7_scheme *sc, s7_pointer args) -{ - #define H_call_with_input_file "(call-with-input-file filename proc) opens filename and calls proc with the input port as its argument" - #define Q_call_with_input_file sc->pl_sf - - s7_pointer str = car(args), proc = cadr(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->call_with_input_file_symbol, args, sc->type_names[T_STRING], 1)); - - if (!s7_is_aritable(sc, proc, 1)) - wrong_type_error_nr(sc, sc->call_with_input_file_symbol, 2, proc, - wrap_string(sc, "a procedure of one argument (the port)", 38)); - if ((is_continuation(proc)) || (is_goto(proc))) - wrong_type_error_nr(sc, sc->call_with_input_file_symbol, 2, proc, a_normal_procedure_string); - return(call_with_input(sc, open_input_file_1(sc, string_value(str), "r", "call-with-input-file"), args)); -} - - -/* -------------------------------- with-input-from-string -------------------------------- */ -static s7_pointer with_input(s7_scheme *sc, s7_pointer port, s7_pointer args) -{ - s7_pointer old_input_port = current_input_port(sc); - set_current_input_port(sc, port); - port_set_string_or_function(port, car(args)); - push_stack(sc, OP_UNWIND_INPUT, old_input_port, port); - push_stack(sc, OP_APPLY, sc->nil, cadr(args)); - return(sc->F); -} - -static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args) -{ - #define H_with_input_from_string "(with-input-from-string str thunk) opens str as the temporary current-input-port and calls thunk" - #define Q_with_input_from_string sc->pl_sf - - s7_pointer str = car(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->with_input_from_string_symbol, args, sc->type_names[T_STRING], 1)); - if (cadr(args) == global_value(sc->read_symbol)) - { - if (string_length(str) == 0) - return(eof_object); - push_input_port(sc, current_input_port(sc)); - set_current_input_port(sc, open_and_protect_input_string(sc, str)); - port_set_string_or_function(current_input_port(sc), str); - push_stack(sc, OP_UNWIND_INPUT, sc->unused, current_input_port(sc)); - push_stack_op_let(sc, OP_READ_DONE); - push_stack_op_let(sc, OP_READ_INTERNAL); - return(current_input_port(sc)); - } - if (!is_thunk(sc, cadr(args))) - return(method_or_bust(sc, cadr(args), sc->with_input_from_string_symbol, args, a_thunk_string, 2)); - /* since the arguments are evaluated before we get here, we can get some confusing situations: - * (with-input-from-string "#x2.1" (read)) - * (read) -> whatever it can get from the current input port! - * ";with-input-from-string argument 2, #, is untyped but should be a thunk" - * (with-input-from-string "" (read-line)) -> hangs awaiting stdin input - * also this can't be split into wifs and wifs_read because we need the runtime value of 'read - */ - return(with_input(sc, open_and_protect_input_string(sc, str), args)); -} - - -/* -------------------------------- with-input-from-file -------------------------------- */ -static s7_pointer g_with_input_from_file(s7_scheme *sc, s7_pointer args) -{ - #define H_with_input_from_file "(with-input-from-file filename thunk) opens filename as the temporary current-input-port and calls thunk" - #define Q_with_input_from_file sc->pl_sf - - if (!is_string(car(args))) - return(method_or_bust(sc, car(args), sc->with_input_from_file_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_thunk(sc, cadr(args))) - return(method_or_bust(sc, cadr(args), sc->with_input_from_file_symbol, args, a_thunk_string, 2)); - return(with_input(sc, open_input_file_1(sc, string_value(car(args)), "r", "with-input-from-file"), args)); -} - -static s7_pointer with_string_in(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer old_port = current_input_port(sc); - set_current_input_port(sc, open_and_protect_input_string(sc, sc->value)); - push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc)); - sc->curlet = inline_make_let(sc, sc->curlet); - return(opt2_pair(sc->code)); -} - -static s7_pointer with_file_in(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer old_port = current_input_port(sc); - set_current_input_port(sc, open_input_file_1(sc, string_value(sc->value), "r", "with-input-from-file")); - push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc)); - sc->curlet = inline_make_let(sc, sc->curlet); - return(opt2_pair(sc->code)); -} - -static s7_pointer with_file_out(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer old_port = current_output_port(sc); - set_current_output_port(sc, s7_open_output_file(sc, string_value(sc->value), "w")); - push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc)); - sc->curlet = make_let(sc, sc->curlet); - return(opt2_pair(sc->code)); -} - -static s7_pointer call_string_in(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer port = open_and_protect_input_string(sc, sc->value); - push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); - return(opt2_pair(sc->code)); -} - -static s7_pointer call_file_in(s7_scheme *sc, s7_pointer unused_args) -{ - s7_pointer port = open_input_file_1(sc, string_value(sc->value), "r", "with-input-from-file"); - push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); - return(opt2_pair(sc->code)); -} - -static s7_pointer call_file_out(s7_scheme *sc, s7_pointer args) -{ - s7_pointer port = s7_open_output_file(sc, string_value(sc->value), "w"); - push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); - sc->curlet = make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); - return(opt2_pair(sc->code)); -} - -static s7_pointer c_function_name_to_symbol(s7_scheme *sc, s7_pointer f) -{ - if (!is_c_function(f)) /* c_function* uses c_sym slot for arg_names */ - return(make_symbol(sc, c_function_name(f), c_function_name_length(f))); - if (!c_function_symbol(f)) - c_function_symbol(f) = make_symbol(sc, c_function_name(f), c_function_name_length(f)); - return(c_function_symbol(f)); -} - -#define op_with_io_1(Sc) (((s7_function)((Sc->code)->object.cons.opt1))(Sc, Sc->nil)) -static s7_pointer op_lambda(s7_scheme *sc, s7_pointer code); - -static void op_with_io_1_method(s7_scheme *sc) -{ - s7_pointer lt = sc->value; - if (has_active_methods(sc, lt)) - { - s7_pointer method = car(sc->code); - if (is_c_function(method)) /* #_call-with-input-string et al */ - method = c_function_name_to_symbol(sc, method); - push_stack(sc, OP_GC_PROTECT, lt, sc->code); - sc->code = caddr(sc->code); - sc->value = op_lambda(sc, sc->code); /* don't unstack */ - sc->value = find_and_apply_method(sc, lt, method, list_2(sc, lt, sc->value)); - } - else - if (is_symbol(car(sc->code))) /* might be e.g. #_call-with-input-string so use c_function_name */ - wrong_type_error_nr(sc, car(sc->code), 1, lt, sc->type_names[T_STRING]); - else wrong_type_error_nr(sc, wrap_string(sc, c_function_name(car(sc->code)), c_function_name_length(car(sc->code))), 1, lt, sc->type_names[T_STRING]); -} - -static bool op_with_io_op(s7_scheme *sc) -{ - sc->value = cadr(sc->code); - if (is_string(sc->value)) - { - sc->code = op_with_io_1(sc); - return(false); - } - push_stack_no_args_direct(sc, OP_WITH_IO_1); - sc->code = sc->value; - return(true); -} - -static void op_with_output_to_string(s7_scheme *sc) -{ - s7_pointer old_port = current_output_port(sc); - set_current_output_port(sc, s7_open_output_string(sc)); - push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc)); - sc->curlet = inline_make_let(sc, sc->curlet); - push_stack(sc, OP_GET_OUTPUT_STRING, old_port, current_output_port(sc)); - sc->code = opt2_pair(sc->code); -} - -static void op_call_with_output_string(s7_scheme *sc) -{ - s7_pointer port = s7_open_output_string(sc); - push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port); - push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); - sc->code = opt2_pair(sc->code); -} - - -/* -------------------------------- iterators -------------------------------- */ -#if S7_DEBUGGING -static s7_pointer titr_let(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if (!is_let(iterator_sequence(p))) - { - fprintf(stderr, "%s%s[%d]: let iterator sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer titr_pair(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if (!is_pair(iterator_sequence(p))) - { - fprintf(stderr, "%s%s[%d]: pair iterator sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer titr_hash(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if (!is_hash_table(iterator_sequence(p))) - { - fprintf(stderr, "%s%s[%d]: hash iterator sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer titr_len(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if ((is_hash_table(iterator_sequence(p))) || (is_pair(iterator_sequence(p)))) - { - fprintf(stderr, "%s%s[%d]: iterator length sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} - -static s7_pointer titr_pos(s7_scheme *sc, s7_pointer p, const char *func, int32_t line) -{ - if (((is_let(iterator_sequence(p))) && (iterator_sequence(p) != sc->rootlet) && (iterator_sequence(p) != sc->s7_starlet)) || - (is_pair(iterator_sequence(p)))) - { - fprintf(stderr, "%s%s[%d]: iterator-position sequence is %s%s\n", - BOLD_TEXT, func, line, check_name(sc, unchecked_type(iterator_sequence(p))), UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } - return(p); -} -#endif - - -/* -------------------------------- iterator? -------------------------------- */ -static s7_pointer g_is_iterator(s7_scheme *sc, s7_pointer args) -{ - #define H_is_iterator "(iterator? obj) returns #t if obj is an iterator." - #define Q_is_iterator sc->pl_bt - - s7_pointer x = car(args); - if (is_iterator(x)) return(sc->T); - /* closure itself is not an iterator: (let ((c1 (let ((+iterator+ #t) (a 0)) (lambda () (set! a (+ a 1)))))) (iterate c1)): error (a function not an iterator) */ - check_boolean_method(sc, is_iterator, sc->is_iterator_symbol, args); - return(sc->F); -} - -bool s7_is_iterator(s7_pointer obj) {return(is_iterator(obj));} - -static bool is_iterator_b_7p(s7_scheme *sc, s7_pointer obj) {return(g_is_iterator(sc, set_plist_1(sc, obj)) != sc->F);} - - -static s7_pointer iterator_copy(s7_scheme *sc, s7_pointer p) -{ - /* fields are obj cur [loc|lcur] [len|slow|hcur] next, but untangling them in debugging case is a pain */ - s7_pointer iter; - new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE); - memcpy((void *)iter, (void *)p, sizeof(s7_cell)); /* picks up ITER_OK I hope */ - return(iter); -} - -static s7_pointer iterator_finished(s7_scheme *sc, s7_pointer iterator) {return(ITERATOR_END);} - -static s7_pointer iterator_quit(s7_pointer iterator) -{ - iterator_next(iterator) = iterator_finished; - clear_iter_ok(iterator); - return(ITERATOR_END); -} - -static s7_pointer let_iterate(s7_scheme *sc, s7_pointer iterator) -{ - s7_pointer p, slot = iterator_current_slot(iterator); - if (!tis_slot(slot)) - return(iterator_quit(iterator)); - iterator_set_current_slot(iterator, next_slot(slot)); - p = iterator_let_cons(iterator); - if (!p) - return(cons(sc, slot_symbol(slot), slot_value(slot))); - set_car(p, slot_symbol(slot)); - set_cdr(p, slot_value(slot)); - return(p); -} - -static s7_pointer rootlet_iterate(s7_scheme *sc, s7_pointer iterator) -{ - s7_pointer slot = iterator_current(iterator); - if (!is_slot(slot)) - return(iterator_quit(iterator)); - if (iterator_position(iterator) < sc->rootlet_entries) - { - iterator_position(iterator)++; - iterator_current(iterator) = rootlet_element(sc->rootlet, iterator_position(iterator)); - } - else iterator_current(iterator) = sc->nil; - return(cons(sc, slot_symbol(slot), slot_value(slot))); -} - -static s7_pointer hash_entry_to_cons(s7_scheme *sc, hash_entry_t *entry, s7_pointer p) -{ - if (!p) - return(cons(sc, hash_entry_key(entry), hash_entry_value(entry))); - set_car(p, hash_entry_key(entry)); - set_cdr(p, hash_entry_value(entry)); - return(p); -} - -static s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator) -{ - s7_pointer table; - s7_int len; - hash_entry_t **elements; - hash_entry_t *lst = iterator_hash_current(iterator); - - if (lst) - { - iterator_hash_current(iterator) = hash_entry_next(lst); - return(hash_entry_to_cons(sc, lst, iterator_current(iterator))); - } - table = iterator_sequence(iterator); /* using iterator_length and hash_table_entries here was slightly slower */ - len = hash_table_mask(table) + 1; - elements = hash_table_elements(table); - - for (s7_int loc = iterator_position(iterator) + 1; loc < len; loc++) - { - hash_entry_t *x = elements[loc]; - if (x) - { - iterator_position(iterator) = loc; - iterator_hash_current(iterator) = hash_entry_next(x); - return(hash_entry_to_cons(sc, x, iterator_current(iterator))); - }} - if (is_weak_hash_table(table)) - { - clear_weak_hash_iterator(iterator); - weak_hash_iters(table)--; - } - return(iterator_quit(iterator)); -} - -static s7_pointer string_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(chars[(uint8_t)(string_value(iterator_sequence(obj))[iterator_position(obj)++])]); - return(iterator_quit(obj)); -} - -static s7_pointer byte_vector_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(small_int(byte_vector(iterator_sequence(obj), iterator_position(obj)++))); - return(iterator_quit(obj)); -} - -static s7_pointer float_vector_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(make_real(sc, float_vector(iterator_sequence(obj), iterator_position(obj)++))); - return(iterator_quit(obj)); -} - -static s7_pointer int_vector_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(make_integer(sc, int_vector(iterator_sequence(obj), iterator_position(obj)++))); - return(iterator_quit(obj)); -} - -static s7_pointer vector_iterate(s7_scheme *sc, s7_pointer obj) -{ - if (iterator_position(obj) < iterator_length(obj)) - return(vector_element(iterator_sequence(obj), iterator_position(obj)++)); - return(iterator_quit(obj)); -} - -static s7_pointer closure_iterate(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result = s7_call(sc, iterator_sequence(obj), sc->nil); - /* this can't use s7_apply_function -- we need to catch the error handler's longjmp here */ - if (result == ITERATOR_END) - { - iterator_next(obj) = iterator_finished; - clear_iter_ok(obj); - } - return(result); -} - -static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result, p, cur; - if (iterator_position(obj) >= iterator_length(obj)) - return(iterator_quit(obj)); - p = iterator_sequence(obj); - cur = iterator_current(obj); - set_car(cur, p); - set_car(cdr(cur), make_integer(sc, iterator_position(obj))); - result = (*(c_object_ref(sc, p)))(sc, cur); /* used to save/restore sc->x|z here */ - iterator_position(obj)++; - if (result == ITERATOR_END) - { - iterator_next(obj) = iterator_finished; - clear_iter_ok(obj); - } - return(result); -} - -static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer obj); -static s7_pointer pair_iterate(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result; - if (!is_pair(iterator_current(obj))) - return(iterator_quit(obj)); - result = car(iterator_current(obj)); - iterator_current(obj) = cdr(iterator_current(obj)); - if (iterator_current(obj) == iterator_slow(obj)) - iterator_current(obj) = sc->nil; - iterator_next(obj) = pair_iterate_1; - return(result); -} - -static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result; - if (!is_pair(iterator_current(obj))) - return(iterator_quit(obj)); - result = car(iterator_current(obj)); - iterator_current(obj) = cdr(iterator_current(obj)); - if (iterator_current(obj) == iterator_slow(obj)) - iterator_current(obj) = sc->nil; - else iterator_set_slow(obj, cdr(iterator_slow(obj))); - iterator_next(obj) = pair_iterate; - return(result); -} - -static s7_pointer find_make_iterator_method(s7_scheme *sc, s7_pointer e, s7_pointer iter) -{ - s7_pointer func; - if ((has_active_methods(sc, e)) && - ((func = find_method_with_let(sc, e, sc->make_iterator_symbol)) != sc->undefined)) - { - s7_pointer it; - gc_protect_via_stack(sc, iter); - it = s7_apply_function(sc, func, set_plist_1(sc, e)); - unstack(sc); - if (!is_iterator(it)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "make-iterator method must return an iterator: ~S", 48), it)); - return(it); - } - return(NULL); -} - - -/* -------------------------------- make-iterator -------------------------------- */ -static s7_pointer funclet_entry(s7_scheme *sc, s7_pointer x, s7_pointer sym) -{ - if ((has_closure_let(x)) && (is_let(closure_let(x)))) - { - s7_pointer val = symbol_to_local_slot(sc, sym, closure_let(x)); - if ((!is_slot(val)) && (is_let(let_outlet(closure_let(x))))) - val = symbol_to_local_slot(sc, sym, let_outlet(closure_let(x))); - if (is_slot(val)) - return(slot_value(val)); - } - return(NULL); -} - -static bool is_iterable_closure(s7_scheme *sc, s7_pointer x) -{ - s7_pointer iter; - if (!is_thunk(sc, x)) - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, x, a_thunk_string); - iter = funclet_entry(sc, x, sc->local_iterator_symbol); - return((iter) && (iter != sc->F)); -} - -static s7_pointer s7_starlet_make_iterator(s7_scheme *sc, s7_pointer iter); -static s7_int c_object_length_to_int(s7_scheme *sc, s7_pointer obj); - -s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) -{ - s7_pointer iter, p; - new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK); - iterator_sequence(iter) = e; - - if (is_pair(e)) /* by far the most common case */ - { - iterator_current(iter) = e; - iterator_next(iter) = pair_iterate; - iterator_set_slow(iter, e); - return(iter); - } - if (!is_let(e)) - iterator_position(iter) = 0; - - switch (type(e)) - { - case T_LET: - if (e == sc->rootlet) - { - iterator_current(iter) = rootlet_element(e, 0); /* unfortunately tricky -- let_iterate uses different fields */ - iterator_position(iter) = 0; - iterator_next(iter) = rootlet_iterate; - return(iter); - } - if (e == sc->s7_starlet) - return(s7_starlet_make_iterator(sc, iter)); - p = find_make_iterator_method(sc, e, iter); - if (p) {free_cell(sc, iter); return(p);} - iterator_set_current_slot(iter, let_slots(e)); - iterator_next(iter) = let_iterate; - iterator_let_cons(iter) = NULL; - break; - - case T_HASH_TABLE: - iterator_hash_current(iter) = NULL; - iterator_current(iter) = NULL; - iterator_position(iter) = -1; - iterator_next(iter) = hash_table_iterate; - if (is_weak_hash_table(e)) - { - set_weak_hash_iterator(iter); - weak_hash_iters(e)++; - add_weak_hash_iterator(sc, iter); - } - break; - - case T_STRING: - iterator_length(iter) = string_length(e); - iterator_next(iter) = string_iterate; - break; - - case T_BYTE_VECTOR: - iterator_length(iter) = byte_vector_length(e); - iterator_next(iter) = byte_vector_iterate; - break; - - case T_VECTOR: - iterator_length(iter) = vector_length(e); - iterator_next(iter) = vector_iterate; - break; - - case T_INT_VECTOR: - iterator_length(iter) = vector_length(e); - iterator_next(iter) = int_vector_iterate; - break; - - case T_FLOAT_VECTOR: - iterator_length(iter) = vector_length(e); - iterator_next(iter) = float_vector_iterate; - break; - - case T_NIL: /* (make-iterator #()) -> #, so I guess () should also work */ - iterator_length(iter) = 0; - iterator_next(iter) = iterator_finished; - clear_iter_ok(iter); - break; - - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - if (is_iterable_closure(sc, e)) - { - p = list_1_unchecked(sc, int_zero); - iterator_current(iter) = p; - set_mark_seq(iter); - iterator_next(iter) = closure_iterate; - iterator_length(iter) = (has_active_methods(sc, e)) ? closure_length(sc, e) : S7_INT64_MAX; - } - else - { - free_cell(sc, iter); - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, e, - wrap_string(sc, "a function or macro with a '+iterator+ local that is not #f", 59)); - } - break; - - case T_C_OBJECT: - iterator_length(iter) = c_object_length_to_int(sc, e); - p = find_make_iterator_method(sc, e, iter); - if (p) {free_cell(sc, iter); return(p);} - iterator_current(iter) = list_2_unchecked(sc, e, int_zero); /* if not unchecked, gc protect iter */ - set_mark_seq(iter); - iterator_next(iter) = c_object_iterate; - break; - - default: - free_cell(sc, iter); /* 19-Mar-22 */ - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, e, a_sequence_string); - } - return(iter); -} - -static s7_pointer g_make_iterator(s7_scheme *sc, s7_pointer args) -{ - #define H_make_iterator "(make-iterator sequence carrier) returns an iterator object that returns the next value \ -in the sequence each time it is called. When it reaches the end, it returns " ITERATOR_END_NAME "." - #define Q_make_iterator s7_make_signature(sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, sc->is_pair_symbol) - - /* we need to call s7_make_iterator before fixing up the optional second arg in case let->method */ - s7_pointer seq = car(args); - s7_pointer carrier = (is_pair(cdr(args))) ? cadr(args) : NULL; - s7_pointer iter = s7_make_iterator(sc, seq); - - if (carrier) - { - if (!is_pair(carrier)) - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, carrier, sc->type_names[T_PAIR]); - if (is_immutable_pair(carrier)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->make_iterator_symbol, carrier)); - - if (is_hash_table(iterator_sequence(iter))) - { - iterator_current(iter) = carrier; - set_mark_seq(iter); - } - else - if ((is_let(iterator_sequence(iter))) && - (iterator_sequence(iter) != sc->rootlet)) - { - iterator_let_cons(iter) = carrier; - set_mark_seq(iter); - }} - return(iter); -} - - -/* -------------------------------- iterate -------------------------------- */ -static s7_pointer g_iterate(s7_scheme *sc, s7_pointer args) -{ - #define H_iterate "(iterate obj) returns the next element from the iterator obj, or " ITERATOR_END_NAME "." - #define Q_iterate s7_make_signature(sc, 2, sc->T, sc->is_iterator_symbol) - s7_pointer iter = car(args); - if (!is_iterator(iter)) - return(sole_arg_method_or_bust(sc, iter, sc->iterate_symbol, args, sc->type_names[T_ITERATOR])); - return((iterator_next(iter))(sc, iter)); -} - -static s7_pointer iterate_p_p(s7_scheme *sc, s7_pointer iter) -{ - if (!is_iterator(iter)) - return(method_or_bust_p(sc, iter, sc->iterate_symbol, sc->type_names[T_ITERATOR])); - return((iterator_next(iter))(sc, iter)); -} - -s7_pointer s7_iterate(s7_scheme *sc, s7_pointer obj) {return((iterator_next(obj))(sc, obj));} - -bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer obj) -{ - if (!is_iterator(obj)) - sole_arg_wrong_type_error_nr(sc, sc->iterator_is_at_end_symbol, obj, sc->type_names[T_ITERATOR]); - return(!iter_ok(obj)); -} - -static bool op_implicit_iterate(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_iterator(s)) {sc->last_function = s; return(false);} - sc->value = (iterator_next(s))(sc, s); - return(true); -} - - -/* -------------------------------- iterator-at-end? -------------------------------- */ -static bool iterator_is_at_end_b_7p(s7_scheme *sc, s7_pointer obj) -{ - if (!is_iterator(obj)) - sole_arg_wrong_type_error_nr(sc, sc->iterator_is_at_end_symbol, obj, sc->type_names[T_ITERATOR]); - return(!iter_ok(obj)); -} - -static s7_pointer g_iterator_is_at_end(s7_scheme *sc, s7_pointer args) -{ - #define H_iterator_is_at_end "(iterator-at-end? iter) returns #t if the iterator has reached the end of its sequence." - #define Q_iterator_is_at_end s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_iterator_symbol) - s7_pointer iter = car(args); - if (!is_iterator(iter)) - return(sole_arg_method_or_bust(sc, iter, sc->iterator_is_at_end_symbol, args, sc->type_names[T_ITERATOR])); - return(make_boolean(sc, !iter_ok(iter))); -} - - -/* -------------------------------- iterator-sequence -------------------------------- */ -static s7_pointer g_iterator_sequence(s7_scheme *sc, s7_pointer args) -{ - #define H_iterator_sequence "(iterator-sequence iterator) returns the sequence that iterator is traversing." - #define Q_iterator_sequence s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_iterator_symbol) - s7_pointer iter = car(args); - if (!is_iterator(iter)) - return(sole_arg_method_or_bust(sc, iter, sc->iterator_sequence_symbol, args, sc->type_names[T_ITERATOR])); - return(iterator_sequence(iter)); -} - - -/* -------- cycles -------- */ - -#define INITIAL_SHARED_INFO_SIZE 8 - -static int32_t shared_ref(shared_info_t *ci, s7_pointer p) -{ - /* from print after collecting refs, not called by equality check, only called in object_to_port_with_circle_check_1 */ - s7_pointer *objs = ci->objs; - for (int32_t i = 0; i < ci->top; i++) - if (objs[i] == p) - { - int32_t val = ci->refs[i]; - if (val > 0) - ci->refs[i] = -ci->refs[i]; - return(val); - } - return(0); -} - -static void flip_ref(shared_info_t *ci, s7_pointer p) -{ - s7_pointer *objs = ci->objs; - for (int32_t i = 0; i < ci->top; i++) - if (objs[i] == p) - { - ci->refs[i] = -ci->refs[i]; - break; - } -} - -static int32_t peek_shared_ref_1(shared_info_t *ci, s7_pointer p) -{ - /* returns 0 if not found, otherwise the ref value for p */ - s7_pointer *objs = ci->objs; - for (int32_t i = 0; i < ci->top; i++) - if (objs[i] == p) - return(ci->refs[i]); - return(0); -} - -static int32_t peek_shared_ref(shared_info_t *ci, s7_pointer p) -{ - /* returns 0 if not found, otherwise the ref value for p */ - return((is_collected_unchecked(p)) ? peek_shared_ref_1(ci, p) : 0); -} - -static void enlarge_shared_info(shared_info_t *ci) -{ - ci->size *= 2; - ci->size2 = ci->size - 2; - ci->objs = (s7_pointer *)Realloc(ci->objs, ci->size * sizeof(s7_pointer)); - ci->refs = (int32_t *)Realloc(ci->refs, ci->size * sizeof(int32_t)); - ci->defined = (bool *)Realloc(ci->defined, ci->size * sizeof(bool)); - /* this clearing is needed, memclr is not faster */ - for (int32_t i = ci->top; i < ci->size; i++) - { - ci->refs[i] = 0; - ci->objs[i] = NULL; - } -} - -static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length); -static bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash); - -static bool check_collected(s7_pointer top, shared_info_t *ci) -{ - s7_pointer *objs_end = (s7_pointer *)(ci->objs + ci->top); - for (s7_pointer *p = ci->objs; p < objs_end; p++) - if ((*p) == top) - { - int32_t i = (int32_t)(p - ci->objs); - if (ci->refs[i] == 0) - { - ci->has_hits = true; - ci->refs[i] = ++ci->ref; /* if found, set the ref number */ - } - break; - } - set_cyclic(top); - return(true); -} - -static bool collect_vector_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length) -{ - s7_int plen; - bool cyclic = false; - - if (stop_at_print_length) - { - plen = sc->print_length; - if (plen > vector_length(top)) - plen = vector_length(top); - } - else plen = vector_length(top); - - for (s7_int i = 0; i < plen; i++) - { - s7_pointer vel = unchecked_vector_element(top, i); /* "unchecked" because top might be rootlet, I think */ - if ((has_structure(vel)) && - (collect_shared_info(sc, ci, vel, stop_at_print_length))) - { - set_cyclic(vel); - cyclic = true; - if ((is_c_pointer(vel)) || - (is_iterator(vel)) || - (is_c_object(vel))) - check_collected(top, ci); - }} - if (cyclic) set_cyclic(top); - return(cyclic); -} - -static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length) -{ - /* look for top in current list. - * As we collect objects (guaranteed to have structure) we set the collected bit. If we ever - * encounter an object with that bit on, we've seen it before so we have a possible cycle. - * Once the collection pass is done, we run through our list, and clear all these bits. - */ - bool top_cyclic; - - if (is_collected_or_shared(top)) - return((!is_shared(top)) && (check_collected(top, ci))); - - /* top not seen before -- add it to the list */ - set_collected(top); - - if (ci->top == ci->size) - enlarge_shared_info(ci); - ci->objs[ci->top++] = top; - - top_cyclic = false; - /* now search the rest of this structure */ - if (is_pair(top)) - { - s7_pointer p; - if ((has_structure(car(top))) && - (collect_shared_info(sc, ci, car(top), stop_at_print_length))) - top_cyclic = true; - - for (p = cdr(top); is_pair(p); p = cdr(p)) - { - if (is_collected_or_shared(p)) - { - set_cyclic(top); - set_cyclic(p); - if (!is_shared(p)) - return(check_collected(p, ci)); - if (!top_cyclic) - for (s7_pointer cp = top; cp != p; cp = cdr(cp)) set_shared(cp); - return(top_cyclic); - } - set_collected(p); - if (ci->top == ci->size) - enlarge_shared_info(ci); - ci->objs[ci->top++] = p; - if ((has_structure(car(p))) && - (collect_shared_info(sc, ci, car(p), stop_at_print_length))) - top_cyclic = true; - } - if ((has_structure(p)) && - (collect_shared_info(sc, ci, p, stop_at_print_length))) - { - set_cyclic(top); - return(true); - } - if (!top_cyclic) - for (s7_pointer cp = top; is_pair(cp); cp = cdr(cp)) set_shared(cp); - else set_cyclic(top); - return(top_cyclic); - } - - switch (type(top)) - { - case T_VECTOR: - if (collect_vector_info(sc, ci, top, stop_at_print_length)) - top_cyclic = true; - break; - - case T_ITERATOR: - if ((is_sequence(iterator_sequence(top))) && /* might be a function with +iterator+ local */ - (collect_shared_info(sc, ci, iterator_sequence(top), stop_at_print_length))) - { - if (peek_shared_ref(ci, iterator_sequence(top)) == 0) - check_collected(iterator_sequence(top), ci); - top_cyclic = true; - } - break; - - case T_HASH_TABLE: - if (hash_table_entries(top) > 0) - { - s7_int len = hash_table_mask(top) + 1; - hash_entry_t **entries = hash_table_elements(top); - bool keys_safe = hash_keys_not_cyclic(sc, top); - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = entries[i]; p; p = hash_entry_next(p)) - { - if ((!keys_safe) && - (has_structure(hash_entry_key(p))) && - (collect_shared_info(sc, ci, hash_entry_key(p), stop_at_print_length))) - top_cyclic = true; - if ((has_structure(hash_entry_value(p))) && - (collect_shared_info(sc, ci, hash_entry_value(p), stop_at_print_length))) - { - if ((is_c_pointer(hash_entry_value(p))) || - (is_iterator(hash_entry_value(p))) || - (is_c_object(hash_entry_value(p)))) - check_collected(top, ci); - top_cyclic = true; - }}} - break; - - case T_SLOT: /* this can be hit if we somehow collect_shared_info on sc->rootlet via collect_vector_info (see the let case below) */ - if ((has_structure(slot_value(top))) && - (collect_shared_info(sc, ci, slot_value(top), stop_at_print_length))) - top_cyclic = true; - break; - - case T_LET: - if (top == sc->rootlet) - { - if (collect_vector_info(sc, ci, top, stop_at_print_length)) - top_cyclic = true; - } - else - for (s7_pointer q = top; is_let(q) && (q != sc->rootlet); q = let_outlet(q)) - for (s7_pointer p = let_slots(q); tis_slot(p); p = next_slot(p)) - if ((has_structure(slot_value(p))) && - (collect_shared_info(sc, ci, slot_value(p), stop_at_print_length))) - { - top_cyclic = true; - if ((is_c_pointer(slot_value(p))) || - (is_iterator(slot_value(p))) || - (is_c_object(slot_value(p)))) - check_collected(top, ci); - } - break; - - case T_CLOSURE: - case T_CLOSURE_STAR: - if (collect_shared_info(sc, ci, closure_body(top), stop_at_print_length)) - { - if (peek_shared_ref(ci, top) == 0) - check_collected(top, ci); - top_cyclic = true; - } - break; - - case T_C_POINTER: - if ((has_structure(c_pointer_type(top))) && - (collect_shared_info(sc, ci, c_pointer_type(top), stop_at_print_length))) - { - if (peek_shared_ref(ci, c_pointer_type(top)) == 0) - check_collected(c_pointer_type(top), ci); - top_cyclic = true; - } - if ((has_structure(c_pointer_info(top))) && - (collect_shared_info(sc, ci, c_pointer_info(top), stop_at_print_length))) - { - if (peek_shared_ref(ci, c_pointer_info(top)) == 0) - check_collected(c_pointer_info(top), ci); - top_cyclic = true; - } - break; - - case T_C_OBJECT: - if ((c_object_to_list(sc, top)) && - (c_object_set(sc, top)) && - (collect_shared_info(sc, ci, (*(c_object_to_list(sc, top)))(sc, set_plist_1(sc, top)), stop_at_print_length))) - { - if (peek_shared_ref(ci, top) == 0) - check_collected(top, ci); - top_cyclic = true; - } - break; - } - if (!top_cyclic) - set_shared(top); - else set_cyclic(top); - return(top_cyclic); -} - -static shared_info_t *init_circle_info(s7_scheme *sc) -{ - shared_info_t *ci = (shared_info_t *)Calloc(1, sizeof(shared_info_t)); - ci->size = INITIAL_SHARED_INFO_SIZE; - ci->size2 = ci->size - 2; - ci->objs = (s7_pointer *)Malloc(ci->size * sizeof(s7_pointer)); - ci->refs = (int32_t *)Calloc(ci->size, sizeof(int32_t)); /* finder expects 0 = unseen previously */ - ci->defined = (bool *)Calloc(ci->size, sizeof(bool)); - ci->cycle_port = sc->F; - ci->init_port = sc->F; - return(ci); -} - -static inline shared_info_t *new_shared_info(s7_scheme *sc) -{ - shared_info_t *ci = sc->circle_info; - if (ci->top > 0) - { - memclr((void *)(ci->refs), ci->top * sizeof(int32_t)); - memclr((void *)(ci->defined), ci->top * sizeof(bool)); - for (int32_t i = 0; i < ci->top; i++) - clear_cyclic_bits(ci->objs[i]); /* LOOP_4 is not faster */ - ci->top = 0; - } - ci->ref = 0; - ci->has_hits = false; - ci->ctr = 0; - return(ci); -} - -static shared_info_t *make_shared_info(s7_scheme *sc, s7_pointer top, bool stop_at_print_length) -{ - /* for the printer, here only if is_structure(top) and top is not sc->rootlet */ - bool no_problem = true; - s7_int k, stop_len; - - /* check for simple cases first */ - if (is_pair(top)) - { - s7_pointer x = top; - if (stop_at_print_length) - { - s7_pointer slow = top; - stop_len = sc->print_length; - for (k = 0; k < stop_len; k += 2) - { - if (!is_pair(x)) break; - if (has_structure(car(x))) {no_problem = false; break;} - x = cdr(x); - if (!is_pair(x)) break; - if (has_structure(car(x))) {no_problem = false; break;} - x = cdr(x); - slow = cdr(slow); - if (x == slow) {no_problem = false; break;} - }} - else - if (s7_list_length(sc, top) == 0) /* it is circular at the top level (following cdr) */ - no_problem = false; - else - for (; is_pair(x); x = cdr(x)) - if (has_structure(car(x))) {no_problem = false; break;} /* perhaps (and (length > 0)) or vector typer etc */ - if ((no_problem) && - (!is_null(x)) && (has_structure(x))) - no_problem = false; - if (no_problem) return(NULL); - } - else - if (is_normal_vector(top)) /* any other vector can't happen */ - { - stop_len = vector_length(top); - if ((stop_at_print_length) && - (stop_len > sc->print_length)) - stop_len = sc->print_length; - for (k = 0; k < stop_len; k++) - if (has_structure(vector_element(top, k))) {no_problem = false; break;} - if (no_problem) return(NULL); - } -#if 1 - else /* added these 19-Oct-22 -- helps in tgc, but not much elsewhere */ - if ((is_let(top)) && (top != sc->rootlet)) - { - for (s7_pointer lp = top; (no_problem) && (is_let(lp)) && (lp != sc->rootlet); lp = let_outlet(lp)) - for (s7_pointer p = let_slots(lp); tis_slot(p); p = next_slot(p)) - if (has_structure(slot_value(p))) /* slot_symbol need not be checked? */ - {no_problem = false; break;} - if (no_problem) return(NULL); - } - else - if (is_hash_table(top)) - { - s7_int len = hash_table_mask(top) + 1; - hash_entry_t **entries = hash_table_elements(top); - bool keys_safe = hash_keys_not_cyclic(sc, top); - if (hash_table_entries(top) == 0) return(NULL); - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = entries[i]; p; p = hash_entry_next(p)) - if (((!keys_safe) && (has_structure(hash_entry_key(p)))) || - (has_structure(hash_entry_value(p)))) - {no_problem = false; break;} - if (no_problem) return(NULL); - } -#endif - if ((S7_DEBUGGING) && (is_any_vector(top)) && (!is_normal_vector(top))) fprintf(stderr, "%s[%d]: got abnormal vector\n", __func__, __LINE__); - - { - shared_info_t *ci = new_shared_info(sc); - /* collect all pointers associated with top */ - bool cyclic = collect_shared_info(sc, ci, top, stop_at_print_length); - s7_pointer *ci_objs = ci->objs; - int32_t *ci_refs = ci->refs; - int32_t refs = 0; - - for (int32_t i = 0; i < ci->top; i++) - clear_collected_and_shared(ci_objs[i]); - - if (!cyclic) - return(NULL); - if (!(ci->has_hits)) - return(NULL); - - /* find if any were referenced twice (once for just being there, so twice=shared) - * we know there's at least one such reference because has_hits is true. - */ - for (int32_t i = 0; i < ci->top; i++) - if (ci_refs[i] > 0) - { - set_collected(ci_objs[i]); - if (i == refs) - refs++; - else - { - ci_objs[refs] = ci_objs[i]; - ci_refs[refs++] = ci_refs[i]; - ci_refs[i] = 0; - ci_objs[i] = NULL; - }} - ci->top = refs; - return(ci); - } -} - - -/* -------------------------------- cyclic-sequences -------------------------------- */ -static s7_pointer cyclic_sequences_p_p(s7_scheme *sc, s7_pointer obj) -{ - if (has_structure(obj)) - { - shared_info_t *ci = (sc->object_out_locked) ? sc->circle_info : make_shared_info(sc, obj, false); /* false=don't stop at print length (vectors etc) */ - if (ci) - { - s7_pointer lst; - sc->w = sc->nil; - check_free_heap_size(sc, ci->top); - for (int32_t i = 0; i < ci->top; i++) - sc->w = cons_unchecked(sc, ci->objs[i], sc->w); - lst = sc->w; - sc->w = sc->unused; - return(lst); - }} - return(sc->nil); -} - -static s7_pointer g_cyclic_sequences(s7_scheme *sc, s7_pointer args) -{ - #define H_cyclic_sequences "(cyclic-sequences obj) returns a list of elements that are cyclic." - #define Q_cyclic_sequences s7_make_signature(sc, 2, sc->is_proper_list_symbol, sc->T) - return(cyclic_sequences_p_p(sc, car(args))); -} - - -/* -------------------------------- object->port (display format etc) -------------------------------- */ -static int32_t circular_list_entries(s7_pointer lst) -{ - int32_t i = 1; - for (s7_pointer x = cdr(lst); ; i++, x = cdr(x)) - { - int32_t j = 0; - for (s7_pointer y = lst; j < i; y = cdr(y), j++) - if (x == y) - return(i); - } -} - -static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer vr, s7_pointer port, use_write_t use_write, shared_info_t *ci); -#define object_to_port_with_circle_check(Sc, Vr, Port, Use_Write, Ci) \ - do { \ - s7_pointer _V_ = Vr; \ - if ((Ci) && (has_structure(_V_))) \ - object_to_port_with_circle_check_1(Sc, _V_, Port, Use_Write, Ci); \ - else object_to_port(Sc, _V_, Port, Use_Write, Ci); \ - } while (0) - -static void (*display_functions[256])(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci); -#define object_to_port(Sc, Obj, Port, Use_Write, Ci) (*display_functions[unchecked_type(Obj)])(Sc, Obj, Port, Use_Write, Ci) - -static bool string_needs_slashification(const uint8_t *str, s7_int len) -{ - /* we have to go by len (str len) not *s==0 because s7 strings can have embedded nulls */ - const uint8_t *pend = (const uint8_t *)(str + len); - for (const uint8_t *p = str; p < pend; p++) - if (slashify_table[*p]) - return(true); - return(false); -} - -#define IN_QUOTES true -#define NOT_IN_QUOTES false - -static void slashify_string_to_port(s7_scheme *sc, s7_pointer port, const char *p, s7_int len, bool quoted) -{ - uint8_t *pcur, *pend, *pstart = NULL; - if (len == 0) - { - if (quoted) - port_write_string(port)(sc, "\"\"", 2, port); - return; - } - pend = (uint8_t *)(p + len); - - /* what about the trailing nulls? Guile writes them out (as does s7 currently) - * but that is not ideal. I'd like to use ~S for error messages, so that - * strings are clearly identified via the double-quotes, but this way of - * writing them is ugly: - * (let ((str (make-string 8 #\null))) (set! (str 0) #\a) str) -> "a\x00\x00\x00\x00\x00\x00\x00" - * but it would be misleading to omit them because: - * (let ((str (make-string 8 #\null))) (set! (str 0) #\a) (string-append str "bc")) -> "a\x00\x00\x00\x00\x00\x00\x00bc" - * also it is problematic to use sc->print_length here (rather than a separate string-print-length) because - * it is normally (say) 8 which truncates just about every string. In CL, *print-length* - * does not affect strings, symbols, or bit-vectors. But if the string is enormous, - * this function can bring us to a complete halt. string-print-length (as a *s7* field) is - * also problematic -- it does not behave as expected in many cases if it is limited to this - * function and string_to_port below, and if set too low, disables the repl. - */ - if (quoted) port_write_character(port)(sc, '"', port); - for (pcur = (uint8_t *)p; pcur < pend; pcur++) - if (slashify_table[*pcur]) - { - if (pstart) pstart++; else pstart = (uint8_t *)p; - if (pstart != pcur) - { - port_write_string(port)(sc, (char *)pstart, pcur - pstart, port); - pstart = pcur; - } - port_write_character(port)(sc, '\\', port); - switch (*pcur) - { - case '"': port_write_character(port)(sc, '"', port); break; - case '\\': port_write_character(port)(sc, '\\', port); break; - case '\'': port_write_character(port)(sc, '\'', port); break; - case '\t': port_write_character(port)(sc, 't', port); break; - case '\r': port_write_character(port)(sc, 'r', port); break; - case '\b': port_write_character(port)(sc, 'b', port); break; - case '\f': port_write_character(port)(sc, 'f', port); break; - case '\?': port_write_character(port)(sc, '?', port); break; - case 'x': port_write_character(port)(sc, 'x', port); break; - default: - { - char buf[5]; - s7_int n = (s7_int)(*pcur); - buf[0] = 'x'; - buf[1] = (n < 16) ? '0' : dignum[(n / 16) % 16]; - buf[2] = dignum[n % 16]; - buf[3] = ';'; - buf[4] = '\0'; - port_write_string(port)(sc, buf, 4, port); - } - break; - }} - if (!pstart) - port_write_string(port)(sc, (char *)p, len, port); - else - { - pstart++; - if (pstart != pcur) - port_write_string(port)(sc, (char *)pstart, pcur - pstart, port); - } - if (quoted) port_write_character(port)(sc, '"', port); -} - -static void output_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if ((obj == sc->standard_output) || - (obj == sc->standard_error)) - port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port); - else - if (use_write == P_READABLE) - { - if (port_is_closed(obj)) - port_write_string(port)(sc, "(let ((p (open-output-string))) (close-output-port p) p)", 56, port); - else - if (is_string_port(obj)) - { - port_write_string(port)(sc, "(let ((p (open-output-string)))", 31, port); - if (port_position(obj) > 0) - { - port_write_string(port)(sc, " (display ", 10, port); - slashify_string_to_port(sc, port, (const char *)port_data(obj), port_position(obj), IN_QUOTES); - port_write_string(port)(sc, " p)", 3, port); - } - port_write_string(port)(sc, " p)", 3, port); - } - else - if (is_file_port(obj)) - { - char str[256]; - int32_t nlen; - str[0] = '\0'; - nlen = catstrs(str, 256, "(open-output-file \"", port_filename(obj), "\" \"a\")", (char *)NULL); - port_write_string(port)(sc, str, nlen, port); - } - else port_write_string(port)(sc, "#", 23, port); - } - else - { - if (is_string_port(obj)) - port_write_string(port)(sc, "#", 8, port); - else port_write_character(port)(sc, '>', port); - } -} - -static void input_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (obj == sc->standard_input) - port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port); - else - if (use_write == P_READABLE) - { - if (port_is_closed(obj)) - port_write_string(port)(sc, "(call-with-input-string \"\" (lambda (p) p))", 42, port); - else - if (is_function_port(obj)) - port_write_string(port)(sc, "#", 22, port); - else - if (is_file_port(obj)) - { - char str[256]; - int32_t nlen; - str[0] = '\0'; - nlen = catstrs(str, 256, "(open-input-file \"", port_filename(obj), "\")", (char *)NULL); - port_write_string(port)(sc, str, nlen, port); - } - else - { - s7_int data_len = port_data_size(obj) - port_position(obj); - if (data_len > 100) - { - const char *filename = (const char *)s7_port_filename(sc, obj); - if (filename) - { - #define DO_STR_LEN 1024 - char do_str[DO_STR_LEN]; - int32_t len; - do_str[0] = '\0'; - if (port_position(obj) > 0) - { - len = catstrs(do_str, DO_STR_LEN, "(let ((port (open-input-file \"", filename, "\")))", (char *)NULL); - port_write_string(port)(sc, do_str, len, port); - do_str[0] = '\0'; - len = catstrs(do_str, DO_STR_LEN, " (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i ", - pos_int_to_str_direct(sc, port_position(obj) - 1), - ") port)))", (char *)NULL); - } - else len = catstrs(do_str, DO_STR_LEN, "(open-input-file \"", filename, "\")", (char *)NULL); - port_write_string(port)(sc, do_str, len, port); - return; - }} - port_write_string(port)(sc, "(open-input-string ", 19, port); - /* not port_write_string here because there might be embedded double-quotes */ - slashify_string_to_port(sc, port, (const char *)(port_data(obj) + port_position(obj)), port_data_size(obj) - port_position(obj), IN_QUOTES); - port_write_character(port)(sc, ')', port); - }} - else - { - if (is_string_port(obj)) - port_write_string(port)(sc, "#", 8, port); - else port_write_character(port)(sc, '>', port); - } -} - -static bool symbol_needs_slashification(s7_scheme *sc, s7_pointer obj) -{ - uint8_t *pend; - const char *str = symbol_name(obj); - s7_int len; - - if ((str[0] == '#') || (str[0] == '\'') || (str[0] == ',')) - return(true); - if (is_number(make_atom(sc, (char *)str, 10, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR))) - return(true); - - len = symbol_name_length(obj); - pend = (uint8_t *)(str + len); - for (uint8_t *p = (uint8_t *)str; p < pend; p++) - if (symbol_slashify_table[*p]) - return(true); - set_clean_symbol(obj); - return(false); -} - -static /* inline */ void symbol_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - /* I think this is the only place we print a symbol's name; ci is needed to be a display_function, it is not used */ - if ((!is_clean_symbol(obj)) && - (symbol_needs_slashification(sc, obj))) - { - port_write_string(port)(sc, "(symbol \"", 9, port); - slashify_string_to_port(sc, port, symbol_name(obj), symbol_name_length(obj), NOT_IN_QUOTES); - port_write_string(port)(sc, "\")", 2, port); - } - else - { - char c = '\0'; - if ((use_write == P_READABLE) || (use_write == P_CODE)) - { - if (!is_keyword(obj)) c = '\''; - } - else if ((use_write == P_KEY) && (!is_keyword(obj))) c = ':'; - if (is_string_port(port)) - { - s7_int new_len = port_position(port) + symbol_name_length(obj) + ((c) ? 1 : 0); - if (new_len >= port_data_size(port)) - resize_port_data(sc, port, new_len * 2); - if (c) port_data(port)[port_position(port)++] = c; - memcpy((void *)(port_data(port) + port_position(port)), (void *)symbol_name(obj), symbol_name_length(obj)); - port_position(port) = new_len; - } - else - { - if (c) port_write_character(port)(sc, c, port); - port_write_string(port)(sc, symbol_name(obj), symbol_name_length(obj), port); - }} -} - -static char *multivector_indices_to_string(s7_scheme *sc, s7_int index, s7_pointer vect, char *str, int32_t str_len, int32_t cur_dim) -{ - s7_int size = vector_dimension(vect, cur_dim); - s7_int ind = index % size; - if (cur_dim > 0) - multivector_indices_to_string(sc, (index - ind) / size, vect, str, str_len, cur_dim - 1); - catstrs(str, str_len, " ", pos_int_to_str_direct(sc, ind), (char *)NULL); - return(str); -} - -#define NOT_P_DISPLAY(Choice) ((Choice == P_DISPLAY) ? P_WRITE : Choice) - -static int32_t multivector_to_port_1(s7_scheme *sc, s7_pointer vec, s7_pointer port, - int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, bool *last, - use_write_t use_write, shared_info_t *ci) -{ - if (use_write != P_READABLE) - { - if (*last) - port_write_string(port)(sc, " (", 2, port); - else port_write_character(port)(sc, '(', port); - (*last) = false; - } - for (int32_t i = 0; i < vector_dimension(vec, dimension); i++) - if (dimension == (dimensions - 1)) - { - if (flat_ref < out_len) - { - object_to_port_with_circle_check(sc, vector_getter(vec)(sc, vec, flat_ref), port, NOT_P_DISPLAY(use_write), ci); - - if (use_write == P_READABLE) - port_write_string(port)(sc, ") ", 2, port); - flat_ref++; - } - else - { - port_write_string(port)(sc, "...)", 4, port); - return(flat_ref); - } - if ((use_write != P_READABLE) && - (i < (vector_dimension(vec, dimension) - 1))) - port_write_character(port)(sc, ' ', port); - } - else - if (flat_ref < out_len) - flat_ref = multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension + 1, dimensions, last, NOT_P_DISPLAY(use_write), ci); - else - { - port_write_string(port)(sc, "...)", 4, port); - return(flat_ref); - } - if (use_write != P_READABLE) - port_write_character(port)(sc, ')', port); - (*last) = true; - return(flat_ref); -} - -static int32_t multivector_to_port(s7_scheme *sc, s7_pointer vec, s7_pointer port, - int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, - use_write_t use_write, shared_info_t *ci) -{ - bool last = false; - return(multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension, dimensions, &last, use_write, ci)); -} - -static void make_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port) -{ - s7_int vlen; - int32_t plen; - char buf[128]; - const char* vtyp = ""; - - if (is_float_vector(vect)) - vtyp = "float-"; - else - if (is_int_vector(vect)) - vtyp = "int-"; - else - if (is_byte_vector(vect)) - vtyp = "byte-"; - vlen = vector_length(vect); - - if (vector_rank(vect) == 1) - { - plen = catstrs_direct(buf, "(make-", vtyp, "vector ", integer_to_string_no_length(sc, vlen), " ", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else - { - s7_int dim; - plen = catstrs_direct(buf, "(make-", vtyp, "vector '(", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - for (dim = 0; dim < vector_ndims(vect) - 1; dim++) - { - plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), " ", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), ") ", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } -} - -static void write_vector_dimensions(s7_scheme *sc, s7_pointer vect, s7_pointer port) -{ - char buf[128]; - s7_int dim, plen; - port_write_string(port)(sc, " '(", 3, port); - for (dim = 0; dim < vector_ndims(vect) - 1; dim++) - { - plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), " ", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - plen = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), "))", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); -} - -static void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port); - -static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - s7_int i, len = vector_length(vect), plen; - bool too_long = false; - char buf[2048]; /* 128 is too small -- this is the list of indices with a few minor flourishes */ - - if (len == 0) - { - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_string(port)(sc, "#()", 3, port); - return; - } - if (use_write != P_READABLE) - { - if (sc->print_length == 0) - { - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d(...)", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_string(port)(sc, "#(...)", 6, port); - return; - } - if (len > sc->print_length) - { - too_long = true; - len = sc->print_length; - }} - if ((!ci) && - (len > 1000)) - { - s7_int vlen = vector_length(vect); - s7_pointer *els = vector_elements(vect); - s7_pointer p0 = els[0]; - for (i = 1; i < vlen; i++) - if (els[i] != p0) - break; - if (i == vlen) - { - make_vector_to_port(sc, vect, port); - object_to_port(sc, p0, port, use_write, NULL); - if (is_typed_vector(vect)) - { - port_write_character(port)(sc, ' ', port); - port_write_vector_typer(sc, vect, port); - } - port_write_character(port)(sc, ')', port); - return; - }} - - check_stack_size(sc); - s7_gc_protect_via_stack(sc, vect); - if (use_write == P_READABLE) - { - int32_t vref; - if ((ci) && - (is_cyclic(vect)) && - ((vref = peek_shared_ref(ci, vect)) != 0)) - { - s7_pointer *els = vector_elements(vect); - if (vref < 0) vref = -vref; - if ((ci->defined[vref]) || (port == ci->cycle_port)) - { - plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, vref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - unstack(sc); - return; - } - - if (is_typed_vector(vect)) - port_write_string(port)(sc, "(let (( ", 11, port); - - if (vector_rank(vect) > 1) - port_write_string(port)(sc, "(subvector ", 11, port); - - port_write_string(port)(sc, "(vector", 7, port); /* top level let */ - for (i = 0; i < len; i++) - if (has_structure(els[i])) - { - int32_t eref = peek_shared_ref(ci, els[i]); - port_write_string(port)(sc, " #f", 3, port); - if (eref != 0) - { - if (eref < 0) eref = -eref; - if (vector_rank(vect) > 1) - { - s7_int dimension = vector_rank(vect) - 1; - int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); - block_t *b = callocate(sc, str_len); - char *indices = (char *)block_data(b); - multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* calls pos_int_to_str_direct, writes to indices */ - plen = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), ">", - indices, ") <", pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - liberate(sc, b); - } - else - { - size_t len1 = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string(sc, i, &plen), ") <", - pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port); - }} - else - { - if (vector_rank(vect) > 1) - { - s7_int dimension = vector_rank(vect) - 1; - int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); - block_t *b = callocate(sc, str_len); - char *indices = (char *)block_data(b); - buf[0] = '\0'; - multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* writes to indices */ - plen = catstrs(buf, 2048, " (set! (<", pos_int_to_str_direct(sc, vref), ">", indices, ") ", (char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - liberate(sc, b); - } - else - { - size_t len1 = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string_no_length(sc, i), ") ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port); - } - object_to_port_with_circle_check(sc, els[i], ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - }} - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, els[i], port, P_READABLE, ci); - } - port_write_character(port)(sc, ')', port); - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - write_vector_dimensions(sc, vect, port); - } - if (is_typed_vector(vect)) - { - port_write_string(port)(sc, ")) (set! (vector-typer ) ", 28, port); - port_write_vector_typer(sc, vect, port); - port_write_string(port)(sc, ") )", 6, port); - }} - else - { - if (is_typed_vector(vect)) - port_write_string(port)(sc, "(let (( ", 11, port); - /* (let ((v (make-vector 3 'a symbol?))) (object->string v :readable)): "(let (( (vector 'a 'a 'a))) (set! (vector-typer ) symbol?) )" */ - - if (vector_rank(vect) > 1) - port_write_string(port)(sc, "(subvector ", 11, port); - - if (is_immutable_vector(vect)) - port_write_string(port)(sc, "(immutable! ", 12, port); - - port_write_string(port)(sc, "(vector", 7, port); - for (i = 0; i < len; i++) - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, vector_element(vect, i), port, P_READABLE, ci); - } - - if (is_immutable_vector(vect)) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - - if (vector_rank(vect) > 1) /* subvector above */ - { - plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - write_vector_dimensions(sc, vect, port); - } - if (is_typed_vector(vect)) - { - port_write_string(port)(sc, ")) (set! (vector-typer ) ", 28, port); - port_write_vector_typer(sc, vect, port); - port_write_string(port)(sc, ") )", 6, port); - }}} - else /* not readable write */ - { - if (vector_rank(vect) > 1) - { - if (vector_ndims(vect) > 1) - { - plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_character(port)(sc, '#', port); - multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), use_write, ci); - } - else - { - port_write_string(port)(sc, "#(", 2, port); - for (i = 0; i < len - 1; i++) - { - object_to_port_with_circle_check(sc, vector_element(vect, i), port, NOT_P_DISPLAY(use_write), ci); - port_write_character(port)(sc, ' ', port); - } - object_to_port_with_circle_check(sc, vector_element(vect, i), port, NOT_P_DISPLAY(use_write), ci); - - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - }} - unstack(sc); -} - -static int32_t print_vector_length(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write) -{ - int32_t plen, len = vector_length(vect); - char buf[128]; - const char *vtype = "r"; - - if (is_int_vector(vect)) vtype = "i"; - else if (is_byte_vector(vect)) vtype = "u"; - if (len == 0) - { - if (vector_rank(vect) > 1) - plen = catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)(const char *)NULL); - else plen = catstrs_direct(buf, "#", vtype, "()", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - return(-1); - } - if (use_write == P_READABLE) - return(len); - if (sc->print_length != 0) - return((len > sc->print_length) ? sc->print_length : len); - - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d(...)", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else - if (is_int_vector(vect)) - port_write_string(port)(sc, "#i(...)", 7, port); - else - if (is_float_vector(vect)) - port_write_string(port)(sc, "#r(...)", 7, port); - else port_write_string(port)(sc, "#u(...)", 7, port); - return(-1); -} - -static void int_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - s7_int plen; - bool too_long; - char buf[128]; - char *p; - s7_int len = print_vector_length(sc, vect, port, use_write); - if (len < 0) return; - too_long = (len < vector_length(vect)); - - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (len > 1000) - { - s7_int i, vlen = vector_length(vect); - s7_int *els = int_vector_ints(vect); - s7_int first = els[0]; - for (i = 1; i < vlen; i++) - if (els[i] != first) - break; - if (i == vlen) - { - make_vector_to_port(sc, vect, port); - p = integer_to_string(sc, int_vector(vect, 0), &plen); - port_write_string(port)(sc, p, plen, port); - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - return; - }} - if (vector_rank(vect) == 1) - { - port_write_string(port)(sc, "#i(", 3, port); - if (!is_string_port(port)) - { - p = integer_to_string(sc, int_vector(vect, 0), &plen); - port_write_string(port)(sc, p, plen, port); - for (s7_int i = 1; i < len; i++) - { - plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - }} - else - { - s7_int new_len = port_position(port); - s7_int next_len = port_data_size(port) - 128; - uint8_t *dbuf = port_data(port); - if (new_len >= next_len) - { - resize_port_data(sc, port, port_data_size(port) * 2); - next_len = port_data_size(port) - 128; - dbuf = port_data(port); - } - p = integer_to_string(sc, int_vector(vect, 0), &plen); - memcpy((void *)(dbuf + new_len), (void *)p, plen); - new_len += plen; - for (s7_int i = 1; i < len; i++) - { - if (new_len >= next_len) - { - resize_port_data(sc, port, port_data_size(port) * 2); - next_len = port_data_size(port) - 128; - dbuf = port_data(port); - } - plen = catstrs_direct((char *)(dbuf + new_len), " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL); - new_len += plen; - } - port_position(port) = new_len; - } - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - } - else - { - plen = catstrs_direct(buf, "#i", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - s7_gc_protect_via_stack(sc, vect); - multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), P_DISPLAY, NULL); - unstack(sc); - } - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); -} - -static void float_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - #define FV_BUFSIZE 512 /* some floats can take around 312 bytes */ - char buf[FV_BUFSIZE]; - s7_int i, plen; - bool too_long; - s7_double *els = float_vector_floats(vect); - s7_int len = print_vector_length(sc, vect, port, use_write); - if (len < 0) return; /* vector-length=0 etc */ - too_long = (len < vector_length(vect)); - - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (len > 1000) - { - s7_int vlen = vector_length(vect); - s7_double first = els[0]; - for (i = 1; i < vlen; i++) - if (els[i] != first) - break; - if (i == vlen) - { - make_vector_to_port(sc, vect, port); - plen = snprintf(buf, FV_BUFSIZE, "%.*g)", sc->float_format_precision, first); - port_write_string(port)(sc, buf, clamp_length(plen, FV_BUFSIZE), port); - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); - return; - }} - - if (vector_rank(vect) == 1) - { - port_write_string(port)(sc, "#r(", 3, port); - plen = snprintf(buf, FV_BUFSIZE - 4, "%.*g", sc->float_format_precision, els[0]); /* -4 so floatify has room */ - floatify(buf, &plen); - port_write_string(port)(sc, buf, clamp_length(plen, FV_BUFSIZE), port); - for (i = 1; i < len; i++) - { - plen = snprintf(buf, FV_BUFSIZE - 4, " %.*g", sc->float_format_precision, els[i]); - plen--; /* fixup for the initial #\space */ - floatify((char *)(buf + 1), &plen); - port_write_string(port)(sc, buf, clamp_length(plen + 1, FV_BUFSIZE), port); - } - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - } - else - { - plen = catstrs_direct(buf, "#r", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - s7_gc_protect_via_stack(sc, vect); - multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), P_DISPLAY, NULL); - unstack(sc); - } - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); -} - -static void byte_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - s7_int i, plen; - bool too_long; - char buf[128]; - char *p; - s7_int len = print_vector_length(sc, vect, port, use_write); - if (len < 0) return; - too_long = (len < vector_length(vect)); - - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (len > 1000) - { - s7_int vlen = vector_length(vect); - uint8_t *els = byte_vector_bytes(vect); - uint8_t first = els[0]; - for (i = 1; i < vlen; i++) - if (els[i] != first) - break; - if (i == vlen) - { - make_vector_to_port(sc, vect, port); - p = integer_to_string(sc, byte_vector(vect, 0), &plen); /* only 0..10 start out with names: init_small_ints */ - port_write_string(port)(sc, p, plen, port); - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - return; - }} - - if (vector_rank(vect) == 1) - { - port_write_string(port)(sc, "#u(", 3, port); - p = integer_to_string(sc, byte_vector(vect, 0), &plen); - port_write_string(port)(sc, p, plen, port); - for (i = 1; i < len; i++) - { - plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, byte_vector(vect, i)), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - } - else - { - plen = catstrs_direct(buf, "#u", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), P_DISPLAY, NULL); - } - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); -} - -static void string_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - bool immutable = ((use_write == P_READABLE) && - (is_immutable_string(obj)) && - (string_length(obj) > 0)); /* (immutable "") looks dumb */ - if (immutable) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (string_length(obj) > 0) - { - /* since string_length is a scheme length, not C, this write can embed nulls from C's point of view */ - if (string_length(obj) > 1000) /* was 10000 28-Feb-18 */ - { - size_t size; - char buf[128]; - buf[0] = string_value(obj)[0]; - buf[1] = '\0'; - size = strspn((const char *)(string_value(obj) + 1), buf); /* if all #\null, this won't work */ - if (size == (size_t)(string_length(obj) - 1)) - { - s7_pointer c = chars[(int32_t)((uint8_t)(buf[0]))]; - int32_t nlen = catstrs_direct(buf, "(make-string ", pos_int_to_str_direct(sc, string_length(obj)), " ", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - port_write_string(port)(sc, character_name(c), character_name_length(c), port); - if (immutable) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - return; - }} - if (use_write == P_DISPLAY) - port_write_string(port)(sc, string_value(obj), string_length(obj), port); - else - if (!string_needs_slashification((const uint8_t *)string_value(obj), string_length(obj))) - { - port_write_character(port)(sc, '"', port); - port_write_string(port)(sc, string_value(obj), string_length(obj), port); - port_write_character(port)(sc, '"', port); - } - else slashify_string_to_port(sc, port, string_value(obj), string_length(obj), IN_QUOTES); - } - else - if (use_write != P_DISPLAY) - port_write_string(port)(sc, "\"\"", 2, port); - - if (immutable) - port_write_character(port)(sc, ')', port); -} - -static s7_int list_length_with_immutable_check(s7_scheme *sc, s7_pointer a, bool *immutable) -{ - s7_pointer slow = a, fast = a; - for (s7_int i = 0; ; i += 2) - { - if (!is_pair(fast)) return((is_null(fast)) ? i : -i); - if (is_immutable(fast)) *immutable = true; - fast = cdr(fast); - if (!is_pair(fast)) return((is_null(fast)) ? (i + 1) : (-i - 1)); - if (is_immutable(fast)) *immutable = true; - fast = cdr(fast); - slow = cdr(slow); - if (fast == slow) return(0); - } - return(0); -} - -static void simple_list_readable_display(s7_scheme *sc, s7_pointer lst, s7_int true_len, s7_int len, s7_pointer port, shared_info_t *ci, bool immutable) -{ - /* the easier cases: no circles or shared refs to patch up */ - s7_pointer x; - - if ((true_len > 0) && (!immutable)) - { - port_write_string(port)(sc, "list", 4, port); - for (x = lst; is_pair(x); x = cdr(x)) - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, car(x), port, P_READABLE, ci); - } - port_write_character(port)(sc, ')', port); - } - else - { - s7_int immutable_ctr = 0; - if (is_immutable(lst)) - { - port_write_string(port)(sc, "immutable! (cons ", 17, port); - immutable_ctr++; - } - else port_write_string(port)(sc, "cons ", 5, port); - object_to_port_with_circle_check(sc, car(lst), port, P_READABLE, ci); - - for (x = cdr(lst); is_pair(x); x = cdr(x)) - { - if (is_immutable(x)) - { - port_write_string(port)(sc, " (immutable! (cons ", 19, port); - immutable_ctr++; - } - else port_write_string(port)(sc, " (cons ", 7, port); - object_to_port_with_circle_check(sc, car(x), port, P_READABLE, ci); - } - if (is_null(x)) - port_write_string(port)(sc, " ()", 3, port); - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, x, port, P_READABLE, ci); - } - for (s7_int i = (true_len <= 0) ? 1 : 0; i < len; i++) - port_write_character(port)(sc, ')', port); - for (s7_int i = 0; i < immutable_ctr; i++) - port_write_character(port)(sc, ')', port); - } -} - -static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - s7_pointer x; - s7_int i, len; - bool immutable = false; - s7_int true_len = list_length_with_immutable_check(sc, lst, &immutable); - if (true_len < 0) /* a dotted list -- handle cars, then final cdr */ - len = (-true_len + 1); - else len = (true_len == 0) ? circular_list_entries(lst) : true_len; /* circular list (nil is handled by unique_to_port) */ - - if ((use_write == P_READABLE) && - (ci)) - { - int32_t href = peek_shared_ref(ci, lst); - if (href != 0) - { - if (href < 0) href = -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - return; - }}} - - if ((use_write != P_READABLE) && - (car(lst) == sc->quote_symbol) && - (true_len == 2)) - { - /* len == 1 is important, otherwise (list 'quote 1 2) -> '1 2 which looks weird - * or (object->string (apply . `''1)) -> "'quote 1" - * so (quote x) = 'x but (quote x y z) should be left alone (if evaluated, it's an error) - * :readable is tricky because the list might be something like (list 'quote (lambda () #f)) which needs to be evalable back to its original - */ - port_write_character(port)(sc, '\'', port); - object_to_port_with_circle_check(sc, cadr(lst), port, P_WRITE, ci); - return; - } - - if (is_multiple_value(lst)) - port_write_string(port)(sc, "(values ", 8, port); - else port_write_character(port)(sc, '(', port); - - check_stack_size(sc); - s7_gc_protect_via_stack(sc, lst); - - if (use_write == P_READABLE) - { - if (!is_cyclic(lst)) - { - /* here (and in the cyclic case) we need to handle immutable pairs -- this requires using cons rather than list etc */ - simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); - unstack(sc); - return; - } - if (ci) - { - int32_t plen; - s7_pointer local_port; - char buf[128], lst_name[128]; - bool lst_local = false; - int32_t lst_ref = peek_shared_ref(ci, lst); - if (lst_ref == 0) - { - s7_pointer p; - for (p = lst; is_pair(p); p = cdr(p)) - if ((has_structure(car(p))) || - ((is_pair(cdr(p))) && - (peek_shared_ref(ci, cdr(p)) != 0))) - { - lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0'; - lst_local = true; - port_write_string(port)(sc, "let (( (list", 15, port); /* '(' above */ - break; - } - if (!lst_local) - { - if (has_structure(p)) - { - lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0'; - lst_local = true; - port_write_string(port)(sc, "let (( (list", 15, port); /* '(' above */ - } - else - { - simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); - unstack(sc); - return; - }}} - else - { - if (lst_ref < 0) lst_ref = -lst_ref; - catstrs_direct(lst_name, "<", pos_int_to_str_direct(sc, lst_ref), ">", (const char *)NULL); - port_write_string(port)(sc, "list", 4, port); /* '(' above */ - } - - for (i = 0, x = lst; (i < len) && (is_pair(x)); x = cdr(x), i++) - { - if ((has_structure(car(x))) && - (is_cyclic(car(x)))) - port_write_string(port)(sc, " #f", 3, port); - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, car(x), port, use_write, ci); - } - if ((is_pair(cdr(x))) && - (peek_shared_ref(ci, cdr(x)) != 0)) - break; - } - - if (lst_local) - port_write_string(port)(sc, "))) ", 4, port); - else port_write_character(port)(sc, ')', port); - - /* fill in the cyclic entries */ - local_port = ((lst_local) || (ci->cycle_port == sc->F)) ? port : ci->cycle_port; /* (object->string (list-values `(x . 1) (signature (int-vector))) :readable) */ - for (x = lst, i = 0; (i < len) && (is_pair(x)); x = cdr(x), i++) - { - int32_t lref; - if ((has_structure(car(x))) && - (is_cyclic(car(x)))) - { - if (i == 0) - plen = catstrs_direct(buf, " (set-car! ", lst_name, " ", (const char *)NULL); - else plen = catstrs_direct(buf, " (set! (", lst_name, " ", pos_int_to_str_direct(sc, i), ") ", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - lref = peek_shared_ref(ci, car(x)); - if (lref == 0) - object_to_port_with_circle_check(sc, car(x), local_port, use_write, ci); - else - { - if (lref < 0) lref = -lref; - plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - } - port_write_string(local_port)(sc, ") ", 2, local_port); - } - if ((is_pair(cdr(x))) && - ((lref = peek_shared_ref(ci, cdr(x))) != 0)) - { - if (lref < 0) lref = -lref; - if (i == 0) - plen = catstrs_direct(buf, (lst_local) ? " " : " ", - "(set-cdr! ", lst_name, " <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - else - if (i == 1) - plen = catstrs_direct(buf, (lst_local) ? " " : " ", - "(set-cdr! (cdr ", lst_name, ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - else plen = catstrs_direct(buf, (lst_local) ? " " : " ", - "(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct_1(sc, i), - ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - break; - }} - if (true_len < 0) /* dotted list */ - { - s7_pointer end_x; - for (end_x = lst; is_pair(end_x); end_x = cdr(end_x)); /* or maybe faster, start at x? */ - /* we can't depend on the loops above to set x to the last element because they sometimes break out */ - if (true_len == -1) /* cons cell */ - plen = catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! ", lst_name, " ", (const char *)NULL); - else - if (true_len == -2) - plen = catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! (cdr ", lst_name, ") ", (const char *)NULL); - else plen = catstrs_direct(buf, "(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct(sc, len - 2), ") ", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - object_to_port_with_circle_check(sc, end_x, local_port, use_write, ci); - port_write_string(local_port)(sc, ") ", 2, local_port); - } - if (lst_local) - port_write_string(local_port)(sc, " )", 8, local_port); - } - else simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); - } - else /* not :readable */ - { - s7_int plen = (len > sc->print_length) ? sc->print_length : len; - if (plen <= 0) - { - port_write_string(port)(sc, "(...))", 6, port); /* open paren above about 150 lines, "list" here is wrong if it's a cons */ - unstack(sc); - return; - } - if (ci) - { - for (x = lst, i = 0; (is_pair(x)) && (i < plen) && ((i == 0) || (peek_shared_ref(ci, x) == 0)); i++, x = cdr(x)) - { - ci->ctr++; - if (ci->ctr > sc->print_length) - { - port_write_string(port)(sc, " ...)", 5, port); - unstack(sc); - return; - } - object_to_port_with_circle_check(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); - if (i < (len - 1)) - port_write_character(port)(sc, ' ', port); - } - if (is_not_null(x)) - { - if (plen < len) - port_write_string(port)(sc, " ...", 4, port); - else - { - if ((true_len == 0) && - (i == len)) - port_write_string(port)(sc, " . ", 3, port); - else port_write_string(port)(sc, ". ", 2, port); - object_to_port_with_circle_check(sc, x, port, NOT_P_DISPLAY(use_write), ci); - }} - port_write_character(port)(sc, ')', port); - } - else - { - s7_int len1 = plen - 1; - if (is_string_port(port)) - { - for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x)) - { - object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); - if (port_position(port) >= sc->objstr_max_len) - { - unstack(sc); - return; - } - if (port_position(port) >= port_data_size(port)) - resize_port_data(sc, port, port_data_size(port) * 2); - port_data(port)[port_position(port)++] = (uint8_t)' '; - }} - else - for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x)) - { - object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); - port_write_character(port)(sc, ' ', port); - } - if (is_pair(x)) - { - object_to_port(sc, car(x), port, NOT_P_DISPLAY(use_write), ci); - x = cdr(x); - } - if (is_not_null(x)) - { - if (plen < len) - port_write_string(port)(sc, " ...", 4, port); - else - { - port_write_string(port)(sc, ". ", 2, port); - object_to_port(sc, x, port, NOT_P_DISPLAY(use_write), ci); - }} - port_write_character(port)(sc, ')', port); - }} - unstack(sc); -} - -static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let); -static const char *hash_table_checker_name(s7_scheme *sc, s7_pointer ht); - -static const char *hash_table_typer_name(s7_scheme *sc, s7_pointer typer) -{ - s7_pointer sym; - if (is_c_function(typer)) return(c_function_name(typer)); - if (is_boolean(typer)) return("#t"); - sym = find_closure(sc, typer, closure_let(typer)); - if (is_null(sym)) return(NULL); - return(symbol_name(sym)); -} - -static void hash_typers_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port) -{ - if (((is_typed_hash_table(hash)) || (is_pair(hash_table_procedures(hash)))) && - ((!is_boolean(hash_table_key_typer(hash))) || (!is_boolean(hash_table_value_typer(hash))))) - { - const char *typer = hash_table_typer_name(sc, hash_table_key_typer(hash)); - port_write_string(port)(sc, " (cons ", 7, port); - port_write_string(port)(sc, typer, safe_strlen(typer), port); - port_write_character(port)(sc, ' ', port); - typer = hash_table_typer_name(sc, hash_table_value_typer(hash)); - port_write_string(port)(sc, typer, safe_strlen(typer), port); - port_write_string(port)(sc, "))", 2, port); - } - else port_write_character(port)(sc, ')', port); -} - -static void hash_table_procedures_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, bool closed, shared_info_t *ci) -{ - const char *typer = hash_table_checker_name(sc, hash); - if ((closed) && (is_immutable(hash))) - port_write_string(port)(sc, "(immutable! ", 12, port); - - if (typer[0] == '#') /* #f */ - { - if (is_pair(hash_table_procedures(hash))) - { - s7_int nlen = 0; - const char *str = (const char *)integer_to_string(sc, hash_table_mask(hash) + 1, &nlen); - const char *checker = hash_table_typer_name(sc, hash_table_procedures_checker(hash)); - const char *mapper = hash_table_typer_name(sc, hash_table_procedures_mapper(hash)); - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); - else port_write_string(port)(sc, "(make-hash-table ", 17, port); - port_write_string(port)(sc, str, nlen, port); - if ((checker) && (mapper)) - { - if ((is_boolean(hash_table_procedures_checker(hash))) && (is_boolean(hash_table_procedures_mapper(hash)))) - port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ - else - { - port_write_string(port)(sc, " (cons ", 7, port); - port_write_string(port)(sc, checker, safe_strlen(checker), port); - port_write_character(port)(sc, ' ', port); - port_write_string(port)(sc, mapper, safe_strlen(mapper), port); - port_write_character(port)(sc, ')', port); - }} - else - if ((is_any_closure(hash_table_procedures_checker(hash))) || - (is_any_closure(hash_table_procedures_mapper(hash)))) - { - port_write_string(port)(sc, " (cons ", 7, port); - if (is_any_closure(hash_table_procedures_checker(hash))) - object_to_port_with_circle_check(sc, hash_table_procedures_checker(hash), port, P_READABLE, ci); - else port_write_string(port)(sc, checker, safe_strlen(checker), port); - port_write_character(port)(sc, ' ', port); - if (is_any_closure(hash_table_procedures_mapper(hash))) - object_to_port_with_circle_check(sc, hash_table_procedures_mapper(hash), port, P_READABLE, ci); - else port_write_string(port)(sc, mapper, safe_strlen(mapper), port); - port_write_character(port)(sc, ')', port); - } - else port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ - hash_typers_to_port(sc, hash, port); - } - else - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table)", 17, port); - else port_write_string(port)(sc, "(hash-table)", 12, port); - } - else - { - s7_int nlen = 0; - char *str = integer_to_string(sc, hash_table_mask(hash) + 1, &nlen); - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); - else port_write_string(port)(sc, "(make-hash-table ", 17, port); - port_write_string(port)(sc, str, nlen, port); - port_write_character(port)(sc, ' ', port); - port_write_string(port)(sc, typer, safe_strlen(typer), port); - hash_typers_to_port(sc, hash, port); - } - if (is_immutable(hash)) - port_write_character(port)(sc, ')', port); -} - -static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - s7_int gc_iter, len = hash_table_entries(hash); - bool too_long = false, hash_cyclic = false, copied = false, immut = false, letd = false; - s7_pointer iterator, p; - int32_t href = -1; - - if (len == 0) - { - if (use_write == P_READABLE) - hash_table_procedures_to_port(sc, hash, port, true, ci); - else - { - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table)", 17, port); - else port_write_string(port)(sc, "(hash-table)", 12, port); - } - return; - } - - if (use_write != P_READABLE) - { - s7_int plen = sc->print_length; - if (plen <= 0) - { - port_write_string(port)(sc, "(hash-table ...)", 16, port); - return; - } - if (len > plen) - { - too_long = true; - len = plen; - }} - - if ((use_write == P_READABLE) && - (ci)) - { - href = peek_shared_ref(ci, hash); - if (href != 0) - { - if (href < 0) href = -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - return; - }}} - - iterator = s7_make_iterator(sc, hash); - gc_iter = gc_protect_1(sc, iterator); - p = cons_unchecked(sc, sc->F, sc->F); - iterator_current(iterator) = p; - set_mark_seq(iterator); - hash_cyclic = ((ci) && (is_cyclic(hash)) && ((href = peek_shared_ref(ci, hash)) != 0)); - - if (use_write == P_READABLE) - { - if ((is_typed_hash_table(hash)) || (is_pair(hash_table_procedures(hash))) || (hash_chosen(hash))) - { - port_write_string(port)(sc, "(let (( ", 11, port); - letd = true; - } - else - if ((is_immutable(hash)) && (!hash_cyclic)) - { - port_write_string(port)(sc, "(immutable! ", 12, port); - immut = true; - }} - - if ((use_write == P_READABLE) && - (hash_cyclic)) - { - if (href < 0) href = -href; - if ((!is_typed_hash_table(hash)) && (!is_pair(hash_table_procedures(hash))) && (!hash_chosen(hash))) - { - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table", 16, port); - else port_write_string(port)(sc, "(hash-table", 11, port); /* top level let */ - } - else - { - hash_table_procedures_to_port(sc, hash, port, true, ci); - port_write_character(port)(sc, ')', port); - } - - /* output here is deferred via ci->cycle_port until later in cyclic_out */ - for (s7_int i = 0; i < len; i++) - { - s7_pointer key_val = hash_table_iterate(sc, iterator); - s7_pointer key = car(key_val); - s7_pointer val = cdr(key_val); - char buf[128]; - int32_t eref = peek_shared_ref(ci, val); - int32_t kref = peek_shared_ref(ci, key); - int32_t plen = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, href), "> ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - if (kref != 0) - { - if (kref < 0) kref = -kref; - plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, kref), ">", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - } - else object_to_port(sc, key, ci->cycle_port, P_READABLE, ci); - if (eref != 0) - { - if (eref < 0) eref = -eref; - plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, eref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - } - else - { - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - }}} - else - { - if (((!is_typed_hash_table(hash)) && (!is_pair(hash_table_procedures(hash))) && (!hash_chosen(hash))) || (use_write != P_READABLE)) - { - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table", 16, port); - else port_write_string(port)(sc, "(hash-table", 11, port); - } - else - { - hash_table_procedures_to_port(sc, hash, port, true, ci); - port_write_character(port)(sc, ')', port); - port_write_string(port)(sc, ") (copy (hash-table", 19, port); - copied = true; - } - for (s7_int i = 0; i < len; i++) - { - s7_pointer key_val = hash_table_iterate(sc, iterator); - port_write_character(port)(sc, ' ', port); - if ((use_write != P_READABLE) && (use_write != P_CODE) && (is_normal_symbol(car(key_val)))) - port_write_character(port)(sc, '\'', port); - object_to_port_with_circle_check(sc, car(key_val), port, NOT_P_DISPLAY(use_write), ci); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, cdr(key_val), port, NOT_P_DISPLAY(use_write), ci); - } - if (use_write != P_READABLE) - { - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - }} - - if (use_write == P_READABLE) - { - if (copied) - { - if (!letd) - { - char buf[128]; - int32_t plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_string(port)(sc, ") ))", 7, port); - } - else - if (letd) - port_write_string(port)(sc, ") )", 6, port); - else port_write_character(port)(sc, ')', port); - - if ((is_immutable(hash)) && (!hash_cyclic) && (!is_typed_hash_table(hash))) - port_write_character(port)(sc, ')', port); - - if ((!immut) && (is_immutable(hash)) && (!hash_cyclic)) - port_write_string(port)(sc, ") (immutable! ))", 19, port); - } - s7_gc_unprotect_at(sc, gc_iter); - iterator_current(iterator) = sc->nil; - free_cell(sc, p); /* free_cell(sc, iterator); */ /* 18-Dec-18 removed */ -} - -static void slot_list_to_port(s7_scheme *sc, s7_pointer slot, s7_pointer port, shared_info_t *ci, bool bindings) /* bindings=let/inlet choice */ -{ - bool first_time = true; - for (; tis_slot(slot); slot = next_slot(slot)) - { - if (bindings) - { - if (first_time) - { - port_write_character(port)(sc, '(', port); - first_time = false; - } - else port_write_string(port)(sc, " (", 2, port); - } - else port_write_character(port)(sc, ' ', port); - symbol_to_port(sc, slot_symbol(slot), port, (bindings) ? P_DISPLAY : P_KEY, NULL); /* (object->string (inlet (symbol "(\")") 1) :readable) */ - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, slot_value(slot), port, P_READABLE, ci); - if (bindings) port_write_character(port)(sc, ')', port); - } -} - -static void slot_list_to_port_with_cycle(s7_scheme *sc, s7_pointer obj, s7_pointer slot, s7_pointer port, shared_info_t *ci, bool bindings) -{ - bool first_time = true; - for (; tis_slot(slot); slot = next_slot(slot)) - { - s7_pointer sym = slot_symbol(slot), val = slot_value(slot); - if (bindings) - { - if (first_time) - { - port_write_character(port)(sc, '(', port); - first_time = false; - } - else port_write_string(port)(sc, " (", 2, port); - } - else port_write_character(port)(sc, ' ', port); - symbol_to_port(sc, sym, port, (bindings) ? P_DISPLAY : P_KEY, NULL); - if (has_structure(val)) - { - char buf[128]; - int32_t symref; - int32_t len = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), "> ", (const char *)NULL); - port_write_string(port)(sc, " #f", 3, port); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - symbol_to_port(sc, sym, ci->cycle_port, P_KEY, NULL); - - symref = peek_shared_ref(ci, val); - if (symref != 0) - { - if (symref < 0) symref = -symref; - len = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, symref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - } - else - { - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - }} - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); - } - if (bindings) port_write_character(port)(sc, ')', port); - if (is_immutable(obj)) - { - char buf[128]; - int32_t len = catstrs_direct(buf, " (immutable! <", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - }} -} - -static bool let_has_setter(s7_pointer obj) -{ - for (s7_pointer slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) - if ((slot_has_setter(slot)) || (is_immutable(slot))) - return(true); - return(false); -} - -static bool slot_setters_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci) -{ - bool spaced_out = false; - for (s7_pointer slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) - if (slot_has_setter(slot)) - { - if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; - port_write_string(port)(sc, "(set! (setter '", 15, port); - symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, NULL); - port_write_string(port)(sc, ") ", 2, port); - object_to_port_with_circle_check(sc, slot_setter(slot), port, P_READABLE, ci); - port_write_character(port)(sc, ')', port); - } - return(spaced_out); -} - -static void immutable_slots_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, bool spaced_out) -{ - for (s7_pointer slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) - if (is_immutable(slot)) - { - if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; - port_write_string(port)(sc, "(immutable! '", 13, port); - symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, NULL); - port_write_character(port)(sc, ')', port); - } -} - -static void slot_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - /* the slot symbol might need (symbol...) in which case we don't want the preceding quote */ - symbol_to_port(sc, slot_symbol(obj), port, P_READABLE, NULL); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, slot_value(obj), port, use_write, ci); -} - -static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - /* if outer env points to (say) method list, the object needs to specialize object->string itself */ - - if (has_active_methods(sc, obj)) - { - s7_pointer print_func = find_method(sc, obj, sc->object_to_string_symbol); - if (print_func != sc->undefined) - { - s7_pointer p; - /* what needs to be protected here? for one, the function might not return a string! */ - - clear_has_methods(obj); - if ((use_write == P_WRITE) || (use_write == P_CODE)) - p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); - else p = s7_apply_function(sc, print_func, set_plist_2(sc, obj, (use_write == P_DISPLAY) ? sc->F : sc->readable_keyword)); - set_has_methods(obj); - - if ((is_string(p)) && - (string_length(p) > 0)) - port_write_string(port)(sc, string_value(p), string_length(p), port); - return; - }} - if (obj == sc->rootlet) {port_write_string(port)(sc, "(rootlet)", 9, port); return;} - if (obj == sc->s7_starlet) {port_write_string(port)(sc, "*s7*", 4, port); return;} - if (sc->short_print) {port_write_string(port)(sc, "#", 6, port); return;} - - /* circles can happen here: - * (let () (let ((b (curlet))) (curlet))): #> - * or (let ((b #f)) (set! b (curlet)) (curlet)): #1=# - */ - if (use_write == P_READABLE) - { - int32_t lref; - if ((ci) && - (is_cyclic(obj)) && - ((lref = peek_shared_ref(ci, obj)) != 0)) - { - if (lref < 0) lref = -lref; - if ((ci->defined[lref]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - return; - } - if ((let_outlet(obj) != sc->nil) && - (let_outlet(obj) != sc->rootlet)) - { - char buf[128]; - int32_t len = catstrs_direct(buf, " (set! (outlet <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - let_to_port(sc, let_outlet(obj), ci->cycle_port, use_write, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - } - if (is_openlet(obj)) - port_write_string(port)(sc, "(openlet ", 9, port); - /* not immutable here because we'll need to set the let fields below, then declare it immutable */ - if (let_has_setter(obj)) /* both explicit setters and immutable slots */ - { - port_write_string(port)(sc, "(let (", 6, port); - slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, true); - port_write_string(port)(sc, ") ", 2, port); - immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci)); - port_write_string(port)(sc, " (curlet))", 10, port); - } - else - { - port_write_string(port)(sc, "(inlet", 6, port); - slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, false); - port_write_character(port)(sc, ')', port); - } - if (is_openlet(obj)) - port_write_character(port)(sc, ')', port); - } - else - { - if (is_openlet(obj)) - port_write_string(port)(sc, "(openlet ", 9, port); - if (is_immutable(obj)) - port_write_string(port)(sc, "(immutable! ", 12, port); - - /* this ignores outlet -- but is that a problem? */ - /* (object->string (let ((i 0)) (set! (setter 'i) integer?) (curlet)) :readable) -> "(let ((i 0)) (set! (setter 'i) #_integer?) (curlet))" */ - if (let_has_setter(obj)) - { - port_write_string(port)(sc, "(let (", 6, port); - slot_list_to_port(sc, let_slots(obj), port, ci, true); - port_write_string(port)(sc, ") ", 2, port); - immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci)); - /* perhaps set outlet here?? */ - port_write_string(port)(sc, " (curlet))", 10, port); - } - else - { - if ((let_outlet(obj) != sc->nil) && - (let_outlet(obj) != sc->rootlet)) - { - int32_t ref; - port_write_string(port)(sc, "(sublet ", 8, port); - if ((ci) && ((ref = peek_shared_ref(ci, let_outlet(obj))) < 0)) - { - char buf[128]; - int32_t len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, len, port); - } - else - { - s7_pointer name = let_ref(sc, obj, sc->class_name_symbol); - if (is_symbol(name)) - symbol_to_port(sc, name, port, P_DISPLAY, NULL); - else let_to_port(sc, let_outlet(obj), port, use_write, ci); - }} - else port_write_string(port)(sc, "(inlet", 6, port); - slot_list_to_port(sc, let_slots(obj), port, ci, false); - port_write_character(port)(sc, ')', port); - } - if (is_immutable(obj)) - port_write_character(port)(sc, ')', port); - if (is_openlet(obj)) - port_write_character(port)(sc, ')', port); - }} - else /* not readable write */ - { - s7_pointer slot = let_slots(obj); - port_write_string(port)(sc, "(inlet", 6, port); - for (int32_t i = 1; tis_slot(slot); i++, slot = next_slot(slot)) - { - port_write_character(port)(sc, ' ', port); - slot_to_port(sc, slot, port, use_write, ci); - if ((tis_slot(next_slot(slot))) && (i == sc->print_length)) - { - port_write_string(port)(sc, " ...", 4, port); - break; - }} - port_write_character(port)(sc, ')', port); - } -} - -static void write_macro_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - s7_pointer expr, body = closure_body(obj), arglist = closure_args(obj); - /* this doesn't handle recursive macros well -- we need letrec or the equivalent as in write_closure_readably */ - /* (letrec ((m2 (macro (x) `(if (> ,x 0) (m2 (- ,x 1)) 32)))) (object->string m2 :readable)) */ - - port_write_string(port)(sc, (is_either_macro(obj)) ? "(macro" : "(bacro", 6, port); - if ((is_macro_star(obj)) || (is_bacro_star(obj))) - port_write_character(port)(sc, '*', port); - if (is_symbol(arglist)) - { - port_write_character(port)(sc, ' ', port); - port_write_string(port)(sc, symbol_name(arglist), symbol_name_length(arglist), port); - port_write_character(port)(sc, ' ', port); - } - else - if (is_pair(arglist)) - { - port_write_string(port)(sc, " (", 2, port); - for (expr = arglist; is_pair(expr); expr = cdr(expr)) - { - object_to_port(sc, car(expr), port, P_WRITE, NULL); - if (is_pair(cdr(expr))) - port_write_character(port)(sc, ' ', port); - } - if (!is_null(expr)) - { - port_write_string(port)(sc, " . ", 3, port); - object_to_port(sc, expr, port, P_WRITE, NULL); - } - port_write_string(port)(sc, ") ", 2, port); - } - else port_write_string(port)(sc, " () ", 4, port); - - for (expr = body; is_pair(expr); expr = cdr(expr)) - object_to_port(sc, car(expr), port, P_WRITE, NULL); - port_write_character(port)(sc, ')', port); -} - - -static s7_pointer match_symbol(const s7_pointer symbol, s7_pointer e) -{ - for (s7_pointer le = e; is_let(le); le = let_outlet(le)) - for (s7_pointer y = let_slots(le); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); - return(NULL); -} - -static bool slot_memq(const s7_pointer symbol, s7_pointer symbols) -{ - for (s7_pointer x = symbols; is_pair(x); x = cdr(x)) - if (slot_symbol(car(x)) == symbol) - return(true); - return(false); -} - -static bool arg_memq(const s7_pointer symbol, s7_pointer args) -{ - for (s7_pointer x = args; is_pair(x); x = cdr(x)) - if ((car(x) == symbol) || - ((is_pair(car(x))) && - (caar(x) == symbol))) - return(true); - return(false); -} - -static void collect_symbol(s7_scheme *sc, s7_pointer sym, s7_pointer e, s7_pointer args, s7_int gc_loc) -{ - if ((!arg_memq(T_Sym(sym), args)) && - (!slot_memq(sym, gc_protected_at(sc, gc_loc)))) - { - s7_pointer slot = match_symbol(sym, e); - if (slot) - gc_protected_at(sc, gc_loc) = cons(sc, slot, gc_protected_at(sc, gc_loc)); - } -} - -static void collect_locals(s7_scheme *sc, s7_pointer body, s7_pointer e, s7_pointer args, s7_int gc_loc) /* currently called only in write_closure_readably */ -{ - if (is_pair(body)) - { - collect_locals(sc, car(body), e, args, gc_loc); - collect_locals(sc, cdr(body), e, args, gc_loc); - } - else - if (is_symbol(body)) - collect_symbol(sc, body, e, args, gc_loc); -} - -static void collect_specials(s7_scheme *sc, s7_pointer e, s7_pointer args, s7_int gc_loc) -{ - collect_symbol(sc, sc->local_signature_symbol, e, args, gc_loc); - collect_symbol(sc, sc->local_setter_symbol, e, args, gc_loc); - collect_symbol(sc, sc->local_documentation_symbol, e, args, gc_loc); - collect_symbol(sc, sc->local_iterator_symbol, e, args, gc_loc); -} - -static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let) -{ - for (s7_pointer e = current_let; is_let(e); e = let_outlet(e)) - { - if ((is_funclet(e)) || (is_maclet(e))) - { - s7_pointer sym = funclet_function(e); - s7_pointer f = s7_symbol_local_value(sc, sym, e); - if (f == closure) - return(sym); - } - for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_value(y) == closure) - return(slot_symbol(y)); - } - if ((is_any_macro(closure)) && /* can't be a c_macro here */ - (has_pair_macro(closure))) /* maybe macro never called, so no maclet exists */ - return(pair_macro(closure_body(closure))); - return(sc->nil); -} - -static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer port) -{ - s7_pointer x = find_closure(sc, closure, closure_let(closure)); - if (is_symbol(x)) - { - port_write_string(port)(sc, symbol_name(x), symbol_name_length(x), port); - return; - } - switch (type(closure)) - { - case T_CLOSURE: port_write_string(port)(sc, "#", 3, port); - else - { - s7_pointer args = closure_args(closure); - if (is_symbol(args)) - { - port_write_string(port)(sc, symbol_name(args), symbol_name_length(args), port); - port_write_character(port)(sc, '>', port); /* (lambda a a) -> # */ - } - else - { - port_write_character(port)(sc, '(', port); - x = car(args); - if (is_pair(x)) x = car(x); - port_write_string(port)(sc, symbol_name(x), symbol_name_length(x), port); - if (!is_null(cdr(args))) - { - s7_pointer y; - port_write_character(port)(sc, ' ', port); - if (is_pair(cdr(args))) - { - y = cadr(args); - if (is_pair(y)) - y = car(y); - else - if (y == sc->rest_keyword) - { - port_write_string(port)(sc, ":rest ", 6, port); - args = cdr(args); - y = cadr(args); - if (is_pair(y)) y = car(y); - }} - else - { - port_write_string(port)(sc, ". ", 2, port); - y = cdr(args); - } - port_write_string(port)(sc, symbol_name(y), symbol_name_length(y), port); - if ((is_pair(cdr(args))) && - (!is_null(cddr(args)))) - port_write_string(port)(sc, " ...", 4, port); - } - port_write_string(port)(sc, ")>", 2, port); - }} -} - -static s7_pointer closure_name(s7_scheme *sc, s7_pointer closure) -{ - /* this is used by the error handlers to get the current function name */ - s7_pointer x = find_closure(sc, closure, sc->curlet); - if (is_symbol(x)) - return(x); - if (is_pair(current_code(sc))) - return(current_code(sc)); - return(closure); /* desperation -- the parameter list (caar here) will cause endless confusion in OP_APPLY errors! */ -} - -static s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - s7_pointer p = cdr(a), tp; - gc_protect_via_stack(sc, b); - if (is_null(p)) - tp = cons(sc, car(a), b); - else - { - s7_pointer np; - tp = list_1(sc, car(a)); - set_stack_protected2(sc, tp); - for (np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - set_cdr(np, list_1(sc, car(p))); - set_cdr(np, b); - } - unstack(sc); - return(tp); -} - -static void write_closure_readably_1(s7_scheme *sc, s7_pointer obj, s7_pointer arglist, s7_pointer body, s7_pointer port) -{ - s7_int old_print_length = sc->print_length; - - if (type(obj) == T_CLOSURE_STAR) - port_write_string(port)(sc, "(lambda* ", 9, port); - else port_write_string(port)(sc, "(lambda ", 8, port); - - if ((is_pair(arglist)) && - (allows_other_keys(arglist))) - { - sc->temp9 = (is_null(cdr(arglist))) ? - set_plist_2(sc, car(arglist), sc->allow_other_keys_keyword) : - pair_append(sc, arglist, list_1(sc, sc->allow_other_keys_keyword)); - object_to_port(sc, sc->temp9, port, P_WRITE, NULL); - sc->temp9 = sc->unused; - } - else object_to_port(sc, arglist, port, P_WRITE, NULL); /* here we just want the straight output (a b) not (list 'a 'b) */ - - sc->print_length = 1048576; - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - { - port_write_character(port)(sc, ' ', port); - object_to_port(sc, car(p), port, P_WRITE, NULL); - } - port_write_character(port)(sc, ')', port); - sc->print_length = old_print_length; -} - -static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci) -{ - s7_pointer body = closure_body(obj); - s7_pointer arglist = closure_args(obj); - s7_pointer pe, local_slots, setter = NULL, obj_slot = NULL; - s7_int gc_loc; - bool sent_let = false, sent_letrec = false; - - if (sc->safety > NO_SAFETY) - { - if (tree_is_cyclic(sc, body)) - { - port_write_string(port)(sc, "#", 32, port); /* not s7_error here! */ - return; - } - /* perhaps: if any sequence in the closure_body is cyclic, complain, but how to check without clobbering ci? - * perhaps pass ci, and use make_shared_info if ci=null else continue_shared_info? - * this can happen only if (apply lambda ... cyclic-seq ...) I think - * long-term we need to include closure_body(obj) in the top object_out make_shared_info - */ - } - if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist); - pe = closure_let(obj); - - gc_loc = gc_protect_1(sc, sc->nil); - collect_locals(sc, body, pe, arglist, gc_loc); /* collect locals used only here (and below) */ - collect_specials(sc, pe, arglist, gc_loc); - - if (s7_is_dilambda(obj)) - { - setter = closure_setter(obj); - if (has_closure_let(setter)) /* collect args etc so need the arglist */ - { - arglist = closure_args(setter); - if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist); - collect_locals(sc, closure_body(setter), pe, arglist, gc_loc); - }} - - local_slots = T_Lst(gc_protected_at(sc, gc_loc)); /* possibly a list of slots */ - if (!is_null(local_slots)) - { - /* if (let|letrec ((f (lambda () f))) (object->string f :readable)), local_slots: ('f f) */ - /* but we can't handle it below because that leads to an infinite loop */ - for (s7_pointer x = local_slots; is_pair(x); x = cdr(x)) - { - s7_pointer slot = car(x); - if ((!is_any_closure(slot_value(slot))) && /* mutually referencing closures? ./snd -l snd-test 24 hits this in the effects dialogs */ - ((!has_structure(slot_value(slot))) || /* see s7test example, vector has closure that refers to vector */ - (slot_symbol(slot) == sc->local_signature_symbol))) - { - if (!sent_let) - { - port_write_string(port)(sc, "(let (", 6, port); - sent_let = true; - } - port_write_character(port)(sc, '(', port); - port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port); - port_write_character(port)(sc, ' ', port); - /* (object->string (list (let ((local 1)) (lambda (x) (+ x local)))) :readable) */ - object_to_port(sc, slot_value(slot), port, P_READABLE, NULL); - if (is_null(cdr(x))) - port_write_character(port)(sc, ')', port); - else port_write_string(port)(sc, ") ", 2, port); - }} - if (sent_let) port_write_string(port)(sc, ") ", 2, port); - } - - /* now we need to know if obj is in the closure_let via letrec, and if so, send out letrec+obj name+def below, then close it with obj-name?? - * the two cases are: (let ((f (lambda () f)))...) which is ok now, and (letrec ((f (lambda () f)))...) which needs the letrec - */ - if (!is_null(local_slots)) - for (s7_pointer x = local_slots; is_pair(x); x = cdr(x)) - { - s7_pointer slot = car(x); - if ((is_any_closure(slot_value(slot))) && - (slot_value(slot) == obj)) - { - port_write_string(port)(sc, "(letrec ((", 10, port); /* (letrec ((f (lambda () f))) f) */ - sent_letrec = true; - port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port); - port_write_character(port)(sc, ' ', port); - obj_slot = slot; - break; - }} - - if (setter) - port_write_string(port)(sc, "(dilambda ", 10, port); - - write_closure_readably_1(sc, obj, closure_args(obj), body, port); - - if (setter) - { - port_write_character(port)(sc, ' ', port); - if (has_closure_let(setter)) - write_closure_readably_1(sc, setter, closure_args(setter), closure_body(setter), port); - else object_to_port_with_circle_check(sc, setter, port, P_READABLE, ci); - port_write_character(port)(sc, ')', port); - } - if (sent_letrec) - { - port_write_string(port)(sc, ")) ", 3, port); - port_write_string(port)(sc, symbol_name(slot_symbol(obj_slot)), symbol_name_length(slot_symbol(obj_slot)), port); - port_write_character(port)(sc, ')', port); - } - - if (sent_let) - port_write_character(port)(sc, ')', port); - - s7_gc_unprotect_at(sc, gc_loc); -} - -static void iterator_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - if (use_write == P_READABLE) - { - if (iterator_is_at_end(obj)) - { - switch (type(iterator_sequence(obj))) - { - case T_NIL: - case T_PAIR: port_write_string(port)(sc, "(make-iterator ())", 18, port); break; - case T_STRING: port_write_string(port)(sc, "(make-iterator \"\")", 18, port); break; - case T_BYTE_VECTOR: port_write_string(port)(sc, "(make-iterator #u())", 20, port); break; - case T_VECTOR: port_write_string(port)(sc, "(make-iterator #())", 19, port); break; - case T_INT_VECTOR: port_write_string(port)(sc, "(make-iterator #i())", 20, port); break; - case T_FLOAT_VECTOR: port_write_string(port)(sc, "(make-iterator #r())", 20, port); break; - case T_LET: port_write_string(port)(sc, "(make-iterator (inlet))", 23, port); break; - - case T_HASH_TABLE: - if (is_weak_hash_table(iterator_sequence(obj))) - port_write_string(port)(sc, "(make-iterator (weak-hash-table))", 33, port); - else port_write_string(port)(sc, "(make-iterator (hash-table))", 28, port); - break; - - default: - port_write_string(port)(sc, "(make-iterator ())", 18, port); break; /* c-object?? function? */ - }} - else - { - s7_pointer seq = iterator_sequence(obj); - int32_t iter_ref; - if ((ci) && - (is_cyclic(obj)) && - ((iter_ref = peek_shared_ref(ci, obj)) != 0)) - { - /* basically the same as c_pointer_to_port */ - if (!is_cyclic_set(obj)) - { - int32_t nlen; - char buf[128]; - if (iter_ref < 0) iter_ref = -iter_ref; - - if (ci->init_port == sc->F) - { - ci->init_port = s7_open_output_string(sc); - ci->init_loc = gc_protect_1(sc, ci->init_port); - } - port_write_string(port)(sc, "#f", 2, port); - nlen = catstrs_direct(buf, " (set! <", pos_int_to_str_direct(sc, iter_ref), "> (make-iterator ", (const char *)NULL); - port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); - - flip_ref(ci, seq); - object_to_port_with_circle_check(sc, seq, ci->init_port, use_write, ci); - flip_ref(ci, seq); - - port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); - set_cyclic_set(obj); - return; - }} - - if (is_string(seq)) - { - s7_int len = string_length(seq) - iterator_position(obj); - if (len == 0) - port_write_string(port)(sc, "(make-iterator \"\")", 18, port); - else - { - const char *iter_str = (const char *)(string_value(seq) + iterator_position(obj)); - port_write_string(port)(sc, "(make-iterator \"", 16, port); - if (!string_needs_slashification((const uint8_t *)iter_str, len)) - port_write_string(port)(sc, iter_str, len, port); - else slashify_string_to_port(sc, port, iter_str, len, NOT_IN_QUOTES); - port_write_string(port)(sc, "\")", 2, port); - }} - else - { - if (is_pair(seq)) - { - port_write_string(port)(sc, "(make-iterator ", 15, port); - object_to_port_with_circle_check(sc, iterator_current(obj), port, use_write, ci); - port_write_character(port)(sc, ')', port); - } - else - { - if ((is_let(seq)) && (seq != sc->rootlet) && (seq != sc->s7_starlet)) - { - port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port); - object_to_port_with_circle_check(sc, seq, port, use_write, ci); - port_write_string(port)(sc, "))) ", 4, port); - for (s7_pointer slot = let_slots(seq); slot != iterator_current_slot(obj); slot = next_slot(slot)) - port_write_string(port)(sc, "(iter) ", 7, port); - port_write_string(port)(sc, "iter)", 5, port); - } - else - { - if (iterator_position(obj) > 0) - port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port); - else port_write_string(port)(sc, "(make-iterator ", 15, port); - object_to_port_with_circle_check(sc, seq, port, use_write, ci); - if (iterator_position(obj) > 0) - { - if (iterator_position(obj) == 1) - port_write_string(port)(sc, "))) (iter) iter)", 16, port); - else - { - char str[128]; - int32_t nlen = catstrs_direct(str, "))) (do ((i 0 (+ i 1))) ((= i ", - pos_int_to_str_direct(sc, iterator_position(obj)), - ") iter) (iter)))", (const char *)NULL); - port_write_string(port)(sc, str, nlen, port); - }} - else port_write_character(port)(sc, ')', port); - }}}}} - else - { - const char *str; - if ((is_hash_table(iterator_sequence(obj))) && (is_weak_hash_table(iterator_sequence(obj)))) - str = "weak-hash-table"; - else str = type_name(sc, iterator_sequence(obj), NO_ARTICLE); - port_write_string(port)(sc, "#', port); - } -} - -static void c_pointer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - #define CP_BUFSIZE 128 - char buf[CP_BUFSIZE]; - int32_t nlen; - /* c-pointer is special because we can't set the type or info fields from scheme except via the c-pointer function */ - - if (use_write == P_READABLE) - { - int32_t ref; - if ((ci) && - (is_cyclic(obj)) && - ((ref = peek_shared_ref(ci, obj)) != 0)) - { - port_write_string(port)(sc, "#f", 2, port); - if (!is_cyclic_set(obj)) - { - if (ci->init_port == sc->F) - { - ci->init_port = s7_open_output_string(sc); - ci->init_loc = gc_protect_1(sc, ci->init_port); - } - nlen = snprintf(buf, CP_BUFSIZE, " (set! <%d> (c-pointer %" p64, -ref, (intptr_t)c_pointer(obj)); - port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); - - if ((c_pointer_type(obj) != sc->F) || - (c_pointer_info(obj) != sc->F)) - { - flip_ref(ci, c_pointer_type(obj)); - - port_write_character(ci->init_port)(sc, ' ', ci->init_port); - object_to_port_with_circle_check(sc, c_pointer_type(obj), ci->init_port, use_write, ci); - - flip_ref(ci, c_pointer_type(obj)); - flip_ref(ci, c_pointer_info(obj)); - - port_write_character(ci->init_port)(sc, ' ', ci->init_port); - object_to_port_with_circle_check(sc, c_pointer_info(obj), ci->init_port, use_write, ci); - - flip_ref(ci, c_pointer_info(obj)); - } - port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); - set_cyclic_set(obj); - }} - else - { - nlen = snprintf(buf, CP_BUFSIZE, "(c-pointer %" p64, (intptr_t)c_pointer(obj)); - port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); - if ((c_pointer_type(obj) != sc->F) || - (c_pointer_info(obj) != sc->F)) - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, c_pointer_type(obj), port, use_write, ci); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, c_pointer_info(obj), port, use_write, ci); - } - port_write_character(port)(sc, ')', port); - }} - else - { - if ((is_symbol(c_pointer_type(obj))) && - (symbol_name_length(c_pointer_type(obj)) < (CP_BUFSIZE / 2))) - nlen = snprintf(buf, CP_BUFSIZE, "#<%s %p>", symbol_name(c_pointer_type(obj)), c_pointer(obj)); - else nlen = snprintf(buf, CP_BUFSIZE, "#", c_pointer(obj)); - port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); - } -} - -static void random_state_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - #define B_BUFSIZE 128 - char buf[B_BUFSIZE]; - int32_t nlen; -#if WITH_GMP - if (use_write == P_READABLE) - nlen = snprintf(buf, B_BUFSIZE, "#"); - else nlen = snprintf(buf, B_BUFSIZE, "#", obj); -#else - if (use_write == P_READABLE) - nlen = snprintf(buf, B_BUFSIZE, "(random-state %" PRIu64 " %" PRIu64 ")", random_seed(obj), random_carry(obj)); - else nlen = snprintf(buf, B_BUFSIZE, "#", random_seed(obj), random_carry(obj)); -#endif - port_write_string(port)(sc, buf, clamp_length(nlen, B_BUFSIZE), port); -} - -static void display_fallback(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ -#if S7_DEBUGGING - print_debugging_state(sc, obj, port); -#else - if (is_free(obj)) - port_write_string(port)(sc, "", 12, port); - else port_write_string(port)(sc, "", 17, port); -#endif -} - -static void unique_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - port_write_string(port)(sc, unique_name(obj), unique_name_length(obj), port); -} - -static void undefined_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if ((obj != sc->undefined) && - (use_write == P_READABLE)) - { - port_write_string(port)(sc, "(with-input-from-string \"", 25, port); - port_write_string(port)(sc, undefined_name(obj), undefined_name_length(obj), port); - port_write_string(port)(sc, "\" read)", 7, port); - } - else port_write_string(port)(sc, undefined_name(obj), undefined_name_length(obj), port); -} - -static void eof_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (use_write == P_READABLE) - port_write_string(port)(sc, "(begin #)", 14, port); - else port_write_string(port)(sc, eof_name(obj), eof_name_length(obj), port); -} - -static void counter_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - port_write_string(port)(sc, "#", 10, port); -} - -static void integer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (has_number_name(obj)) - { - if (is_string_port(port)) - { - if (port_position(port) + number_name_length(obj) < port_data_size(port)) - { - memcpy((void *)(port_data(port) + port_position(port)), (void *)number_name(obj), number_name_length(obj)); - port_position(port) += number_name_length(obj); - } - else string_write_string_resized(sc, number_name(obj), number_name_length(obj), port); - } - else port_write_string(port)(sc, number_name(obj), number_name_length(obj), port); - } - else - { - s7_int nlen = 0; - char *str = integer_to_string(sc, integer(obj), &nlen); - set_number_name(obj, str, nlen); - port_write_string(port)(sc, str, nlen, port); - } -} - -static void number_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (has_number_name(obj)) - port_write_string(port)(sc, number_name(obj), number_name_length(obj), port); - else - { - s7_int nlen = 0; - char *str = number_to_string_base_10(sc, obj, 0, sc->float_format_precision, 'g', &nlen, use_write); /* was 14 */ - if ((nlen < NUMBER_NAME_SIZE) && - (str[0] != 'n') && (str[0] != 'i') && - ((!(is_t_complex(obj))) || - ((!is_NaN(imag_part(obj))) && (!is_inf(imag_part(obj)))))) - set_number_name(obj, str, nlen); - port_write_string(port)(sc, str, nlen, port); - } -} - -#if WITH_GMP -static void big_number_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - s7_int nlen = 0; - block_t *str = big_number_to_string_with_radix(sc, obj, BASE_10, 0, &nlen, use_write); - port_write_string(port)(sc, (char *)block_data(str), nlen, port); - liberate(sc, str); -} -#endif - -static void syntax_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - port_display(port)(sc, symbol_name(syntax_symbol(obj)), port); -} - -static void character_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (use_write == P_DISPLAY) - port_write_character(port)(sc, character(obj), port); - else port_write_string(port)(sc, character_name(obj), character_name_length(obj), port); -} - -static void closure_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - if (has_active_methods(sc, obj)) - { - /* look for object->string method else fallback on ordinary case. - * can't use recursion on closure_let here because then the fallback name is #. - * this is tricky!: (display (openlet (with-let (mock-c-pointer 0) (lambda () 1)))) - * calls object->string on the closure whose closure_let is the mock-c-pointer; - * it has an object->string method that clears mock-c-pointers and tries again... - * so, display methods need to use coverlet/openlet. - */ - s7_pointer print_func = find_method(sc, closure_let(obj), sc->object_to_string_symbol); - if (print_func != sc->undefined) - { - s7_pointer p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); - if (string_length(p) > 0) - port_write_string(port)(sc, string_value(p), string_length(p), port); - return; - }} - if (use_write == P_READABLE) - write_closure_readably(sc, obj, port, ci); - else write_closure_name(sc, obj, port); -} - -static void macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - if (has_active_methods(sc, obj)) - { - s7_pointer print_func = find_method(sc, closure_let(obj), sc->object_to_string_symbol); - if (print_func != sc->undefined) - { - s7_pointer p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); - if (string_length(p) > 0) - port_write_string(port)(sc, string_value(p), string_length(p), port); - return; - }} - if (use_write == P_READABLE) - write_macro_readably(sc, obj, port); - else write_closure_name(sc, obj, port); -} - -static void c_function_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) -{ - s7_pointer sym = c_function_name_to_symbol(sc, obj); - if ((!is_global(sym)) && - (is_slot(initial_slot(sym))) && - ((use_write == P_READABLE) || (lookup(sc, sym) != initial_value(sym)))) - { - port_write_string(port)(sc, "#_", 2, port); - port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port); - return; - } - if (c_function_name_length(obj) > 0) - port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port); - else port_write_string(port)(sc, "#", 13, port); -} - -static void c_macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (c_macro_name_length(obj) > 0) - port_write_string(port)(sc, c_macro_name(obj), c_macro_name_length(obj), port); - else port_write_string(port)(sc, "#", 10, port); -} - -static void continuation_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (is_symbol(continuation_name(obj))) - { - port_write_string(port)(sc, "#', port); - } - else port_write_string(port)(sc, "#", 15, port); -} - -static void goto_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (is_symbol(call_exit_name(obj))) - { - port_write_string(port)(sc, "#', port); - } - else port_write_string(port)(sc, "#", 7, port); -} - -static void catch_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - port_write_string(port)(sc, "#", 8, port); -} - -static void dynamic_wind_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - /* this can happen because (*s7* 'stack) can involve dynamic-wind markers */ - port_write_string(port)(sc, "#", 15, port); -} - -static void c_object_name_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - port_write_string(port)(sc, string_value(c_object_scheme_name(sc, obj)), string_length(c_object_scheme_name(sc, obj)), port); -} - -static void c_object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ -#if (!DISABLE_DEPRECATED) - if (c_object_print(sc, obj)) - { - char *str = ((*(c_object_print(sc, obj)))(sc, c_object_value(obj))); - port_display(port)(sc, str, port); - free(str); - return; - } -#endif - if (c_object_to_string(sc, obj)) /* plist here and below can clobber args if SHOW_EVAL_ARGS */ - port_display(port)(sc, s7_string((*(c_object_to_string(sc, obj)))(sc, set_mlist_2(sc, obj, (use_write == P_READABLE) ? sc->readable_keyword : sc->T))), port); - else - { - if ((use_write == P_READABLE) && - (c_object_to_list(sc, obj)) && /* to_list and (implicit) set are needed to reconstruct a cyclic c-object, as well as the maker (via type name) */ - (c_object_set(sc, obj))) - { - int32_t href; - s7_pointer old_w = sc->w; - s7_pointer obj_list = ((*(c_object_to_list(sc, obj)))(sc, set_mlist_1(sc, obj))); - s7_pointer p = obj_list; - sc->w = obj_list; - if ((ci) && - (is_cyclic(obj)) && - ((href = peek_shared_ref(ci, obj)) != 0)) - { - if (href < 0) href = -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t nlen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - return; - } - port_write_character(port)(sc, '(', port); - c_object_name_to_port(sc, obj, port); - for (int32_t i = 0; is_pair(p); i++, p = cdr(p)) - { - s7_pointer val = car(p); - if (has_structure(val)) - { - char buf[128]; - int32_t symref; - int32_t len = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, href), "> ", pos_int_to_str_direct_1(sc, i), ") ", (const char *)NULL); - port_write_string(port)(sc, " #f", 3, port); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - - symref = peek_shared_ref(ci, val); - if (symref != 0) - { - if (symref < 0) symref = -symref; - len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, symref), ">)\n", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - } - else - { - object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ")\n", 2, ci->cycle_port); - }} - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); - }}} - else - { - port_write_character(port)(sc, '(', port); - c_object_name_to_port(sc, obj, port); - for (p = obj_list; is_pair(p); p = cdr(p)) - { - s7_pointer val = car(p); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); - }} - port_write_character(port)(sc, ')', port); - sc->w = old_w; - } - else - { - char buf[128]; - int32_t nlen; - port_write_string(port)(sc, "#<", 2, port); - c_object_name_to_port(sc, obj, port); - nlen = snprintf(buf, 128, " %p>", obj); - port_write_string(port)(sc, buf, clamp_length(nlen, 128), port); - }} -} - -static void stack_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) -{ - if (obj == sc->stack) - port_write_string(port)(sc, "#", 16, port); - else port_write_string(port)(sc, "#", 8, port); -} - -static void init_display_functions(void) -{ - for (int32_t i = 0; i < 256; i++) display_functions[i] = display_fallback; - display_functions[T_FLOAT_VECTOR] = float_vector_to_port; - display_functions[T_INT_VECTOR] = int_vector_to_port; - display_functions[T_BYTE_VECTOR] = byte_vector_to_port; - display_functions[T_VECTOR] = vector_to_port; - display_functions[T_PAIR] = pair_to_port; - display_functions[T_HASH_TABLE] = hash_table_to_port; - display_functions[T_ITERATOR] = iterator_to_port; - display_functions[T_LET] = let_to_port; - display_functions[T_BOOLEAN] = unique_to_port; - display_functions[T_NIL] = unique_to_port; - display_functions[T_UNUSED] = unique_to_port; - display_functions[T_UNSPECIFIED] = unique_to_port; - display_functions[T_UNDEFINED] = undefined_to_port; - display_functions[T_EOF] = eof_to_port; - display_functions[T_INPUT_PORT] = input_port_to_port; - display_functions[T_OUTPUT_PORT] = output_port_to_port; - display_functions[T_COUNTER] = counter_to_port; - display_functions[T_STACK] = stack_to_port; - display_functions[T_INTEGER] = integer_to_port; - display_functions[T_RATIO] = number_to_port; - display_functions[T_REAL] = number_to_port; - display_functions[T_COMPLEX] = number_to_port; -#if WITH_GMP - display_functions[T_BIG_INTEGER] = big_number_to_port; - display_functions[T_BIG_RATIO] = big_number_to_port; - display_functions[T_BIG_REAL] = big_number_to_port; - display_functions[T_BIG_COMPLEX] = big_number_to_port; -#endif - display_functions[T_SYMBOL] = symbol_to_port; - display_functions[T_SYNTAX] = syntax_to_port; - display_functions[T_STRING] = string_to_port; - display_functions[T_CHARACTER] = character_to_port; - display_functions[T_CLOSURE] = closure_to_port; - display_functions[T_CLOSURE_STAR] = closure_to_port; - display_functions[T_MACRO] = macro_to_port; - display_functions[T_MACRO_STAR] = macro_to_port; - display_functions[T_BACRO] = macro_to_port; - display_functions[T_BACRO_STAR] = macro_to_port; - display_functions[T_C_RST_NO_REQ_FUNCTION] = c_function_to_port; - display_functions[T_C_FUNCTION] = c_function_to_port; - display_functions[T_C_FUNCTION_STAR] = c_function_to_port; - display_functions[T_C_MACRO] = c_macro_to_port; - display_functions[T_C_POINTER] = c_pointer_to_port; - display_functions[T_RANDOM_STATE] = random_state_to_port; - display_functions[T_CONTINUATION] = continuation_to_port; - display_functions[T_GOTO] = goto_to_port; - display_functions[T_CATCH] = catch_to_port; - display_functions[T_DYNAMIC_WIND] = dynamic_wind_to_port; - display_functions[T_C_OBJECT] = c_object_to_port; - display_functions[T_SLOT] = slot_to_port; -} - -static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer vr, s7_pointer port, use_write_t use_write, shared_info_t *ci) -{ - int32_t ref = (is_collected(vr)) ? shared_ref(ci, vr) : 0; - if (ref == 0) - object_to_port(sc, vr, port, use_write, ci); - else - { - char buf[32]; - int32_t nlen; - if (ref > 0) - { - if (use_write == P_READABLE) - { - if (ci->defined[ref]) - { - flip_ref(ci, vr); - nlen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - return; - } - object_to_port(sc, vr, port, P_READABLE, ci); - } - else - { /* "normal" printout involving #n= and #n# */ - s7_int len = 0; - char *p = pos_int_to_str(sc, (s7_int)ref, &len, '='); - *--p = '#'; - port_write_string(port)(sc, p, len, port); - object_to_port(sc, vr, port, NOT_P_DISPLAY(use_write), ci); - }} - else - if (use_write == P_READABLE) - { - nlen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - } - else - { - s7_int len = 0; - char *p = pos_int_to_str(sc, (s7_int)(-ref), &len, '#'); - *--p = '#'; - port_write_string(port)(sc, p, len, port); - }} -} - -static s7_pointer cyclic_out(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci) -{ - int32_t ref, len; - char buf[128]; - - ci->cycle_port = s7_open_output_string(sc); - ci->cycle_loc = gc_protect_1(sc, ci->cycle_port); - - port_write_string(port)(sc, "(let (", 6, port); - for (int32_t i = 0; i < ci->top; i++) - { - ref = peek_shared_ref(ci, ci->objs[i]); /* refs may be in any order */ - if (ref < 0) {ref = -ref; flip_ref(ci, ci->objs[i]);} - len = catstrs_direct(buf, (i == 0) ? "(<" : "\n (<", pos_int_to_str_direct(sc, ref), "> ", (const char *)NULL); - port_write_string(port)(sc, buf, len, port); - ci->defined[ref] = false; - object_to_port_with_circle_check(sc, ci->objs[i], port, P_READABLE, ci); - port_write_character(port)(sc, ')', port); - ci->defined[ref] = true; - if (peek_shared_ref(ci, ci->objs[i]) > 0) flip_ref(ci, ci->objs[i]); /* ref < 0 -> use <%d> in object_to_port */ - } - port_write_string(port)(sc, ")\n", 2, port); - - if (ci->init_port != sc->F) - { - port_write_string(port)(sc, (const char *)(port_data(ci->init_port)), port_position(ci->init_port), port); - s7_close_output_port(sc, ci->init_port); - s7_gc_unprotect_at(sc, ci->init_loc); - ci->init_port = sc->F; - } - - if (port_position(ci->cycle_port) > 0) /* 0 if e.g. (object->string (object->let (rootlet)) :readable) */ - port_write_string(port)(sc, (const char *)(port_data(ci->cycle_port)), port_position(ci->cycle_port), port); - s7_close_output_port(sc, ci->cycle_port); - s7_gc_unprotect_at(sc, ci->cycle_loc); - ci->cycle_port = sc->F; - - if ((is_immutable(obj)) && (!is_let(obj))) - port_write_string(port)(sc, " (immutable! ", 14, port); - else port_write_string(port)(sc, " ", 2, port); - - ref = peek_shared_ref(ci, obj); - if (ref == 0) - object_to_port_with_circle_check(sc, obj, port, P_READABLE, ci); - else - { - len = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, (ref < 0) ? -ref : ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, len, port); - } - - if ((is_immutable(obj)) && (!is_let(obj))) - port_write_string(port)(sc, "))\n", 3, port); - else port_write_string(port)(sc, ")\n", 2, port); - return(obj); -} - -static void object_out_1(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice) -{ - if (sc->object_out_locked) - object_to_port_with_circle_check(sc, T_Pos(obj), strport, choice, sc->circle_info); - else - { - shared_info_t *ci = make_shared_info(sc, T_Pos(obj), choice != P_READABLE); - if (ci) - { - sc->object_out_locked = true; - if (choice == P_READABLE) - cyclic_out(sc, obj, strport, ci); - else object_to_port_with_circle_check(sc, T_Pos(obj), strport, choice, ci); - sc->object_out_locked = false; - } - else object_to_port(sc, obj, strport, choice, NULL); - } -} - -static inline s7_pointer object_out(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice) -{ - if ((has_structure(obj)) && - (obj != sc->rootlet)) - object_out_1(sc, obj, strport, choice); - else object_to_port(sc, obj, strport, choice, NULL); - return(obj); -} - -static s7_pointer new_format_port(s7_scheme *sc) -{ - s7_pointer x = alloc_pointer(sc); - s7_int len = FORMAT_PORT_LENGTH; - block_t *block, *b; - set_full_type(x, T_OUTPUT_PORT); - b = mallocate_port(sc); - port_block(x) = b; - port_port(x) = (port_t *)block_data(b); - port_type(x) = STRING_PORT; - port_set_closed(x, false); - port_data_size(x) = len; - port_next(x) = NULL; - block = mallocate(sc, len); - port_data(x) = (uint8_t *)(block_data(block)); - port_data_block(x) = block; - port_data(x)[0] = '\0'; - port_position(x) = 0; - port_needs_free(x) = false; - port_port(x)->pf = &output_string_functions; - return(x); -} - -static inline s7_pointer open_format_port(s7_scheme *sc) -{ - s7_pointer x = sc->format_ports; - if (!x) return(new_format_port(sc)); - sc->format_ports = (s7_pointer)(port_next(x)); - port_position(x) = 0; - port_data(x)[0] = '\0'; - return(x); -} - -static void close_format_port(s7_scheme *sc, s7_pointer port) -{ - port_next(port) = (struct block_t *)(sc->format_ports); - sc->format_ports = port; -} - -char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj) -{ - char *str; - s7_pointer strport; - s7_int len; - - TRACK(sc); - if ((sc->safety > NO_SAFETY) && - (!s7_is_valid(sc, obj))) - s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj); - - strport = open_format_port(sc); - object_out(sc, T_Pos(obj), strport, P_WRITE); - len = port_position(strport); - if ((S7_DEBUGGING) && (len == 0)) fprintf(stderr, "%s[%d]: len == 0\n", __func__, __LINE__); - /* if (len == 0) {close_format_port(sc, strport); return(NULL);} */ /* probably never happens */ - str = (char *)Malloc(len + 1); - memcpy((void *)str, (void *)port_data(strport), len); - str[len] = '\0'; - close_format_port(sc, strport); - return(str); -} - -static inline void restore_format_port(s7_scheme *sc, s7_pointer strport) -{ - block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH); - port_data(strport) = (uint8_t *)(block_data(block)); - port_data_block(strport) = block; - port_data(strport)[0] = '\0'; - port_position(strport) = 0; - port_data_size(strport) = FORMAT_PORT_LENGTH; - port_needs_free(strport) = false; - close_format_port(sc, strport); -} - - -/* -------------------------------- object->string -------------------------------- */ -s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer obj, bool use_write) /* unavoidable backwards compatibility rigidity here */ -{ - s7_pointer strport, res; - - if ((sc->safety > NO_SAFETY) && - (!s7_is_valid(sc, obj))) - s7_warn(sc, 256, "bad argument to %s: %p\n", __func__, obj); - - strport = open_format_port(sc); - object_out(sc, obj, strport, (use_write) ? P_WRITE : P_DISPLAY); - - if (port_position(strport) >= port_data_size(strport)) - res = block_to_string(sc, reallocate(sc, port_data_block(strport), port_position(strport) + 1), port_position(strport)); - else res = block_to_string(sc, port_data_block(strport), port_position(strport)); - restore_format_port(sc, strport); - return(res); -} - -static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_object_to_string "(object->string obj (write #t) (max-len (*s7* 'most-positive-fixnum))) returns a string representation of obj." - #define Q_object_to_string s7_make_signature(sc, 4, \ - sc->is_string_symbol, sc->T, \ - s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_keyword_symbol), sc->is_integer_symbol) - use_write_t choice; - s7_pointer obj = car(args), strport, res; - s7_int out_len, pending_max = S7_INT64_MAX; - bool old_openlets = sc->has_openlets; - - if (is_not_null(cdr(args))) - { - s7_pointer arg = cadr(args); - if (arg == sc->F) choice = P_DISPLAY; - else {if (arg == sc->T) choice = P_WRITE; - else {if (arg == sc->readable_keyword) choice = P_READABLE; - else {if (arg == sc->display_keyword) choice = P_DISPLAY; - else {if (arg == sc->write_keyword) choice = P_WRITE; - else wrong_type_error_nr(sc, sc->object_to_string_symbol, 2, arg, wrap_string(sc, "a boolean or :readable", 22));}}}} - - if (is_not_null(cddr(args))) - { - arg = caddr(args); - if (!s7_is_integer(arg)) - { - if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable "hi") */ - wrong_type_error_nr(sc, sc->object_to_string_symbol, 3, arg, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, arg, sc->object_to_string_symbol, args, sc->type_names[T_INTEGER], 3)); - } - if (s7_integer_clamped_if_gmp(sc, arg) < 0) - out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, arg, a_non_negative_integer_string); - pending_max = s7_integer_clamped_if_gmp(sc, arg); - }} - else choice = P_WRITE; - /* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean */ - - if (choice == P_READABLE) - sc->has_openlets = false; /* so (object->string obj :readable) ignores obj's object->string method -- is this a good idea? */ - else check_method(sc, obj, sc->object_to_string_symbol, args); - - strport = open_format_port(sc); - sc->objstr_max_len = pending_max; - object_out(sc, obj, strport, choice); - sc->objstr_max_len = S7_INT64_MAX; - out_len = port_position(strport); - - if ((pending_max >= 0) && - (out_len > pending_max)) - { - if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable 4) */ - { - close_format_port(sc, strport); - sc->has_openlets = old_openlets; - out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, wrap_integer(sc, out_len), wrap_string(sc, "the readable string is too long", 31)); - } - out_len = pending_max; - if (out_len < 3) - { - close_format_port(sc, strport); - sc->has_openlets = old_openlets; - return(make_string_with_length(sc, "...", 3)); - } - for (s7_int i = out_len - 3; i < out_len; i++) - port_data(strport)[i] = (uint8_t)'.'; - } - if (out_len >= port_data_size(strport)) /* this can happen (but only == I think) */ - res = block_to_string(sc, reallocate(sc, port_data_block(strport), out_len + 1), out_len); - else res = block_to_string(sc, port_data_block(strport), out_len); - restore_format_port(sc, strport); - sc->has_openlets = old_openlets; - return(res); -} - -#if S7_DEBUGGING -const char *s7_object_to_c_string_x(s7_scheme *sc, s7_pointer obj, s7_pointer urchoice) {return(string_value(g_object_to_string(sc, list_2(sc, obj, urchoice))));} -#endif - - -/* -------------------------------- newline -------------------------------- */ -void s7_newline(s7_scheme *sc, s7_pointer port) -{ - if (port != sc->F) - port_write_character(port)(sc, (uint8_t)'\n', port); -} - -#define newline_char chars[(uint8_t)'\n'] - -static s7_pointer g_newline(s7_scheme *sc, s7_pointer args) -{ - #define H_newline "(newline (port (current-output-port))) writes a carriage return to the port" - #define Q_newline s7_make_signature(sc, 2, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - - s7_pointer port = (is_not_null(args)) ? car(args) : current_output_port(sc); - if (!is_output_port(port)) - { - if (port == sc->F) return(newline_char); - check_method(sc, port, sc->newline_symbol, args); - sole_arg_wrong_type_error_nr(sc, sc->newline_symbol, port, an_output_port_or_f_string); /* 0 -> "zeroth" */ - } - if (port_is_closed(port)) - sole_arg_wrong_type_error_nr(sc, sc->newline_symbol, port, an_open_output_port_string); - s7_newline(sc, port); - return(newline_char); /* return(sc->unspecified) until 28-Sep-17, but for example (display c) returns c */ -} - -static s7_pointer newline_p(s7_scheme *sc) -{ - s7_newline(sc, current_output_port(sc)); - return(newline_char); -} - -static s7_pointer newline_p_p(s7_scheme *sc, s7_pointer port) -{ - if (!is_output_port(port)) - { - if (port == sc->F) return(newline_char); - return(sole_arg_method_or_bust_p(sc, port, sc->newline_symbol, an_output_port_string)); - } - s7_newline(sc, port); - return(newline_char); -} - - -/* -------------------------------- write -------------------------------- */ -s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - if (port != sc->F) - { - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_open_output_port_string); - object_out(sc, obj, port, P_WRITE); - } - return(obj); -} - -static s7_pointer write_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port) -{ - if (!is_output_port(port)) - { - if (port == sc->F) return(x); - check_method(sc, port, sc->write_symbol, set_mlist_2(sc, x, port)); - wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_output_port_or_f_string); - } - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_open_output_port_string); - return(object_out(sc, x, port, P_WRITE)); -} - -static s7_pointer g_write(s7_scheme *sc, s7_pointer args) -{ - #define H_write "(write obj (port (current-output-port))) writes (object->string obj) to the output port" - #define Q_write s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - check_method(sc, car(args), sc->write_symbol, args); - return(write_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc))); -} - -static s7_pointer write_p_p(s7_scheme *sc, s7_pointer x) -{ - return((current_output_port(sc) == sc->F) ? x : object_out(sc, x, current_output_port(sc), P_WRITE)); -} - - -/* -------------------------------- display -------------------------------- */ -s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port) -{ - if (port != sc->F) - { - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_open_output_port_string); - object_out(sc, obj, port, P_DISPLAY); - } - return(obj); -} - -static s7_pointer display_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port) -{ - if (!is_output_port(port)) - { - if (port == sc->F) return(x); - check_method(sc, port, sc->display_symbol, set_mlist_2(sc, x, port)); - wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_output_port_or_f_string); - } - if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_open_output_port_string); - check_method(sc, x, sc->display_symbol, set_plist_2(sc, x, port)); - return(object_out(sc, x, port, P_DISPLAY)); -} - -static s7_pointer g_display(s7_scheme *sc, s7_pointer args) -{ - #define H_display "(display obj (port (current-output-port))) prints obj" - #define Q_display s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol)) - return(display_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc))); -} - -static s7_pointer g_display_2(s7_scheme *sc, s7_pointer args) {return(display_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_display_f(s7_scheme *unused_sc, s7_pointer args) {return(car(args));} - -static s7_pointer display_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if (args == 2) /* not check_for_substring_temp(sc, expr) here -- display returns arg so can be immutable if substring_uncopied */ - return((caddr(expr) == sc->F) ? sc->display_f : sc->display_2); - return(f); -} - -static s7_pointer display_p_p(s7_scheme *sc, s7_pointer x) -{ - if (current_output_port(sc) == sc->F) return(x); - check_method(sc, x, sc->display_symbol, set_plist_1(sc, x)); - return(object_out(sc, x, current_output_port(sc), P_DISPLAY)); -} - - -/* -------------------------------- call-with-output-string -------------------------------- */ -static s7_pointer g_call_with_output_string(s7_scheme *sc, s7_pointer args) -{ - #define H_call_with_output_string "(call-with-output-string proc) opens a string port applies proc to it, then returns the collected output" - #define Q_call_with_output_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - s7_pointer port, proc = car(args); - if (is_let(proc)) - check_method(sc, proc, sc->call_with_output_string_symbol, args); - if ((!is_any_procedure(proc)) || /* this disallows goto/continuation */ - (!s7_is_aritable(sc, proc, 1))) - return(method_or_bust(sc, proc, sc->call_with_output_string_symbol, args, wrap_string(sc, "a procedure of one argument (the port)", 38), 1)); - - port = s7_open_output_string(sc); - push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* # here is a marker (needed) */ - push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); /* args checked in call_with_exit */ - push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc); - return(sc->F); -} - - -/* -------------------------------- call-with-output-file -------------------------------- */ -static s7_pointer g_call_with_output_file(s7_scheme *sc, s7_pointer args) -{ - #define H_call_with_output_file "(call-with-output-file filename proc) opens filename and calls proc with the output port as its argument" - #define Q_call_with_output_file sc->pl_sf - - s7_pointer port, file = car(args), proc = cadr(args); - if (!is_string(file)) - return(method_or_bust(sc, file, sc->call_with_output_file_symbol, args, sc->type_names[T_STRING], 1)); - if ((!is_any_procedure(proc)) || - (!s7_is_aritable(sc, proc, 1))) - return(method_or_bust(sc, proc, sc->call_with_output_file_symbol, args, wrap_string(sc, "a procedure of one argument (the port)", 38), 2)); - - port = s7_open_output_file(sc, string_value(file), "w"); - push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* # here is a marker (needed) */ - push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc); - return(sc->F); -} - - -/* -------------------------------- with-output-to-string -------------------------------- */ -static s7_pointer g_with_output_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_with_output_to_string "(with-output-to-string thunk) opens a string as a temporary current-output-port, \ -calls thunk, then returns the collected output" - #define Q_with_output_to_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - - s7_pointer old_output_port, p = car(args); - if (!is_thunk(sc, p)) - return(method_or_bust(sc, p, sc->with_output_to_string_symbol, args, a_thunk_string, 1)); - if ((is_continuation(p)) || (is_goto(p))) - wrong_type_error_nr(sc, sc->with_output_to_string_symbol, 1, p, a_normal_procedure_string); - - old_output_port = current_output_port(sc); - set_current_output_port(sc, s7_open_output_string(sc)); - push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, current_output_port(sc)); - push_stack(sc, OP_GET_OUTPUT_STRING, old_output_port, current_output_port(sc)); - push_stack(sc, OP_APPLY, sc->nil, p); - return(sc->F); -} - - -/* -------------------------------- with-output-to-file -------------------------------- */ -static s7_pointer g_with_output_to_file(s7_scheme *sc, s7_pointer args) -{ - #define H_with_output_to_file "(with-output-to-file filename thunk) opens filename as the temporary current-output-port and calls thunk" - #define Q_with_output_to_file sc->pl_sf - - s7_pointer old_output_port, file = car(args), proc = cadr(args); - if (!is_string(file)) - return(method_or_bust(sc, file, sc->with_output_to_file_symbol, args, sc->type_names[T_STRING], 1)); - if (!is_thunk(sc, proc)) - return(method_or_bust(sc, proc, sc->with_output_to_file_symbol, args, a_thunk_string, 2)); - if ((is_continuation(proc)) || (is_goto(proc))) - wrong_type_error_nr(sc, sc->with_output_to_file_symbol, 1, proc, a_normal_procedure_string); - - old_output_port = current_output_port(sc); - set_current_output_port(sc, s7_open_output_file(sc, string_value(file), "w")); - push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, current_output_port(sc)); - push_stack(sc, OP_APPLY, sc->nil, proc); - return(sc->F); -} - - -/* -------------------------------- format -------------------------------- */ -static inline s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst); - -static noreturn void format_error_nr(s7_scheme *sc, const char *ur_msg, s7_int msg_len, const char *str, s7_pointer ur_args, format_data_t *fdat) -{ - s7_pointer x = NULL; - s7_pointer ctrl_str = (fdat->orig_str) ? fdat->orig_str : wrap_string(sc, str, safe_strlen(str)); - s7_pointer args = (is_elist(ur_args)) ? copy_proper_list(sc, ur_args) : ur_args; - s7_pointer msg = wrap_string(sc, ur_msg, msg_len); - if (fdat->loc == 0) - { - if (is_pair(args)) - x = set_elist_4(sc, format_string_1, ctrl_str, args, msg); - else x = set_elist_3(sc, format_string_2, ctrl_str, msg); - } - else - if (is_pair(args)) - x = set_elist_5(sc, format_string_3, ctrl_str, args, wrap_integer(sc, fdat->loc + 20), msg); - else x = set_elist_4(sc, format_string_4, ctrl_str, wrap_integer(sc, fdat->loc + 20), msg); - if (fdat->port) - { - close_format_port(sc, fdat->port); - fdat->port = NULL; - } - error_nr(sc, sc->format_error_symbol, x); -} - -static void format_append_char(s7_scheme *sc, char c, s7_pointer port) -{ - port_write_character(port)(sc, c, port); - sc->format_column++; -} - -static void format_append_newline(s7_scheme *sc, s7_pointer port) -{ - port_write_character(port)(sc, '\n', port); - sc->format_column = 0; -} - -static void format_append_string(s7_scheme *sc, format_data_t *fdat, const char *str, s7_int len, s7_pointer port) -{ - port_write_string(port)(sc, str, len, port); - fdat->loc += len; - sc->format_column += len; -} - -static void format_append_chars(s7_scheme *sc, format_data_t *fdat, char pad, s7_int chars, s7_pointer port) -{ - if (is_string_port(port)) - { - if ((port_position(port) + chars) < port_data_size(port)) - { - local_memset((char *)port_data(port) + port_position(port), pad, chars); - port_position(port) += chars; - } - else - { - s7_int new_len = port_position(port) + chars; - resize_port_data(sc, port, new_len * 2); - local_memset((char *)port_data(port) + port_position(port), pad, chars); - port_position(port) = new_len; - } - fdat->loc += chars; - sc->format_column += chars; - } - else - { - block_t *b = mallocate(sc, chars + 1); - char *str = (char *)block_data(b); - local_memset((void *)str, pad, chars); - str[chars] = '\0'; - format_append_string(sc, fdat, str, chars, port); - liberate(sc, b); - } -} - -static s7_int format_read_integer(s7_int *cur_i, s7_int str_len, const char *str) -{ - /* we know that str[*cur_i] is a digit */ - s7_int i, lval = 0; - for (i = *cur_i; i < str_len - 1; i++) - { - int32_t dig = digits[(uint8_t)str[i]]; - if (dig < 10) - { -#if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow(lval, 10, &lval)) || - (add_overflow(lval, dig, &lval))) - break; -#else - lval = dig + (lval * 10); -#endif - } - else break; - } - *cur_i = i; - return(lval); -} - -static void format_number(s7_scheme *sc, format_data_t *fdat, int32_t radix, s7_int width, s7_int precision, char float_choice, char pad, s7_pointer port) -{ - char *tmp; - block_t *b = NULL; - s7_int nlen = 0; - if (width < 0) width = 0; - - /* precision choice depends on float_choice if it's -1 */ - if (precision < 0) - { - if ((float_choice == 'e') || - (float_choice == 'f') || - (float_choice == 'g')) - precision = 6; - else - /* in the "int" cases, precision depends on the arg type */ - switch (type(car(fdat->args))) - { - case T_INTEGER: case T_RATIO: - precision = 0; - break; - default: - precision = 6; - break; - }} - /* should (format #f "~F" 1/3) return "1/3"?? in CL it's "0.33333334" */ - - if (pad != ' ') - { - char *padtmp; -#if (!WITH_GMP) - if (radix == 10) - tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE); - else -#endif - { - b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen); - tmp = (char *)block_data(b); - } - padtmp = tmp; - while (*padtmp == ' ') (*(padtmp++)) = pad; - format_append_string(sc, fdat, tmp, nlen, port); - if ((WITH_GMP) || (radix != 10)) liberate(sc, b); - } - else - { -#if (!WITH_GMP) - if (radix == 10) - tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE); - else -#endif - { - b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen); - tmp = (char *)block_data(b); - } - format_append_string(sc, fdat, tmp, nlen, port); - if ((WITH_GMP) || (radix != 10)) liberate(sc, b); - } - fdat->args = cdr(fdat->args); - fdat->ctr++; -} - -static const char *ordinal[11] = {"zeroth", "first", "second", "third", "fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth"}; -static const s7_int ordinal_length[11] = {6, 5, 6, 5, 6, 5, 5, 7, 6, 5, 5}; - -static void format_ordinal_number(s7_scheme *sc, format_data_t *fdat, s7_pointer port) -{ - s7_int num = s7_integer_clamped_if_gmp(sc, car(fdat->args)); - if (num < 11) - format_append_string(sc, fdat, ordinal[num], ordinal_length[num], port); - else - { - s7_int nlen = 0; - char *tmp = integer_to_string(sc, num, &nlen); - format_append_string(sc, fdat, tmp, nlen, port); - num = num % 100; - if ((num >= 11) && (num <= 13)) - format_append_string(sc, fdat, "th", 2, port); - else - { - num = num % 10; - if (num == 1) format_append_string(sc, fdat, "st", 2, port); - else - if (num == 2) format_append_string(sc, fdat, "nd", 2, port); - else - if (num == 3) format_append_string(sc, fdat, "rd", 2, port); - else format_append_string(sc, fdat, "th", 2, port); - }} - fdat->args = cdr(fdat->args); - fdat->ctr++; -} - -static s7_int format_nesting(const char *str, char opener, char closer, s7_int start, s7_int end) /* start=i, end=str_len-1 */ -{ - s7_int nesting = 1; - for (s7_int k = start + 2; k < end; k++) - if (str[k] == '~') - { - if (str[k + 1] == closer) - { - nesting--; - if (nesting == 0) - return(k - start - 1); - } - else - if (str[k + 1] == opener) - nesting++; - } - return(-1); -} - -static bool format_method(s7_scheme *sc, const char *str, format_data_t *fdat, s7_pointer port) -{ - s7_pointer func, obj = car(fdat->args); - char ctrl_str[3]; - - if ((!has_active_methods(sc, obj)) || - ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined)) - return(false); - - ctrl_str[0] = '~'; - ctrl_str[1] = str[0]; - ctrl_str[2] = '\0'; - - if (port == obj) /* a problem! we need the openlet port for format, but that's an infinite loop when it calls format again as obj */ - s7_apply_function(sc, func, set_plist_3(sc, port, s7_make_string_wrapper(sc, ctrl_str), s7_make_string_wrapper(sc, "#"))); - else s7_apply_function(sc, func, set_plist_3(sc, port, s7_make_string_wrapper(sc, ctrl_str), obj)); - - fdat->args = cdr(fdat->args); - fdat->ctr++; - return(true); -} - -static s7_int format_n_arg(s7_scheme *sc, const char *str, format_data_t *fdat, s7_pointer args) -{ - s7_int n; - - if (is_null(fdat->args)) /* (format #f "~nT") */ - format_error_nr(sc, "~~N: missing argument", 21, str, args, fdat); - if (!s7_is_integer(car(fdat->args))) - format_error_nr(sc, "~~N: integer argument required", 30, str, args, fdat); - n = s7_integer_clamped_if_gmp(sc, car(fdat->args)); - - if (n < 0) - format_error_nr(sc, "~~N value is negative?", 22, str, args, fdat); - if (n > sc->max_format_length) - format_error_nr(sc, "~~N value is too big", 20, str, args, fdat); - - fdat->args = cdr(fdat->args); /* I don't think fdat->ctr should be incremented here -- it's for *vector-print-length* etc */ - return(n); -} - -static s7_int format_numeric_arg(s7_scheme *sc, const char *str, s7_int str_len, format_data_t *fdat, s7_int *i) -{ - s7_int old_i = *i; - s7_int width = format_read_integer(i, str_len, str); - if (width < 0) - { - if (str[old_i - 1] != ',') /* need branches here, not if-expr because format_error creates the permanent string */ - format_error_nr(sc, "width is negative?", 18, str, fdat->args, fdat); - format_error_nr(sc, "precision is negative?", 22, str, fdat->args, fdat); - } - if (width > sc->max_format_length) - { - if (str[old_i - 1] != ',') - format_error_nr(sc, "width is too big", 16, str, fdat->args, fdat); - format_error_nr(sc, "precision is too big", 20, str, fdat->args, fdat); - } - return(width); -} - -static format_data_t *open_format_data(s7_scheme *sc) -{ - format_data_t *fdat; - sc->format_depth++; - if (sc->format_depth >= sc->num_fdats) - { - int32_t new_num_fdats = sc->format_depth * 2; - sc->fdats = (format_data_t **)Realloc(sc->fdats, sizeof(format_data_t *) * new_num_fdats); - for (int32_t k = sc->num_fdats; k < new_num_fdats; k++) sc->fdats[k] = NULL; - sc->num_fdats = new_num_fdats; - } - fdat = sc->fdats[sc->format_depth]; - if (!fdat) - { - fdat = (format_data_t *)Malloc(sizeof(format_data_t)); - sc->fdats[sc->format_depth] = fdat; - fdat->curly_len = 0; - fdat->curly_str = NULL; - fdat->ctr = 0; - } - else - { - if (fdat->port) - close_format_port(sc, fdat->port); - if (fdat->strport) - close_format_port(sc, fdat->strport); - } - fdat->port = NULL; - fdat->strport = NULL; - fdat->loc = 0; - fdat->curly_arg = sc->nil; - return(fdat); -} - -#if WITH_GMP -static bool is_one_or_big_one(s7_scheme *sc, s7_pointer p) -{ - if (!is_big_number(p)) return(is_one(p)); - if (is_t_big_integer(p)) return(mpz_cmp_ui(big_integer(p), 1) == 0); - if (is_t_big_real(p)) return(mpfr_cmp_d(big_real(p), 1.0) == 0); - return(false); -} -#else -#define is_one_or_big_one(Sc, Num) is_one(Num) -#endif - -static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj); - -static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args, - s7_pointer *next_arg, bool with_result, bool columnized, s7_int len, s7_pointer orig_str) -{ - s7_int i, str_len; - format_data_t *fdat; - s7_pointer deferred_port; - - if (len <= 0) - { - str_len = safe_strlen(str); - if (str_len == 0) - { - if (is_not_null(args)) - error_nr(sc, sc->format_error_symbol, - set_elist_2(sc, wrap_string(sc, "format control string is null, but there are arguments: ~S", 58), args)); - return((with_result) ? nil_string : sc->F); - }} - else str_len = len; - - fdat = open_format_data(sc); - fdat->args = args; - fdat->orig_str = orig_str; - - if (with_result) - { - deferred_port = port; - port = open_format_port(sc); - fdat->port = port; - } - else deferred_port = sc->F; - - for (i = 0; i < str_len - 1; i++) - { - if ((uint8_t)(str[i]) == (uint8_t)'~') - { - use_write_t use_write; - switch (str[i + 1]) - { - case '%': /* -------- newline -------- */ - /* sbcl apparently accepts numeric args here (including 0) */ - if ((port_data(port)) && - (port_position(port) < port_data_size(port))) - { - port_data(port)[port_position(port)++] = '\n'; - sc->format_column = 0; - } - else format_append_newline(sc, port); - i++; - break; - - case '&': /* -------- conditional newline -------- */ - /* this only works if all output goes through format -- display/write for example do not update format_column */ - if (sc->format_column > 0) - format_append_newline(sc, port); - i++; - break; - - case '~': /* -------- tilde -------- */ - format_append_char(sc, '~', port); - i++; - break; - - case '\n': /* -------- trim white-space -------- so (format #f "hiho~\n") -> "hiho"! */ - for (i = i + 2; i args)) /* (format #f "~*~A") */ - format_error_nr(sc, "can't skip argument!", 20, str, args, fdat); - fdat->args = cdr(fdat->args); - break; - - case '|': /* -------- exit if args nil or ctr > (*s7* 'print-length) -------- */ - if ((is_pair(fdat->args)) && - (fdat->ctr >= sc->print_length)) - { - format_append_string(sc, fdat, " ...", 4, port); - fdat->args = sc->nil; - } - /* fall through */ - - case '^': /* -------- exit -------- */ - if (is_null(fdat->args)) - { - i = str_len; - goto ALL_DONE; - } - i++; - break; - - case '@': /* -------- plural, 'y' or 'ies' -------- */ - i += 2; - if ((str[i] != 'P') && (str[i] != 'p')) - format_error_nr(sc, "unknown '@' directive", 21, str, args, fdat); - if (!is_pair(fdat->args)) - format_error_nr(sc, "'@' directive argument missing", 30, str, args, fdat); - if (!is_real(car(fdat->args))) /* CL accepts non numbers here */ - format_error_nr(sc, "'@P' directive argument is not a real number", 44, str, args, fdat); - - if (!is_one_or_big_one(sc, car(fdat->args))) - format_append_string(sc, fdat, "ies", 3, port); - else format_append_char(sc, 'y', port); - - fdat->args = cdr(fdat->args); - break; - - case 'P': case 'p': /* -------- plural in 's' -------- */ - if (!is_pair(fdat->args)) - format_error_nr(sc, "'P' directive argument missing", 30, str, args, fdat); - if (!is_real(car(fdat->args))) - format_error_nr(sc, "'P' directive argument is not a real number", 43, str, args, fdat); - if (!is_one_or_big_one(sc, car(fdat->args))) - format_append_char(sc, 's', port); - i++; - fdat->args = cdr(fdat->args); - break; - - case '{': /* -------- iteration -------- */ - { - s7_int curly_len; - - if (is_null(fdat->args)) - format_error_nr(sc, "missing argument", 16, str, args, fdat); - - if ((is_pair(car(fdat->args))) && /* any sequence is possible here */ - (s7_list_length(sc, car(fdat->args)) < 0)) /* (format #f "~{~a~e~}" (cons 1 2)) */ - format_error_nr(sc, "~{ argument is a dotted list", 28, str, args, fdat); - - curly_len = format_nesting(str, '{', '}', i, str_len - 1); - - if (curly_len == -1) - format_error_nr(sc, "'{' directive, but no matching '}'", 34, str, args, fdat); - if (curly_len == 1) - format_error_nr(sc, "~{~}' doesn't consume any arguments!", 36, str, args, fdat); - - /* what about cons's here? I can't see any way to specify the car or cdr of a cons within the format string */ - if (is_not_null(car(fdat->args))) /* (format #f "~{~A ~}" ()) -> "" */ - { - s7_pointer curly_arg = object_to_list(sc, car(fdat->args)); /* if a pair (or non-sequence), this simply returns the original */ - /* perhaps use an iterator here -- rootlet->list is expensive! */ - if (is_pair(curly_arg)) /* (format #f "~{~A ~}" #()) -> "" */ - { - char *curly_str = NULL; /* this is the local (nested) format control string */ - s7_pointer orig_arg, cycle_arg; - - fdat->curly_arg = curly_arg; - orig_arg = (curly_arg != car(fdat->args)) ? curly_arg : sc->nil; - if (curly_len > fdat->curly_len) - { - if (fdat->curly_str) free(fdat->curly_str); - fdat->curly_len = curly_len; - fdat->curly_str = (char *)Malloc(curly_len); - } - curly_str = fdat->curly_str; - memcpy((void *)curly_str, (void *)(str + i + 2), curly_len - 1); - curly_str[curly_len - 1] = '\0'; - - if ((sc->format_depth < sc->num_fdats - 1) && - (sc->fdats[sc->format_depth + 1])) - sc->fdats[sc->format_depth + 1]->ctr = 0; - - /* it's not easy to use an iterator here instead of a list (so object->list isn't needed above), - * because the curly brackets may enclose multiple arguments -- we would need to use - * iterators throughout this function. - */ - cycle_arg = curly_arg; - while (is_pair(curly_arg)) - { - s7_pointer new_arg = sc->nil; - format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1, NULL); - if (curly_arg == new_arg) - { - if (cdr(curly_arg) == curly_arg) break; - fdat->curly_arg = sc->nil; - format_error_nr(sc, "'{...}' doesn't consume any arguments!", 38, str, args, fdat); - } - curly_arg = new_arg; - if ((!is_pair(curly_arg)) || (curly_arg == cycle_arg)) - break; - cycle_arg = cdr(cycle_arg); - format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1, NULL); - curly_arg = new_arg; - } - fdat->curly_arg = sc->nil; - while (is_pair(orig_arg)) /* free_cell below clears the type, so a circular list here is ok */ - { - s7_pointer p = orig_arg; - orig_arg = cdr(orig_arg); - free_cell(sc, p); /* if car(fdar->args) is a hash-table, we could also free_cell(car(p)), but not in any other case */ - }} - else - if (!is_null(curly_arg)) - format_error_nr(sc, "'{' directive argument should be a list or something we can turn into a list", 76, str, args, fdat); - } - i += (curly_len + 2); /* jump past the ending '}' too */ - fdat->args = cdr(fdat->args); - fdat->ctr++; - } - break; - - case '}': - format_error_nr(sc, "unmatched '}'", 13, str, args, fdat); - - case '$': - use_write = P_CODE; - goto OBJSTR; - - case 'W': case 'w': - use_write = P_READABLE; - goto OBJSTR; - - case 'S': case 's': - use_write = P_WRITE; - goto OBJSTR; - - case 'A': case 'a': - use_write = P_DISPLAY; - OBJSTR: /* object->string */ - { - s7_pointer obj, strport; - if (is_null(fdat->args)) - format_error_nr(sc, "missing argument", 16, str, args, fdat); - i++; - obj = car(fdat->args); - if ((use_write == P_READABLE) || - (!has_active_methods(sc, obj)) || - (!format_method(sc, (char *)(str + i), fdat, port))) - { - bool old_openlets = sc->has_openlets; - /* for the column check, we need to know the length of the object->string output */ - if (columnized) - { - strport = open_format_port(sc); - fdat->strport = strport; - } - else strport = port; - if (use_write == P_READABLE) - sc->has_openlets = false; - object_out(sc, obj, strport, use_write); - if (use_write == P_READABLE) - sc->has_openlets = old_openlets; - if (columnized) - { - if (port_position(strport) >= port_data_size(strport)) - resize_port_data(sc, strport, port_data_size(strport) * 2); - port_data(strport)[port_position(strport)] = '\0'; - if (port_position(strport) > 0) - format_append_string(sc, fdat, (const char *)port_data(strport), port_position(strport), port); - close_format_port(sc, strport); - fdat->strport = NULL; - } - fdat->args = cdr(fdat->args); - fdat->ctr++; - }} - break; - - /* -------- numeric args -------- */ - case ':': - i += 2; - if ((str[i] != 'D') && (str[i] != 'd')) - format_error_nr(sc, "unknown ':' directive", 21, str, args, fdat); - if (!is_pair(fdat->args)) - format_error_nr(sc, "':D' directive argument missing", 31, str, args, fdat); - if (!s7_is_integer(car(fdat->args))) - format_error_nr(sc, "':D' directive argument is not an integer", 41, str, args, fdat); - if (s7_integer_clamped_if_gmp(sc, car(fdat->args)) < 0) - format_error_nr(sc, "':D' directive argument can't be negative", 41, str, args, fdat); - format_ordinal_number(sc, fdat, port); - break; - - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': case ',': - case 'N': case 'n': - - case 'B': case 'b': - case 'D': case 'd': - case 'E': case 'e': - case 'F': case 'f': - case 'G': case 'g': - case 'O': case 'o': - case 'X': case 'x': - - case 'T': case 't': - case 'C': case 'c': - { - s7_int width = -1, precision = -1; - char pad = ' '; - i++; /* str[i] == '~' */ - - if (isdigit((int32_t)(str[i]))) - width = format_numeric_arg(sc, str, str_len, fdat, &i); - else - if ((str[i] == 'N') || (str[i] == 'n')) - { - i++; - width = format_n_arg(sc, str, fdat, args); - } - if (str[i] == ',') - { - i++; /* is (format #f "~12,12D" 1) an error? The precision (or is it the width?) has no use here */ - if (isdigit((int32_t)(str[i]))) - precision = format_numeric_arg(sc, str, str_len, fdat, &i); - else - if ((str[i] == 'N') || (str[i] == 'n')) - { - i++; - precision = format_n_arg(sc, str, fdat, args); - } - else - if (str[i] == '\'') /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */ - { - pad = str[i + 1]; - i += 2; - if (i >= str_len) /* (format #f "~,'") */ - format_error_nr(sc, "incomplete numeric argument", 27, str, args, fdat); - }} /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */ - - switch (str[i]) - { - /* -------- pad to column -------- - * are columns numbered from 1 or 0? there seems to be disagreement about this directive, does "space over to" mean including? - */ - case 'T': case 't': - if (width == -1) width = 0; - if (precision == -1) precision = 0; - if ((width > 0) || (precision > 0)) /* (format #f "a~8Tb") */ - { - /* (length (substring (format #f "~%~10T.") 1)) == (length (format #f "~10T.")) - * (length (substring (format #f "~%-~10T.~%") 1)) == (length (format #f "-~10T.~%")) - */ - if (precision > 0) - { - int32_t mult = (int32_t)(ceil((s7_double)(sc->format_column + 1 - width) / (s7_double)precision)); /* CLtL2 ("least positive int") */ - if (mult < 1) mult = 1; - width += (precision * mult); - } - width -= (sc->format_column + 1); - if (width > 0) - format_append_chars(sc, fdat, pad, width, port); - } - break; - - case 'C': case 'c': - { - s7_pointer obj; - - if (is_null(fdat->args)) - format_error_nr(sc, "~~C: missing argument", 21, str, args, fdat); - /* the "~~" here and below protects against "~C" being treated as a directive */ - obj = car(fdat->args); - if (!is_character(obj)) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) /* i stepped forward above */ - format_error_nr(sc, "'C' directive requires a character argument", 43, str, args, fdat); - } - else - { - /* here use_write is false, so we just add the char, not its name */ - if (width == -1) - format_append_char(sc, character(obj), port); - else - if (width > 0) - format_append_chars(sc, fdat, character(obj), width, port); - - fdat->args = cdr(fdat->args); - fdat->ctr++; - }} - break; - - /* -------- numbers -------- */ - case 'F': case 'f': - if (is_null(fdat->args)) - format_error_nr(sc, "~~F: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~F: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'f', pad, port); - break; - - case 'G': case 'g': - if (is_null(fdat->args)) - format_error_nr(sc, "~~G: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~G: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'g', pad, port); - break; - - case 'E': case 'e': - if (is_null(fdat->args)) - format_error_nr(sc, "~~E: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~E: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'e', pad, port); - break; - - /* how to handle non-integer arguments in the next 4 cases? clisp just returns - * the argument: (format nil "~X" 1.25) -> "1.25" which is perverse (ClTl2 p 581: - * "if arg is not an integer, it is printed in ~A format and decimal base")!! - * I think I'll use the type of the number to choose the output format. - */ - case 'D': case 'd': - if (is_null(fdat->args)) - format_error_nr(sc, "~~D: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - /* (let () (require mockery.scm) (format #f "~D" ((*mock-number* 'mock-number) 123))) - * port here is a string-port, str has the width/precision data if the caller wants it, - * args is the current arg. But format_number handles fdat->args and so on, so - * I think I'll pass the format method the current control string (str), the - * current object (car(fdat->args)), and the arglist (args), and assume it will - * return a (scheme) string. - */ - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~D: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'd', pad, port); - break; - - case 'O': case 'o': - if (is_null(fdat->args)) - format_error_nr(sc, "~~O: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~O: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 8, width, precision, 'o', pad, port); - break; - - case 'X': case 'x': - if (is_null(fdat->args)) - format_error_nr(sc, "~~X: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~X: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 16, width, precision, 'x', pad, port); - break; - - case 'B': case 'b': - if (is_null(fdat->args)) - format_error_nr(sc, "~~B: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (char *)(str + i), fdat, port)) - format_error_nr(sc, "~~B: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 2, width, precision, 'b', pad, port); - break; - - default: - if (width > 0) - format_error_nr(sc, "unused numeric argument", 23, str, args, fdat); - format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat); - }} - break; - - default: - format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat); - }} - else /* str[i] is not #\~ */ - { - const char *p = (char *)strchr((const char *)(str + i + 1), (int)'~'); - s7_int j = (p) ? p - str : str_len; - s7_int new_len = j - i; - - if ((port_data(port)) && - ((port_position(port) + new_len) < port_data_size(port))) - { - memcpy((void *)(port_data(port) + port_position(port)), (void *)(str + i), new_len); - port_position(port) += new_len; - } - else port_write_string(port)(sc, (char *)(str + i), new_len, port); - fdat->loc += new_len; - sc->format_column += new_len; - i = j - 1; - }} - - ALL_DONE: - if (next_arg) - (*next_arg) = fdat->args; - else - if (is_not_null(fdat->args)) - format_error_nr(sc, "too many arguments", 18, str, args, fdat); - - if (i < str_len) - { - if (str[i] == '~') - format_error_nr(sc, "control string ends in tilde", 28, str, args, fdat); - format_append_char(sc, str[i], port); - } - sc->format_depth--; - if (with_result) - { - s7_pointer result; - if ((is_output_port(deferred_port)) && - (port_position(port) > 0)) - { - if (port_position(port) < port_data_size(port)) - port_data(port)[port_position(port)] = '\0'; - port_write_string(deferred_port)(sc, (const char *)port_data(port), port_position(port), deferred_port); - } - if (port_position(port) < port_data_size(port)) - { - block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH); - result = inline_block_to_string(sc, port_data_block(port), port_position(port)); - port_data_size(port) = FORMAT_PORT_LENGTH; - port_data_block(port) = block; - port_data(port) = (uint8_t *)(block_data(block)); - port_data(port)[0] = '\0'; - port_position(port) = 0; - } - else result = make_string_with_length(sc, (char *)port_data(port), port_position(port)); - close_format_port(sc, port); - fdat->port = NULL; - return(result); - } - return(sc->F); -} - -static bool is_columnizing(const char *str) /* look for ~t ~,T ~,t */ -{ - for (char *p = (char *)str; (*p);) - if (*p++ == '~') /* this is faster than strchr */ - { - char c = *p++; - if ((c == 't') || (c == 'T')) return(true); - if (!c) return(false); - if ((c == ',') || ((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) - { - while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++; - if ((c == 't') || (c == 'T')) return(true); - if (!c) return(false); /* ~,1 for example */ - if (c == ',') - { - c = *p++; - while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++; - if ((c == 't') || (c == 'T')) return(true); - if (!c) return(false); - }}} - return(false); -} - -static s7_pointer format_to_port(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args, bool with_result, s7_int len) -{ - if ((with_result) || - (port != sc->F)) - return(format_to_port_1(sc, port, str, args, NULL, with_result, true /* is_columnizing(str) */, len, NULL)); - /* is_columnizing on every call is much slower than ignoring the issue */ - return(sc->F); -} - -static s7_pointer g_format(s7_scheme *sc, s7_pointer args) -{ - #define H_format "(format out str . args) substitutes args into str sending the result to out. Most of \ -s7's format directives are taken from CL: ~% = newline, ~& = newline if the preceding output character was \ -no a newline, ~~ = ~, ~ trims white space, ~* skips an argument, ~^ exits {} iteration if the arg list is exhausted, \ -~nT spaces over to column n, ~A prints a representation of any object, ~S is the same, but puts strings in double quotes, \ -~C prints a character, numbers are handled by ~F, ~E, ~G, ~B, ~O, ~D, and ~X with preceding numbers giving \ -spacing (and spacing character) and precision. ~{ starts an embedded format directive which is ended by ~}: \n\ -\n\ - >(format #f \"dashed: ~{~A~^-~}\" '(1 2 3))\n\ - \"dashed: 1-2-3\"\n\ -\n\ -~P inserts \"s\" if the current it is not 1 or 1.0 (use ~@P for \"ies\" or \"y\").\n\ -~B is number->string in base 2, ~O in base 8, ~D base 10, ~X base 16,\n\ -~E: (format #f \"~E\" 100.1) -> \"1.001000e+02\" (%e in C)\n\ -~F: (format #f \"~F\" 100.1) -> \"100.100000\" (%f in C)\n\ -~G: (format #f \"~G\" 100.1) -> \"100.1\" (%g in C)\n\ -\n\ -If the 'out' it is not an output port, the resultant string is returned. If it \ -is #t, the string is also sent to the current-output-port." - - #define Q_format s7_make_circular_signature(sc, 2, 3, \ - s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), \ - s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T) - - s7_pointer pt = car(args), str; - if (is_null(pt)) - { - pt = current_output_port(sc); /* () -> (current-output-port) */ - if (pt == sc->F) /* otherwise () -> #f so we get a returned string, which is confusing */ - return(pt); /* but this means some error checks are skipped? */ - } - sc->format_column = 0; - if (!((is_boolean(pt)) || /* #f or #t */ - ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ - (!port_is_closed(pt))))) - return(method_or_bust(sc, pt, sc->format_symbol, args, an_output_port_string, 1)); - - str = cadr(args); - if (!is_string(str)) - return(method_or_bust(sc, str, sc->format_symbol, args, sc->type_names[T_STRING], 2)); - return(format_to_port_1(sc, (pt == sc->T) ? current_output_port(sc) : pt, - string_value(str), cddr(args), NULL, !is_output_port(pt), true, string_length(str), str)); -} - -const char *s7_format(s7_scheme *sc, s7_pointer args) -{ - s7_pointer result = g_format(sc, args); - return((is_string(result)) ? string_value(result) : NULL); -} - -static s7_pointer g_format_f(s7_scheme *sc, s7_pointer args) -{ - /* port == #f, there are other args */ - s7_pointer str = cadr(args); - sc->format_column = 0; - if (!is_string(str)) - return(method_or_bust(sc, str, sc->format_symbol, args, sc->type_names[T_STRING], 2)); - return(format_to_port_1(sc, sc->F, string_value(str), cddr(args), NULL, true, true, string_length(str), str)); -} - -static s7_pointer g_format_just_control_string(s7_scheme *sc, s7_pointer args) -{ - s7_pointer pt = car(args); - s7_pointer str = cadr(args); - if (pt == sc->F) - return(str); - - if (is_null(pt)) - { - pt = current_output_port(sc); - if (pt == sc->F) - return(sc->F); - } - if (pt == sc->T) - { - if ((current_output_port(sc) != sc->F) && (string_length(str) != 0)) - port_write_string(sc->output_port)(sc, string_value(str), string_length(str), current_output_port(sc)); - return(str); - } - if ((!is_output_port(pt)) || - (port_is_closed(pt))) - return(method_or_bust(sc, pt, sc->format_symbol, args, a_format_port_string, 1)); - - if (string_length(str) == 0) - return((is_output_port(pt)) ? sc->F : nil_string); - - port_write_string(pt)(sc, string_value(str), string_length(str), pt); - return(sc->F); -} - -static s7_pointer g_format_as_objstr(s7_scheme *sc, s7_pointer args) -{ - s7_pointer func, obj = caddr(args); - if ((!has_active_methods(sc, obj)) || - ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined)) - return(s7_object_to_string(sc, obj, false)); - return(s7_apply_function(sc, func, set_plist_3(sc, sc->F, cadr(args), obj))); -} - -static s7_pointer g_format_no_column(s7_scheme *sc, s7_pointer args) -{ - s7_pointer pt = car(args), str; - if (is_null(pt)) - { - pt = current_output_port(sc); - if (pt == sc->F) - return(sc->F); - } - if (!((is_boolean(pt)) || - ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ - (!port_is_closed(pt))))) - return(method_or_bust(sc, pt, sc->format_symbol, args, a_format_port_string, 1)); - - str = cadr(args); - sc->format_column = 0; - return(format_to_port_1(sc, (pt == sc->T) ? current_output_port(sc) : pt, - string_value(str), cddr(args), NULL, - !is_output_port(pt), /* i.e. is boolean port so we're returning a string */ - false, /* we checked in advance that it is not columnized */ - string_length(str), str)); -} - -static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (args > 1) - { - s7_pointer port = cadr(expr); - s7_pointer str_arg = caddr(expr); - if (is_string(str_arg)) - { - if ((ops) && ((args == 2) || (args == 3))) - { - s7_int len; - char *orig = string_value(str_arg); - const char *p = strchr((const char *)orig, (int)'~'); - if (!p) - return((args == 2) ? sc->format_just_control_string : f); - - len = string_length(str_arg); - if ((args == 2) && - (len > 1) && - (orig[len - 1] == '%') && - ((p - orig) == len - 2)) - { - orig[len - 2] = '\n'; - orig[len - 1] = '\0'; - string_length(str_arg) = len - 1; - return(sc->format_just_control_string); - } - if ((args == 3) && - (len == 2) && - (port == sc->F) && - (orig[0] == '~') && - ((orig[1] == 'A') || (orig[1] == 'a'))) - return(sc->format_as_objstr); - } - /* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */ - if (!is_columnizing(string_value(str_arg))) - return(sc->format_no_column); - } - if (port == sc->F) - return(sc->format_f); - } - return(f); -} - - -#if WITH_SYSTEM_EXTRAS -#include - -/* -------------------------------- directory? -------------------------------- */ -static s7_pointer g_is_directory(s7_scheme *sc, s7_pointer args) -{ - #define H_is_directory "(directory? str) returns #t if str is the name of a directory" - #define Q_is_directory s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol) - - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->is_directory_symbol, args, sc->type_names[T_STRING])); - return(s7_make_boolean(sc, is_directory(string_value(name)))); -} - -static bool is_directory_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_string(p)) - sole_arg_wrong_type_error_nr(sc, sc->is_directory_symbol, p, sc->type_names[T_STRING]); - return(is_directory(string_value(p))); -} - -static bool file_probe(const char *arg) -{ -#if (!MS_WINDOWS) - return(access(arg, F_OK) == 0); -#else - int32_t fd = open(arg, O_RDONLY, 0); - if (fd == -1) return(false); - close(fd); - return(true); -#endif -} - -/* -------------------------------- file-exists? -------------------------------- */ -static s7_pointer g_file_exists(s7_scheme *sc, s7_pointer args) -{ - #define H_file_exists "(file-exists? filename) returns #t if the file exists" - #define Q_file_exists s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol) - - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->file_exists_symbol, args, sc->type_names[T_STRING])); - return(s7_make_boolean(sc, file_probe(string_value(name)))); -} - -static bool file_exists_b_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_string(p)) - sole_arg_wrong_type_error_nr(sc, sc->file_exists_symbol, p, sc->type_names[T_STRING]); - return(file_probe(string_value(p))); -} - -/* -------------------------------- delete-file -------------------------------- */ -static s7_pointer g_delete_file(s7_scheme *sc, s7_pointer args) -{ - #define H_delete_file "(delete-file filename) deletes the file filename." - #define Q_delete_file s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol) - - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->delete_file_symbol, args, sc->type_names[T_STRING])); - return(make_integer(sc, unlink(string_value(name)))); -} - -/* -------------------------------- getenv -------------------------------- */ -static s7_pointer g_getenv(s7_scheme *sc, s7_pointer args) /* r7rs says #f if no such variable. this used to return "" in that case, 6-May-22 */ -{ - #define H_getenv "(getenv var) returns the value of an environment variable, or #f if none is found" - #define Q_getenv s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_string_symbol) - - char *result; - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->getenv_symbol, args, sc->type_names[T_STRING])); - result = getenv(string_value(name)); - return((result) ? s7_make_string(sc, result) : sc->F); -} - -/* -------------------------------- system -------------------------------- */ -static s7_pointer g_system(s7_scheme *sc, s7_pointer args) -{ - #define H_system "(system command) executes the command. If the optional second argument is #t, \ -system captures the output as a string and returns it." - #define Q_system s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_boolean_symbol) - -#ifdef __EMSCRIPTEN__ - return s7_nil(sc); -#else - s7_pointer name = car(args); - - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->system_symbol, args, sc->type_names[T_STRING])); - - if ((is_pair(cdr(args))) && - (cadr(args) == sc->T)) - { - #define BUF_SIZE 256 - char buf[BUF_SIZE]; - char *str = NULL; - int32_t cur_len = 0, full_len = 0; - FILE *fd = popen(string_value(name), "r"); - while (fgets(buf, BUF_SIZE, fd)) - { - s7_int buf_len = safe_strlen(buf); - if (cur_len + buf_len >= full_len) - { - full_len += BUF_SIZE * 2; - str = (str) ? (char *)Realloc(str, full_len) : (char *)Malloc(full_len); - } - memcpy((void *)(str + cur_len), (void *)buf, buf_len); - cur_len += buf_len; - } - pclose(fd); - if (str) - { - block_t *b = mallocate_block(sc); - block_data(b) = (void *)str; - block_set_index(b, TOP_BLOCK_LIST); - return(block_to_string(sc, b, cur_len)); - } - return(nil_string); - } - return(make_integer(sc, system(string_value(name)))); -#endif -} - - -#if (!MS_WINDOWS) -#include - -/* -------------------------------- directory->list -------------------------------- */ -static s7_pointer g_directory_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_directory_to_list "(directory->list directory) returns the contents of the directory as a list of strings (filenames)." - #define Q_directory_to_list s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_string_symbol) /* can return nil */ - - s7_pointer name = car(args); - DIR *dpos; - s7_pointer result; - - if (!is_string(name)) - return(method_or_bust_p(sc, name, sc->directory_to_list_symbol, sc->type_names[T_STRING])); - - sc->w = sc->nil; - if ((dpos = opendir(string_value(name)))) - { - struct dirent *dirp; - while ((dirp = readdir(dpos))) - sc->w = cons_unchecked(sc, s7_make_string(sc, dirp->d_name), sc->w); - closedir(dpos); - } - result = sc->w; - sc->w = sc->unused; - return(result); -} - -/* -------------------------------- file-mtime -------------------------------- */ -static s7_pointer g_file_mtime(s7_scheme *sc, s7_pointer args) -{ - #define H_file_mtime "(file-mtime file): return the write date of file" - #define Q_file_mtime s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol) - - struct stat statbuf; - int32_t err; - s7_pointer name = car(args); - if (!is_string(name)) - return(sole_arg_method_or_bust(sc, name, sc->file_mtime_symbol, args, sc->type_names[T_STRING])); - err = stat(string_value(name), &statbuf); - if (err < 0) - file_error_nr(sc, "file-mtime", strerror(errno), string_value(name)); - return(make_integer(sc, (s7_int)(statbuf.st_mtime))); -} -#endif -#endif /* with_system_extras */ - - -/* -------------------------------- lists -------------------------------- */ -s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - s7_pointer x; - new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); - set_car(x, a); - set_cdr(x, b); - return(x); -} - -static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - /* apparently slightly faster as a function? */ - s7_pointer x; - new_cell_no_check(sc, x, T_PAIR | T_SAFE_PROCEDURE); - set_car(x, a); - set_cdr(x, b); - return(x); -} - -static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, uint64_t type) -{ - s7_pointer x = alloc_pointer(sc); - set_full_type(x, type | T_UNHEAP); - set_car(x, a); - set_cdr(x, b); - return(x); -} - -static s7_pointer semipermanent_list(s7_scheme *sc, s7_int len) -{ - s7_pointer p = sc->nil; - for (s7_int j = 0; j < len; j++) - p = semipermanent_cons(sc, sc->unused, p, T_PAIR | T_IMMUTABLE); - return(p); -} - -s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...) -{ - va_list ap; - s7_int i; - s7_pointer res = sc->nil; - - for (i = 0; i < len; i++) - res = semipermanent_cons(sc, sc->unused, res, T_PAIR | T_IMMUTABLE); - va_start(ap, len); - i = 0; - for (s7_pointer p = res; is_pair(p); p = cdr(p), i++) - { - set_car(p, va_arg(ap, s7_pointer)); - if ((!is_normal_symbol(car(p))) && (!is_boolean(car(p))) && (!is_pair(car(p)))) - s7_warn(sc, 512, "s7_make_signature got an invalid entry %s at position %" ld64, display(car(p)), i); - } - va_end(ap); - return((s7_pointer)res); -} - -s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...) -{ - va_list ap; - s7_int i; - s7_pointer p, res = sc->nil, back = NULL, end = NULL; - - for (i = 0; i < len; i++) - res = semipermanent_cons(sc, sc->nil, res, T_PAIR | T_IMMUTABLE); - va_start(ap, len); - for (p = res, i = 0; is_pair(p); p = cdr(p), i++) - { - set_car(p, va_arg(ap, s7_pointer)); - if ((!is_normal_symbol(car(p))) && (!is_boolean(car(p))) && (!is_pair(car(p)))) - s7_warn(sc, 512, "s7_make_circular_signature got an invalid entry %s at position %" ld64, display(car(p)), i); - if (i == cycle_point) back = p; - if (i == (len - 1)) end = p; - } - va_end(ap); - if (end) set_cdr(end, back); - if (i < len) - s7_warn(sc, 256, "s7_make_circular_signature got too few entries: %s\n", display(res)); - return((s7_pointer)res); -} - - -bool s7_is_pair(s7_pointer p) {return(is_pair(p));} -static s7_pointer is_pair_p_p(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? sc->T : sc->F);} - -s7_pointer s7_car(s7_pointer p) {return(car(p));} -s7_pointer s7_cdr(s7_pointer p) {return(cdr(p));} - -s7_pointer s7_cadr(s7_pointer p) {return(cadr(p));} -s7_pointer s7_cddr(s7_pointer p) {return(cddr(p));} -s7_pointer s7_cdar(s7_pointer p) {return(cdar(p));} -s7_pointer s7_caar(s7_pointer p) {return(caar(p));} - -s7_pointer s7_caadr(s7_pointer p) {return(caadr(p));} -s7_pointer s7_caddr(s7_pointer p) {return(caddr(p));} -s7_pointer s7_cadar(s7_pointer p) {return(cadar(p));} -s7_pointer s7_caaar(s7_pointer p) {return(caaar(p));} -s7_pointer s7_cdadr(s7_pointer p) {return(cdadr(p));} -s7_pointer s7_cdddr(s7_pointer p) {return(cdddr(p));} -s7_pointer s7_cddar(s7_pointer p) {return(cddar(p));} -s7_pointer s7_cdaar(s7_pointer p) {return(cdaar(p));} - -s7_pointer s7_caaadr(s7_pointer p) {return(caaadr(p));} -s7_pointer s7_caaddr(s7_pointer p) {return(caaddr(p));} -s7_pointer s7_caadar(s7_pointer p) {return(caadar(p));} -s7_pointer s7_caaaar(s7_pointer p) {return(caaaar(p));} -s7_pointer s7_cadadr(s7_pointer p) {return(cadadr(p));} -s7_pointer s7_cadddr(s7_pointer p) {return(cadddr(p));} -s7_pointer s7_caddar(s7_pointer p) {return(caddar(p));} -s7_pointer s7_cadaar(s7_pointer p) {return(cadaar(p));} - -s7_pointer s7_cdaadr(s7_pointer p) {return(cdaadr(p));} -s7_pointer s7_cdaddr(s7_pointer p) {return(cdaddr(p));} -s7_pointer s7_cdadar(s7_pointer p) {return(cdadar(p));} -s7_pointer s7_cdaaar(s7_pointer p) {return(cdaaar(p));} -s7_pointer s7_cddadr(s7_pointer p) {return(cddadr(p));} -s7_pointer s7_cddddr(s7_pointer p) {return(cddddr(p));} -s7_pointer s7_cdddar(s7_pointer p) {return(cdddar(p));} -s7_pointer s7_cddaar(s7_pointer p) {return(cddaar(p));} - -s7_pointer s7_set_car(s7_pointer p, s7_pointer q) {set_car(p, q); return(q);} -s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q) {set_cdr(p, q); return(q);} - - -/* -------------------------------------------------------------------------------- */ -void s7_list_to_array(s7_scheme *sc, s7_pointer list, s7_pointer *array, int32_t len) -{ - int32_t i = 0; - for (s7_pointer p = list; is_pair(p); p = cdr(p), i++) array[i] = car(p); - for (; i < len; i++) array[i] = sc->undefined; -} - - -/* ---------------- tree-leaves ---------------- */ -static inline s7_int tree_len_1(s7_scheme *sc, s7_pointer p) -{ - s7_int sum; - if ((S7_DEBUGGING) && (tree_is_cyclic(sc, p))) {fprintf(stderr, "%s[%d]: tree is cyclic\n", __func__, __LINE__); abort();} - for (sum = 0; is_pair(p); p = cdr(p)) - { - s7_pointer cp = car(p); - if ((!is_pair(cp)) || - (car(cp) == sc->quote_symbol)) - sum++; - else - { - do { - s7_pointer ccp = car(cp); - if ((!is_pair(ccp)) || - (car(ccp) == sc->quote_symbol)) - sum++; - else - { - do { - s7_pointer cccp = car(ccp); - if ((!is_pair(cccp)) || - (car(cccp) == sc->quote_symbol)) - sum++; - else sum += tree_len_1(sc, cccp); - ccp = cdr(ccp); - } while (is_pair(ccp)); - if (!is_null(ccp)) sum++; - } - cp = cdr(cp); - } while (is_pair(cp)); - if (!is_null(cp)) sum++; - }} - return((is_null(p)) ? sum : sum + 1); -} - -static inline s7_int tree_len(s7_scheme *sc, s7_pointer p) -{ - if (is_null(p)) - return(0); - if ((!is_pair(p)) || - (car(p) == sc->quote_symbol)) - return(1); - return(tree_len_1(sc, p)); -} - -static s7_int tree_leaves_i_7p(s7_scheme *sc, s7_pointer p) -{ - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, p))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-leaves: tree is cyclic: ~S", 31), p)); - return(tree_len(sc, p)); -} - -static s7_pointer tree_leaves_p_p(s7_scheme *sc, s7_pointer tree) -{ - if ((sc->safety > NO_SAFETY) && /* repeat code to avoid extra call overhead */ - (tree_is_cyclic(sc, tree))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-leaves: tree is cyclic: ~S", 31), tree)); - return(make_integer(sc, tree_len(sc, tree))); -} - -static s7_pointer g_tree_leaves(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_leaves "(tree-leaves tree) returns the number of leaves in the tree" - #define Q_tree_leaves s7_make_signature(sc, 2, sc->is_integer_symbol, sc->T) - return(tree_leaves_p_p(sc, car(args))); -} - - -/* ---------------- tree-memq ---------------- */ -static inline bool tree_memq_1(s7_scheme *sc, s7_pointer sym, s7_pointer tree) /* sym need not be a symbol */ -{ - if (car(tree) == sc->quote_symbol) - return((!is_symbol(sym)) && (!is_pair(sym)) && (is_pair(cdr(tree))) && (sym == cadr(tree))); - do { - if (sym == car(tree)) - return(true); - - if (is_pair(car(tree))) - { - s7_pointer cp = car(tree); - if (car(cp) == sc->quote_symbol) - { - if ((!is_symbol(sym)) && (!is_pair(sym)) && (is_pair(cdr(cp))) && (sym == cadr(cp))) - return(true); - } - else - do { - if (sym == car(cp)) - return(true); - if ((is_pair(car(cp))) && (tree_memq_1(sc, sym, car(cp)))) - return(true); - cp = cdr(cp); - if (sym == cp) - return(true); - } while (is_pair(cp)); - } - tree = cdr(tree); - if (sym == tree) - return(true); - } while (is_pair(tree)); - return(false); -} - -bool s7_tree_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree) -{ - if (sym == tree) return(true); - if (!is_pair(tree)) return(false); - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, tree))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-memq: tree is cyclic: ~S", 29), tree)); - return(tree_memq_1(sc, sym, tree)); -} - -static s7_pointer g_tree_memq(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_memq "(tree-memq obj tree) is a tree-oriented version of memq, but returning #t if the object is in the tree." - #define Q_tree_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) - return(make_boolean(sc, s7_tree_memq(sc, car(args), cadr(args)))); -} - - -/* ---------------- tree-set-memq ---------------- */ -static inline bool pair_set_memq(s7_scheme *sc, s7_pointer tree) -{ - while (true) - { - s7_pointer p = car(tree); - if (is_symbol(p)) - { - if (symbol_is_in_list(sc, p)) - return(true); - } - else - if ((is_unquoted_pair(p)) && - (pair_set_memq(sc, p))) - return(true); - tree = cdr(tree); - if (!is_pair(tree)) break; - } - return((is_symbol(tree)) && (symbol_is_in_list(sc, tree))); -} - -static bool tree_set_memq(s7_scheme *sc, s7_pointer tree) -{ - if (is_symbol(tree)) - return(symbol_is_in_list(sc, tree)); - if ((!is_pair(tree)) || - (car(tree) == sc->quote_symbol)) - return(false); - return(pair_set_memq(sc, tree)); -} - -static bool tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) -{ - if (!is_pair(syms)) return(false); - if (sc->safety > NO_SAFETY) - { - if (tree_is_cyclic(sc, syms)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: symbol list is cyclic: ~S", 40), syms)); - if (tree_is_cyclic(sc, tree)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree)); - } - clear_symbol_list(sc); - for (s7_pointer p = syms; is_pair(p); p = cdr(p)) - if (is_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - return(tree_set_memq(sc, tree)); -} - -static s7_pointer tree_set_memq_p_pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) -{ - return(make_boolean(sc, tree_set_memq_b_7pp(sc, syms, tree))); -} - -static s7_pointer g_tree_set_memq(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_set_memq "(tree-set-memq symbols tree) returns #t if any of the list of symbols is in the tree" - #define Q_tree_set_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T) - return(make_boolean(sc, tree_set_memq_b_7pp(sc, car(args), cadr(args)))); -} - -static s7_pointer tree_set_memq_direct(s7_scheme *sc, s7_pointer syms, s7_pointer tree) -{ - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, tree))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree)); - clear_symbol_list(sc); - for (s7_pointer p = syms; is_pair(p); p = cdr(p)) - add_symbol_to_list(sc, car(p)); - return(make_boolean(sc, tree_set_memq(sc, tree))); -} - -static s7_pointer g_tree_set_memq_1(s7_scheme *sc, s7_pointer args) -{ - return(tree_set_memq_direct(sc, car(args), cadr(args))); -} - -static s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - if ((is_proper_quote(sc, cadr(expr))) && /* not (tree-set-memq (quote) ... */ - (is_pair(cadadr(expr)))) - { - for (s7_pointer p = cadadr(expr); is_pair(p); p = cdr(p)) - if (!is_symbol(car(p))) - return(f); - return(sc->tree_set_memq_syms); /* this is tree_set_memq_1 */ - } - return(f); -} - - -/* ---------------- tree-count ---------------- */ -static s7_int tree_count(s7_scheme *sc, s7_pointer x, s7_pointer p, s7_int count) -{ - if (p == x) return(count + 1); - if ((!is_pair(p)) || (car(p) == sc->quote_symbol)) return(count); - return(tree_count(sc, x, cdr(p), tree_count(sc, x, car(p), count))); -} - -static inline s7_int tree_count_at_least(s7_scheme *sc, s7_pointer x, s7_pointer p, s7_int count, s7_int top) -{ - if (p == x) return(count + 1); - if ((!is_pair(p)) || (car(p) == sc->quote_symbol)) return(count); - do { - count = tree_count_at_least(sc, x, car(p), count, top); - if (count >= top) return(count); - p = cdr(p); - if (p == x) return(count + 1); - } while (is_pair(p)); - return(count); -} - -static s7_pointer g_tree_count(s7_scheme *sc, s7_pointer args) -{ - #define H_tree_count "(tree-count obj tree max-count) returns how many times obj is in tree (using eq?), stopping at max-count (if specified)" - #define Q_tree_count s7_make_signature(sc, 4, sc->is_integer_symbol, sc->T, sc->T, sc->is_integer_symbol) - s7_pointer obj = car(args); - s7_pointer tree = cadr(args), count; - - if (!is_pair(tree)) - { - if ((is_pair(cddr(args))) && - (!s7_is_integer(caddr(args)))) - wrong_type_error_nr(sc, sc->tree_count_symbol, 3, caddr(args), sc->type_names[T_INTEGER]); - /* here we need eqv? not eq? for integers: (tree-count <0-int-zero> <0-not-int-zero>) - * perhaps split tree_count|_at_least into eq?/eqv?/equal?/equivalent? cases? - * this is used primarily for symbol counts in lint.scm - */ - return((obj == tree) ? int_one : int_zero); - } - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, tree))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-count: tree is cyclic: ~S", 30), tree)); - if (is_null(cddr(args))) - return(make_integer(sc, tree_count(sc, obj, tree, 0))); - count = caddr(args); - if (!s7_is_integer(count)) - wrong_type_error_nr(sc, sc->tree_count_symbol, 3, count, sc->type_names[T_INTEGER]); - return(make_integer(sc, tree_count_at_least(sc, obj, tree, 0, s7_integer_clamped_if_gmp(sc, count)))); -} - - -/* -------------------------------- pair? -------------------------------- */ -static s7_pointer g_is_pair(s7_scheme *sc, s7_pointer args) -{ - #define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)" - #define Q_is_pair sc->pl_bt - check_boolean_method(sc, is_pair, sc->is_pair_symbol, args); -} - - -/* -------------------------------- list? -------------------------------- */ -bool s7_is_list(s7_scheme *sc, s7_pointer p) {return(is_list(p));} - -static bool is_list_b(s7_pointer p) {return((is_pair(p)) || (type(p) == T_NIL));} - -static s7_pointer g_is_list(s7_scheme *sc, s7_pointer args) -{ - #define H_is_list "(list? obj) returns #t if obj is a pair or null" - #define Q_is_list sc->pl_bt - #define is_a_list(p) s7_is_list(sc, p) - check_boolean_method(sc, is_a_list, sc->is_list_symbol, args); -} - -static s7_int proper_list_length(s7_pointer a) -{ - s7_int i = 0; - for (s7_pointer b = a; is_pair(b); i++, b = cdr(b)) {}; - return(i); -} - -static s7_int proper_list_length_with_end(s7_pointer a, s7_pointer *c) -{ - s7_int i = 0; - s7_pointer b; - for (b = a; is_pair(b); i++, b = cdr(b)) {}; - *c = b; - return(i); -} - -s7_int s7_list_length(s7_scheme *sc, s7_pointer a) /* returns -len if list is dotted, 0 if it's (directly) circular */ -{ - s7_pointer slow = a, fast = a; - for (s7_int i = 0; ; i += 2) - { - if (!is_pair(fast)) return((is_null(fast)) ? i : -i); - fast = cdr(fast); - if (!is_pair(fast)) return((is_null(fast)) ? (i + 1) : (-i - 1)); /* if unrolled further, it's a lot slower? */ - fast = cdr(fast); - slow = cdr(slow); - if (fast == slow) return(0); - } - return(0); -} - - -/* -------------------------------- proper-list? -------------------------------- */ -static inline s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst) -{ - s7_pointer tp; - if (!is_pair(lst)) return(sc->nil); - sc->temp5 = lst; - tp = list_1(sc, car(lst)); - sc->temp8 = tp; - for (s7_pointer p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - { - set_cdr(np, list_1_unchecked(sc, car(p))); - p = cdr(p); - if (is_pair(p)) {np = cdr(np); set_cdr(np, list_1_unchecked(sc, car(p)));} else break; - p = cdr(p); - if (is_pair(p)) {np = cdr(np); set_cdr(np, list_1(sc, car(p)));} else break; - } - sc->temp8 = sc->unused; - sc->temp5 = sc->unused; - return(tp); -} - -bool s7_is_proper_list(s7_scheme *sc, s7_pointer lst) -{ - /* #t if () or undotted/non-circular pair */ - s7_pointer slow = lst, fast = lst; - while (true) - { - if (!is_pair(fast)) - return(is_null(fast)); /* else it's an improper list */ - LOOP_4(fast = cdr(fast); if (!is_pair(fast)) return(is_null(fast))); - fast = cdr(fast); - slow = cdr(slow); - if (fast == slow) return(false); - } - return(true); -} - -static s7_pointer g_is_proper_list(s7_scheme *sc, s7_pointer args) -{ - #define H_is_proper_list "(proper-list? x) returns #t is x is a list that is neither circular nor dotted." - #define Q_is_proper_list sc->pl_bt - return(make_boolean(sc, s7_is_proper_list(sc, car(args)))); -} - -static s7_pointer is_proper_list_p_p(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, s7_is_proper_list(sc, arg)));} - -static bool is_proper_list_1(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_null(cdr(p))));} -static bool is_proper_list_2(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_null(cddr(p))));} -static bool is_proper_list_3(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p))) && (is_null(cdddr(p))));} -static bool is_proper_list_4(s7_scheme *unused_sc, s7_pointer p) {return(proper_list_length(p) == 4);} - - -/* -------------------------------- make-list -------------------------------- */ -static s7_pointer make_big_list(s7_scheme *sc, s7_int len, s7_pointer init) -{ - check_free_heap_size(sc, len + 1); /* using cons_unchecked below, +1 in case we are on the trigger at the end */ - sc->value = sc->nil; - for (s7_int i = 0; i < len; i++) sc->value = cons_unchecked(sc, init, sc->value); - return(sc->value); -} - -static inline s7_pointer make_list(s7_scheme *sc, s7_int len, s7_pointer init) -{ - switch (len) - { - case 0: return(sc->nil); - case 1: return(T_Pair(cons(sc, init, sc->nil))); - case 2: return(T_Pair(cons_unchecked(sc, init, cons(sc, init, sc->nil)))); - case 3: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))); - case 4: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))))); - case 5: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))))); - case 6: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, - cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))))))); - case 7: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, - cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))))))); - default: - return(make_big_list(sc, len, init)); - } - return(sc->nil); /* never happens, I hope */ -} - -s7_pointer s7_make_list(s7_scheme *sc, s7_int len, s7_pointer init) {return(make_list(sc, len, init));} - -static s7_pointer make_list_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer init) -{ - s7_int len; - if (!s7_is_integer(n)) - return(method_or_bust(sc, n, sc->make_list_symbol, set_plist_2(sc, n, init), sc->type_names[T_INTEGER], 1)); - - len = s7_integer_clamped_if_gmp(sc, n); -#if WITH_GMP - if ((len == 0) && (!is_zero(n))) - out_of_range_error_nr(sc, sc->make_list_symbol, int_one, n, wrap_string(sc, "big integer is too big for s7_int", 33)); -#endif - if (len == 0) return(sc->nil); /* what about (make-list 0 123)? */ - if ((len < 0) || (len > sc->max_list_length)) - out_of_range_error_nr(sc, sc->make_list_symbol, int_one, n, (len < 0) ? it_is_negative_string : it_is_too_large_string); - return(make_list(sc, len, init)); -} - -static s7_pointer g_make_list(s7_scheme *sc, s7_pointer args) -{ - #define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'." - #define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T) - return(make_list_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->F)); -} - - -/* -------------------------------- list-ref -------------------------------- */ -s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num) -{ - s7_int i; - s7_pointer x; - for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {} - if ((i == num) && (is_pair(x))) - return(car(x)); - return(sc->nil); -} - -static s7_pointer list_ref_1(s7_scheme *sc, s7_pointer lst, s7_pointer ind) -{ - s7_int index; - s7_pointer p = lst; - - if (!s7_is_integer(ind)) - return(method_or_bust_pp(sc, ind, sc->list_ref_symbol, lst, ind, sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); - - for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {} - if (is_pair(p)) return(car(p)); - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, ind, it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string); - return(NULL); -} - -static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices); - -static s7_pointer ref_index_checked(s7_scheme *sc, s7_pointer caller, s7_pointer in_obj, s7_pointer args) -{ - if (!is_applicable(in_obj)) /* let implicit_index shuffle syntax and closures */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), - cons(sc, caller, args), cons(sc, in_obj, cddr(args)), in_obj)); - /* perhaps first $s -> "(~S ~{~$~^ ~})..." and we can pass the symbol rather than the global value as "caller" */ - return(implicit_index(sc, in_obj, cddr(args))); -} - -static s7_pointer g_list_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_list_ref "(list-ref lst i ...) returns the i-th element (0-based) of the list" - #define Q_list_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) - /* (let ((L '((1 2 3) (4 5 6)))) (list-ref L 1 2)) */ - - s7_pointer lst = car(args); - if (!is_pair(lst)) - return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); - - lst = list_ref_1(sc, lst, cadr(args)); - if (is_pair(cddr(args))) - return(ref_index_checked(sc, global_value(sc->list_ref_symbol), lst, args)); - return(lst); -} - -static bool op_implicit_pair_ref_a(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_pair(s)) {sc->last_function = s; return(false);} - sc->value = list_ref_1(sc, s, fx_call(sc, cdr(sc->code))); - return(true); -} - -static s7_pointer implicit_pair_index_checked(s7_scheme *sc, s7_pointer obj, s7_pointer in_obj, s7_pointer indices) -{ - if (!is_applicable(in_obj)) - { - s7_pointer safe_indices = copy_proper_list(sc, indices); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), - cons(sc, obj, safe_indices), cons(sc, in_obj, cdr(safe_indices)), in_obj)); - } - return(implicit_index(sc, in_obj, cdr(indices))); -} - -static bool op_implicit_pair_ref_aa(s7_scheme *sc) -{ - s7_pointer i1; - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_pair(s)) {sc->last_function = s; return(false);} - sc->args = fx_call(sc, cddr(sc->code)); - i1 = fx_call(sc, cdr(sc->code)); - sc->value = implicit_pair_index_checked(sc, s, list_ref_1(sc, s, i1), set_plist_2(sc, i1, sc->args)); - return(true); -} - -static s7_pointer list_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if (args == 2) - { - s7_pointer index = caddr(expr); - if (is_t_integer(index)) - { - if (integer(index) == 0) return(sc->list_ref_at_0); - if (integer(index) == 1) return(sc->list_ref_at_1); - if (integer(index) == 2) return(sc->list_ref_at_2); - }} - return(f); -} - -static inline s7_pointer list_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - s7_pointer p = p1; - if ((i1 < 0) || (i1 > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - for (s7_int i = 0; ((is_pair(p)) && (i < i1)); i++, p = cdr(p)); - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, wrap_integer(sc, i1), it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p1, a_proper_list_string); - } - return(car(p)); -} - -static s7_pointer list_ref_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - if (!is_pair(p1)) - wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p1, sc->type_names[T_PAIR]); - return(list_ref_p_pi_unchecked(sc, p1, i1)); -} - -static s7_pointer list_ref_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_pair(p1)) - return(g_list_ref(sc, set_plist_2(sc, p1, p2))); - if (!s7_is_integer(p2)) - wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p2, sc->type_names[T_INTEGER]); - return(list_ref_p_pi_unchecked(sc, p1, s7_integer_clamped_if_gmp(sc, p2))); -} - - -/* -------------------------------- list-set! -------------------------------- */ -s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val) -{ - s7_int i; - s7_pointer x; - for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {} - if ((i == num) && - (is_pair(x))) - set_car(x, T_Ext(val)); - return(val); -} - -static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, int32_t arg_num) -{ - #define H_list_set "(list-set! lst i ... val) sets the i-th element (0-based) of the list to val" - #define Q_list_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_pair_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol) - - s7_int index; - s7_pointer p = lst, ind; - /* (let ((L '((1 2 3) (4 5 6)))) (list-set! L 1 2 32) L) */ - - if (!is_mutable_pair(lst)) - return(mutable_method_or_bust(sc, lst, sc->list_set_symbol, set_ulist_1(sc, lst, args), sc->type_names[T_PAIR], 1)); - ind = car(args); - if ((arg_num > 2) && (is_null(cdr(args)))) - { - set_car(lst, ind); - return(ind); - } - if (!s7_is_integer(ind)) - return(method_or_bust(sc, ind, sc->list_set_symbol, set_ulist_1(sc, lst, args), sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); - - for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {} - - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, a_proper_list_string); - } - if (is_null(cddr(args))) - set_car(p, cadr(args)); - else - { - if (!s7_is_pair(car(p))) - wrong_number_of_args_error_nr(sc, "too many arguments for list-set!: ~S", args); - return(g_list_set_1(sc, car(p), cdr(args), arg_num + 1)); - } - return(cadr(args)); -} - -static s7_pointer g_list_set(s7_scheme *sc, s7_pointer args) {return(g_list_set_1(sc, car(args), cdr(args), 2));} - -static inline s7_pointer list_set_p_pip_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - s7_pointer p = p1; - if ((i1 < 0) || (i1 > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - for (s7_int i = 0; ((is_pair(p)) && (i < i1)); i++, p = cdr(p)); - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, i1), it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, a_proper_list_string); - } - set_car(p, p2); - return(p2); -} - -static s7_pointer list_increment_p_pip_unchecked(opt_info *o) -{ - s7_scheme *sc = o->sc; - s7_pointer p = slot_value(o->v[2].p), p1, p2; - s7_int index = integer(p); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); - p1 = slot_value(o->v[1].p); - p = p1; - for (s7_int i = 0; ((is_pair(p)) && (i < index)); i++, p = cdr(p)); - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, a_proper_list_string); - } - p2 = g_add_xi(sc, car(p), integer(o->v[3].p), index); - set_car(p, p2); - return(p2); -} - -static s7_pointer list_set_p_pip(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - if (!is_pair(p1)) - wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, sc->type_names[T_PAIR]); - return(list_set_p_pip_unchecked(sc, p1, i1, p2)); -} - -static s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args) -{ - s7_pointer lst = car(args), val; - s7_pointer p = lst; - s7_int index; - if (!is_mutable_pair(lst)) - return(mutable_method_or_bust(sc, lst, sc->list_set_symbol, args, sc->type_names[T_PAIR], 1)); - - index = s7_integer_clamped_if_gmp(sc, cadr(args)); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); - - for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {} - if (!is_pair(p)) - { - if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, a_proper_list_string); - } - val = caddr(args); - set_car(p, val); - return(val); -} - -static s7_pointer list_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if ((args == 3) && - (s7_is_integer(caddr(expr))) && - (s7_integer_clamped_if_gmp(sc, caddr(expr)) >= 0) && - (s7_integer_clamped_if_gmp(sc, caddr(expr)) < sc->max_list_length)) - return(sc->list_set_i); - return(f); -} - - -/* -------------------------------- list-tail -------------------------------- */ -static s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer p) -{ - s7_int i, index; - if (!s7_is_integer(p)) - return(method_or_bust_pp(sc, p, sc->list_tail_symbol, lst, p, sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, p); - - if (!is_list(lst)) /* (list-tail () 0) -> () */ - return(method_or_bust_with_type_pi(sc, lst, sc->list_tail_symbol, lst, index, a_list_string, 1)); - if ((index < 0) || (index > sc->max_list_length)) - out_of_range_error_nr(sc, sc->list_tail_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); - - for (i = 0; (i < index) && (is_pair(lst)); i++, lst = cdr(lst)) {} - if (i < index) - out_of_range_error_nr(sc, sc->list_tail_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - return(lst); -} - -static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args) -{ - #define H_list_tail "(list-tail lst i) returns the list from the i-th element on" - #define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */ - return(list_tail_p_pp(sc, car(args), cadr(args))); -} - - -/* -------------------------------- cons -------------------------------- */ -static s7_pointer g_cons(s7_scheme *sc, s7_pointer args) -{ - #define H_cons "(cons a b) returns a pair containing a and b" - #define Q_cons s7_make_signature(sc, 3, sc->is_pair_symbol, sc->T, sc->T) - - s7_pointer x; - new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); - set_car(x, car(args)); - set_cdr(x, cadr(args)); - return(x); -} - -static s7_pointer cons_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - s7_pointer x; - new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE); - set_car(x, p1); - set_cdr(x, p2); - return(x); -} - - -/* -------- car -------- */ - -static s7_pointer g_car(s7_scheme *sc, s7_pointer args) -{ - #define H_car "(car pair) returns the first element of the pair" - #define Q_car sc->pl_p - - s7_pointer lst = car(args); - if (is_pair(lst)) - return(car(lst)); - return(sole_arg_method_or_bust(sc, lst, sc->car_symbol, args, sc->type_names[T_PAIR])); -} - -static s7_pointer car_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_pair(p)) - return(car(p)); - return(sole_arg_method_or_bust(sc, p, sc->car_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - -static s7_pointer g_list_ref_at_0(s7_scheme *sc, s7_pointer args) -{ - if (is_pair(car(args))) return(caar(args)); - return(method_or_bust(sc, car(args), sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); /* 1=arg num if error */ -} - - -static s7_pointer g_set_car(s7_scheme *sc, s7_pointer args) -{ - #define H_set_car "(set-car! pair val) sets the pair's first element to val" - #define Q_set_car s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T) - - s7_pointer p = car(args); - if (!is_mutable_pair(p)) return(mutable_method_or_bust(sc, p, sc->set_car_symbol, args, sc->type_names[T_PAIR], 1)); - set_car(p, cadr(args)); - return(car(p)); -} - -static Inline s7_pointer inline_set_car(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_mutable_pair(p1)) return(mutable_method_or_bust(sc, p1, sc->set_car_symbol, set_plist_1(sc, p1), sc->type_names[T_PAIR], 1)); - set_car(p1, p2); - return(p2); -} - -static s7_pointer set_car_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(inline_set_car(sc, p1, p2));} - - -/* -------- cdr -------- */ -static s7_pointer g_cdr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdr "(cdr pair) returns the second element of the pair" - #define Q_cdr sc->pl_p - - s7_pointer lst = car(args); - if (is_pair(lst)) - return(cdr(lst)); - return(sole_arg_method_or_bust(sc, lst, sc->cdr_symbol, args, sc->type_names[T_PAIR])); -} - -static s7_pointer cdr_p_p(s7_scheme *sc, s7_pointer p) -{ - if (is_pair(p)) - return(cdr(p)); - return(sole_arg_method_or_bust(sc, p, sc->cdr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - - -static s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args) -{ - #define H_set_cdr "(set-cdr! pair val) sets the pair's second element to val" - #define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T) - - s7_pointer p = car(args); - if (!is_mutable_pair(p)) return(mutable_method_or_bust(sc, p, sc->set_cdr_symbol, args, sc->type_names[T_PAIR], 1)); - set_cdr(p, cadr(args)); - return(cdr(p)); -} - -static Inline s7_pointer inline_set_cdr(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - if (!is_mutable_pair(p1)) return(mutable_method_or_bust(sc, p1, sc->set_cdr_symbol, set_plist_1(sc, p1), sc->type_names[T_PAIR], 1)); - set_cdr(p1, p2); - return(p2); -} - -static s7_pointer set_cdr_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(inline_set_cdr(sc, p1, p2));} - - -/* -------- caar --------*/ -static s7_pointer g_caar(s7_scheme *sc, s7_pointer args) -{ - #define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1" - #define Q_caar sc->pl_p - - s7_pointer lst = car(args); - /* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caar_symbol, lst, car_a_list_string); - return(caar(lst)); - -} - -static s7_pointer caar_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(car(p)))) return(caar(p)); - if (is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->caar_symbol, p, car_a_list_string); - return(sole_arg_method_or_bust(sc, p, sc->caar_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - - -/* -------- cadr --------*/ -static s7_pointer g_cadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cadr "(cadr lst) returns (car (cdr lst)): (cadr '(1 2 3)) -> 2" - #define Q_cadr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadr_symbol, lst, cdr_a_list_string); - return(cadr(lst)); -} - -static s7_pointer cadr_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(cdr(p)))) return(cadr(p)); - if (is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->cadr_symbol, p, cdr_a_list_string); - return(sole_arg_method_or_bust(sc, p, sc->cadr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - -static s7_pointer g_list_ref_at_1(s7_scheme *sc, s7_pointer args) -{ - s7_pointer lst = car(args); - if (!is_pair(lst)) return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); - if (!is_pair(cdr(lst))) out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, cadr(args), it_is_too_large_string); - return(cadr(lst)); -} - - -/* -------- cdar -------- */ -static s7_pointer g_cdar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdar "(cdar lst) returns (cdr (car lst)): (cdar '((1 2 3))) -> '(2 3)" - #define Q_cdar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdar_symbol, lst, car_a_list_string); - return(cdar(lst)); -} - -static s7_pointer cdar_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(car(p)))) return(cdar(p)); - if (!is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->cdar_symbol, p, car_a_list_string); - return(sole_arg_method_or_bust(sc, p, sc->cdar_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - - -/* -------- cddr -------- */ -static s7_pointer g_cddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cddr "(cddr lst) returns (cdr (cdr lst)): (cddr '(1 2 3 4)) -> '(3 4)" - #define Q_cddr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddr_symbol, lst, cdr_a_list_string); - return(cddr(lst)); -} - -static s7_pointer cddr_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(cdr(p)))) return(cddr(p)); - if (is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->cddr_symbol, p, cdr_a_list_string); - return(sole_arg_method_or_bust(sc, p, sc->cddr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); -} - -/* -------- caaar -------- */ -static s7_pointer caaar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, caar_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, caar_a_list_string); - return(caaar(lst)); -} - -static s7_pointer g_caaar(s7_scheme *sc, s7_pointer args) -{ - #define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1" - #define Q_caaar sc->pl_p - return(caaar_p_p(sc, car(args))); -} - -/* -------- caadr -------- */ -static s7_pointer caadr_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cadr(p)))) return(caadr(p)); - if (!is_pair(p)) return(sole_arg_method_or_bust(sc, p, sc->caadr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); - if (!is_pair(cdr(p))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, p, cdr_a_list_string); - sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, p, cadr_a_list_string); - return(NULL); -} - -static s7_pointer g_caadr(s7_scheme *sc, s7_pointer args) -{ - #define H_caadr "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2" - #define Q_caadr sc->pl_p - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, cadr_a_list_string); - return(caadr(lst)); -} - -/* -------- cadar -------- */ -static s7_pointer g_cadar(s7_scheme *sc, s7_pointer args) -{ - #define H_cadar "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2" - #define Q_cadar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, cdar_a_list_string); - return(cadar(lst)); -} - -static s7_pointer cadar_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(car(p))) && (is_pair(cdar(p)))) return(cadar(p)); - if (!is_pair(p)) return(sole_arg_method_or_bust(sc, p, sc->cadar_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); - if (!is_pair(car(p))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, p, car_a_list_string); - sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, p, cdar_a_list_string); - return(NULL); -} - -/* -------- cdaar -------- */ -static s7_pointer cdaar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaar_symbol, lst, caar_a_list_string); - return(cdaar(lst)); -} - -static s7_pointer g_cdaar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)" - #define Q_cdaar sc->pl_p - return(cdaar_p_p(sc, car(args))); -} - -/* -------- caddr -------- */ -static s7_pointer g_caddr(s7_scheme *sc, s7_pointer args) -{ - #define H_caddr "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3" - #define Q_caddr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, cddr_a_list_string); - return(caddr(lst)); -} - -static s7_pointer caddr_p_p(s7_scheme *sc, s7_pointer p) -{ - if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p)))) return(caddr(p)); - if (!is_pair(p)) return(sole_arg_method_or_bust(sc, p, sc->caddr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR])); - if (!is_pair(cdr(p))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, p, cdr_a_list_string); - sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, p, cddr_a_list_string); - return(NULL); -} - -static s7_pointer g_list_ref_at_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer lst = car(args); - if (!is_pair(lst)) - return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); - if ((!is_pair(cdr(lst))) || (!is_pair(cddr(lst)))) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, cadr(args), it_is_too_large_string); - return(caddr(lst)); -} - - -/* -------- cdddr -------- */ -static s7_pointer cdddr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddr_symbol, lst, cddr_a_list_string); - return(cdddr(lst)); -} - -static s7_pointer g_cdddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdddr "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)" - #define Q_cdddr sc->pl_p - return(cdddr_p_p(sc, car(args))); -} - -/* -------- cdadr -------- */ -static s7_pointer cdadr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadr_symbol, lst, cadr_a_list_string); - return(cdadr(lst)); -} - -static s7_pointer g_cdadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdadr "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)" - #define Q_cdadr sc->pl_p - return(cdadr_p_p(sc, car(args))); -} - -/* -------- cddar -------- */ -static s7_pointer cddar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddar_symbol, lst, cdar_a_list_string); - return(cddar(lst)); -} - -static s7_pointer g_cddar(s7_scheme *sc, s7_pointer args) -{ - #define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)" - #define Q_cddar sc->pl_p - return(cddar_p_p(sc, car(args))); -} - -/* -------- caaaar -------- */ -static s7_pointer g_caaaar(s7_scheme *sc, s7_pointer args) -{ - #define H_caaaar "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) -> 1" - #define Q_caaaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaaar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, caar_a_list_string); - if (!is_pair(caaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, caaar_a_list_string); - return(caaaar(lst)); -} - -/* -------- caaadr -------- */ -static s7_pointer g_caaadr(s7_scheme *sc, s7_pointer args) -{ - #define H_caaadr "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) -> 2" - #define Q_caaadr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaadr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, cadr_a_list_string); - if (!is_pair(caadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, caadr_a_list_string); - return(caaadr(lst)); -} - -/* -------- caadar -------- */ -static s7_pointer g_caadar(s7_scheme *sc, s7_pointer args) -{ - #define H_caadar "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2" - #define Q_caadar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, cdar_a_list_string); - if (!is_pair(cadar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, cadar_a_list_string); - return(caadar(lst)); -} - -/* -------- cadaar -------- */ -static s7_pointer g_cadaar(s7_scheme *sc, s7_pointer args) -{ - #define H_cadaar "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) -> 2" - #define Q_cadaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadaar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, caar_a_list_string); - if (!is_pair(cdaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, cdaar_a_list_string); - return(cadaar(lst)); -} - -/* -------- caaddr -------- */ - -static s7_pointer caaddr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, cddr_a_list_string); - if (!is_pair(caddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, caddr_a_list_string); - return(caaddr(lst)); -} - -static s7_pointer g_caaddr(s7_scheme *sc, s7_pointer args) -{ - #define H_caaddr "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) -> 3" - #define Q_caaddr sc->pl_p - return(caaddr_p_p(sc, car(args))); -} - -/* -------- cadddr -------- */ -static s7_pointer cadddr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, cddr_a_list_string); - if (!is_pair(cdddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, cdddr_a_list_string); - return(cadddr(lst)); -} - -static s7_pointer g_cadddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cadddr "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) -> 4" - #define Q_cadddr sc->pl_p - return(cadddr_p_p(sc, car(args))); -} - -/* -------- cadadr -------- */ -static s7_pointer cadadr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, cadr_a_list_string); - if (!is_pair(cdadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, cdadr_a_list_string); - return(cadadr(lst)); -} - -static s7_pointer g_cadadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cadadr "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) -> 3" - #define Q_cadadr sc->pl_p - return(cadadr_p_p(sc, car(args))); -} - -/* -------- caddar -------- */ -static s7_pointer caddar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, cdar_a_list_string); - if (!is_pair(cddar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, cddar_a_list_string); - return(caddar(lst)); -} - -static s7_pointer g_caddar(s7_scheme *sc, s7_pointer args) -{ - #define H_caddar "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) -> 3" - #define Q_caddar sc->pl_p - return(caddar_p_p(sc, car(args))); -} - -/* -------- cdaaar -------- */ -static s7_pointer g_cdaaar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdaaar "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) -> '(2 3)" - #define Q_cdaaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaaar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, caar_a_list_string); - if (!is_pair(caaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, caaar_a_list_string); - return(cdaaar(lst)); -} - -/* -------- cdaadr -------- */ -static s7_pointer g_cdaadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdaadr "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) -> '(3 4)" - #define Q_cdaadr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaadr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, cadr_a_list_string); - if (!is_pair(caadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, caadr_a_list_string); - return(cdaadr(lst)); -} - -/* -------- cdadar -------- */ -static s7_pointer g_cdadar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdadar "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) -> '(3 4)" - #define Q_cdadar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdadar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, cdar_a_list_string); - if (!is_pair(cadar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, cadar_a_list_string); - return(cdadar(lst)); -} - -/* -------- cddaar -------- */ -static s7_pointer g_cddaar(s7_scheme *sc, s7_pointer args) -{ - #define H_cddaar "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) -> '(3 4)" - #define Q_cddaar sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddaar_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, car_a_list_string); - if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, caar_a_list_string); - if (!is_pair(cdaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, cdaar_a_list_string); - return(cddaar(lst)); -} - -/* -------- cdaddr -------- */ -static s7_pointer g_cdaddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cdaddr "(cdaddr lst) returns (cdr (car (cdr (cdr lst)))): (cdaddr '(1 2 (3 4 5))) -> '(4 5)" - #define Q_cdaddr sc->pl_p - - s7_pointer lst = car(args); - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaddr_symbol, args, sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, cddr_a_list_string); - if (!is_pair(caddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, caddr_a_list_string); - return(cdaddr(lst)); -} - -/* -------- cddddr -------- */ - -static s7_pointer cddddr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, cdr_a_list_string); - if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, cddr_a_list_string); - if (!is_pair(cdddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, cdddr_a_list_string); - return(cddddr(lst)); -} - -static s7_pointer g_cddddr(s7_scheme *sc, s7_pointer args) -{ - #define H_cddddr "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) -> '(5)" - #define Q_cddddr sc->pl_p - return(cddddr_p_p(sc, car(args))); -} - - -/* -------- cddadr -------- */ -static s7_pointer cddadr_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, cdr_a_list_string); - if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, cadr_a_list_string); - if (!is_pair(cdadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, cdadr_a_list_string); - return(cddadr(lst)); -} - -static s7_pointer g_cddadr(s7_scheme *sc, s7_pointer args) -{ - #define H_cddadr "(cddadr lst) returns (cdr (cdr (car (cdr lst)))): (cddadr '(1 (2 3 4 5))) -> '(4 5)" - #define Q_cddadr sc->pl_p - return(cddadr_p_p(sc, car(args))); -} - - -/* -------- cdddar -------- */ - -static s7_pointer cdddar_p_p(s7_scheme *sc, s7_pointer lst) -{ - if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR])); - if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, car_a_list_string); - if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, cdar_a_list_string); - if (!is_pair(cddar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, cddar_a_list_string); - return(cdddar(lst)); -} - -static s7_pointer g_cdddar(s7_scheme *sc, s7_pointer args) -{ - #define H_cdddar "(cdddar lst) returns (cdr (cdr (cdr (car lst)))): (cdddar '((1 2 3 4 5))) -> '(4 5)" - #define Q_cdddar sc->pl_p - return(cdddar_p_p(sc, car(args))); -} - -/* -------------------------------- assoc assv assq -------------------------------- */ -s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; - while (true) - { - /* we can blithely take the car of anything, since we're not treating it as an object, - * then if we get a bogus match, the following check that caar made sense ought to catch it. - * if car(#) = # (initialization time), then cdr(nil)->unspec - * and subsequent caar(unspec)->unspec so we could forgo half the is_pair checks below. - * This breaks if "x" is a dotted list -- the last cdr is not nil, so we lose. - */ - LOOP_8(if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) return(car(x)); x = cdr(x); if (!is_pair(x)) return(sc->F)); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); /* not reached */ -} - -static s7_pointer assq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - return((is_pair(y)) ? s7_assq(sc, x, y) : - ((is_null(y)) ? sc->F : - method_or_bust_pp(sc, y, sc->assq_symbol, x, y, an_association_list_string, 2))); -} - -static s7_pointer g_assq(s7_scheme *sc, s7_pointer args) -{ - #define H_assq "(assq obj alist) returns the key-value pair associated (via eq?) with the key obj in the association list alist" - #define Q_assq s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol) - return(assq_p_pp(sc, car(args), cadr(args))); - /* we don't check for (pair? (car x)) here (or in assv) so we get some inconsistency with assoc: - * (assq #f '(#f 2 . 3)) -> #f, (assoc #f '(#f 2 . 3)) -> 'error - */ -} - -static s7_pointer assv_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - s7_pointer z; - if (!is_pair(y)) - { - if (is_null(y)) return(sc->F); - return(method_or_bust_pp(sc, y, sc->assv_symbol, x, y, an_association_list_string, 2)); - } - if (is_simple(x)) - return(s7_assq(sc, x, y)); - - z = y; - while (true) - { - /* here we can't play the assq == game because s7_is_eqv thinks it's getting a legit s7 object */ - if ((is_pair(car(y))) && (s7_is_eqv(sc, x, caar(y)))) return(car(y)); - y = cdr(y); - if (!is_pair(y)) return(sc->F); - - if ((is_pair(car(y))) && (s7_is_eqv(sc, x, caar(y)))) return(car(y)); - y = cdr(y); - if (!is_pair(y)) return(sc->F); - - z = cdr(z); - if (z == y) return(sc->F); - } - return(sc->F); /* not reached */ -} - -static s7_pointer g_assv(s7_scheme *sc, s7_pointer args) /* g_assv is called by g_assoc below */ -{ - #define H_assv "(assv obj alist) returns the key-value pair associated (via eqv?) with the key obj in the association list alist" - #define Q_assv Q_assq - return(assv_p_pp(sc, car(args), cadr(args))); -} - -s7_pointer s7_assoc(s7_scheme *sc, s7_pointer sym, s7_pointer lst) -{ - s7_pointer x, y; - if (!is_pair(lst)) - return(sc->F); - x = lst; - y = lst; - while (true) - { - if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); -} - -static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args); -static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args); -static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr); - -static s7_pointer assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; - if (is_string(obj)) - { - while (true) - { - if (is_pair(car(x))) - { - s7_pointer val = caar(x); - if ((val == obj) || - ((is_string(val)) && - (scheme_strings_are_equal(obj, val)))) - return(car(x)); - } - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if (is_pair(car(x))) - { - s7_pointer val = caar(x); - if ((val == obj) || - ((is_string(val)) && - (scheme_strings_are_equal(obj, val)))) - return(car(x)); - } - x = cdr(x); - if (!is_pair(x)) return(sc->F); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); - } - while (true) - { - if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); /* not reached */ -} - -static bool closure_has_two_normal_args(s7_scheme *sc, s7_pointer eq_func) /* sc for is_null */ -{ - return((is_closure(eq_func)) && - (is_pair(closure_args(eq_func))) && - (is_pair(cdr(closure_args(eq_func)))) && /* not dotted arg list */ - (is_null(cddr(closure_args(eq_func))))); /* arity == 2 */ -} - -static s7_pointer g_assoc(s7_scheme *sc, s7_pointer args) -{ - #define H_assoc "(assoc obj alist (func #f)) returns the key-value pair associated (via equal?) with the key obj in the association list alist.\ -If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?" - #define Q_assoc s7_make_signature(sc, 4, \ - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), \ - sc->T, sc->is_list_symbol, sc->is_procedure_symbol) - s7_pointer x = cadr(args), obj, eq_func = NULL; - - if (!is_null(x)) - { - if (!is_pair(x)) - return(method_or_bust(sc, x, sc->assoc_symbol, args, an_association_list_string, 2)); - if (!is_pair(car(x))) - wrong_type_error_nr(sc, sc->assoc_symbol, 2, x, an_association_list_string); /* we're assuming caar below so it better exist */ - } - if (is_pair(cddr(args))) - { - s7_pointer y; - eq_func = caddr(args); - /* here we know x is a pair, but need to protect against circular lists */ - /* I wonder if the assoc equality function should get the cons, not just caar? */ - - if (is_safe_c_function(eq_func)) - { - s7_function func = c_function_call(eq_func); - if (func == g_is_eq) return(is_null(x) ? sc->F : s7_assq(sc, car(args), x)); - if (func == g_is_eqv) return(assv_p_pp(sc, car(args), x)); - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); - set_car(sc->t2_1, car(args)); - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - set_car(sc->t2_2, caar(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); - x = cdr(x); - if ((!is_pair(x)) || (x == slow)) return(sc->F); - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - set_car(sc->t2_2, caar(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); - } - return(sc->F); - } - if (closure_has_two_normal_args(sc, eq_func)) - { - s7_pointer body = closure_body(eq_func); - if (is_null(x)) return(sc->F); - if (is_null(cdr(body))) - { - s7_pfunc func; - sc->curlet = make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F); - func = s7_bool_optimize(sc, body); - if (func) - { - s7_pointer slowx = x; - opt_info *o = sc->opts[0]; - s7_pointer b = next_slot(let_slots(sc->curlet)); - while (true) - { - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - slot_set_value(b, caar(x)); - if (o->v[0].fb(o)) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - slot_set_value(b, caar(x)); - if (o->v[0].fb(o)) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - slowx = cdr(slowx); - if (x == slowx) return(sc->F); - } - return(sc->F); - }}} - - /* member_if is similar. Do not call eval here with op_eval_done to return! An error will longjmp past the - * assoc point, leaving the op_eval_done on the stack, causing s7 to quit. - */ - if (type(eq_func) < T_CONTINUATION) - return(sole_arg_method_or_bust_p(sc, eq_func, sc->assoc_symbol, a_procedure_string)); - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); - if (is_null(x)) return(sc->F); - if ((is_any_macro(eq_func)) && (!is_c_macro(eq_func))) clear_all_optimizations(sc, closure_body(eq_func)); - y = list_1(sc, copy_proper_list(sc, args)); - set_opt1_fast(y, x); - set_opt2_slow(y, x); - push_stack(sc, OP_ASSOC_IF, list_1_unchecked(sc, y), eq_func); - if (needs_copied_args(eq_func)) - push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), caar(x)), eq_func); - else - { - set_car(sc->t2_1, car(args)); - set_car(sc->t2_2, caar(x)); - push_stack(sc, OP_APPLY, sc->t2_1, eq_func); - } - return(sc->unspecified); - } - if (is_null(x)) return(sc->F); - obj = car(args); - if (is_simple(obj)) - return(s7_assq(sc, obj, x)); - return(assoc_1(sc, obj, x)); -} - -static s7_pointer assoc_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - if (!is_pair(x)) - { - if (is_null(x)) return(sc->F); - return(method_or_bust(sc, x, sc->assoc_symbol, set_plist_2(sc, obj, x), an_association_list_string, 2)); - } - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, x, an_association_list_string); - if (is_simple(obj)) return(s7_assq(sc, obj, x)); - return(assoc_1(sc, obj, x)); -} - -static bool op_assoc_if(s7_scheme *sc) -{ - s7_pointer orig_args = car(sc->args); - /* code=func, args=(list (list args)) with f/opt1_fast=list, value=result of comparison - * (assoc 3 '((1 . a) (2 . b) (3 . c) (4 . d)) =) - */ - if (sc->value != sc->F) /* previous comparison was not #f -- return (car list) */ - { - sc->value = car(opt1_fast(orig_args)); - return(true); - } - if (!is_pair(cdr(opt1_fast(orig_args)))) /* (assoc 3 '((1 . 2) . 3) =) or nil */ - { - sc->value = sc->F; - return(true); - } - set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */ - - if (sc->cur_op == OP_ASSOC_IF1) - { - /* circular list check */ - if (opt1_fast(orig_args) == opt2_slow(orig_args)) - { - sc->value = sc->F; - return(true); - } - set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list */ - push_stack_direct(sc, OP_ASSOC_IF); - } - else push_stack_direct(sc, OP_ASSOC_IF1); - - if (!is_pair(car(opt1_fast(orig_args)))) /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "assoc: second argument is not an alist: ~S", 42), orig_args)); - /* not sure about this -- we could simply skip the entry both here and in g_assoc - * (assoc 1 '((2 . 2) 3)) -> #f - * (assoc 1 '((2 . 2) 3) =) -> error currently - */ - if (needs_copied_args(sc->code)) - sc->args = list_2(sc, caar(orig_args), caar(opt1_fast(orig_args))); - else sc->args = set_plist_2(sc, caar(orig_args), caar(opt1_fast(orig_args))); - return(false); -} - -static s7_pointer assoc_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((args == 3) && (is_normal_symbol(cadddr(expr)))) - { - if (cadddr(expr) == sc->is_eq_symbol) return(global_value(sc->assq_symbol)); - if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->assv_symbol)); - } - return(f); -} - - -/* ---------------- member, memv, memq ---------------- */ -s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; - while (true) - { - LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); -} - -static s7_pointer memq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - return((is_pair(y)) ? s7_memq(sc, x, y) : - ((is_null(y)) ? sc->F : method_or_bust_pp(sc, y, sc->memq_symbol, x, y, a_list_string, 2))); -} - -static s7_pointer g_memq(s7_scheme *sc, s7_pointer args) -{ - #define H_memq "(memq obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memq uses eq?" - #define Q_memq sc->pl_tl - - s7_pointer x = car(args); - s7_pointer y = cadr(args); - if (is_pair(y)) - return(s7_memq(sc, x, y)); - if (is_null(y)) - return(sc->F); - return(method_or_bust_pp(sc, y, sc->memq_symbol, x, y, a_list_string, 2)); -} - -/* I think (memq 'c '(a b . c)) should return #f because otherwise (memq () ...) would return the () at the end */ -/* if memq's list is a quoted list, it won't be changing, so we can tell ahead of time that it is a proper list, and what its length is */ - -static s7_pointer g_memq_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = cadr(args); - s7_pointer obj = car(args); - if (obj == car(x)) return(x); - return((obj == cadr(x)) ? cdr(x) : sc->F); -} - -static s7_pointer memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - if (obj == car(x)) return(x); - return((obj == cadr(x)) ? cdr(x) : sc->F); -} - -static s7_pointer memq_3_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - if (obj == car(x)) return(x); - if (obj == cadr(x)) return(cdr(x)); - return((obj == caddr(x)) ? cddr(x) : sc->F); -} - -static s7_pointer g_memq_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer x = cadr(args); - s7_pointer obj = car(args); - while (true) - { - if (obj == car(x)) return(x); - x = cdr(x); - if (obj == car(x)) return(x); - x = cdr(x); - if (obj == car(x)) return(x); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - } - return(sc->F); -} - -static s7_pointer memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - while (true) - { - LOOP_4(if (obj == car(x)) return(x); x = cdr(x)); - if (!is_pair(x)) return(sc->F); - } - return(sc->F); -} - -static s7_pointer g_memq_4(s7_scheme *sc, s7_pointer args) {return(memq_4_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args) -{ - /* no circular list check needed in this case */ - s7_pointer x = cadr(args); - s7_pointer obj = car(args); - while (true) - { - LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - } - return(sc->F); -} - -static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - s7_pointer lst = caddr(expr); - if ((is_proper_quote(sc, lst)) && - (is_pair(cadr(lst)))) - { - s7_int len = s7_list_length(sc, cadr(lst)); - if (len > 0) - { - if (len == 2) /* this used to set opt3_any to cadr, but that doesn't survive call/cc's copy_stack */ - return(sc->memq_2); - if ((len % 4) == 0) - return(sc->memq_4); - return(((len % 3) == 0) ? sc->memq_3 : sc->memq_any); - }} - return(f); -} - -static bool numbers_are_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ -#if WITH_GMP - if ((is_big_number(a)) || (is_big_number(b))) - return(big_numbers_are_eqv(sc, a, b)); - if (type(a) != type(b)) return(false); -#endif - /* if (type(a) != type(b)) return(false); */ /* (eqv? 1 1.0) -> #f! but assume that we've checked types already */ - - /* switch is apparently as expensive as 3-4 if's! so this only loses if every call involves complex numbers? */ - if (is_t_integer(a)) return(integer(a) == integer(b)); - if (is_t_real(a)) return(real(a) == real(b)); /* NaNs are not equal to anything including themselves */ - if (is_t_ratio(a)) return((numerator(a) == numerator(b)) && (denominator(a) == denominator(b))); - if (!is_t_complex(a)) return(false); - return((real_part(a) == real_part(b)) && (imag_part(a) == imag_part(b))); -} - -static s7_pointer memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; -#if (!WITH_GMP) - uint8_t obj_type = type(obj); -#endif - while (true) - { -#if WITH_GMP - LOOP_4(if ((is_number(car(x))) && (numbers_are_eqv(sc, obj, car(x)))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); -#else - LOOP_4(if ((type(car(x)) == obj_type) && (numbers_are_eqv(sc, obj, car(x)))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); -#endif - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); -} - -static s7_pointer memv_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - s7_pointer z; - if (!is_pair(y)) - { - if (is_null(y)) return(sc->F); - return(method_or_bust_pp(sc, y, sc->memv_symbol, x, y, a_list_string, 2)); - } - if (is_simple(x)) return(s7_memq(sc, x, y)); - if (is_number(x)) return(memv_number(sc, x, y)); - - z = y; - while (true) - { - if (s7_is_eqv(sc, x, car(y))) return(y); - y = cdr(y); - if (!is_pair(y)) return(sc->F); - - if (s7_is_eqv(sc, x, car(y))) return(y); - y = cdr(y); - if (!is_pair(y)) return(sc->F); - - z = cdr(z); - if (z == y) return(sc->F); - } - return(sc->F); /* not reached */ -} - -static s7_pointer g_memv(s7_scheme *sc, s7_pointer args) -{ - #define H_memv "(memv obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memv uses eqv?" - #define Q_memv sc->pl_tl - return(memv_p_pp(sc, car(args), cadr(args))); -} - - -s7_pointer s7_member(s7_scheme *sc, s7_pointer sym, s7_pointer lst) -{ - for (s7_pointer x = lst; is_pair(x); x = cdr(x)) - if (s7_is_equal(sc, sym, car(x))) - return(x); - return(sc->F); -} - -static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - s7_pointer y = x; - if (is_string(obj)) - while (true) - { - if ((obj == car(x)) || - ((is_string(car(x))) && - (scheme_strings_are_equal(obj, car(x))))) - return(x); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if ((obj == car(x)) || - ((is_string(car(x))) && - (scheme_strings_are_equal(obj, car(x))))) - return(x); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - y = cdr(y); - if (x == y) return(sc->F); - } - else - while (true) - { - LOOP_4(if (s7_is_equal(sc, obj, car(x))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - y = cdr(y); - if (x == y) return(sc->F); - } - return(sc->F); -} - -static bool p_to_b(opt_info *p); - -static s7_pointer g_member(s7_scheme *sc, s7_pointer args) -{ - #define H_member "(member obj list (func #f)) looks for obj in list and returns the list from that point if it is found, otherwise #f. \ -member uses equal? If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?" - #define Q_member s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol) - - /* this could be extended to accept sequences: - * (member #\a "123123abnfc" char=?) -> "abnfc" - * (member "abc" "123abc321" string=?) -> "abc321" but there's the string length complication - * (member 1 #(0 1 2) =) -> #(1 2) etc but what would it do for a hash-table? - * the third arg can be weird: (member #f (list #t) cons) -> (#t) -- cons returns '(#f . #t) which is true, so we get '(#t) - * should this be an error: (member '(1 2 3) () '(1 . 2)) -- the third arg is bogus, but the second is nil - * - * here as in assoc, sort, and make-hash-table we accept macros, but I can't think of a good reason to do so. - */ - s7_pointer x = cadr(args), obj; - - if ((!is_pair(x)) && (!is_null(x))) - return(method_or_bust(sc, x, sc->member_symbol, args, a_list_string, 2)); - - if (is_not_null(cddr(args))) - { - s7_pointer y, eq_func = caddr(args); - - if (is_safe_c_function(eq_func)) - { - s7_function func = c_function_call(eq_func); - if (func == g_is_eq) return(is_null(x) ? sc->F : s7_memq(sc, car(args), x)); - if (func == g_is_eqv) return(g_memv(sc, args)); - if (func == g_less) - func = g_less_2; - else - if (func == g_greater) - func = g_greater_2; - else - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); - set_car(sc->t2_1, car(args)); - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - set_car(sc->t2_2, car(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(x); - if (!is_pair(cdr(x))) return(sc->F); - x = cdr(x); - if (x == slow) return(sc->F); - set_car(sc->t2_2, car(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(x); - } - return(sc->F); - } - - if (closure_has_two_normal_args(sc, eq_func)) - { - s7_pointer body = closure_body(eq_func); - if (is_null(x)) return(sc->F); - if ((!no_bool_opt(body)) && - (is_null(cdr(body)))) - { - s7_pfunc func; - sc->curlet = make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F); - func = s7_bool_optimize(sc, body); - if (func) - { - opt_info *o = sc->opts[0]; - s7_pointer b = next_slot(let_slots(sc->curlet)); - if (o->v[0].fb == p_to_b) - { - s7_pointer (*fp)(opt_info *o) = o->v[O_WRAP].fp; - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - slot_set_value(b, car(x)); - if (fp(o) != sc->F) return(x); - if (!is_pair(cdr(x))) return(sc->F); - x = cdr(x); - if (x == slow) return(sc->F); - slot_set_value(b, car(x)); - if (fp(o) != sc->F) return(x); - }} - else - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - slot_set_value(b, car(x)); - if (o->v[0].fb(o)) return(x); - if (!is_pair(cdr(x))) return(sc->F); - x = cdr(x); - if (x == slow) return(sc->F); - slot_set_value(b, car(x)); - if (o->v[0].fb(o)) return(x); - } - return(sc->F); - } - set_no_bool_opt(body); - }} - if (type(eq_func) < T_CONTINUATION) - return(method_or_bust(sc, eq_func, sc->member_symbol, args, a_procedure_string, 3)); - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); - if (is_null(x)) return(sc->F); - if ((is_any_macro(eq_func)) && (!is_c_macro(eq_func))) clear_all_optimizations(sc, closure_body(eq_func)); - y = list_1(sc, copy_proper_list(sc, args)); /* this could probably be handled with a counter cell (cdr here is unused) */ - set_opt1_fast(y, x); - set_opt2_slow(y, x); - push_stack(sc, OP_MEMBER_IF, list_1(sc, y), eq_func); - if (needs_copied_args(eq_func)) - push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), car(x)), eq_func); - else - { - set_car(sc->t2_1, car(args)); - set_car(sc->t2_2, car(x)); - push_stack(sc, OP_APPLY, sc->t2_1, eq_func); - } - return(sc->unspecified); - } - if (is_null(x)) return(sc->F); - obj = car(args); - if (is_simple(obj)) - return(s7_memq(sc, obj, x)); - /* the only things that aren't simply == here are c_object, string, number, vector, hash-table, pair, and c_pointer, but all the other cases are unlikely */ - if (is_number(obj)) - return(memv_number(sc, obj, x)); - return(member(sc, obj, x)); -} - -static s7_pointer member_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x) -{ - if (is_null(x)) return(sc->F); - if (!is_pair(x)) return(method_or_bust(sc, x, sc->member_symbol, set_plist_2(sc, obj, x), a_list_string, 2)); - if (is_simple(obj)) return(s7_memq(sc, obj, x)); - if (is_number(obj)) return(memv_number(sc, obj, x)); - return(member(sc, obj, x)); -} - -static s7_pointer member_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) -{ - if (!ops) return(f); - if ((args == 3) && (is_normal_symbol(cadddr(expr)))) - { - if (cadddr(expr) == sc->is_eq_symbol) return(memq_chooser(sc, global_value(sc->memq_symbol), 2, expr, ops)); - if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->memv_symbol)); - } - return(f); -} - -static bool op_member_if(s7_scheme *sc) -{ - s7_pointer orig_args = car(sc->args); - /* code=func, args = (list (list original args)) with opt1_fast->position in cadr (the list), - * the extra indirection (list (list...)) is needed because call/cc copies arg lists - * value = result of comparison - */ - if (sc->value != sc->F) /* previous comparison was not #f -- return list */ - { - sc->value = opt1_fast(orig_args); - return(true); - } - if (!is_pair(cdr(opt1_fast(orig_args)))) /* no more args -- return #f */ - { - sc->value = sc->F; - return(true); - } - set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */ - - if (sc->cur_op == OP_MEMBER_IF1) - { - /* circular list check */ - if (opt1_fast(orig_args) == opt2_slow(orig_args)) - { - sc->value = sc->F; - return(true); - } - set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list (check for circular list) */ - push_stack_direct(sc, OP_MEMBER_IF); - } - else push_stack_direct(sc, OP_MEMBER_IF1); - - if (needs_copied_args(sc->code)) - sc->args = list_2(sc, caar(orig_args), car(opt1_fast(orig_args))); - else sc->args = set_plist_2(sc, caar(orig_args), car(opt1_fast(orig_args))); - return(false); -} - - -/* -------------------------------- list -------------------------------- */ -static s7_pointer g_list(s7_scheme *sc, s7_pointer args) -{ - #define H_list "(list ...) returns its arguments in a list" - #define Q_list s7_make_circular_signature(sc, 1, 2, sc->is_proper_list_symbol, sc->T) - return(copy_proper_list(sc, args)); -} - -static s7_pointer g_list_0(s7_scheme *sc, s7_pointer args) {return(sc->nil);} -static s7_pointer g_list_1(s7_scheme *sc, s7_pointer args) {return(list_1(sc, car(args)));} -static s7_pointer g_list_2(s7_scheme *sc, s7_pointer args) {return(list_2(sc, car(args), cadr(args)));} -static s7_pointer g_list_3(s7_scheme *sc, s7_pointer args) {return(list_3(sc, car(args), cadr(args), caddr(args)));} -static s7_pointer g_list_4(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = cddr(args); - return(list_4(sc, car(args), cadr(args), car(p), cadr(p))); -} - -static s7_pointer list_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 0) return(sc->list_0); - if (args == 1) return(sc->list_1); - if (args == 2) return(sc->list_2); - if (args == 3) return(sc->list_3); - return((args == 4) ? sc->list_4 : f); -} - -static s7_pointer list_p_p(s7_scheme *sc, s7_pointer p1) {return(list_1(sc, sc->value = p1));} -static s7_pointer list_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(list_2(sc, p1, p2));} -static s7_pointer list_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(list_3(sc, p1, p2, p3));} -/* if the GC sees a free cell here, protect it in the caller, not here, but sometimes the GC is called here! */ - -static void check_list_validity(s7_scheme *sc, const char *caller, s7_pointer lst) -{ - s7_pointer p = lst; - for (int32_t i = 1; is_pair(p); p = cdr(p), i++) - if (!s7_is_valid(sc, car(p))) - s7_warn(sc, 256, "bad argument (#%d) to %s: %p\n", i, caller, car(p)); -} - -s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...) -{ - va_list ap; - s7_pointer p; - if (num_values == 0) - return(sc->nil); - sc->w = make_list(sc, num_values, sc->unused); - p = sc->w; - va_start(ap, num_values); - for (s7_int i = 0; i < num_values; i++, p = cdr(p)) - set_car(p, va_arg(ap, s7_pointer)); - va_end(ap); - if (sc->safety > NO_SAFETY) - check_list_validity(sc, "s7_list", sc->w); - p = sc->w; - sc->w = sc->unused; - return(p); -} - -s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...) /* arglist should be NULL terminated */ -{ - s7_int i = 0; - va_list ap; - s7_pointer p; - - if (num_values == 0) - return(sc->nil); - - sc->w = make_list(sc, num_values, sc->unused); - va_start(ap, num_values); - for (s7_pointer q = sc->w; i < num_values; i++, q = cdr(q)) - { - p = va_arg(ap, s7_pointer); - if (!p) - { - va_end(ap); - wrong_number_of_args_error_nr(sc, "not enough arguments for s7_list_nl: ~S", sc->w); /* ideally we'd sublist this and append extra below */ - } - set_car(q, p); - } - p = va_arg(ap, s7_pointer); - va_end(ap); - if (p) wrong_number_of_args_error_nr(sc, "too many arguments for s7_list_nl: ~S", sc->w); - - if (sc->safety > NO_SAFETY) - check_list_validity(sc, "s7_list_nl", sc->w); - - p = sc->w; - sc->w = sc->unused; - return(p); -} - -static s7_pointer safe_list_1(s7_scheme *sc) -{ - if (!list_is_in_use(sc->safe_lists[1])) - { - sc->current_safe_list = 1; - set_list_in_use(sc->safe_lists[1]); - return(sc->safe_lists[1]); - } - return(cons(sc, sc->nil, sc->nil)); -} - -static s7_pointer safe_list_2(s7_scheme *sc) -{ - if (!list_is_in_use(sc->safe_lists[2])) - { - sc->current_safe_list = 2; - set_list_in_use(sc->safe_lists[2]); - return(sc->safe_lists[2]); - } - return(cons_unchecked(sc, sc->nil, list_1(sc, sc->nil))); -} - -static s7_pointer make_safe_list(s7_scheme *sc, s7_int num_args) -{ - if (num_args < NUM_SAFE_LISTS) - { - sc->current_safe_list = num_args; - if (!is_pair(sc->safe_lists[num_args])) - sc->safe_lists[num_args] = semipermanent_list(sc, num_args); - if (!list_is_in_use(sc->safe_lists[num_args])) - { - set_list_in_use(sc->safe_lists[num_args]); - return(sc->safe_lists[num_args]); - }} - return(make_big_list(sc, num_args, sc->nil)); -} - -static inline s7_pointer safe_list_if_possible(s7_scheme *sc, s7_int num_args) -{ - if ((num_args < NUM_SAFE_PRELISTS) && - (!list_is_in_use(sc->safe_lists[num_args]))) - { - sc->current_safe_list = num_args; - set_list_in_use(sc->safe_lists[num_args]); - return(sc->safe_lists[num_args]); - } - return(make_safe_list(sc, num_args)); -} - -static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args) -{ - s7_pointer tp = sc->nil, np = NULL, pp; - - /* we know here that car(args) is a list and cdr(args) is not nil; this function does not check sc->max_list_length; called only in g_append */ - s7_gc_protect_via_stack(sc, args); - for (s7_pointer y = args; is_pair(y); y = cdr(y)) /* arglist so not dotted */ - { - s7_pointer p = car(y), func; - - if ((has_active_methods(sc, p)) && - ((func = find_method_with_let(sc, p, sc->append_symbol)) != sc->undefined)) - { - unstack(sc); - return(s7_apply_function(sc, func, (is_null(tp)) ? y : set_ulist_1(sc, tp, y))); - } - if (is_null(cdr(y))) - { - if (is_null(tp)) - { - /* Guile: (append '() 1): 1, r7rs claims an improper list is the result, yet its own examples contradict that - * (what does "share structure" mean when there are no structures? I assume they mean sequences) - */ - unstack(sc); - return(p); - } - if (is_list(p)) - set_cdr(np, p); - else - { - s7_int len = sequence_length(sc, p); - if (len > 0) - set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); - else - if (len < 0) - set_cdr(np, p); - } - sc->temp8 = sc->unused; - unstack(sc); - return(tp); - } - - if (!is_sequence(p)) - { - unstack(sc); - wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string); - } - if (!sequence_is_empty(sc, p)) - { - if (is_pair(p)) - { - if (!s7_is_proper_list(sc, p)) - { - sc->temp8 = sc->unused; - unstack(sc); - wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_proper_list_string); - } - if (is_null(tp)) - { - tp = list_1(sc, car(p)); - np = tp; - sc->temp8 = tp; /* GC protect? */ - pp = cdr(p); - } - else pp = p; - for (; is_pair(pp); pp = cdr(pp), np = cdr(np)) - set_cdr(np, list_1(sc, car(pp))); - } - else - { - s7_int len = sequence_length(sc, p); - if (len > 0) - { - if (is_null(tp)) - { - tp = s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused))); - np = tp; - sc->temp8 = tp; - } - else set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); - for (; is_pair(cdr(np)); np = cdr(np)); - } - else - if (len < 0) - { - unstack(sc); - wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string); - }}}} - unstack(sc); - return(tp); -} - -static s7_pointer append_in_place(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - /* tack b onto the end of a without copying either -- 'a' is changed! */ - s7_pointer p; - if (is_null(a)) return(b); - p = a; - while (is_not_null(cdr(p))) p = cdr(p); - set_cdr(p, b); - return(a); -} - - -/* -------------------------------- vectors -------------------------------- */ -bool s7_is_vector(s7_pointer p) {return(is_any_vector(p));} -bool s7_is_float_vector(s7_pointer p) {return(is_float_vector(p));} -bool s7_is_int_vector(s7_pointer p) {return(is_int_vector(p));} -bool s7_is_byte_vector(s7_pointer p) {return(is_byte_vector(p));} - -static bool is_byte_vector_b_p(s7_pointer b) {return(is_byte_vector(b));} - -s7_int s7_vector_length(s7_pointer vec) {return(vector_length(vec));} - -static s7_pointer normal_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) -{ - vector_element(vec, loc) = val; - return(val); -} - -static s7_pointer typed_vector_typer_symbol(s7_scheme *sc, s7_pointer p) -{ - s7_pointer typer = typed_vector_typer(p); - return((is_c_function(typer)) ? c_function_symbol(typer) : find_closure(sc, typer, closure_let(typer))); -} - -static const char *typed_vector_typer_name(s7_scheme *sc, s7_pointer p) -{ - s7_pointer typer = typed_vector_typer(p); - return((is_c_function(typer)) ? c_function_name(typer) : symbol_name(typed_vector_typer_symbol(sc, p))); -} - -static const char *make_type_name(s7_scheme *sc, const char *name, article_t article); -static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg); - -static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg); - -static void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port) -{ - const char *setter = make_type_name(sc, typed_vector_typer_name(sc, vect), NO_ARTICLE); - port_write_string(port)(sc, setter, safe_strlen(setter), port); -} - -static noreturn void typed_vector_type_error_nr(s7_scheme *sc, s7_pointer vec, s7_pointer val) -{ - const char *descr = typed_vector_typer_name(sc, vec); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "vector-set! third argument ~$, is ~A, but the vector's element type checker, ~A, rejects it", 91), - val, type_name_string(sc, val), wrap_string(sc, descr, safe_strlen(descr)))); -} - -static inline s7_pointer typed_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) -{ - if ((sc->safety >= NO_SAFETY) && - (typed_vector_typer_call(sc, vec, set_plist_1(sc, val)) == sc->F)) - typed_vector_type_error_nr(sc, vec, val); - vector_element(vec, loc) = val; - return(val); -} - -static s7_pointer normal_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(vector_element(vec, loc));} -static s7_pointer int_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_integer(sc, int_vector(vec, loc)));} -static s7_pointer float_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_real(sc, float_vector(vec, loc)));} -static s7_pointer byte_vector_getter(s7_scheme *sc, s7_pointer bv, s7_int loc) {return(small_int(byte_vector(bv, loc)));} - -static s7_pointer int_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) -{ - if (s7_is_integer(val)) - int_vector(vec, loc) = s7_integer_clamped_if_gmp(sc, val); - else wrong_type_error_nr(sc, sc->int_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]); - return(val); -} - -static s7_pointer float_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) -{ - float_vector(vec, loc) = real_to_double(sc, val, "float-vector-set!"); - return(val); -} - -static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer val) -{ - s7_int byte; - if (!s7_is_integer(val)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]); - byte = s7_integer_clamped_if_gmp(sc, val); - if ((byte < 0) || (byte >= 256)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, wrap_string(sc, "a byte", 6)); - byte_vector(str, loc) = (uint8_t)byte; - return(val); -} - -static block_t *mallocate_empty_block(s7_scheme *sc) -{ - block_t *b; - b = mallocate_block(sc); - block_data(b) = NULL; - block_info(b) = NULL; - return(b); -} - -#define mallocate_vector(Sc, Len) ((Len) > 0) ? inline_mallocate(Sc, Len) : mallocate_empty_block(Sc) - -static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ -{ - s7_pointer x; - block_t *b = mallocate_vector(sc, len * sizeof(s7_pointer)); - new_cell(sc, x, T_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = b; - vector_elements(x) = (s7_pointer *)block_data(b); - vector_set_dimension_info(x, NULL); - vector_getter(x) = normal_vector_getter; - vector_setter(x) = normal_vector_setter; - add_vector(sc, x); - return(x); -} - -static inline s7_pointer make_simple_float_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ -{ - s7_pointer x; - block_t *b = mallocate_vector(sc, len * sizeof(s7_double)); - new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = b; - float_vector_floats(x) = (s7_double *)block_data(b); - vector_set_dimension_info(x, NULL); - vector_getter(x) = float_vector_getter; - vector_setter(x) = float_vector_setter; - add_vector(sc, x); - return(x); -} - -static inline s7_pointer make_simple_int_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ -{ - s7_pointer x; - block_t *b = mallocate_vector(sc, len * sizeof(s7_int)); - new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = b; - int_vector_ints(x) = (s7_int *)block_data(b); - vector_set_dimension_info(x, NULL); - vector_getter(x) = int_vector_getter; - vector_setter(x) = int_vector_setter; - add_vector(sc, x); - return(x); -} - -static s7_pointer make_simple_byte_vector(s7_scheme *sc, s7_int len) -{ - s7_pointer x; - block_t *b = inline_mallocate(sc, len); - new_cell(sc, x, T_BYTE_VECTOR | T_SAFE_PROCEDURE); - vector_block(x) = b; - byte_vector_bytes(x) = (uint8_t *)block_data(b); - vector_length(x) = len; - vector_set_dimension_info(x, NULL); - vector_getter(x) = byte_vector_getter; - vector_setter(x) = byte_vector_setter; - add_vector(sc, x); - return(x); -} - -static Vectorized void normal_vector_fill(s7_pointer vec, s7_pointer obj) -{ - s7_pointer *orig = vector_elements(vec); - s7_int len = vector_length(vec), i, left; - if (len == 0) return; - /* splitting out this part made no difference in speed; type check of obj is handled elsewhere */ - left = len - 8; - i = 0; - while (i <= left) - LOOP_8(orig[i++] = obj); - for (; i < len; i++) - orig[i] = obj; -} - -static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, uint8_t typ) -{ - s7_pointer x; - - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_vector_symbol, int_one, wrap_integer(sc, len), (len < 0) ? it_is_negative_string : it_is_too_large_string); - - /* this has to follow the error checks! (else garbage in free_heap temps portion confuses GC when "vector" is finalized) */ - new_cell(sc, x, typ | T_SAFE_PROCEDURE); - vector_length(x) = len; - if (len == 0) - { - vector_block(x) = mallocate_empty_block(sc); - any_vector_elements(x) = NULL; - if (typ == T_VECTOR) set_has_simple_elements(x); - } - else - if (typ == T_VECTOR) - { - block_t *b = inline_mallocate(sc, len * sizeof(s7_pointer)); - vector_block(x) = b; - vector_elements(x) = (s7_pointer *)block_data(b); - vector_getter(x) = normal_vector_getter; - vector_setter(x) = normal_vector_setter; - if (filled) normal_vector_fill(x, sc->nil); - } - else - if (typ == T_FLOAT_VECTOR) - { - block_t *b = inline_mallocate(sc, len * sizeof(s7_double)); - vector_block(x) = b; - float_vector_floats(x) = (s7_double *)block_data(b); - if (filled) - { - if (STEP_8(len)) - memclr64((void *)float_vector_floats(x), len * sizeof(s7_double)); - else memclr((void *)float_vector_floats(x), len * sizeof(s7_double)); - } - vector_getter(x) = float_vector_getter; - vector_setter(x) = float_vector_setter; - } - else - if (typ == T_INT_VECTOR) - { - block_t *b = inline_mallocate(sc, len * sizeof(s7_int)); - vector_block(x) = b; - int_vector_ints(x) = (s7_int *)block_data(b); - if (filled) - { - if (STEP_8(len)) - memclr64((void *)int_vector_ints(x), len * sizeof(s7_int)); - else memclr((void *)int_vector_ints(x), len * sizeof(s7_int)); - } - vector_getter(x) = int_vector_getter; - vector_setter(x) = int_vector_setter; - } - else /* byte-vector */ - { - block_t *b = mallocate(sc, len); - vector_block(x) = b; - byte_vector_bytes(x) = (uint8_t *)block_data(b); - vector_getter(x) = byte_vector_getter; - vector_setter(x) = byte_vector_setter; - if (filled) - { - if (STEP_64(len)) - memclr64((void *)(byte_vector_bytes(x)), len); - else memclr((void *)(byte_vector_bytes(x)), len); - }} - vector_set_dimension_info(x, NULL); - return(x); -} - -#define FILLED true -#define NOT_FILLED false - -s7_pointer s7_make_vector(s7_scheme *sc, s7_int len) -{ - s7_pointer v = make_vector_1(sc, len, FILLED, T_VECTOR); - add_vector(sc, v); - return(v); -} - -s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill) -{ - s7_pointer vect = make_simple_vector(sc, len); - normal_vector_fill(vect, fill); - return(vect); -} - -static vdims_t *make_wrap_only(s7_scheme *sc) /* this makes sc->wrap_only */ -{ - vdims_t *v = (vdims_t *)mallocate_block(sc); - vdims_original(v) = sc->F; - vector_elements_should_be_freed(v) = false; - vdims_rank(v) = 1; - vdims_dims(v) = NULL; - vdims_offsets(v) = NULL; - return(v); -} - -static vdims_t *make_vdims(s7_scheme *sc, bool elements_should_be_freed, s7_int dims, s7_int *dim_info) -{ - vdims_t *v; - if ((dims == 1) && (!elements_should_be_freed)) - return(sc->wrap_only); - - if (dims > 1) - { - s7_int offset = 1; - v = (vdims_t *)mallocate(sc, dims * 2 * sizeof(s7_int)); - vdims_original(v) = sc->F; - vector_elements_should_be_freed(v) = elements_should_be_freed; - vdims_rank(v) = dims; - vdims_offsets(v) = (s7_int *)(vdims_dims(v) + dims); - for (s7_int i = 0; i < dims; i++) - vdims_dims(v)[i] = dim_info[i]; - for (s7_int i = dims - 1; i >= 0; i--) - { - vdims_offsets(v)[i] = offset; - offset *= vdims_dims(v)[i]; - } - return(v); - } - v = (vdims_t *)mallocate_block(sc); - vdims_original(v) = sc->F; - vector_elements_should_be_freed(v) = elements_should_be_freed; - vdims_rank(v) = 1; - vdims_dims(v) = NULL; - vdims_offsets(v) = NULL; - return(v); -} - -static s7_pointer make_any_vector(s7_scheme *sc, int32_t type, s7_int len, s7_int dims, s7_int *dim_info) -{ - s7_pointer p = make_vector_1(sc, len, FILLED, type); - if (dim_info) - { - vector_set_dimension_info(p, make_vdims(sc, false, dims, dim_info)); - add_multivector(sc, p); - } - else add_vector(sc, p); - return(p); -} - -s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_INT_VECTOR, len, dims, dim_info));} -s7_pointer s7_make_byte_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_BYTE_VECTOR, len, dims, dim_info));} -s7_pointer s7_make_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_FLOAT_VECTOR, len, dims, dim_info));} -s7_pointer s7_make_normal_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_VECTOR, len, dims, dim_info));} - -s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_int len, s7_double *data, s7_int dims, s7_int *dim_info, bool free_data) -{ - /* this wraps up a C-allocated/freed double array as an s7 vector */ - s7_pointer x; - block_t *b = mallocate_empty_block(sc); - new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); - vector_block(x) = b; - float_vector_floats(x) = data; - vector_getter(x) = float_vector_getter; - vector_setter(x) = float_vector_setter; - vector_length(x) = len; - if (!dim_info) - { - s7_int di[1]; - di[0] = len; - vector_set_dimension_info(x, make_vdims(sc, free_data, 1, di)); - } - else vector_set_dimension_info(x, make_vdims(sc, free_data, dims, dim_info)); - add_multivector(sc, x); - return(x); -} - - -/* -------------------------------- vector-fill! -------------------------------- */ -static Vectorized void float_vector_fill(s7_pointer vec, s7_double x) -{ - s7_int len = vector_length(vec); - if (len == 0) return; - if (x == 0.0) - { - if (STEP_8(len)) - memclr64((void *)float_vector_floats(vec), len * sizeof(s7_double)); - else memclr((void *)float_vector_floats(vec), len * sizeof(s7_double)); - } - else - { - s7_int i = 0, left = len - 8; - s7_double *orig = float_vector_floats(vec); - while (i <= left) - LOOP_8(orig[i++] = x); - for (; i < len; i++) - orig[i] = x; - } -} - -static Vectorized void int_vector_fill(s7_pointer vec, s7_int k) -{ - s7_int len = vector_length(vec); - if (len == 0) return; - if (k == 0) - { - if (STEP_8(len)) - memclr64((void *)int_vector_ints(vec), len * sizeof(s7_int)); - else memclr((void *)int_vector_ints(vec), len * sizeof(s7_int)); - } - else - { - s7_int i = 0, left = len - 8; - s7_int *orig = int_vector_ints(vec); - while (i <= left) - LOOP_8(orig[i++] = k); - for (; i < len; i++) - orig[i] = k; - } -} - -static void byte_vector_fill(s7_pointer vec, uint8_t byte) -{ - s7_int len = vector_length(vec); - if (len == 0) return; - if (byte > 0) - local_memset((void *)(byte_vector_bytes(vec)), byte, len); - else /* byte == 0 */ - if (STEP_64(len)) - memclr64((void *)(byte_vector_bytes(vec)), len); - else memclr((void *)(byte_vector_bytes(vec)), len); -} - -void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj) -{ - switch (type(vec)) - { - case T_FLOAT_VECTOR: - if (!is_real(obj)) - wrong_type_error_nr(sc, wrap_string(sc, "float-vector fill!", 18), 2, obj, sc->type_names[T_REAL]); - float_vector_fill(vec, s7_real(obj)); - break; - case T_INT_VECTOR: - if (!s7_is_integer(obj)) /* possibly a bignum */ - wrong_type_error_nr(sc, wrap_string(sc, "int-vector fill!", 16), 2, obj, sc->type_names[T_INTEGER]); - int_vector_fill(vec, s7_integer_clamped_if_gmp(sc, obj)); - break; - case T_BYTE_VECTOR: - if (!is_byte(obj)) - wrong_type_error_nr(sc, wrap_string(sc, "byte-vector fill!", 17), 2, obj, wrap_string(sc, "a byte", 6)); - byte_vector_fill(vec, (uint8_t)s7_integer_clamped_if_gmp(sc, obj)); - break; - case T_VECTOR: - default: - normal_vector_fill(vec, obj); - } -} - -static s7_pointer g_vector_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) -{ - s7_pointer x = car(args), fill; - s7_int start = 0, end; - - if (!is_any_vector(x)) - { - check_method(sc, x, sc->vector_fill_symbol, args); - /* not two_methods (and fill!) here else we get stuff like: - * (let ((e (openlet (inlet 'fill! (lambda (obj val) (string-fill! (obj 'value) val)) 'value "01234")))) (vector-fill! e #\a) (e 'value)) -> "aaaaa" - */ - wrong_type_error_nr(sc, caller, 1, x, sc->type_names[T_VECTOR]); - } - if (is_immutable_vector(x)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, x)); - - fill = cadr(args); - - if ((is_typed_vector(x)) && - (typed_vector_typer_call(sc, x, set_plist_1(sc, fill)) == sc->F)) - { - const char *tstr = make_type_name(sc, typed_vector_typer_name(sc, x), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, wrap_string(sc, "vector fill!", 12), 2, fill, wrap_string(sc, tstr, safe_strlen(tstr))); - } - if (is_float_vector(x)) - { - if (!is_real(fill)) /* possibly a bignum */ - return(method_or_bust(sc, fill, caller, args, sc->type_names[T_REAL], 2)); - } - else - if ((is_int_vector(x)) || (is_byte_vector(x))) - { - if (!s7_is_integer(fill)) - return(method_or_bust(sc, fill, caller, args, sc->type_names[T_INTEGER], 2)); - if ((is_byte_vector(x)) && - ((s7_integer_clamped_if_gmp(sc, fill) < 0) || (s7_integer_clamped_if_gmp(sc, fill) > 255))) - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "~S second argument, ~S, should fit in an unsigned byte", 54), caller, fill)); - } - end = vector_length(x); - if (!is_null(cddr(args))) - { - s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); - if (p != sc->unused) return(p); - if (start == end) return(fill); - } - if (end == 0) return(fill); - - if ((start == 0) && (end == vector_length(x))) - s7_vector_fill(sc, x, fill); - else - if (is_normal_vector(x)) - for (s7_int i = start; i < end; i++) vector_element(x, i) = fill; - else - if (is_int_vector(x)) - { - s7_int k = s7_integer_clamped_if_gmp(sc, fill); - if (k == 0) - memclr((void *)(int_vector_ints(x) + start), (end - start) * sizeof(s7_int)); - else for (s7_int i = start; i < end; i++) int_vector(x, i) = k; - } - else - if (is_float_vector(x)) - { - s7_double y = s7_real(fill); - if (y == 0.0) - memclr((void *)(float_vector_floats(x) + start), (end - start) * sizeof(s7_double)); - else - { - s7_double *orig = float_vector_floats(x); - s7_int left = end - 8; - s7_int i = start; - while (i <= left) - LOOP_8(orig[i++] = y); - for (; i < end; i++) - orig[i] = y; - }} - else - if (is_byte_vector(x)) - { - uint8_t k = (uint8_t)s7_integer_clamped_if_gmp(sc, fill); - if (k == 0) - memclr((void *)(byte_vector_bytes(x) + start), end - start); - else local_memset((void *)(byte_vector_bytes(x) + start), k, end - start); - } - return(fill); -} - -#if (!WITH_PURE_S7) -/* -------------------------------- vector-fill! -------------------------------- */ -static s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_fill "(vector-fill! v val start end) sets all elements of the vector v between start and end to val" - #define Q_vector_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->T, sc->is_integer_symbol) - return(g_vector_fill_1(sc, sc->vector_fill_symbol, args)); -} - -/* -------------------------------- vector-append -------------------------------- */ -static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_pointer caller); -static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer caller, s7_pointer source, s7_pointer args); - -static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args) -{ - /* returns a one-dimensional vector. To handle multidimensional vectors, we'd need to - * ensure all the dimensional data matches (rank, size of each dimension except the last etc), - * which is too much trouble. - */ - #define H_vector_append "(vector-append . vectors) returns a new (1-dimensional) vector containing the elements of its vector arguments." - #define Q_vector_append sc->pcl_v - - s7_pointer p = args; - if (is_null(args)) - return(make_simple_vector(sc, 0)); - - if ((is_null(cdr(args))) && - (is_any_vector(car(args)))) - return(copy_source_no_dest(sc, sc->vector_append_symbol, car(args), args)); - - for (int32_t i = 0; is_pair(p); p = cdr(p), i++) - { - s7_pointer x = car(p); - if (!is_any_vector(x)) - { - if (has_active_methods(sc, x)) - { - s7_pointer func = find_method_with_let(sc, x, sc->vector_append_symbol); - if (func != sc->undefined) - { - int32_t k; - s7_pointer v, y; - if (i == 0) - return(s7_apply_function(sc, func, args)); - sc->temp9 = make_list(sc, i, sc->unused); /* we have to copy the arglist here */ - for (k = 0, y = args, v = sc->temp9; k < i; k++, y = cdr(y), v = cdr(v)) - set_car(v, car(y)); - v = g_vector_append(sc, sc->temp9); - y = s7_apply_function(sc, func, set_ulist_1(sc, v, p)); - sc->temp9 = sc->unused; - return(y); - }} - wrong_type_error_nr(sc, sc->vector_append_symbol, i + 1, x, sc->type_names[T_VECTOR]); - }} - return(vector_append(sc, args, type(car(args)), sc->vector_append_symbol)); -} - -static s7_pointer vector_append_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - s7_pointer val; - sc->temp7 = list_2(sc, p1, p2); /* ideally this list would be stack_protected, avoiding temp7 (method call above) */ - val = g_vector_append(sc, sc->temp7); - sc->temp7 = sc->unused; - return(val); -} - -static s7_pointer vector_append_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) -{ - s7_pointer val; - sc->temp7 = list_3(sc, p1, p2, p3); - val = g_vector_append(sc, sc->temp7); - sc->temp7 = sc->unused; - return(val); -} -#endif - - -/* -------------------------------- vector-ref|set! -------------------------------- */ -s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index) -{ - if (index >= vector_length(vec)) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - return(vector_getter(vec)(sc, vec, index)); -} - -s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a) -{ - if (index >= vector_length(vec)) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); - if (is_typed_vector(vec)) - return(typed_vector_setter(sc, vec, index, a)); - vector_setter(vec)(sc, vec, index, T_Ext(a)); - return(a); -} - -s7_pointer *s7_vector_elements(s7_pointer vec) {return(vector_elements(vec));} - -/* these are for s7.h */ -s7_int *s7_int_vector_elements(s7_pointer vec) {return(int_vector_ints(vec));} -s7_int s7_int_vector_ref(s7_pointer vec, s7_int index) {return(int_vector(vec, index));} -s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value) {int_vector(vec, index) = value; return(value);} - -uint8_t *s7_byte_vector_elements(s7_pointer vec) {return(byte_vector_bytes(vec));} -uint8_t s7_byte_vector_ref(s7_pointer vec, s7_int index) {return(byte_vector(vec, index));} -uint8_t s7_byte_vector_set(s7_pointer vec, s7_int index, uint8_t value) {byte_vector(vec, index) = value; return(value);} - -s7_double *s7_float_vector_elements(s7_pointer vec) {return(float_vector_floats(vec));} -s7_double s7_float_vector_ref(s7_pointer vec, s7_int index) {return(float_vector(vec, index));} -s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value) {float_vector(vec, index) = value; return(value);} - -s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size) -{ - if (dims_size <= 0) return(0); - if (vector_dimension_info(vec)) - { - s7_int lim = vector_ndims(vec); - if (lim > dims_size) lim = dims_size; - for (s7_int i = 0; i < lim; i++) dims[i] = vector_dimension(vec, i); - return(lim); - } - dims[0] = vector_length(vec); - return(1); -} - -s7_int s7_vector_dimension(s7_pointer vec, s7_int dim) -{ - if (vector_dimension_info(vec)) - return(vector_dimension(vec, dim)); - return((dim == 0) ? vector_length(vec) : -1); -} - -s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size) -{ - if (offs_size <= 0) return(0); - if (vector_dimension_info(vec)) - { - s7_int lim = vector_ndims(vec); - if (lim > offs_size) lim = offs_size; - for (s7_int i = 0; i < lim; i++) offs[i] = vector_offset(vec, i); - return(lim); - } - offs[0] = 1; - return(1); -} - - -static s7_int flatten_multivector_indices(s7_scheme *sc, s7_pointer vector, s7_int indices, va_list ap) -{ - s7_int index, rank = vector_rank(vector); - if (rank != indices) - { - va_end(ap); - wrong_number_of_args_error_nr(sc, "s7_vector_ref_n: wrong number of indices: ~A", wrap_integer(sc, indices)); - } - if (rank == 1) - index = va_arg(ap, s7_int); - else - { - s7_int i; - s7_int *dimensions = vector_dimensions(vector); - s7_int *offsets = vector_offsets(vector); - for (i = 0, index = 0; i < indices; i++) - { - s7_int ind = va_arg(ap, s7_int); - if ((ind < 0) || (ind >= dimensions[i])) - { - va_end(ap); - out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i), wrap_integer(sc, ind), (ind < 0) ? it_is_negative_string : it_is_too_large_string); - return(-1); - } - index += (ind * offsets[i]); - }} - va_end(ap); - return(index); -} - -s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, s7_int indices, ...) -{ - s7_int index; - va_list ap; - va_start(ap, indices); - index = flatten_multivector_indices(sc, vector, indices, ap); - return(vector_getter(vector)(sc, vector, index)); -} - -s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, s7_int indices, ...) -{ - s7_int index; - va_list ap; - va_start(ap, indices); - index = flatten_multivector_indices(sc, vector, indices, ap); - if (is_typed_vector(vector)) - return(typed_vector_setter(sc, vector, index, value)); - return(vector_setter(vector)(sc, vector, index, value)); -} - - -/* -------------------------------- vector->list -------------------------------- */ -s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect) -{ - s7_int len = vector_length(vect); - s7_pointer result; - if (len == 0) return(sc->nil); - init_temp(sc->y, sc->nil); - gc_protect_via_stack(sc, vect); - switch (type(vect)) - { - case T_VECTOR: - check_free_heap_size(sc, len); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, vector_element(vect, i), sc->y); - break; - case T_BYTE_VECTOR: - check_free_heap_size(sc, len); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, small_int(byte_vector(vect, i)), sc->y); - break; - case T_INT_VECTOR: - check_free_heap_size(sc, 2 * len); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, make_integer_unchecked(sc, int_vector(vect, i)), sc->y); - break; - case T_FLOAT_VECTOR: - check_free_heap_size(sc, 2 * len); - for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, make_real_unchecked(sc, float_vector(vect, i)), sc->y); - break; - } - unstack(sc); - result = sc->y; - sc->y = sc->unused; - return(result); -} - -s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array) -{ - s7_pointer result; - if (num_values == 0) return(sc->nil); - init_temp(sc->y, sc->nil); - check_free_heap_size(sc, num_values); - for (s7_int i = num_values - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, array[i], sc->y); - result = sc->y; - if (sc->safety > NO_SAFETY) - check_list_validity(sc, "s7_array_to_list", result); - sc->y = sc->unused; - return(result); -} - -#if (!WITH_PURE_S7) -static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_to_list "(vector->list v (start 0) end) returns the elements of the vector v as a list; (map values v)" - #define Q_vector_to_list s7_make_signature(sc, 4, sc->is_proper_list_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol) - - s7_int i, start = 0, end; - s7_pointer p, vec = car(args); - if (!is_any_vector(vec)) - return(sole_arg_method_or_bust(sc, vec, sc->vector_to_list_symbol, args, sc->type_names[T_VECTOR])); - - end = vector_length(vec); - if (!is_null(cdr(args))) - { - p = start_and_end(sc, sc->vector_to_list_symbol, args, 2, cdr(args), &start, &end); - if (p != sc->unused) return(p); - if (start == end) return(sc->nil); - } - if ((end - start) > sc->max_list_length) - out_of_range_error_nr(sc, sc->vector_to_list_symbol, int_one, car(args), it_is_too_large_string); - - check_free_heap_size(sc, end - start); - sc->w = sc->nil; - gc_protect_via_stack(sc, vec); - if (is_normal_vector(vec)) - for (i = end - 1; i >= start; i--) sc->w = cons_unchecked(sc, vector_element(vec, i), sc->w); - else for (i = end - 1; i >= start; i--) sc->w = cons_unchecked(sc, vector_getter(vec)(sc, vec, i), sc->w); - unstack(sc); - p = sc->w; - sc->w = sc->unused; - return(p); -} - -static s7_pointer vector_to_list_p_p(s7_scheme *sc, s7_pointer p) -{ - if (!is_any_vector(p)) - return(method_or_bust_p(sc, p, sc->vector_to_list_symbol, sc->type_names[T_VECTOR])); - return(s7_vector_to_list(sc, p)); -} -#endif - - -/* -------------------------------- string->byte-vector -------------------------------- */ -static s7_pointer g_string_to_byte_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_string_to_byte_vector "(string->byte-vector obj) turns a string into a byte-vector." - #define Q_string_to_byte_vector s7_make_signature(sc, 2, sc->is_byte_vector_symbol, sc->is_string_symbol) - s7_pointer str = car(args); - if (!is_string(str)) - return(method_or_bust_p(sc, str, sc->string_to_byte_vector_symbol, sc->type_names[T_STRING])); - return(s7_copy_1(sc, sc->string_to_byte_vector_symbol, set_plist_2(sc, str, make_simple_byte_vector(sc, string_length(str))))); -} - - -/* -------------------------------- byte-vector->string -------------------------------- */ -static s7_pointer g_byte_vector_to_string(s7_scheme *sc, s7_pointer args) -{ - #define H_byte_vector_to_string "(byte-vector->string obj) turns a byte-vector into a string." - #define Q_byte_vector_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_byte_vector_symbol) - s7_pointer v = car(args); - if (!is_byte_vector(v)) - return(method_or_bust_p(sc, v, sc->byte_vector_to_string_symbol, sc->type_names[T_BYTE_VECTOR])); - return(s7_copy_1(sc, sc->byte_vector_to_string_symbol, set_plist_2(sc, v, make_empty_string(sc, byte_vector_length(v), 0)))); -} - - -/* -------------------------------- vector -------------------------------- */ -static s7_pointer g_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_vector "(vector ...) returns a vector whose elements are the arguments" - #define Q_vector s7_make_circular_signature(sc, 1, 2, sc->is_vector_symbol, sc->T) - - s7_pointer vec, b; - s7_int len = proper_list_length_with_end(args, &b); - if (!is_null(b)) - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "vector constant data is not a proper list", 41))); - vec = make_simple_vector(sc, len); - if (len > 0) - { - s7_pointer x = args; - for (s7_int i = 0; is_pair(x); x = cdr(x), i++) - vector_element(vec, i) = car(x); - } - return(vec); -} - -static inline s7_pointer vector_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) -{ - s7_pointer vec = make_simple_vector(sc, 2); - vector_element(vec, 0) = p1; - vector_element(vec, 1) = p2; - return(vec); -} - -static s7_pointer g_vector_2(s7_scheme *sc, s7_pointer args) {return(vector_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_vector_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer vec = make_simple_vector(sc, 3); - vector_element(vec, 0) = car(args); args = cdr(args); - vector_element(vec, 1) = car(args); - vector_element(vec, 2) = cadr(args); - return(vec); -} - -static s7_pointer vector_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 2) return(sc->vector_2); - return((args == 3) ? sc->vector_3 : f); -} - - -/* -------------------------------- float-vector? -------------------------------- */ -static s7_pointer g_is_float_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_float_vector "(float-vector? obj) returns #t if obj is an homogeneous float vector" - #define Q_is_float_vector sc->pl_bt - check_boolean_method(sc, s7_is_float_vector, sc->is_float_vector_symbol, args); -} - - -/* -------------------------------- float-vector -------------------------------- */ -static s7_pointer g_float_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_float_vector "(float-vector ...) returns an homogeneous float vector whose elements are the arguments" - #define Q_float_vector s7_make_circular_signature(sc, 1, 2, sc->is_float_vector_symbol, sc->is_real_symbol) - - s7_pointer vec, b; - s7_int len = proper_list_length_with_end(args, &b); - if (!is_null(b)) - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "float-vector constant data is not a proper list", 47))); - - vec = make_simple_float_vector(sc, len); - if (len > 0) - { - s7_int i = 0; - for (s7_pointer x = args; is_pair(x); x = cdr(x), i++) - { /* this used to gc protect vec via sc->w? was that due to very old bignum code in s7_real? */ - s7_pointer p = car(x); - if (is_t_real(p)) - float_vector(vec, i) = real(p); - else - if (is_real(p)) /* bignum is ok here */ - float_vector(vec, i) = s7_real(p); - else return(method_or_bust(sc, p, sc->float_vector_symbol, args, sc->type_names[T_REAL], i + 1)); - }} - return(vec); -} - -static s7_pointer float_vector_p_d(s7_scheme *sc, s7_double x) -{ - s7_pointer vec = make_simple_float_vector(sc, 1); - float_vector(vec, 0) = x; - return(vec); -} - - -/* -------------------------------- int-vector? -------------------------------- */ -static s7_pointer g_is_int_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_int_vector "(int-vector? obj) returns #t if obj is an homogeneous s7_int vector" - #define Q_is_int_vector sc->pl_bt - check_boolean_method(sc, is_int_vector, sc->is_int_vector_symbol, args); -} - - -/* -------------------------------- int-vector -------------------------------- */ -static s7_pointer g_int_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_int_vector "(int-vector ...) returns an homogeneous s7_int vector whose elements are the arguments" - #define Q_int_vector s7_make_circular_signature(sc, 1, 2, sc->is_int_vector_symbol, sc->is_integer_symbol) - - s7_int i = 0; - s7_pointer vec, b; - s7_int len = proper_list_length_with_end(args, &b); - if (!is_null(b)) - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "int-vector constant data is not a proper list", 45))); - - vec = make_simple_int_vector(sc, len); - if (len == 0) return(vec); - for (s7_pointer x = args; is_pair(x); x = cdr(x), i++) - { - s7_pointer p = car(x); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->int_vector_symbol, args, sc->type_names[T_INTEGER], i + 1)); - int_vector(vec, i) = s7_integer_clamped_if_gmp(sc, p); - } - return(vec); -} - -static s7_pointer int_vector_p_i(s7_scheme *sc, s7_int x) -{ - s7_pointer vec = make_simple_int_vector(sc, 1); - int_vector(vec, 0) = x; - return(vec); -} - - -/* -------------------------------- byte-vector? -------------------------------- */ -static s7_pointer g_is_byte_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector" - #define Q_is_byte_vector sc->pl_bt - check_boolean_method(sc, is_byte_vector_b_p, sc->is_byte_vector_symbol, args); -} - - -/* -------------------------------- byte-vector -------------------------------- */ -static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_byte_vector "(byte-vector ...) returns a byte-vector whose elements are the arguments" - #define Q_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_byte_symbol) - - s7_int i = 0; - s7_pointer vec, end; - uint8_t *str; - s7_int len = proper_list_length_with_end(args, &end); - if (!is_null(end)) - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "byte-vector constant data is not a proper list", 46))); - - vec = make_simple_byte_vector(sc, len); - str = byte_vector_bytes(vec); - for (s7_pointer x = args; is_pair(x); i++, x = cdr(x)) - { - s7_pointer byte = car(x); - s7_int b; - if (is_t_integer(byte)) - b = integer(byte); - else -#if WITH_GMP - if (is_t_big_integer(byte)) - b = big_integer_to_s7_int(sc, big_integer(byte)); - else -#endif - return(method_or_bust(sc, byte, sc->byte_vector_symbol, args, sc->type_names[T_INTEGER], i + 1)); - if ((b < 0) || (b > 255)) - wrong_type_error_nr(sc, sc->byte_vector_symbol, i + 1, byte, an_unsigned_byte_string); - str[i] = (uint8_t)b; - } - return(vec); -} - - -#if (!WITH_PURE_S7) -/* -------------------------------- list->vector -------------------------------- */ -static s7_pointer g_list_to_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_list_to_vector "(list->vector lst) returns a vector containing the elements of lst; (apply vector lst)" - #define Q_list_to_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_proper_list_symbol) - - s7_pointer p = car(args); - if (is_null(p)) - return(make_simple_vector(sc, 0)); /* was s7_make_vector */ - sc->temp3 = p; - if (!s7_is_proper_list(sc, p)) - return(sole_arg_method_or_bust_p(sc, p, sc->list_to_vector_symbol, a_proper_list_string)); - p = g_vector(sc, p); - sc->temp3 = sc->unused; - return(p); -} - -/* -------------------------------- vector-length -------------------------------- */ -static s7_pointer g_vector_length(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_length "(vector-length v) returns the length of vector v" - #define Q_vector_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol) - - s7_pointer vec = car(args); - if (!is_any_vector(vec)) - return(sole_arg_method_or_bust(sc, vec, sc->vector_length_symbol, args, sc->type_names[T_VECTOR])); - return(make_integer(sc, vector_length(vec))); -} - -static s7_int vector_length_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_any_vector(p)) - return(integer(method_or_bust_p(sc, p, sc->vector_length_symbol, sc->type_names[T_VECTOR]))); - return(vector_length(p)); -} - -static s7_pointer vector_length_p_p(s7_scheme *sc, s7_pointer vec) -{ - if (!is_any_vector(vec)) - return(method_or_bust_p(sc, vec, sc->vector_length_symbol, sc->type_names[T_VECTOR])); - return(make_integer(sc, vector_length(vec))); -} -#endif - - -/* -------------------------------- subvector subvector? subvector-vector subvector-position -------------------------------- */ -static bool s7_is_subvector(s7_pointer g) {return((is_any_vector(g)) && (is_subvector(g)));} - -static s7_pointer g_is_subvector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_subvector "(subvector? obj) returns #t if obj is a subvector" - #define Q_is_subvector sc->pl_bt - check_boolean_method(sc, s7_is_subvector, sc->is_subvector_symbol, args); -} - -static s7_pointer g_subvector_position(s7_scheme *sc, s7_pointer args) -{ - #define H_subvector_position "(subvector-position obj) returns obj's offset" - #define Q_subvector_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_subvector_symbol) - - s7_pointer sv = car(args); - if (s7_is_subvector(sv)) - { - /* we can't use vector_elements(sv) - vector_elements(subvector_vector(sv)) because that assumes we're looking at s7_pointer*, - * so a subvector of a byte_vector gets a bogus position (0 if position is less than 8 etc). - * Since we currently let the user reset s7_int and s7_double, all four cases have to be handled explicitly. - */ - switch (type(sv)) - { - case T_VECTOR: return(make_integer(sc, (s7_int)(vector_elements(sv) - vector_elements(subvector_vector(sv))))); - case T_INT_VECTOR: return(make_integer(sc, (s7_int)(int_vector_ints(sv) - int_vector_ints(subvector_vector(sv))))); - case T_FLOAT_VECTOR: return(make_integer(sc, (s7_int)(float_vector_floats(sv) - float_vector_floats(subvector_vector(sv))))); - case T_BYTE_VECTOR: return(make_integer(sc, (s7_int)(byte_vector_bytes(sv) - byte_vector_bytes(subvector_vector(sv))))); - }} - return(sole_arg_method_or_bust(sc, sv, sc->subvector_position_symbol, args, sc->type_names[T_VECTOR])); -} - -static s7_pointer g_subvector_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_subvector_vector "(subvector-vector obj) returns the vector underlying the subvector obj" - #define Q_subvector_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_subvector_symbol) - - if (s7_is_subvector(car(args))) - return(subvector_vector(car(args))); - return(sole_arg_method_or_bust(sc, car(args), sc->subvector_vector_symbol, args, sc->type_names[T_VECTOR])); -} - -static s7_pointer subvector(s7_scheme *sc, s7_pointer vect, s7_int skip_dims, s7_int index) -{ - s7_int dims = vector_ndims(vect) - skip_dims; - s7_pointer x; - new_cell(sc, x, (full_type(vect) & (~T_COLLECTED)) | T_SUBVECTOR | T_SAFE_PROCEDURE); - vector_length(x) = 0; - vector_block(x) = mallocate_empty_block(sc); - any_vector_elements(x) = NULL; - vector_getter(x) = vector_getter(vect); - vector_setter(x) = vector_setter(vect); - if (dims > 1) - { - vdims_t *v = (vdims_t *)mallocate_block(sc); - vdims_rank(v) = dims; - vdims_dims(v) = (s7_int *)(vector_dimensions(vect) + skip_dims); - vdims_offsets(v) = (s7_int *)(vector_offsets(vect) + skip_dims); - vdims_original(v) = vect; - vector_elements_should_be_freed(v) = false; - vector_set_dimension_info(x, v); - } - else - { - vector_set_dimension_info(x, NULL); - subvector_set_vector(x, vect); - } - if (is_normal_vector(vect)) - mark_function[T_VECTOR] = mark_vector_possibly_shared; - else mark_function[type(vect)] = mark_int_or_float_vector_possibly_shared; - - vector_length(x) = (skip_dims > 0) ? vector_offset(vect, skip_dims - 1) : vector_length(vect); - if (is_int_vector(vect)) - int_vector_ints(x) = (s7_int *)(int_vector_ints(vect) + index); - else - if (is_float_vector(vect)) - float_vector_floats(x) = (s7_double *)(float_vector_floats(vect) + index); - else - if (is_normal_vector(vect)) - vector_elements(x) = (s7_pointer *)(vector_elements(vect) + index); - else byte_vector_bytes(x) = (uint8_t *)(byte_vector_bytes(vect) + index); - add_multivector(sc, x); - return(x); -} - -static inline vdims_t *list_to_dims(s7_scheme *sc, s7_pointer x) -{ - s7_int i, offset; - s7_pointer y; - s7_int *ds, *os; - s7_int len = proper_list_length(x); - vdims_t *v = (vdims_t *)inline_mallocate(sc, len * 2 * sizeof(s7_int)); - vdims_rank(v) = len; - vdims_offsets(v) = (s7_int *)(vdims_dims(v) + len); - vector_elements_should_be_freed(v) = false; - ds = vdims_dims(v); - os = vdims_offsets(v); - - for (i = 0, y = x; is_not_null(y); i++, y = cdr(y)) - ds[i] = s7_integer_clamped_if_gmp(sc, car(y)); - - for (i = len - 1, offset = 1; i >= 0; i--) - { - os[i] = offset; - offset *= ds[i]; - } - return(v); -} - -static s7_pointer g_subvector(s7_scheme *sc, s7_pointer args) -{ - #define H_subvector "(subvector original-vector (start 0) (end original-vector-len) new-dimensions) returns \ -a vector that points to the same elements as the original-vector but with different starting point, end point, and dimensional info." - #define Q_subvector s7_make_signature(sc, 5, sc->is_subvector_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_pair_symbol) - - /* (let ((v1 #2d((1 2 3) (4 5 6)))) (let ((v2 (subvector v1 0 6))) v2)) -> #(1 2 3 4 5 6) - * (let ((v1 #(1 2 3 4 5 6))) (let ((v2 (subvector v1 0 6 '(3 2)))) v2)) -> #2D((1 2) (3 4) (5 6)) - */ - s7_pointer orig = car(args), x; - vdims_t *v = NULL; - s7_int new_len, orig_len, offset = 0; - - if (!is_any_vector(orig)) - return(method_or_bust(sc, orig, sc->subvector_symbol, args, sc->type_names[T_VECTOR], 1)); - - orig_len = vector_length(orig); - new_len = orig_len; - - if (is_pair(cdr(args))) /* get start point in vector */ - { - s7_pointer start = cadr(args); - if (!s7_is_integer(start)) - return(method_or_bust(sc, start, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 2)); - offset = s7_integer_clamped_if_gmp(sc, start); - if ((offset < 0) || (offset > orig_len)) /* we need this if, for example, offset == 9223372036854775807 */ - out_of_range_error_nr(sc, sc->subvector_symbol, int_two, start, (offset < 0) ? it_is_negative_string : it_is_too_large_string); - new_len -= offset; - - if (is_pair(cddr(args))) /* get end point in vector */ - { - s7_pointer end = caddr(args); - s7_int new_end; - if (!s7_is_integer(end)) - return(method_or_bust(sc, end, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 3)); - new_end = s7_integer_clamped_if_gmp(sc, end); - if ((new_end < 0) || (new_end > orig_len)) - out_of_range_error_nr(sc, sc->subvector_symbol, int_three, end, (new_end < 0) ? it_is_negative_string : it_is_too_large_string); - if (offset > new_end) - out_of_range_error_nr(sc, sc->subvector_symbol, int_two, start, wrap_string(sc, "start point > end point", 23)); - new_len = new_end - offset; - - if (is_pair(cdddr(args))) - { - s7_pointer dims = cadddr(args); - if ((is_null(dims)) || - (!s7_is_proper_list(sc, dims))) - return(method_or_bust(sc, dims, sc->subvector_symbol, args, sc->type_names[T_PAIR], 4)); - - for (s7_pointer y = dims; is_pair(y); y = cdr(y)) - if ((!s7_is_integer(car(y))) || /* (subvector v '((1 2) (3 4))) */ - (s7_integer_clamped_if_gmp(sc, car(y)) > orig_len) || - (s7_integer_clamped_if_gmp(sc, car(y)) < 0)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_1(sc, wrap_string(sc, "a subvector must fit in the original vector", 43))); - - v = list_to_dims(sc, dims); - new_len = vdims_dims(v)[0]; - for (s7_int i = 1; i < vdims_rank(v); i++) new_len *= vdims_dims(v)[i]; - if (new_len != new_end - offset) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "subvector dimensional length, ~S, does not match the start and end positions: ~S to ~S~%", 88), - wrap_integer(sc, new_len), start, end)); - vdims_original(v) = orig; - }}} - - if (is_normal_vector(orig)) - mark_function[T_VECTOR] = mark_vector_possibly_shared; - else mark_function[type(orig)] = mark_int_or_float_vector_possibly_shared; /* I think this works for byte-vectors also */ - - new_cell(sc, x, (full_type(orig) & (~T_COLLECTED)) | T_SUBVECTOR | T_SAFE_PROCEDURE); - vector_block(x) = mallocate_empty_block(sc); - vector_set_dimension_info(x, v); - if (!v) subvector_set_vector(x, orig); - vector_length(x) = new_len; /* might be less than original length */ - if ((new_len == 0) && (is_normal_vector(orig))) set_has_simple_elements(x); - vector_getter(x) = vector_getter(orig); - vector_setter(x) = vector_setter(orig); - - if (is_int_vector(orig)) - int_vector_ints(x) = (s7_int *)(int_vector_ints(orig) + offset); - else - if (is_float_vector(orig)) - float_vector_floats(x) = (s7_double *)(float_vector_floats(orig) + offset); - else - if (is_normal_vector(x)) - vector_elements(x) = (s7_pointer *)(vector_elements(orig) + offset); - else byte_vector_bytes(x) = (uint8_t *)(byte_vector_bytes(orig) + offset); - add_multivector(sc, x); - return(x); -} - - -/* -------------------------------- vector-ref -------------------------------- */ -static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indices) -{ - s7_int index = 0; - if (vector_length(vect) == 0) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_one, vect, it_is_too_large_string); - - if (vector_rank(vect) > 1) - { - s7_int i; - s7_pointer x; - for (x = indices, i = 0; (is_not_null(x)) && (i < vector_ndims(vect)); x = cdr(x), i++) - { - s7_int n; - s7_pointer p = car(x); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, p); - if ((n < 0) || (n >= vector_dimension(vect, i))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i + 2), p, (n < 0) ? it_is_negative_string : it_is_too_large_string); - - index += n * vector_offset(vect, i); - } - if (is_not_null(x)) - { - s7_pointer nv; - if (!is_normal_vector(vect)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); - nv = vector_element(vect, index); - return(implicit_index(sc, nv, x)); - } - /* if not enough indices, return a subvector covering whatever is left */ - if (i < vector_ndims(vect)) - return(subvector(sc, vect, i, index)); - } - else - { - s7_pointer p = car(indices); - /* (let ((hi (make-vector 3 0.0)) (sum 0.0)) (do ((i 0 (+ i 1))) ((= i 3)) (set! sum (+ sum (hi i)))) sum) */ - - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, p); - - if ((index < 0) || (index >= vector_length(vect))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); - - if (is_not_null(cdr(indices))) /* (let ((L #(#(1 2 3) #(4 5 6)))) (vector-ref L 1 2)) */ - { - s7_pointer nv; - if (!is_normal_vector(vect)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); - nv = vector_element(vect, index); - return(implicit_pair_index_checked(sc, vect, nv, indices)); - }} - return((vector_getter(vect))(sc, vect, index)); -} - -static s7_pointer g_vector_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_ref "(vector-ref v ... i) returns the i-th element of vector v." - #define Q_vector_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol) - - s7_pointer vec = car(args); - if (!is_any_vector(vec)) - return(method_or_bust(sc, vec, sc->vector_ref_symbol, args, sc->type_names[T_VECTOR], 1)); - return(vector_ref_1(sc, vec, cdr(args))); /* 19-Jan-19 */ -} - -static s7_pointer vector_ref_p_pi(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((!is_normal_vector(v)) || - (vector_rank(v) > 1) || - (i < 0) || (i >= vector_length(v))) - return(g_vector_ref(sc, set_plist_2(sc, v, make_integer(sc, i)))); - return(vector_element(v, i)); -} - -static s7_pointer vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((i >= 0) && (i < vector_length(v))) - return(vector_getter(v)(sc, v, i)); - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(v); -} - -static s7_pointer normal_vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((i >= 0) && (i < vector_length(v))) - return(vector_element(v, i)); - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(v); -} - -static s7_pointer vector_ref_p_pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((!is_any_vector(v)) || - (vector_rank(v) != 2) || - (i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_ref(sc, set_plist_3(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2)))); - return(vector_getter(v)(sc, v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_pointer vector_ref_p_pii_direct(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_ref(sc, set_plist_3(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2)))); - return(vector_element(v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_pointer normal_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i) {return(vector_element(v, i));} - -static inline s7_pointer vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer ind) -{ - s7_int index; - if ((!is_normal_vector(vec)) || - (vector_rank(vec) != 1) || - (!s7_is_integer(ind))) - return(g_vector_ref(sc, set_plist_2(sc, vec, ind))); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index >= vector_length(vec))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); - return(vector_element(vec, index)); -} - -static s7_pointer g_vector_ref_2(s7_scheme *sc, s7_pointer args) {return(vector_ref_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_vector_ref_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer vec = car(args), i1, i2; - s7_int ix, iy; - - if (!is_any_vector(vec)) - return(g_vector_ref(sc, args)); - if (vector_rank(vec) != 2) - return(g_vector_ref(sc, args)); - - i1 = cadr(args); - if (!s7_is_integer(i1)) - return(g_vector_ref(sc, args)); - i2 = caddr(args); - if (!s7_is_integer(i2)) - return(g_vector_ref(sc, args)); - ix = s7_integer_clamped_if_gmp(sc, i1); - iy = s7_integer_clamped_if_gmp(sc, i2); - if ((ix >= 0) && (iy >= 0) && - (ix < vector_dimension(vec, 0)) && (iy < vector_dimension(vec, 1))) - { - s7_int index = (ix * vector_offset(vec, 0)) + iy; /* vector_offset(vec, 1) == 1 */ - return(vector_getter(vec)(sc, vec, index)); - } - return(g_vector_ref(sc, args)); -} - -static s7_pointer vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 2) - return(sc->vector_ref_2); - return((args == 3) ? sc->vector_ref_3 : f); -} - - -/* -------------------------------- vector-set! -------------------------------- */ -static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_set "(vector-set! v i ... value) sets the i-th element of vector v to value." - #define Q_vector_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol) - - s7_pointer vec = car(args), val; - s7_int index; - - if (!is_any_vector(vec)) - return(method_or_bust(sc, vec, sc->vector_set_symbol, args, sc->type_names[T_VECTOR], 1)); - if (is_immutable_vector(vec)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec)); - if (vector_length(vec) == 0) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_one, vec, it_is_too_large_string); - - if (vector_rank(vec) > 1) - { - s7_int i; - s7_pointer x; - index = 0; - for (x = cdr(args), i = 0; (is_not_null(cdr(x))) && (i < vector_ndims(vec)); x = cdr(x), i++) - { - s7_int n; - s7_pointer p = car(x); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, p); - if ((n < 0) || (n >= vector_dimension(vec, i))) - out_of_range_error_nr(sc, sc->vector_set_symbol, wrap_integer(sc, i + 2), p, (n < 0) ? it_is_negative_string : it_is_too_large_string); - - index += n * vector_offset(vec, i); - } - if (is_not_null(cdr(x))) - wrong_number_of_args_error_nr(sc, "too many arguments for vector-set!: ~S", args); - if (i != vector_ndims(vec)) - wrong_number_of_args_error_nr(sc, "not enough arguments for vector-set!: ~S", args); - - /* since vector-ref can return a subvector (if not passed enough args), it might be interesting to - * also set a complete subvector via set!, but would that introduce ambiguity? Only copy the vector - * if at least one index is missing, and the value fits. It also makes error detection harder, - * but so does the current vector-ref handling. Can't decide... - * (define v (make-vector '(2 3) 0)) (vector-set! v 0 #(1 2 3)) -> error, but (vector-ref v 0) -> #(0 0 0) - * Other possible additions: complex-vector and string-vector. - */ - val = car(x); - } - else - { - s7_pointer p = cadr(args); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); - index = s7_integer_clamped_if_gmp(sc, p); - if ((index < 0) || (index >= vector_length(vec))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); - - if (is_not_null(cdddr(args))) - { - s7_pointer v = vector_getter(vec)(sc, vec, index); - if (!is_any_vector(v)) - wrong_number_of_args_error_nr(sc, "too many arguments for vector-set!: ~S", args); - return(g_vector_set(sc, set_ulist_1(sc, v, cddr(args)))); - } - val = caddr(args); - } - if (is_typed_vector(vec)) - return(typed_vector_setter(sc, vec, index, val)); - if (is_normal_vector(vec)) - vector_element(vec, index) = val; - else vector_setter(vec)(sc, vec, index, val); - return(val); -} - -static s7_pointer vector_set_p_pip(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - if ((!is_any_vector(v)) || - (vector_rank(v) > 1) || - (i < 0) || (i >= vector_length(v))) - return(g_vector_set(sc, set_plist_3(sc, v, make_integer(sc, i), p))); - - if (is_typed_vector(v)) - return(typed_vector_setter(sc, v, i, p)); - if (is_normal_vector(v)) - vector_element(v, i) = p; - else vector_setter(v)(sc, v, i, p); - return(p); -} - -static s7_pointer vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - if ((i >= 0) && (i < vector_length(v))) - vector_element(v, i) = p; - else out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(p); -} - -static s7_pointer vector_set_p_piip(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_pointer p) -{ - if ((!is_any_vector(v)) || - (vector_rank(v) != 2) || - (i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_set(sc, set_elist_4(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2), p))); /* someday these should use plist_4 */ - - if (is_typed_vector(v)) - return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), p)); - - if (is_normal_vector(v)) - vector_element(v, i2 + (i1 * vector_offset(v, 0))) = p; - else vector_setter(v)(sc, v, i2 + (i1 * vector_offset(v, 0)), p); - return(p); -} - -static s7_pointer vector_set_p_piip_direct(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_pointer p) -{ - /* normal untyped vector, rank == 2 */ - if ((i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_set(sc, set_elist_4(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2), p))); - vector_element(v, i2 + (i1 * vector_offset(v, 0))) = p; - return(p); -} - -static s7_pointer typed_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - if ((i >= 0) && (i < vector_length(v))) - typed_vector_setter(sc, v, i, p); - else out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(p); -} - -static s7_pointer typed_vector_set_p_piip_direct(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_pointer p) -{ - if ((i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_set(sc, set_elist_4(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2), p))); - return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), p)); -} - -static s7_pointer normal_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i, s7_pointer p) {vector_element(v, i) = p; return(p);} - -static s7_pointer typed_normal_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - typed_vector_setter(sc, v, i, p); - return(p); -} - -static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args) -{ - /* (vector-set! vector index value) */ - s7_pointer ind, vec = car(args), val; - s7_int index; - - if (!is_any_vector(vec)) - return(g_vector_set(sc, args)); - if (is_immutable_vector(vec)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec)); - if (vector_rank(vec) > 1) - return(g_vector_set(sc, args)); - - ind = cadr(args); - if (!s7_is_integer(ind)) - return(g_vector_set(sc, args)); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index >= vector_length(vec))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); - - val = caddr(args); - if (is_typed_vector(vec)) - return(typed_vector_setter(sc, vec, index, val)); - if (is_normal_vector(vec)) - vector_element(vec, index) = val; - else vector_setter(vec)(sc, vec, index, val); - return(val); -} - -static s7_pointer vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val) -{ - s7_int index; - - if ((!is_normal_vector(vec)) || (vector_rank(vec) > 1)) - return(g_vector_set(sc, set_plist_3(sc, vec, ind, val))); - if (is_immutable_vector(vec)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec)); - if (!s7_is_integer(ind)) - return(g_vector_set(sc, set_plist_3(sc, vec, ind, val))); - index = s7_integer_clamped_if_gmp(sc, ind); - if ((index < 0) || (index >= vector_length(vec))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); - - if (is_typed_vector(vec)) - return(typed_vector_setter(sc, vec, index, val)); - vector_element(vec, index) = val; - return(val); -} - -static s7_pointer g_vector_set_4(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), ip1 = cadr(args), ip2 = caddr(args), val; - s7_int i1, i2; - if ((!is_any_vector(v)) || - (vector_rank(v) != 2) || - (is_immutable(v)) || - (!s7_is_integer(ip1)) || - (!s7_is_integer(ip2))) - return(g_vector_set(sc, args)); - i1 = s7_integer_clamped_if_gmp(sc, ip1); - i2 = s7_integer_clamped_if_gmp(sc, ip2); - if ((i1 < 0) || (i2 < 0) || - (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1))) - return(g_vector_set(sc, args)); - val = cadddr(args); - if (is_typed_vector(v)) - return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), val)); - if (is_normal_vector(v)) - vector_element(v, i2 + (i1 * vector_offset(v, 0))) = val; - else vector_setter(v)(sc, v, i2 + (i1 * vector_offset(v, 0)), val); - return(val); -} - -static s7_pointer vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 3) return(sc->vector_set_3); - return((args == 4) ? sc->vector_set_4 : f); -} - - -/* -------------------------------- make-vector -------------------------------- */ -static s7_int multivector_length(s7_scheme *sc, s7_pointer x, s7_pointer caller) -{ - s7_pointer y; - s7_int len, dims = s7_list_length(sc, x); - if (dims <= 0) /* 0 if circular, negative if dotted */ - wrong_type_error_nr(sc, caller, 1, x, a_proper_list_string); - if (dims > sc->max_vector_dimensions) - out_of_range_error_nr(sc, caller, int_one, x, it_is_too_large_string); - - for (y = x, len = 1; is_pair(y); y = cdr(y)) - { - if (!s7_is_integer(car(y))) - wrong_type_error_nr(sc, caller, position_of(y, x), car(y), sc->type_names[T_INTEGER]); -#if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(len, s7_integer_clamped_if_gmp(sc, car(y)), &len)) /* or better perhaps len > sc->max_vector_length */ - out_of_range_error_nr(sc, caller, wrap_integer(sc, position_of(y, x)), car(y), it_is_too_large_string); -#else - len *= s7_integer_clamped_if_gmp(sc, car(y)); -#endif - if (len < 0) - wrong_type_error_nr(sc, caller, position_of(y, x), car(y), a_non_negative_integer_string); - } - return(len); -} - -static void check_vector_typer_c_function(s7_scheme *sc, s7_pointer caller, s7_pointer typf) -{ - s7_pointer sig = c_function_signature(typf); - if ((sig != sc->pl_bt) && - (is_pair(sig)) && - ((car(sig) != sc->is_boolean_symbol) || (cadr(sig) != sc->T) || (!is_null(cddr(sig))))) - wrong_type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a boolean procedure", 19)); - if (!c_function_name(typf)) - wrong_type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a named function", 16)); - if (!c_function_marker(typf)) - c_function_set_marker(typf, mark_vector_1); - if (!c_function_symbol(typf)) - c_function_symbol(typf) = make_symbol(sc, c_function_name(typf), c_function_name_length(typf)); -} - -static inline s7_pointer make_multivector(s7_scheme *sc, s7_pointer vec, s7_pointer x) -{ - vdims_t *v = list_to_dims(sc, x); - vdims_original(v) = sc->F; - vector_set_dimension_info(vec, v); - add_multivector(sc, vec); - return(vec); -} - -static s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - s7_int len; - s7_pointer x = car(args), fill = sc->unspecified, vec, typf = sc->T; - int32_t result_type = T_VECTOR; - - if (s7_is_integer(x)) - { - len = s7_integer_clamped_if_gmp(sc, x); - if (len < 0) - wrong_type_error_nr(sc, caller, 1, x, a_non_negative_integer_string); - } - else - { - if (!(is_pair(x))) - return(method_or_bust(sc, x, caller, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); - - if (!s7_is_integer(car(x))) - wrong_type_error_nr(sc, caller, 1, car(x), sc->type_names[T_INTEGER]); - len = (is_null(cdr(x))) ? s7_integer_clamped_if_gmp(sc, car(x)) : multivector_length(sc, x, caller); - } - - if (is_pair(cdr(args))) - { - fill = cadr(args); - if (caller == sc->make_int_vector_symbol) - result_type = T_INT_VECTOR; - else - if (caller == sc->make_float_vector_symbol) - result_type = T_FLOAT_VECTOR; - else - if (caller == sc->make_byte_vector_symbol) - result_type = T_BYTE_VECTOR; - if (is_pair(cddr(args))) - { - typf = caddr(args); - if ((!is_c_function(typf)) && - (!is_any_closure(typf)) && - (typf != sc->T)) /* default value */ - wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a built-in procedure, a closure or #t", 37)); - if (is_any_closure(typf)) - { - if (!is_symbol(find_closure(sc, typf, closure_let(typf)))) - wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a named function", 16)); - /* the name is needed primarily by the error handler: "vector-set! third argument, ..., is a ... but should be a <...>" */ - } - else - if (is_c_function(typf)) - { - if (typf == global_value(sc->is_float_symbol)) - { - if (!is_real(fill)) wrong_type_error_nr(sc, caller, 3, fill, sc->type_names[T_REAL]); - result_type = T_FLOAT_VECTOR; - } - else - if (typf == global_value(sc->is_integer_symbol)) - { - if (!s7_is_integer(fill)) wrong_type_error_nr(sc, caller, 3, fill, sc->type_names[T_INTEGER]); - result_type = (WITH_GMP) ? T_VECTOR : T_INT_VECTOR; - } - else - if (typf == global_value(sc->is_byte_symbol)) - { - if (!is_byte(fill)) wrong_type_error_nr(sc, caller, 2, fill, an_unsigned_byte_string); - result_type = T_BYTE_VECTOR; - } - else check_vector_typer_c_function(sc, caller, typf); - }}} - /* before making the new vector, if fill is specified and the vector is typed, we have to check for a type error. - * otherwise we can end up with a vector whose elements are NULL, causing a segfault in the gc. - */ - if ((result_type == T_VECTOR) && - (typf != sc->T) && /* default value */ - (s7_apply_function(sc, typf, set_plist_1(sc, fill)) == sc->F)) - { - const char *tstr = make_type_name(sc, (is_c_function(typf)) ? c_function_name(typf) : symbol_name(find_closure(sc, typf, closure_let(typf))), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, sc->make_vector_symbol, 3, fill, wrap_string(sc, tstr, safe_strlen(tstr))); - } - - vec = make_vector_1(sc, len, NOT_FILLED, result_type); - if ((result_type == T_VECTOR) && - (typf != sc->T)) /* default value */ - { - set_typed_vector(vec); - typed_vector_set_typer(vec, typf); - - if ((is_c_function(typf)) && - (c_function_has_simple_elements(typf))) - set_has_simple_elements(vec); - } - s7_vector_fill(sc, vec, fill); - if ((is_pair(x)) && - (is_pair(cdr(x)))) - return(make_multivector(sc, vec, x)); - add_vector(sc, vec); - return(vec); -} - -static s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_make_vector "(make-vector len (value #) type) returns a vector of len elements initialized to value. \ -To create a multidimensional vector, put the dimension bounds in a list (this is to avoid ambiguities such as \ -(make-vector 1 2) where it's not clear whether the '2' is an initial value or a dimension size). (make-vector '(2 3) 1.0) \ -returns a 2 dimensional vector of 6 total elements, all initialized to 1.0." - #define Q_make_vector s7_make_signature(sc, 4, sc->is_vector_symbol, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T, \ - s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_boolean_symbol)) - return(g_make_vector_1(sc, args, sc->make_vector_symbol)); -} - - -/* -------------------------------- make-float-vector -------------------------------- */ -static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_make_float_vector "(make-float-vector len (init 0.0)) returns a float-vector." - #define Q_make_float_vector s7_make_signature(sc, 3, \ - sc->is_float_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_real_symbol) - s7_int len; - s7_pointer x, p = car(args); - block_t *arr; - - if ((is_pair(cdr(args))) || (!s7_is_integer(p))) - { - s7_pointer init; - if (is_pair(cdr(args))) - { - init = cadr(args); - if (!is_real(init)) - return(method_or_bust(sc, init, sc->make_float_vector_symbol, args, sc->type_names[T_REAL], 2)); -#if WITH_GMP - if (s7_is_bignum(init)) - return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real(sc, s7_real(init))), sc->make_float_vector_symbol)); -#endif - if (is_rational(init)) - return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real(sc, rational_to_double(sc, init))), sc->make_float_vector_symbol)); - } - else init = real_zero; - if (s7_is_integer(p)) - len = s7_integer_clamped_if_gmp(sc, p); - else - { - if (!is_pair(p)) - return(method_or_bust(sc, p, sc->make_float_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); - len = multivector_length(sc, p, sc->make_float_vector_symbol); - } - x = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR); - float_vector_fill(x, s7_real(init)); - if (!s7_is_integer(p)) - return(make_multivector(sc, x, p)); - add_vector(sc, x); - return(x); - } - - len = s7_integer_clamped_if_gmp(sc, p); - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_float_vector_symbol, int_one, p, (len < 0) ? it_is_negative_string : it_is_too_large_string); - - arr = mallocate_vector(sc, len * sizeof(s7_double)); - new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = arr; - float_vector_floats(x) = (s7_double *)block_data(arr); - if (len > 0) - { - if (STEP_8(len)) - memclr64((void *)float_vector_floats(x), len * sizeof(s7_double)); - else memclr((void *)float_vector_floats(x), len * sizeof(s7_double)); - } - vector_set_dimension_info(x, NULL); - vector_getter(x) = float_vector_getter; - vector_setter(x) = float_vector_setter; - - add_vector(sc, x); - return(x); -} - -static s7_pointer make_float_vector_p_pp(s7_scheme *sc, s7_pointer len, s7_pointer fill) -{ - if ((is_t_integer(len)) && (is_t_real(fill)) && - (integer(len)>= 0) && (integer(len) < sc->max_vector_length)) - { - s7_pointer fv = make_simple_float_vector(sc, integer(len)); - float_vector_fill(fv, real(fill)); - return(fv); - } - return(g_make_float_vector(sc, set_plist_2(sc, len, fill))); -} - - -/* -------------------------------- make-int-vector -------------------------------- */ -static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_make_int_vector "(make-int-vector len (init 0)) returns an int-vector." - #define Q_make_int_vector s7_make_signature(sc, 3, sc->is_int_vector_symbol, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_integer_symbol) - s7_int len; - s7_pointer x, p = car(args); - block_t *arr; - - if ((is_pair(cdr(args))) || - (!s7_is_integer(p))) - { - s7_pointer init; - if (is_pair(cdr(args))) - { - init = cadr(args); - if (!s7_is_integer(init)) - return(method_or_bust(sc, init, sc->make_int_vector_symbol, args, sc->type_names[T_INTEGER], 2)); - } - else init = int_zero; - if (s7_is_integer(p)) - len = s7_integer_clamped_if_gmp(sc, p); - else - { - if (!is_pair(p)) - return(method_or_bust(sc, p, sc->make_int_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); - len = multivector_length(sc, p, sc->make_int_vector_symbol); - } - x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); - int_vector_fill(x, s7_integer_clamped_if_gmp(sc, init)); - if (!s7_is_integer(p)) - return(make_multivector(sc, x, p)); - add_vector(sc, x); - return(x); - } - - len = s7_integer_clamped_if_gmp(sc, p); - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_int_vector_symbol, int_one, p, (len < 0) ? it_is_negative_string : it_is_too_large_string); - - arr = mallocate_vector(sc, len * sizeof(s7_int)); - new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE); - vector_length(x) = len; - vector_block(x) = arr; - int_vector_ints(x) = (s7_int *)block_data(arr); - if (len > 0) - { - if (STEP_8(len)) - memclr64((void *)int_vector_ints(x), len * sizeof(s7_int)); - else memclr((void *)int_vector_ints(x), len * sizeof(s7_int)); - } - vector_set_dimension_info(x, NULL); - vector_getter(x) = int_vector_getter; - vector_setter(x) = int_vector_setter; - - add_vector(sc, x); - return(x); -} - -static s7_pointer make_int_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) -{ - s7_pointer x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); - int_vector_fill(x, init); - add_vector(sc, x); - return(x); -} - - -/* -------------------------------- make-byte-vector -------------------------------- */ -static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_make_byte_vector "(make-byte-vector len (byte 0)) makes a byte-vector of length len filled with byte." - #define Q_make_byte_vector s7_make_signature(sc, 3, sc->is_byte_vector_symbol, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_byte_symbol) - s7_int len = 0, ib = 0; - s7_pointer p = car(args), init; - - if (!is_pair(p)) - { - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 1)); - len = s7_integer_clamped_if_gmp(sc, p); - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, p, (len < 0) ? it_is_negative_string : it_is_too_large_string); - } - if (is_pair(cdr(args))) - { - init = cadr(args); - if (!s7_is_integer(init)) - return(method_or_bust(sc, init, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 2)); - ib = s7_integer_clamped_if_gmp(sc, init); - if ((ib < 0) || (ib > 255)) - wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, init, an_unsigned_byte_string); - } - else init = int_zero; - - if (!s7_is_integer(p)) - return(g_make_vector_1(sc, set_plist_2(sc, p, init), sc->make_byte_vector_symbol)); - - p = make_simple_byte_vector(sc, len); - if ((len > 0) && (is_pair(cdr(args)))) - local_memset((void *)(byte_vector_bytes(p)), ib, len); - return(p); -} - -static s7_pointer make_byte_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) -{ - s7_pointer p; - if ((len < 0) || (len > sc->max_vector_length)) - out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, wrap_integer(sc, len), (len < 0) ? it_is_negative_string : it_is_too_large_string); - if ((init < 0) || (init > 255)) - wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, wrap_integer(sc, init), an_unsigned_byte_string); - p = make_simple_byte_vector(sc, len); - if (len > 0) - local_memset((void *)(byte_vector_bytes(p)), init, len); - return(p); -} - - -/* -------------------------------- vector? -------------------------------- */ -static s7_pointer g_is_vector(s7_scheme *sc, s7_pointer args) -{ - #define H_is_vector "(vector? obj) returns #t if obj is a vector" - #define Q_is_vector sc->pl_bt - check_boolean_method(sc, is_any_vector, sc->is_vector_symbol, args); -} - - -/* -------------------------------- vector-rank -------------------------------- */ -s7_int s7_vector_rank(s7_pointer vect) {return((s7_int)(vector_rank(vect)));} - -static s7_pointer g_vector_rank(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_rank "(vector-rank vect) returns the number of dimensions in vect" - #define Q_vector_rank s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol) - s7_pointer x = car(args); - if (!is_any_vector(x)) - return(sole_arg_method_or_bust(sc, x, sc->vector_rank_symbol, args, sc->type_names[T_VECTOR])); - return(make_integer(sc, vector_rank(x))); -} - - -/* -------------------------------- vector-dimension -------------------------------- */ -static s7_pointer g_vector_dimension(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_dimension "(vector-dimension vect n) returns the size of the n-th dimension (n is 0-based)" - #define Q_vector_dimension s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_vector_symbol, sc->is_integer_symbol) - s7_pointer v = car(args); - s7_pointer np = cadr(args); - s7_int n; - if (!is_any_vector(v)) - return(method_or_bust(sc, v, sc->vector_dimension_symbol, args, sc->type_names[T_VECTOR], 1)); - if (!s7_is_integer(np)) - return(method_or_bust(sc, v, sc->vector_dimension_symbol, args, sc->type_names[T_INTEGER], 2)); - n = s7_integer_clamped_if_gmp(sc, np); - if (n < 0) - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "vector-dimension second argument is negative: ~S", 48), np)); - if (n >= vector_rank(v)) - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "vector-dimension second argument, ~S, should be less than the vector rank, ~S", 77), - np, wrap_integer(sc, vector_rank(v)))); - if (vector_has_dimension_info(v)) - return(make_integer(sc, vector_dimension(v, n))); - return(make_integer(sc, vector_length(v))); -} - - -/* -------------------------------- vector-dimensions -------------------------------- */ -static s7_pointer g_vector_dimensions(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_dimensions "(vector-dimensions vect) returns a list of vect's dimensions" - #define Q_vector_dimensions s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_vector_symbol) - - s7_pointer x = car(args); - if (!is_any_vector(x)) - return(sole_arg_method_or_bust(sc, x, sc->vector_dimensions_symbol, args, sc->type_names[T_VECTOR])); - if (vector_rank(x) == 1) - return(list_1(sc, make_integer(sc, vector_length(x)))); - - sc->w = sc->nil; - for (s7_int i = vector_ndims(x) - 1; i >= 0; i--) - sc->w = cons(sc, make_integer(sc, vector_dimension(x, i)), sc->w); - x = sc->w; - sc->w = sc->unused; - return(x); -} - - -/* -------------------------------- vector-typer -------------------------------- */ -static s7_pointer g_vector_typer(s7_scheme *sc, s7_pointer args) -{ - #define H_vector_typer "(vector-typer vect) returns the vector's element type checking function" - #define Q_vector_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_vector_symbol) - - s7_pointer v = car(args); - if (!is_any_vector(v)) - return(sole_arg_method_or_bust(sc, v, sc->vector_typer_symbol, args, sc->type_names[T_VECTOR])); - - if (is_typed_vector(v)) return(typed_vector_typer(v)); - if (is_float_vector(v)) return(global_value(sc->is_float_symbol)); - if (is_int_vector(v)) return(global_value(sc->is_integer_symbol)); - if (is_byte_vector(v)) return(global_value(sc->is_byte_symbol)); - return(sc->F); -} - -static s7_pointer g_set_vector_typer(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), typer = cadr(args); - if (!is_any_vector(v)) - wrong_type_error_nr(sc, wrap_string(sc, "set! vector-typer", 17), 1, v, sc->type_names[T_VECTOR]); - if (!is_normal_vector(v)) - { - if (((is_int_vector(v)) && (typer != global_value(sc->is_integer_symbol))) || - ((is_float_vector(v)) && (typer != global_value(sc->is_float_symbol))) || - ((is_byte_vector(v)) && (typer != global_value(sc->is_byte_symbol)))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "vector-typer can't set ~S typer to ~S", 37), v, typer)); - return(typer); - } - if (is_boolean(typer)) - { - if (is_typed_vector(v)) - { - typed_vector_set_typer(v, sc->F); - clear_typed_vector(v); - }} - else - { - if (is_c_function(typer)) - check_vector_typer_c_function(sc, sc->vector_typer_symbol, typer); - else - { - if (!is_any_closure(typer)) - wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a built-in procedure, a closure, #f or #t", 41)); - if (!is_symbol(find_closure(sc, typer, closure_let(typer)))) - wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a named function", 16)); - /* the name is needed primarily by the error handler: "vector-set! second argument, ..., is a ... but should be a <...>" */ - } - set_typed_vector(v); - typed_vector_set_typer(v, typer); - if ((is_c_function(typer)) && - (c_function_has_simple_elements(typer))) - set_has_simple_elements(v); - } - return(typer); -} - - -/* -------------------------------- multivector -------------------------------- */ -#define MULTIVECTOR_TOO_MANY_ELEMENTS -1 -#define MULTIVECTOR_NOT_ENOUGH_ELEMENTS -2 - -static int32_t traverse_vector_data(s7_scheme *sc, s7_pointer vec, s7_int flat_ref, s7_int dimension, s7_int dimensions, s7_int *sizes, s7_pointer lst) -{ - /* we're filling vec, we're currently looking for element flat_ref, - * we're at ref in dimension of dimensions, where sizes gives the bounds, and lst is our data - * #3D(((1 2 3) (4 5 6)) ((7 8 9) (10 11 12))) - */ - s7_pointer x = lst; - for (s7_int i = 0; i < sizes[dimension]; i++, x = cdr(x)) - { - if (!is_pair(x)) - return(MULTIVECTOR_NOT_ENOUGH_ELEMENTS); - if (dimension == (dimensions - 1)) - vector_setter(vec)(sc, vec, flat_ref++, car(x)); - else - { - flat_ref = traverse_vector_data(sc, vec, flat_ref, dimension + 1, dimensions, sizes, car(x)); - if (flat_ref < 0) return(flat_ref); - }} - return((is_null(x)) ? flat_ref : MULTIVECTOR_TOO_MANY_ELEMENTS); -} - -static s7_pointer reverse_in_place_unchecked(s7_scheme *sc, s7_pointer term, s7_pointer list) -{ - s7_pointer p = list, result = term; - while (true) - { - s7_pointer q; - LOOP_4(if (is_null(p)) return(result); q = cdr(p); set_cdr(p, result); result = p; p = q); /* return, not break because LOOP_4 is itself a do loop */ - } - return(result); -} - -static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list) -{ - return(reverse_in_place_unchecked(sc, sc->nil, list)); -} - -static noreturn void multivector_error_nr(s7_scheme *sc, const char *message, s7_pointer data) -{ - error_nr(sc, sc->read_error_symbol, - set_elist_3(sc, wrap_string(sc, "reading constant vector, ~A: ~A", 31), - s7_make_string_wrapper(sc, message), data)); -} - -static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) -{ - /* get the dimension bounds from data, make the new vector, fill it from data - * dims needs to be s7_int so we can at least give correct error messages. - */ - s7_pointer vec, x = data; - s7_int err, vec_loc; - s7_int *sizes; - - /* (#2d((1 2 3) (4 5 6)) 0 0) -> 1 - * (#2d((1 2 3) (4 5 6)) 1 1) -> 5 - * (#3d(((1 2) (3 4)) ((5 6) (7 8))) 1 1 0) -> 7 - * #3d(((1 2) (3 4)) ((5 6) (7))) -> error, #3d(((1 2) (3 4)) ((5 6) (7 8 9))), #3d(((1 2) (3 4)) (5 (7 8 9))) etc - * but a special case: #nd() is an n-dimensional empty vector - */ - - if (dims <= 0) /* #0d(...) #2147483649D() [if dims is int32_t this is negative] */ - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "#nD(...) dimensions, ~A, should be 1 or more", 44), wrap_integer(sc, dims))); - - if (dims > sc->max_vector_dimensions) /* probably can't happen -- caught in read_sharp? */ - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "#nD(...) dimensions, ~A, should be less that (*s7* 'max-vector-dimensions): ~A", 78), - wrap_integer(sc, dims), wrap_integer(sc, sc->max_vector_dimensions))); - sc->w = sc->nil; - if (is_null(data)) /* dims are already 0 (calloc above) */ - return(g_make_vector(sc, set_plist_1(sc, make_list(sc, dims, int_zero)))); - - sizes = (s7_int *)Calloc(dims, sizeof(s7_int)); - for (s7_int i = 0; i < dims; i++) - { - sizes[i] = proper_list_length(x); - sc->w = cons(sc, make_integer(sc, sizes[i]), sc->w); - x = car(x); - if ((i < (dims - 1)) && - (!is_pair(x))) - { - free(sizes); - multivector_error_nr(sc, "we need a list that fully specifies the vector's elements", data); - }} - - vec = g_make_vector(sc, set_plist_1(sc, sc->w = proper_list_reverse_in_place(sc, sc->w))); - vec_loc = gc_protect_1(sc, vec); - sc->w = sc->unused; - - /* now fill the vector checking that all the lists match */ - err = traverse_vector_data(sc, vec, 0, 0, dims, sizes, data); - - free(sizes); - s7_gc_unprotect_at(sc, vec_loc); - if (err < 0) - multivector_error_nr(sc, (err == MULTIVECTOR_TOO_MANY_ELEMENTS) ? "found too many elements" : "not enough elements found", data); - return(vec); -} - -static s7_pointer g_int_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) -{ - /* dims > 1, sc->value is a pair (not null) */ - s7_pointer *src; - s7_int len; - sc->value = g_multivector(sc, dims, data); - src = (s7_pointer *)vector_elements(sc->value); - len = vector_length(sc->value); - for (s7_int i = 0; i < len; i++) - if (!is_t_integer(src[i])) - wrong_type_error_nr(sc, wrap_string(sc, "#i(...)", 7), i + 1, src[i], sc->type_names[T_INTEGER]); - sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), int_zero), sc->make_int_vector_symbol); - return(s7_copy_1(sc, sc->int_vector_symbol, set_plist_2(sc, sc->value, sc->args))); -} - -static s7_pointer g_byte_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) -{ - /* dims > 1, sc->value is a pair (not null) */ - s7_pointer *src; - s7_int len; - sc->value = g_multivector(sc, dims, data); - src = (s7_pointer *)vector_elements(sc->value); - len = vector_length(sc->value); - for (s7_int i = 0; i < len; i++) - if (!is_byte(src[i])) - wrong_type_error_nr(sc, wrap_string(sc, "#u(...)", 7), i + 1, src[i], wrap_string(sc, "a byte", 6)); - sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), int_zero), sc->make_byte_vector_symbol); - return(s7_copy_1(sc, sc->byte_vector_symbol, set_plist_2(sc, sc->value, sc->args))); -} - -static s7_pointer g_float_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) -{ - /* dims > 1, sc->value is a pair (not null) */ - s7_pointer *src; - s7_int len; - sc->value = g_multivector(sc, dims, data); - src = (s7_pointer *)vector_elements(sc->value); - len = vector_length(sc->value); - for (s7_int i = 0; i < len; i++) - if (!is_real(src[i])) - wrong_type_error_nr(sc, wrap_string(sc, "#r(...)", 7), i + 1, src[i], sc->type_names[T_REAL]); - sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), real_zero), sc->make_float_vector_symbol); - return(s7_copy_1(sc, sc->float_vector_symbol, set_plist_2(sc, sc->value, sc->args))); -} - -static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vect) -{ - s7_int len = vector_length(old_vect); - s7_pointer new_vect; - - if (is_normal_vector(old_vect)) - { - s7_pointer *src = (s7_pointer *)vector_elements(old_vect), *dst; - if ((is_typed_vector(old_vect)) && (len > 0)) /* preserve the type info as well */ - { - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), - vector_element(old_vect, 0), typed_vector_typer(old_vect))); - else new_vect = g_make_vector(sc, set_plist_3(sc, make_integer(sc, len), - vector_element(old_vect, 0), typed_vector_typer(old_vect))); - } - else - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)))); - else new_vect = make_simple_vector(sc, len); - /* here and in vector-fill! we have a problem with bignums -- should new bignums be allocated? (copy_proper_list also) */ - dst = (s7_pointer *)vector_elements(new_vect); - for (s7_int i = len; i > 0; i--) *dst++ = *src++; - return(new_vect); - } - - if (is_float_vector(old_vect)) - { - const s7_double *src = (s7_double *)float_vector_floats(old_vect); - s7_double *dst; - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), real_zero), sc->make_float_vector_symbol); - else new_vect = make_simple_float_vector(sc, len); - dst = (s7_double *)float_vector_floats(new_vect); - for (s7_int i = len; i > 0; i--) *dst++ = *src++; /* same speed as memcpy(dst, src, len * sizeof(s7_double)); */ - return(new_vect); - } - - if (is_int_vector(old_vect)) - { - const s7_int *src = (s7_int *)int_vector_ints(old_vect); - s7_int *dst; - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), int_zero), sc->make_int_vector_symbol); - else new_vect = make_simple_int_vector(sc, len); - dst = (s7_int *)int_vector_ints(new_vect); - for (s7_int i = len; i > 0; i--) *dst++ = *src++; - return(new_vect); - } - - if (is_byte_vector(old_vect)) - { - const uint8_t *src = (const uint8_t *)byte_vector_bytes(old_vect); - uint8_t *dst; - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), int_zero), sc->make_byte_vector_symbol); - else new_vect = make_simple_byte_vector(sc, len); - dst = (uint8_t *)byte_vector_bytes(new_vect); - for (s7_int i = len; i > 0; i--) *dst++ = *src++; - return(new_vect); - } - return(NULL); -} - -s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect) {return(s7_vector_copy_1(sc, old_vect));} /* repeated for Vectorized */ - -static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ) -{ - s7_pointer v = car(args), index; - s7_int ind; - - if (type(v) != typ) - return(method_or_bust(sc, v, caller, args, sc->type_names[typ], 1)); - - if (vector_rank(v) == 1) - { - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - sole_arg_out_of_range_error_nr(sc, caller, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - if (!is_null(cddr(args))) - out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string); - } - else - { - s7_int i; - s7_pointer x; - ind = 0; - for (x = cdr(args), i = 0; (is_not_null(x)) && (i < vector_ndims(v)); x = cdr(x), i++) - { - s7_int n; - index = car(x); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, index); - if ((n < 0) || (n >= vector_dimension(v, i))) - out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); - ind += n * vector_offset(v, i); - } - if (is_not_null(x)) - out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string); - - /* if not enough indices, return a subvector covering whatever is left */ - if (i < vector_ndims(v)) - return(subvector(sc, v, i, ind)); - } - if (typ == T_FLOAT_VECTOR) - return(make_real(sc, float_vector(v, ind))); - return((typ == T_INT_VECTOR) ? make_integer(sc, int_vector(v, ind)) : small_int(byte_vector(v, ind))); -} - -static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ) -{ - s7_pointer vec = car(args), val, index; - s7_int ind; - - if (type(vec) != typ) - return(method_or_bust(sc, vec, caller, args, sc->type_names[typ], 1)); - if (is_immutable_vector(vec)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, vec)); - - if (vector_rank(vec) > 1) - { - s7_int i; - s7_pointer x; - ind = 0; - for (x = cdr(args), i = 0; (is_not_null(cdr(x))) && (i < vector_ndims(vec)); x = cdr(x), i++) - { - s7_int n; - index = car(x); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, index); - if ((n < 0) || (n >= vector_dimension(vec, i))) - out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); - ind += n * vector_offset(vec, i); - } - if (is_not_null(cdr(x))) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); - if (i != vector_ndims(vec)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); - val = car(x); - } - else - { - s7_pointer p = cdr(args); - if (is_null(p)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); - /* from (set! (v) val) after optimization into op_set_opsq_a which is completely confused -- set! gets v's setter (float-vector-set!) */ - index = car(p); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(vec))) - out_of_range_error_nr(sc, caller, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - if (is_not_null(cddr(p))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); - val = cadr(p); - } - - if (typ == T_FLOAT_VECTOR) - { - if (!is_real(val)) - return(method_or_bust(sc, val, caller, args, sc->type_names[T_REAL], 3)); - float_vector(vec, ind) = s7_real(val); - } - else - if (typ == T_INT_VECTOR) - { - if (!s7_is_integer(val)) - return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3)); - int_vector(vec, ind) = s7_integer_clamped_if_gmp(sc, val); - } - else - { - if (!is_byte(val)) - return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3)); - byte_vector(vec, ind) = (uint8_t)s7_integer_clamped_if_gmp(sc, val); - } - return(val); -} - - -/* -------------------------------- float-vector-ref -------------------------------- */ -static s7_pointer g_float_vector_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_float_vector_ref "(float-vector-ref v ...) returns an element of the float-vector v." - #define Q_float_vector_ref s7_make_circular_signature(sc, 2, 3, \ - s7_make_signature(sc, 2, sc->is_float_symbol, sc->is_float_vector_symbol), \ - sc->is_float_vector_symbol, sc->is_integer_symbol) - return(univect_ref(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); -} - -static inline s7_pointer float_vector_ref_p_pp(s7_scheme *sc, s7_pointer v, s7_pointer index) -{ - s7_int ind; - if (!is_float_vector(v)) - return(method_or_bust_pp(sc, v, sc->float_vector_ref_symbol, v, index, sc->type_names[T_FLOAT_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_ref(sc, set_plist_2(sc, v, index), sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); - if (!s7_is_integer(index)) - return(method_or_bust_pp(sc, index, sc->float_vector_ref_symbol, v, index, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - return(make_real(sc, float_vector(v, ind))); -} - -static s7_pointer g_fv_ref_2(s7_scheme *sc, s7_pointer args) {return(float_vector_ref_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_fv_ref_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer fv = car(args), index; - s7_int ind1, ind2; - if (!is_float_vector(fv)) - return(method_or_bust(sc, fv, sc->float_vector_ref_symbol, args, sc->type_names[T_FLOAT_VECTOR], 1)); - if (vector_rank(fv) != 2) - return(univect_ref(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->float_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2)); - ind1 = s7_integer_clamped_if_gmp(sc, index); - if ((ind1 < 0) || (ind1 >= vector_dimension(fv, 0))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string); - index = caddr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->float_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3)); - ind2 = s7_integer_clamped_if_gmp(sc, index); - if ((ind2 < 0) || (ind2 >= vector_dimension(fv, 1))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string); - ind1 = ind1 * vector_offset(fv, 0) + ind2; - return(make_real(sc, float_vector(fv, ind1))); -} - -static inline s7_int ref_check_index(s7_scheme *sc, s7_pointer v, s7_int i) -{ - /* according to callgrind, it is faster to split out the bounds check */ - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(i); -} - -static inline s7_double float_vector_ref_d_7pi(s7_scheme *sc, s7_pointer v, s7_int i) {return(float_vector(v, ref_check_index(sc, v, i)));} -static s7_pointer float_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer v, s7_int i) {return(make_real(sc, float_vector(v, i)));} - -static inline s7_double float_vector_ref_d_7pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - return(float_vector(v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_double float_vector_ref_d_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i3 < 0) || (i3 >= vector_dimension(v, 2))) - out_of_range_error_nr(sc, sc->float_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string); - return(float_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0)))); -} - -static s7_pointer float_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : f)); -} - - -/* -------------------------------- float-vector-set! -------------------------------- */ -static s7_pointer g_float_vector_set(s7_scheme *sc, s7_pointer args) -{ - #define H_float_vector_set "(float-vector-set! v i ... value) sets the i-th element of the float-vector v to value." - #define Q_float_vector_set s7_make_circular_signature(sc, 3, 4, \ - sc->is_real_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_real_at_end_symbol) - return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); -} - -static s7_pointer g_fv_set_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer fv = car(args), index, value; - s7_int ind; - if (!is_float_vector(fv)) - return(method_or_bust(sc, fv, sc->float_vector_set_symbol, args, sc->type_names[T_FLOAT_VECTOR], 1)); - if (vector_rank(fv) != 1) - return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); - if (is_immutable_vector(fv)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->float_vector_set_symbol, fv)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->float_vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(fv))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - value = caddr(args); - if (!is_real(value)) - return(method_or_bust(sc, value, sc->float_vector_set_symbol, args, sc->type_names[T_REAL], 3)); - float_vector(fv, ind) = s7_real(value); - return(value); -} - -static s7_pointer g_fv_set_unchecked(s7_scheme *sc, s7_pointer args) -{ - s7_pointer fv, value = caddr(args); - s7_int ind; - if (!is_real(value)) - wrong_type_error_nr(sc, sc->float_vector_set_symbol, 3, value, sc->type_names[T_REAL]); - fv = car(args); - if (is_immutable_vector(fv)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->float_vector_set_symbol, fv)); - ind = s7_integer_clamped_if_gmp(sc, cadr(args)); - float_vector(fv, ind) = s7_real(value); - return(value); -} - -static bool find_matching_ref(s7_scheme *sc, s7_pointer getter, s7_pointer expr) -{ - /* expr: (*set! v i val), val exists (i.e. args=3, so cddddr is null) */ - s7_pointer v = cadr(expr), ind = caddr(expr); - if ((is_symbol(v)) && (!is_pair(ind))) - { - s7_pointer val = cadddr(expr); - if (is_optimized(val)) /* includes is_pair */ - for (s7_pointer p = val; is_pair(p); p = cdr(p)) - if (is_pair(car(p))) - { - s7_pointer ref = car(p); - if (((car(ref) == getter) && /* (getter v ind) */ - (is_proper_list_2(sc, cdr(ref))) && - (cadr(ref) == v) && - (caddr(ref) == ind)) || - ((car(ref) == v) && /* (v ind) */ - (is_proper_list_1(sc, cdr(ref))) && - (cadr(ref) == ind))) - return(true); - }} - return(false); -} - -static s7_pointer float_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if (args == 3) - return((find_matching_ref(sc, sc->float_vector_ref_symbol, expr)) ? sc->fv_set_unchecked : sc->fv_set_3); - return(f); -} - -static s7_double float_vector_set_d_7pid_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i, s7_double x) {float_vector(v, i) = x; return(x);} - -static s7_int set_check_index(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(i); -} - -static s7_double float_vector_set_d_7pid(s7_scheme *sc, s7_pointer v, s7_int i, s7_double x) {float_vector(v, (set_check_index(sc, v, i))) = x; return(x);} - -static s7_double float_vector_set_d_7piid(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_double x) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - float_vector(v, i2 + (i1 * vector_offset(v, 0))) = x; - return(x); -} - -static s7_double float_vector_set_d_7piiid(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3, s7_double x) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i3 < 0) || (i3 >= vector_dimension(v, 2))) - out_of_range_error_nr(sc, sc->float_vector_set_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string); - float_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0))) = x; - return(x); -} - -static s7_pointer float_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - float_vector(v, i) = real_to_double(sc, p, "float-vector-set!"); - return(p); -} - - -/* -------------------------------- int-vector-ref -------------------------------- */ -static s7_pointer g_int_vector_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_int_vector_ref "(int-vector-ref v ...) returns an element of the int-vector v." - #define Q_int_vector_ref s7_make_circular_signature(sc, 2, 3, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_int_vector_symbol), \ - sc->is_int_vector_symbol, sc->is_integer_symbol) - return(univect_ref(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR)); -} - -static s7_int int_vector_ref_i_7pi_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i) {return(int_vector(v, i));} -static s7_pointer int_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer v, s7_int i) {return(make_integer(sc, int_vector(v, i)));} - -static s7_int int_vector_ref_i_7pi(s7_scheme *sc, s7_pointer v, s7_int i) -{ - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - return(int_vector(v, i)); -} - -static s7_int int_vector_ref_i_7pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - return(int_vector(v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_int int_vector_ref_i_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i3 < 0) || (i3 >= vector_dimension(v, 2))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string); - return(int_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0)))); -} - -static inline s7_pointer int_vector_ref_p_pp(s7_scheme *sc, s7_pointer v, s7_pointer index) -{ - s7_int ind; - if (!is_int_vector(v)) - return(method_or_bust_pp(sc, v, sc->int_vector_ref_symbol, v, index, sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_ref(sc, set_plist_2(sc, v, index), sc->int_vector_ref_symbol, T_INT_VECTOR)); - if (!s7_is_integer(index)) - return(method_or_bust_pp(sc, index, sc->int_vector_ref_symbol, v, index, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - return(make_integer(sc, int_vector(v, ind))); -} - -static s7_pointer g_iv_ref_2(s7_scheme *sc, s7_pointer args) {return(int_vector_ref_p_pp(sc, car(args), cadr(args)));} - -static s7_pointer g_iv_ref_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer iv = car(args), index; - s7_int ind1, ind2; - if (!is_int_vector(iv)) - return(method_or_bust(sc, iv, sc->int_vector_ref_symbol, args, sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank(iv) != 2) - return(univect_ref(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->int_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2)); - ind1 = s7_integer_clamped_if_gmp(sc, index); - if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string); - index = caddr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->int_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3)); - ind2 = s7_integer_clamped_if_gmp(sc, index); - if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1))) - out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string); - ind1 = ind1 * vector_offset(iv, 0) + ind2; - return(make_integer(sc, int_vector(iv, ind1))); -} - -static s7_pointer int_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : f)); -} - - -/* -------------------------------- int-vector-set! -------------------------------- */ -static s7_pointer g_int_vector_set(s7_scheme *sc, s7_pointer args) -{ - #define H_int_vector_set "(int-vector-set! v i ... value) sets the i-th element of the int-vector v to value." - #define Q_int_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol) - return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); -} - -static s7_int int_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i, s7_int x) {int_vector(v, i) = x; return(x);} - -static s7_pointer int_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) -{ - int_vector(v, i) = s7_integer_clamped_if_gmp(sc, p); - return(p); -} - -static s7_int int_vector_set_i_7pii(s7_scheme *sc, s7_pointer v, s7_int i, s7_int x) -{ - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector(v, i) = x; - return(x); -} - -static s7_int int_vector_set_i_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3; - return(i3); -} - -static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer v, s7_pointer index, s7_pointer val) -{ - if ((is_int_vector(v)) && (vector_rank(v) == 1) && (!is_immutable_vector(v)) && - (is_t_integer(index)) && (is_t_integer(val))) - { - s7_int i = integer(index); - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector(v, i) = integer(val); - } - else - { - if (!is_int_vector(v)) - return(method_or_bust_ppp(sc, v, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_set(sc, set_plist_3(sc, v, index, val), sc->int_vector_set_symbol, T_INT_VECTOR)); - if (is_immutable_vector(v)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, v)); - if (!s7_is_integer(index)) - return(method_or_bust_ppp(sc, index, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INTEGER], 2)); - if (!s7_is_integer(val)) - return(method_or_bust_ppp(sc, val, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INTEGER], 3)); -#if WITH_GMP - { - s7_int i = s7_integer_clamped_if_gmp(sc, index); - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector(v, i) = s7_integer_clamped_if_gmp(sc, val); - } -#else - if (S7_DEBUGGING) fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__); -#endif - } - return(val); -} - -static s7_pointer g_iv_set_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), index, value; - s7_int ind; - if (!is_int_vector(v)) - return(method_or_bust(sc, v, sc->int_vector_set_symbol, args, sc->type_names[T_INT_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); - if (is_immutable_vector(v)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, v)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - value = caddr(args); - if (!s7_is_integer(value)) - return(method_or_bust(sc, value, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 3)); - int_vector(v, ind) = s7_integer_clamped_if_gmp(sc, value); - return(value); -} - -static s7_pointer int_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 3) ? sc->iv_set_3 : f); -} - - -/* -------------------------------- byte-vector-ref -------------------------------- */ -static s7_pointer g_byte_vector_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_byte_vector_ref "(byte-vector-ref vect index) returns the byte at the index-th element of the byte-vector vect" - #define Q_byte_vector_ref s7_make_circular_signature(sc, 2, 3, \ - s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_byte_vector_symbol), \ - sc->is_byte_vector_symbol, sc->is_integer_symbol) - return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); -} - -static s7_int byte_vector_ref_i_7pi(s7_scheme *sc, s7_pointer p1, s7_int i1) -{ - if ((i1 < 0) || (i1 >= byte_vector_length(p1))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - return((s7_int)((byte_vector(p1, i1)))); -} - -static s7_int byte_vector_ref_i_7pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2) -{ - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - return((s7_int)byte_vector(v, i2 + (i1 * vector_offset(v, 0)))); -} - -static s7_pointer byte_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1) {return(small_int((byte_vector(p1, i1))));} -static s7_int byte_vector_ref_i_7pi_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1) {return(byte_vector(p1, i1));} - -static s7_pointer g_bv_ref_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), index; - s7_int ind; - if (!is_byte_vector(v)) - return(method_or_bust(sc, v, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - return(small_int(byte_vector(v, ind))); -} - -static s7_pointer g_bv_ref_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer iv = car(args), index; - s7_int ind1, ind2; - if (!is_byte_vector(iv)) - return(method_or_bust(sc, iv, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); - if (vector_rank(iv) != 2) - return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2)); - ind1 = s7_integer_clamped_if_gmp(sc, index); - if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string); - index = caddr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3)); - ind2 = s7_integer_clamped_if_gmp(sc, index); - if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1))) - out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string); - ind1 = ind1 * vector_offset(iv, 0) + ind2; - return(small_int(byte_vector(iv, ind1))); -} - -static s7_pointer byte_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : f)); -} - - -/* -------------------------------- byte-vector-set -------------------------------- */ -static s7_pointer g_byte_vector_set(s7_scheme *sc, s7_pointer args) -{ - #define H_byte_vector_set "(byte-vector-set! vect index byte) sets the index-th element of the byte-vector vect to the integer byte" - #define Q_byte_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol) - return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); -} - -static s7_int byte_vector_set_i_7pii(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2) -{ - if (!is_byte_vector(p1)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 1, p1, a_byte_vector_string); - if ((i2 < 0) || (i2 > 255)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, wrap_integer(sc, i2), an_unsigned_byte_string); - if ((i1 < 0) || (i1 >= byte_vector_length(p1))) - out_of_range_error_nr(sc, sc->byte_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - byte_vector(p1, i1) = (uint8_t)i2; - return(i2); -} - -static s7_int byte_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1, s7_int i2) -{ - byte_vector(p1, i1) = (uint8_t)i2; return(i2); -} - -static s7_pointer byte_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1, s7_pointer p2) -{ - byte_vector(p1, i1) = (uint8_t)s7_integer(p2); return(p2); -} - -static s7_int byte_vector_set_i_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3) -{ - if ((i3 < 0) || (i3 > 255)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 4, wrap_integer(sc, i3), an_unsigned_byte_string); - if ((i1 < 0) || (i1 >= vector_dimension(v, 0))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string); - if ((i2 < 0) || (i2 >= vector_dimension(v, 1))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string); - byte_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3; - return(i3); -} - -static s7_pointer g_bv_set_3(s7_scheme *sc, s7_pointer args) -{ - s7_pointer v = car(args), index, value; - s7_int ind, uval; - if (!is_byte_vector(v)) - return(method_or_bust(sc, v, sc->byte_vector_set_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); - if (vector_rank(v) != 1) - return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); - if (is_immutable_vector(v)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->byte_vector_set_symbol, v)); - index = cadr(args); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(v))) - out_of_range_error_nr(sc, sc->byte_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - value = caddr(args); - if (!s7_is_integer(value)) - return(method_or_bust(sc, value, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 3)); - uval = s7_integer_clamped_if_gmp(sc, value); - if ((uval < 0) || (uval > 255)) - wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, value, an_unsigned_byte_string); - byte_vector(v, ind) = (uint8_t)uval; - return(value); -} - -static s7_pointer byte_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 3) ? sc->bv_set_3 : f); -} - - -/* -------------------------------------------------------------------------------- */ -static bool c_function_is_ok(s7_scheme *sc, s7_pointer x) -{ - s7_pointer p = lookup_unexamined(sc, car(x)); /* lookup_global is usually slower (faster in Snd) */ - if ((p == opt1_cfunc(x)) || - ((p) && (is_any_c_function(p)) && (c_function_class(p) == c_function_class(opt1_cfunc(x))) && (set_opt1_cfunc(x, p)))) - return(true); - sc->last_function = p; - return(false); -} - -static bool cl_function_is_ok(s7_scheme *sc, s7_pointer x) -{ - sc->last_function = lookup_unexamined(sc, car(x)); - return(sc->last_function == opt1_cfunc(x)); -} - -static bool arglist_has_rest(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p; - for (p = args; is_pair(p); p = cdr(p)) - if (car(p) == sc->rest_keyword) - return(true); - return(!is_null(p)); -} - - -/* -------------------------------- sort! -------------------------------- */ -static bool bool_optimize(s7_scheme *sc, s7_pointer expr); -static bool bool_optimize_nw(s7_scheme *sc, s7_pointer expr); -static bool cell_optimize(s7_scheme *sc, s7_pointer expr); -static void pc_fallback(s7_scheme *sc, int32_t new_pc) {sc->pc = new_pc;} - -static int32_t dbl_less(const void *f1, const void *f2) -{ - if ((*((s7_double *)f1)) < (*((s7_double *)f2))) return(-1); - return(((*((s7_double *)f1)) > (*((s7_double *)f2))) ? 1 : 0); -} - -static int32_t int_less(const void *f1, const void *f2) -{ - if ((*((s7_int *)f1)) < (*((s7_int *)f2))) return(-1); - return(((*((s7_int *)f1)) > (*((s7_int *)f2))) ? 1 : 0); -} - -static int32_t dbl_greater(const void *f1, const void *f2) {return(-dbl_less(f1, f2));} -static int32_t int_greater(const void *f1, const void *f2) {return(-int_less(f1, f2));} - -static int32_t byte_less(const void *f1, const void *f2) -{ - if ((*((const uint8_t *)f1)) < (*((const uint8_t *)f2))) return(-1); - return(((*((const uint8_t *)f1)) > (*((const uint8_t *)f2))) ? 1 : 0); -} - -static int32_t byte_greater(const void *f1, const void *f2) {return(-byte_less(f1, f2));} - -static int32_t dbl_less_2(const void *f1, const void *f2) -{ - s7_double p1 = real(*((s7_pointer *)f1)); - s7_double p2 = real(*((s7_pointer *)f2)); - if (p1 < p2) return(-1); - return((p1 > p2) ? 1 : 0); -} - -static int32_t int_less_2(const void *f1, const void *f2) -{ - s7_int p1 = integer(*((s7_pointer *)f1)); - s7_int p2 = integer(*((s7_pointer *)f2)); - if (p1 < p2) return(-1); - return((p1 > p2) ? 1 : 0); -} - -static int32_t dbl_greater_2(const void *f1, const void *f2) {return(-dbl_less_2(f1, f2));} -static int32_t int_greater_2(const void *f1, const void *f2) {return(-int_less_2(f1, f2));} - -static int32_t str_less_2(const void *f1, const void *f2) -{ - s7_pointer p1 = (*((s7_pointer *)f1)); - s7_pointer p2 = (*((s7_pointer *)f2)); - return(scheme_strcmp(p1, p2)); -} - -static int32_t str_greater_2(const void *f1, const void *f2) {return(-str_less_2(f1, f2));} - -static int32_t chr_less_2(const void *f1, const void *f2) -{ - uint8_t p1 = character(*((s7_pointer *)f1)); - uint8_t p2 = character(*((s7_pointer *)f2)); - if (p1 < p2) return(-1); - return((p1 > p2) ? 1 : 0); -} - -static int32_t chr_greater_2(const void *f1, const void *f2) {return(-chr_less_2(f1, f2));} - -#if MS_WINDOWS || defined(__APPLE__) || defined(__FreeBSD__) -struct sort_r_data {void *arg; int32_t (*compar)(const void *a1, const void *a2, void *aarg);}; - -static int32_t sort_r_arg_swap(void *s, const void *aa, const void *bb) -{ - struct sort_r_data *ss = (struct sort_r_data*)s; - return (ss->compar)(aa, bb, ss->arg); -} -#endif - -/* qsort_r in Linux requires _GNU_SOURCE and is different from q_sort_r in FreeBSD, neither matches qsort_s in Windows - * this code tested only in Linux and the mac -- my virtualbox freebsd died, netbsd and openbsd run using fallback code. - */ -static void local_qsort_r(void *base, size_t nmemb, size_t size, int32_t (*compar)(const void *, const void *, void *), void *arg) -{ -#if (defined(__linux__)) && (defined(__GLIBC__)) /* __GLIBC__ because musl does not have qsort_r and has no way to detect it */ - qsort_r(base, nmemb, size, compar, arg); -#else -#if defined(__APPLE__) || defined(__FreeBSD__) /* not in OpenBSD or NetBSD as far as I can tell */ - struct sort_r_data tmp = {arg, compar}; - qsort_r(base, nmemb, size, &tmp, &sort_r_arg_swap); -#else -#if MS_WINDOWS - struct sort_r_data tmp = {arg, compar}; - qsort_s(base, nmemb, size, sort_r_arg_swap, &tmp); -#else - /* from the Net somewhere, by "Pete", about 25 times slower than libc's qsort_r in this context */ - if (nmemb > 1) - { - uint8_t *array = (uint8_t *)base; - uint8_t *after = (uint8_t *)(nmemb * size + array); - size_t h, t; - nmemb /= 4; - h = nmemb + 1; - for (t = 1; nmemb != 0; nmemb /= 4) - t *= 2; - do { - size_t bytes = h * size; - uint8_t *i = (uint8_t *)(array + bytes); - uint8_t *k; - do { - uint8_t *j = (uint8_t *)(i - bytes); - if (compar(j, i, arg) > 0) - { - k = i; - do { - uint8_t *p1 = j, *p2 = k; - uint8_t *end = (uint8_t *)(p2 + size); - do { - uint8_t swap = *p1; - *p1++ = *p2; - *p2++ = swap; - } while (p2 != end); - if (bytes + array > j) - break; - k = j; - j -= bytes; - } while (compar(j, k, arg) > 0); - } - i += size; - } while (i != after); - t /= 2; - h = t * t - t * 3 / 2 + 1; - } while (t != 0); - } -#endif -#endif -#endif -} - -static int32_t vector_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - return(((*(sc->sort_f))(sc, (*(s7_pointer *)v1), (*(s7_pointer *)v2))) ? -1 : 1); -} - -static int32_t vector_sort_lt(const void *v1, const void *v2, void *arg) /* for qsort_r */ -{ - s7_pointer s1 = (*(s7_pointer *)v1); - s7_pointer s2 = (*(s7_pointer *)v2); - if ((is_t_integer(s1)) && (is_t_integer(s2))) - return((integer(s1) < integer(s2)) ? -1 : 1); - return((lt_b_7pp((s7_scheme *)arg, s1, s2)) ? -1 : 1); -} - -static int32_t vector_car_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - s7_pointer a = (*(s7_pointer *)v1); - s7_pointer b = (*(s7_pointer *)v2); - a = (is_pair(a)) ? car(a) : g_car(sc, set_plist_1(sc, a)); - b = (is_pair(b)) ? car(b) : g_car(sc, set_plist_1(sc, b)); - return(((*(sc->sort_f))(sc, a, b)) ? -1 : 1); -} - -static int32_t vector_cdr_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - s7_pointer a = (*(s7_pointer *)v1); - s7_pointer b = (*(s7_pointer *)v2); - a = (is_pair(a)) ? cdr(a) : g_cdr(sc, set_plist_1(sc, a)); - b = (is_pair(b)) ? cdr(b) : g_cdr(sc, set_plist_1(sc, b)); - return(((*(sc->sort_f))(sc, a, b)) ? -1 : 1); -} - -static int32_t opt_bool_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); /* first slot in curlet */ - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); /* second slot in curlet */ - return((sc->sort_fb(sc->sort_o)) ? -1 : 1); -} - -static int32_t opt_bool_sort_0(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); /* first slot in curlet */ - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); /* second slot in curlet */ - return((sc->sort_fb(sc->sort_o)) ? -1 : 1); -} - -static int32_t opt_bool_sort_p(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - return((sc->opts[0]->v[O_WRAP].fp(sc->opts[0]) == sc->F) ? 1 : -1); -} - -#define SORT_O1 1 -static inline int32_t begin_bool_sort_bp(s7_scheme *sc, const void *v1, const void *v2, bool int_expr) -{ - s7_int i; - opt_info *top = sc->opts[0], *o; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - for (i = 0; i < sc->sort_body_len - 1; i++) - { - o = top->v[SORT_O1 + i].o1; - o->v[0].fp(o); - } - o = top->v[SORT_O1 + i].o1; - if (int_expr) - return((o->v[0].fb(o)) ? -1 : 1); - return((o->v[0].fp(o) != sc->F) ? -1 : 1); -} - -static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2, void *arg) {return(begin_bool_sort_bp((s7_scheme *)arg, v1, v2, true));} -static int32_t opt_begin_bool_sort_p(const void *v1, const void *v2, void *arg) {return(begin_bool_sort_bp((s7_scheme *)arg, v1, v2, false));} - -static int32_t opt_begin_bool_sort_b2(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - opt_info *top = sc->opts[0], *o; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - o = top->v[SORT_O1].o1; - o->v[0].fp(o); - o = top->v[SORT_O1 + 1].o1; - return((o->v[0].fb(o)) ? -1 : 1); -} - -static int32_t closure_sort(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code); - sc->code = sc->sort_body; /* this should be ok because we checked in advance that it is a safe closure (no sort! for example) */ - eval(sc, sc->sort_op); - return((sc->value != sc->F) ? -1 : 1); -} - -static int32_t closure_sort_begin(const void *v1, const void *v2, void *arg) -{ - s7_scheme *sc = (s7_scheme *)arg; - slot_set_value(sc->sort_v1, (*(s7_pointer *)v1)); - slot_set_value(sc->sort_v2, (*(s7_pointer *)v2)); - push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code); - push_stack_no_args(sc, OP_BEGIN_NO_HOOK, T_Pair(sc->sort_begin)); - sc->code = sc->sort_body; - eval(sc, sc->sort_op); - return((sc->value != sc->F) ? -1 : 1); -} - -static s7_b_7pp_t s7_b_7pp_function(s7_pointer f); -static opt_info *alloc_opt_info(s7_scheme *sc); - -static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) -{ - #define H_sort "(sort! sequence less?) sorts a sequence using the function 'less?' to compare elements." - #define Q_sort s7_make_signature(sc, 3, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_procedure_symbol) - - s7_pointer data = car(args), lessp, lx; - s7_int len = 0, n, k; - int32_t (*sort_func)(const void *v1, const void *v2, void *arg); - s7_pointer *elements; - - /* both the intermediate vector (if any) and the current args pointer need GC protection, - * but it is a real bother to unprotect args at every return statement, so I'll use temp3 - */ - sc->temp3 = args; /* this is needed but maybe insufficient... if sort is semisafe, we should protect the args, not the list: use OP_GC_PROTECT? */ - if (is_null(data)) - { - /* (apply sort! () #f) should be an error I think */ - lessp = cadr(args); - if (type(lessp) < T_CONTINUATION) - return(method_or_bust(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2)); - if (!s7_is_aritable(sc, lessp, 2)) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string); - return(sc->nil); - } - - if (!is_sequence(data)) /* precede immutable because #f (for example) is immutable: "can't sort #f because it is immutable" is a joke */ - wrong_type_error_nr(sc, sc->sort_symbol, 1, data, a_sequence_string); - if (is_immutable(data)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, data)); - - lessp = cadr(args); - if (type(lessp) <= T_GOTO) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, a_normal_procedure_string); - if (!s7_is_aritable(sc, lessp, 2)) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string); - if ((is_any_macro(lessp)) && (!is_c_macro(lessp))) clear_all_optimizations(sc, closure_body(lessp)); - - sort_func = NULL; - sc->sort_f = NULL; - - if (is_safe_c_function(lessp)) /* (sort! a <) */ - { - s7_pointer sig = c_function_signature(lessp); - if ((sig) && - (is_pair(sig)) && - (car(sig) != sc->is_boolean_symbol)) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, - wrap_string(sc, "sort! function should return a boolean", 38)); - sc->sort_f = s7_b_7pp_function(lessp); - if (sc->sort_f) sort_func = (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort; - } - else - { - if (is_closure(lessp)) - { - s7_pointer expr = car(closure_body(lessp)); - s7_pointer largs = closure_args(lessp); - - if ((is_pair(largs)) && /* closure args not a symbol, etc */ - (!arglist_has_rest(sc, largs))) - { - if ((is_null(cdr(closure_body(lessp)))) && - (is_optimized(expr)) && - (is_safe_c_op(optimize_op(expr))) && - /* since (sort seq (lambda (a b) ...)) can't return a "safe closure" (the hop bit is off in - * optimize in this case, for some arcane reason), the optimized expression won't be hop_safe, - * but that is irrelevant at this point -- if c_function_is_ok, we're good to go. - */ - ((op_has_hop(expr)) || - ((is_global(car(expr))) && /* (sort! x (lambda (car y) (car x)...))! */ - (c_function_is_ok(sc, expr))))) - { - int32_t orig_data = optimize_op(expr); - set_optimize_op(expr, optimize_op(expr) | 1); - if ((optimize_op(expr) == HOP_SAFE_C_SS) && - (car(largs) == cadr(expr)) && - (cadr(largs) == caddr(expr))) - { - s7_pointer lp = lookup(sc, car(expr)); - sc->sort_f = s7_b_7pp_function(lp); - if (sc->sort_f) - { - sort_func = (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort; - lessp = lp; - }} - else - if ((optimize_op(expr) == HOP_SAFE_C_opSq_opSq) && - ((caadr(expr) == sc->car_symbol) || (caadr(expr) == sc->cdr_symbol)) && - (caadr(expr) == caaddr(expr)) && - (car(largs) == cadadr(expr)) && - (cadr(largs) == cadaddr(expr))) - { - s7_pointer lp = lookup(sc, car(expr)); - sc->sort_f = s7_b_7pp_function(lp); - if (sc->sort_f) - { - sort_func = ((caadr(expr) == sc->car_symbol) ? vector_car_sort : vector_cdr_sort); - lessp = lp; - }} - set_optimize_op(expr, orig_data); - } - - if (!sort_func) - { - s7_pointer init_val, old_e = sc->curlet; - if (is_float_vector(data)) - init_val = real_zero; - else init_val = ((is_int_vector(data)) || (is_byte_vector(data))) ? int_zero : sc->F; - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(lessp), car(largs), init_val, cadr(largs), init_val); - sc->sort_body = expr; - sc->sort_v1 = let_slots(sc->curlet); - sc->sort_v2 = next_slot(let_slots(sc->curlet)); - if (is_null(cdr(closure_body(lessp)))) - { - if (!no_bool_opt(closure_body(lessp))) - { - s7_pfunc sf1 = s7_bool_optimize(sc, closure_body(lessp)); - if (sf1) - { - if (sc->opts[0]->v[0].fb == p_to_b) - sort_func = opt_bool_sort_p; - else - { - sc->sort_o = sc->opts[0]; - sc->sort_fb = sc->sort_o->v[0].fb; - sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort; - }} - else set_no_bool_opt(closure_body(lessp)); - }} - else - { - sc->sort_body_len = s7_list_length(sc, closure_body(lessp)); - if (sc->sort_body_len < (NUM_VUNIONS - SORT_O1)) - { - s7_pointer p; - int32_t ctr; - opt_info *top; - sc->pc = 0; - top = alloc_opt_info(sc); - for (ctr = SORT_O1, p = closure_body(lessp); is_pair(cdr(p)); ctr++, p = cdr(p)) - { - top->v[ctr].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (is_null(cdr(p))) - { - int32_t start = sc->pc; - top->v[ctr].o1 = sc->opts[start]; - if (bool_optimize_nw(sc, p)) - sort_func = (sc->sort_body_len == 2) ? opt_begin_bool_sort_b2 : opt_begin_bool_sort_b; - else - { - pc_fallback(sc, start); - if (cell_optimize(sc, p)) - sort_func = opt_begin_bool_sort_p; - }}}} - if (!sort_func) - set_curlet(sc, old_e); - } - if ((!sort_func) && - (is_safe_closure(lessp))) /* no embedded sort! or call/cc, etc */ - { - sc->curlet = make_let_with_two_slots(sc, closure_let(lessp), car(largs), sc->F, cadr(largs), sc->F); - sc->sort_body = car(closure_body(lessp)); - sc->sort_begin = cdr(closure_body(lessp)); - sort_func = (is_null(sc->sort_begin)) ? closure_sort : closure_sort_begin; - sc->sort_op = (is_syntactic_pair(sc->sort_body)) ? (opcode_t)optimize_op(sc->sort_body) : (opcode_t)OP_EVAL; - sc->sort_v1 = let_slots(sc->curlet); - sc->sort_v2 = next_slot(let_slots(sc->curlet)); - }}}} - - switch (type(data)) - { - case T_PAIR: - len = s7_list_length(sc, data); /* 0 here == infinite */ - if (len <= 0) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "sort! first argument should be a proper list: ~S", 48), data)); - if (len < 2) - return(data); - if (sort_func) - { - s7_int i = 0; - s7_pointer vec = g_vector(sc, data); - gc_protect_2_via_stack(sc, vec, data); - elements = s7_vector_elements(vec); - local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); - for (s7_pointer p = data; i < len; i++, p = cdr(p)) - { - if (is_immutable(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, data)); - set_car(p, elements[i]); - } - unstack(sc); /* not pop_stack! */ - return(data); - } - push_stack(sc, OP_SORT_PAIR_END, cons(sc, data, lessp), sc->code); /* save and gc protect the original list and func */ - set_car(args, g_vector(sc, data)); - break; - - case T_BYTE_VECTOR: - case T_STRING: - { - s7_int i; - s7_pointer vec; - uint8_t *chrs; - if (is_string(data)) - { - len = string_length(data); - chrs = (uint8_t *)string_value(data); - } - else - { - len = byte_vector_length(data); - chrs = byte_vector_bytes(data); - } - if (len < 2) return(data); - if (is_c_function(lessp)) - { - if (((is_string(data)) && (sc->sort_f == char_lt_b_7pp)) || - ((is_byte_vector(data)) && (sc->sort_f == lt_b_7pp))) - { - qsort((void *)chrs, len, sizeof(uint8_t), byte_less); - return(data); - } - if (((is_string(data)) && (sc->sort_f == char_gt_b_7pp)) || - ((is_byte_vector(data)) && (sc->sort_f == gt_b_7pp))) - { - qsort((void *)chrs, len, sizeof(uint8_t), byte_greater); - return(data); - }} - vec = make_simple_vector(sc, len); - gc_protect_2_via_stack(sc, vec, data); - elements = s7_vector_elements(vec); - if (is_byte_vector(data)) - for (i = 0; i < len; i++) elements[i] = small_int(chrs[i]); - else for (i = 0; i < len; i++) elements[i] = chars[chrs[i]]; - if (sort_func) - { - local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); - if (is_byte_vector(data)) - for (i = 0; i < len; i++) chrs[i] = (char)integer(elements[i]); - else for (i = 0; i < len; i++) chrs[i] = character(elements[i]); - unstack(sc); /* not pop_stack! */ - return(data); - } - unstack(sc); /* not pop_stack! */ - push_stack(sc, OP_SORT_STRING_END, cons_unchecked(sc, data, lessp), sc->code); - set_car(args, vec); - } - break; - - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - { - s7_int i; - s7_pointer vec; - len = vector_length(data); - if (len < 2) - return(data); - if (is_c_function(lessp)) - { - if (sc->sort_f == lt_b_7pp) - { - if (is_float_vector(data)) - qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_less); - else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_less); - return(data); - } - if (sc->sort_f == gt_b_7pp) - { - if (is_float_vector(data)) - qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_greater); - else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_greater); - return(data); - }} - /* currently we have to make the ordinary vector here even if not sf1 - * because the sorter uses vector_element to access sort args (see SORT_DATA in eval). - * This is probably better than passing down getter/setter (fewer allocations). - * get/set macro in eval is SORT_DATA(k) then s7_vector_to_list if pair at start (sort_*_end) - */ - vec = make_vector_1(sc, len, FILLED, T_VECTOR); - gc_protect_2_via_stack(sc, vec, data); - /* we need this vector prefilled because make_real|integer below can cause a GC at any time during that loop, - * and the GC mark process expects the vector to have an s7_pointer at every element. - */ - add_vector(sc, vec); - elements = s7_vector_elements(vec); - check_free_heap_size(sc, len); - if (is_float_vector(data)) - for (i = 0; i < len; i++) elements[i] = make_real_unchecked(sc, float_vector(data, i)); - else for (i = 0; i < len; i++) elements[i] = make_integer_unchecked(sc, int_vector(data, i)); - if (sort_func) - { - local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); - if (is_float_vector(data)) - for (i = 0; i < len; i++) float_vector(data, i) = real(elements[i]); - else for (i = 0; i < len; i++) int_vector(data, i) = integer(elements[i]); - unstack(sc); - return(data); - } - set_car(args, vec); - init_temp(sc->y, cons(sc, data, lessp)); - unstack(sc); - push_stack(sc, OP_SORT_VECTOR_END, sc->y, sc->code); /* save and gc protect the original homogeneous vector and func */ - sc->y = sc->unused; - } - break; - - case T_VECTOR: - len = vector_length(data); - if (len < 2) - return(data); - if (sort_func) - { - s7_pointer *els = s7_vector_elements(data); - int32_t typ = type(els[0]); - if ((typ == T_INTEGER) || (typ == T_REAL) || (typ == T_STRING) || (typ == T_CHARACTER)) - for (s7_int i = 1; i < len; i++) - if (type(els[i]) != typ) - { - typ = T_FREE; - break; - } - if ((sc->sort_f == lt_b_7pp) || (sc->sort_f == gt_b_7pp)) - { - if (typ == T_INTEGER) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? int_less_2 : int_greater_2)); - return(data); - } - if (typ == T_REAL) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? dbl_less_2 : dbl_greater_2)); - return(data); - }} - if ((typ == T_STRING) && - ((sc->sort_f == string_lt_b_7pp) || (sc->sort_f == string_gt_b_7pp))) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == string_lt_b_7pp) ? str_less_2 : str_greater_2)); - return(data); - } - if ((typ == T_CHARACTER) && - ((sc->sort_f == char_lt_b_7pp) || (sc->sort_f == char_gt_b_7pp))) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == char_lt_b_7pp) ? chr_less_2 : chr_greater_2)); - return(data); - } - local_qsort_r((void *)s7_vector_elements(data), len, sizeof(s7_pointer), sort_func, (void *)sc); - return(data); - } - break; - - default: - return(method_or_bust(sc, data, sc->sort_symbol, args, wrap_string(sc, "a sortable sequence", 19), 1)); - } - - n = len - 1; - k = (n / 2) + 1; - lx = make_simple_vector(sc, (sc->safety <= NO_SAFETY) ? 4 : 6); - normal_vector_fill(lx, sc->nil); /* make_mutable_integer below can trigger GC, so all elements of lx must be legit */ - init_temp(sc->y, lx); - vector_element(lx, 0) = make_mutable_integer(sc, n); - vector_element(lx, 1) = make_mutable_integer(sc, k); - vector_element(lx, 2) = make_mutable_integer(sc, 0); - vector_element(lx, 3) = make_mutable_integer(sc, 0); - if (sc->safety > NO_SAFETY) - { - vector_element(lx, 4) = make_mutable_integer(sc, 0); - vector_element(lx, 5) = make_integer_unchecked(sc, n * n); - } - push_stack(sc, OP_SORT, args, lx); - sc->y = sc->unused; - return(sc->F); - /* if the comparison function waffles, sort! can hang: (sort! '(1 2 3) (lambda (a b) (= a b))) - * set 'safety to 1 to add a check for this loop, but the "safe" procedures are direct, so unchecked. - */ -} - -/* these are for the eval sort -- sort a vector, then if necessary put that data into the original sequence */ -static s7_pointer vector_into_list(s7_scheme *sc, s7_pointer vect, s7_pointer lst) -{ - s7_pointer *elements = vector_elements(vect); - s7_int i = 0, len = vector_length(vect); - for (s7_pointer p = lst; i < len; i++, p = cdr(p)) - { - if (is_immutable(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, lst)); - set_car(p, elements[i]); - } - return(lst); -} - -static s7_pointer vector_into_fi_vector(s7_pointer source, s7_pointer dest) -{ - s7_pointer *elements = vector_elements(source); - s7_int len = vector_length(source); - if (is_float_vector(dest)) - { - s7_double *flts = float_vector_floats(dest); - for (s7_int i = 0; i < len; i++) flts[i] = real(elements[i]); - } - else - { - s7_int *ints = int_vector_ints(dest); - for (s7_int i = 0; i < len; i++) ints[i] = integer(elements[i]); - } - return(dest); -} - -static s7_pointer vector_into_string(s7_pointer vect, s7_pointer dest) -{ - s7_pointer *elements = vector_elements(vect); - s7_int len = vector_length(vect); - if (is_byte_vector(dest)) - { - uint8_t *str = (uint8_t *)byte_vector_bytes(dest); - for (s7_int i = 0; i < len; i++) str[i] = (uint8_t)integer(elements[i]); - } - else - { - uint8_t *str = (uint8_t *)string_value(dest); - for (s7_int i = 0; i < len; i++) str[i] = character(elements[i]); - } - return(dest); -} - -#define SORT_N integer(vector_element(sc->code, 0)) -#define SORT_K integer(vector_element(sc->code, 1)) -#define SORT_J integer(vector_element(sc->code, 2)) -#define SORT_K1 integer(vector_element(sc->code, 3)) -#define SORT_CALLS integer(vector_element(sc->code, 4)) -#define SORT_STOP integer(vector_element(sc->code, 5)) -#define SORT_DATA(K) vector_element(car(sc->args), K) -#define SORT_LESSP cadr(sc->args) - -static s7_pointer op_heapsort(s7_scheme *sc) -{ - s7_int n = SORT_N, j, k = SORT_K1; - - if ((n == k) || (k > ((s7_int)(n / 2)))) /* k == n == 0 is the first case */ - return(sc->code); - if (sc->safety > NO_SAFETY) - { - SORT_CALLS++; - if (SORT_CALLS > SORT_STOP) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "sort! is caught in an infinite loop, comparison: ~S", 51), SORT_LESSP)); - } - j = 2 * k; - SORT_J = j; - if (j < n) - { - s7_pointer lx = SORT_LESSP; /* cadr of sc->args */ - push_stack_direct(sc, OP_SORT1); - if (needs_copied_args(lx)) - sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1)); - else sc->args = with_list_t2(SORT_DATA(j), SORT_DATA(j + 1)); - sc->code = lx; - sc->value = sc->T; /* for eval */ - } - else sc->value = sc->F; - return(NULL); -} - -static bool op_sort1(s7_scheme *sc) -{ - s7_int j = SORT_J, k = SORT_K1; - s7_pointer lx = SORT_LESSP; - if (is_true(sc, sc->value)) - { - j = j + 1; - SORT_J = j; - } - push_stack_direct(sc, OP_SORT2); - if (needs_copied_args(lx)) - sc->args = list_2(sc, SORT_DATA(k), SORT_DATA(j)); - else sc->args = with_list_t2(SORT_DATA(k), SORT_DATA(j)); - sc->code = lx; - return(false); -} - -static bool op_sort2(s7_scheme *sc) -{ - s7_int j = SORT_J, k = SORT_K1; - if (is_true(sc, sc->value)) - { - s7_pointer lx = SORT_DATA(j); - SORT_DATA(j) = SORT_DATA(k); - SORT_DATA(k) = lx; - } - else return(true); - SORT_K1 = SORT_J; - return(false); -} - -static bool op_sort(s7_scheme *sc) -{ - /* coming in sc->args is sort args (data less?), sc->code = #(n k 0 ...) - * here we call the inner loop until k <= 0 [the local k! -- this is tricky because scheme passes args by value] - */ - s7_int k = SORT_K; - if (k > 0) - { - SORT_K = k - 1; - SORT_K1 = k - 1; - push_stack_direct(sc, OP_SORT); - return(false); - } - return(true); -} - -static bool op_sort3(s7_scheme *sc) -{ - s7_int n = SORT_N; - s7_pointer lx; - if (n <= 0) - { - sc->value = car(sc->args); - return(true); - } - lx = SORT_DATA(0); - SORT_DATA(0) = SORT_DATA(n); - SORT_DATA(n) = lx; - SORT_N = n - 1; - SORT_K1 = 0; - push_stack_direct(sc, OP_SORT3); - return(false); -} - - -/* -------- hash tables -------- */ - -static void free_hash_table(s7_scheme *sc, s7_pointer table) -{ - if (hash_table_entries(table) > 0) - { - hash_entry_t **entries = hash_table_elements(table); - s7_int len = hash_table_mask(table) + 1; - for (s7_int i = 0; i < len; i++) - { - hash_entry_t *n; - for (hash_entry_t *p = entries[i++]; p; p = n) - { - n = hash_entry_next(p); - liberate_block(sc, p); - } - for (hash_entry_t *p = entries[i]; p; p = n) - { - n = hash_entry_next(p); - liberate_block(sc, p); - }}} - liberate(sc, hash_table_block(table)); -} - -static hash_entry_t *make_hash_entry(s7_scheme *sc, s7_pointer key, s7_pointer value, s7_int raw_hash) -{ - hash_entry_t *p = (hash_entry_t *)mallocate_block(sc); - hash_entry_key(p) = key; - hash_entry_set_value(p, value); - hash_entry_set_raw_hash(p, raw_hash); - return(p); -} - - -/* -------------------------------- hash-table? -------------------------------- */ -bool s7_is_hash_table(s7_pointer p) {return(is_hash_table(p));} - -static s7_pointer g_is_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table" - #define Q_is_hash_table sc->pl_bt - check_boolean_method(sc, is_hash_table, sc->is_hash_table_symbol, args); -} - - -/* -------------------------------- hash-table-entries -------------------------------- */ -static s7_pointer g_hash_table_entries(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_entries "(hash-table-entries obj) returns the number of entries in the hash-table obj" - #define Q_hash_table_entries s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol) - - if (!is_hash_table(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->hash_table_entries_symbol, args, sc->type_names[T_HASH_TABLE])); - return(make_integer(sc, hash_table_entries(car(args)))); -} - -static s7_int hash_table_entries_i_7p(s7_scheme *sc, s7_pointer p) -{ - if (!is_hash_table(p)) - return(integer(method_or_bust_p(sc, p, sc->hash_table_entries_symbol, sc->type_names[T_HASH_TABLE]))); - return(hash_table_entries(p)); -} - - -/* -------------------------------- hash-table-key|value-typer -------------------------------- */ -static s7_pointer g_hash_table_key_typer(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_key_typer "(hash-table-key-typer hash) returns the hash-table's key type checking function" - #define Q_hash_table_key_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol) - - s7_pointer h = car(args); - if (!is_hash_table(h)) return(sole_arg_method_or_bust(sc, h, sc->hash_table_key_typer_symbol, args, sc->type_names[T_HASH_TABLE])); - if (is_typed_hash_table(h)) return(hash_table_key_typer(h)); - return(sc->F); -} - -static s7_pointer g_hash_table_value_typer(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_value_typer "(hash-table-value-typer hash) returns the hash-table's value type checking function" - #define Q_hash_table_value_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol) - - s7_pointer h = car(args); - if (!is_hash_table(h)) return(sole_arg_method_or_bust(sc, h, sc->hash_table_value_typer_symbol, args, sc->type_names[T_HASH_TABLE])); - if (is_typed_hash_table(h)) return(hash_table_value_typer(h)); - return(sc->F); -} - -static s7_pointer make_hash_table_procedures(s7_scheme *sc) -{ - s7_pointer x = cons(sc, sc->T, sc->T); /* checker, mapped */ - set_opt1_any(x, sc->T); /* key */ - set_opt2_any(x, sc->T); /* value */ - return(x); -} - -static s7_pointer copy_hash_table_procedures(s7_scheme *sc, s7_pointer table) -{ - if (is_pair(hash_table_procedures(table))) - { - s7_pointer x = cons(sc, hash_table_procedures_checker(table), hash_table_procedures_mapper(table)); - set_opt1_any(x, hash_table_key_typer(table)); - set_opt2_any(x, hash_table_value_typer(table)); - return(x); - } - return(sc->nil); -} - -static void check_hash_table_typer(s7_scheme *sc, s7_pointer caller, s7_pointer h, s7_pointer typer) -{ - if (is_c_function(typer)) - { - s7_pointer sig = c_function_signature(typer); - if ((sig != sc->pl_bt) && - (is_pair(sig)) && - ((car(sig) != sc->is_boolean_symbol) || (cadr(sig) != sc->T) || (!is_null(cddr(sig))))) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a boolean procedure", 19)); - if (!c_function_name(typer)) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); - } - else - { - if (!is_any_closure(typer)) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a built-in procedure, a closure or #t", 37)); - if (!is_symbol(find_closure(sc, typer, closure_let(typer)))) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); - } - if (!s7_is_aritable(sc, typer, 1)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: the second argument, ~S, (the type checker) should accept one argument", 74), caller, typer)); - if (is_c_function(typer)) - { - if (!c_function_symbol(typer)) - c_function_symbol(typer) = make_symbol(sc, c_function_name(typer), c_function_name_length(typer)); - if (c_function_has_simple_elements(typer)) - { - if (caller == sc->hash_table_value_typer_symbol) - set_has_simple_values(h); - else - { - set_has_simple_keys(h); - if (symbol_type(c_function_symbol(typer)) != T_FREE) - set_has_hash_key_type(h); - }}} - if (is_null(hash_table_procedures(h))) - hash_table_set_procedures(h, make_hash_table_procedures(sc)); - set_is_typed_hash_table(h); -} - -static s7_pointer g_set_hash_table_key_typer(s7_scheme *sc, s7_pointer args) -{ - s7_pointer h = car(args), typer = cadr(args); - if (!is_hash_table(h)) - wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-key-typer", 25), 1, h, sc->type_names[T_HASH_TABLE]); - - if (is_boolean(typer)) /* remove current typer, if any */ - { - if (is_typed_hash_table(h)) - { - hash_table_set_key_typer(h, sc->T); - if (hash_table_value_typer(h) == sc->T) - { - /* clear_is_typed_hash_table(h); */ - clear_has_simple_keys(h); - /* clear_has_hash_key_type?? looks redundant */ - }}} - else - { - check_hash_table_typer(sc, sc->hash_table_key_typer_symbol, h, typer); - hash_table_set_key_typer(h, typer); - } - return(typer); -} - -static s7_pointer g_set_hash_table_value_typer(s7_scheme *sc, s7_pointer args) -{ - s7_pointer h = car(args), typer = cadr(args); - if (!is_hash_table(h)) - wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-value-typer", 27), 1, h, sc->type_names[T_HASH_TABLE]); - - if (is_boolean(typer)) /* remove current typer, if any */ - { - if (is_typed_hash_table(h)) - { - hash_table_set_value_typer(h, sc->T); - if (hash_table_key_typer(h) == sc->T) - { - /* clear_is_typed_hash_table(h); */ - clear_has_simple_values(h); - }}} - else - { - check_hash_table_typer(sc, sc->hash_table_value_typer_symbol, h, typer); - hash_table_set_value_typer(h, typer); - } - return(typer); -} - - -/* ---------------- hash map and equality tables ---------------- */ -/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? string-ci=? char=? char-ci=? (default=equal?) */ -#define hash_loc(Sc, Table, Key) (*(hash_table_mapper(Table)[type(Key)]))(Sc, Table, Key) - -static hash_map_t eq_hash_map[NUM_TYPES]; -static hash_map_t string_eq_hash_map[NUM_TYPES]; -static hash_map_t char_eq_hash_map[NUM_TYPES]; -static hash_map_t closure_hash_map[NUM_TYPES]; -static hash_map_t equivalent_hash_map[NUM_TYPES]; -static hash_map_t c_function_hash_map[NUM_TYPES]; -#if (!WITH_PURE_S7) -static hash_map_t string_ci_eq_hash_map[NUM_TYPES]; -static hash_map_t char_ci_eq_hash_map[NUM_TYPES]; -#endif -/* also default_hash_map */ - - -/* ---------------- hash-code ---------------- */ -/* eqfunc handling which will require other dummy tables */ - -static s7_pointer make_dummy_hash_table(s7_scheme *sc) /* make the absolute minimal hash-table that can support hash-code */ -{ - s7_pointer table = alloc_pointer(sc); - set_type_bit(table, T_IMMUTABLE | T_HASH_TABLE | T_UNHEAP); - hash_table_mapper(table) = default_hash_map; - return(table); -} - -s7_int s7_hash_code(s7_scheme *sc, s7_pointer obj, s7_pointer eqfunc) -{ - return(default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj)); -} - -static s7_pointer g_hash_code(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_code "(hash-code obj (eqfunc)) returns an integer suitable for use as a hash code for obj." - #define Q_hash_code s7_make_signature(sc, 3, sc->is_integer_symbol, sc->T, sc->T) - s7_pointer obj = car(args); - if ((is_pair(cdr(args))) && - (!is_procedure(cadr(args)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "hash-code second argument (currently ignored) should be a function: ~S", 70), cadr(args))); - return(make_integer(sc, default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj))); -} - - -static bool (*equals[NUM_TYPES])(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci); -static bool (*equivalents[NUM_TYPES])(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci); - -static hash_entry_t *(*default_hash_checks[NUM_TYPES])(s7_scheme *sc, s7_pointer table, s7_pointer key); -static hash_entry_t *(*equal_hash_checks[NUM_TYPES])(s7_scheme *sc, s7_pointer table, s7_pointer key); - - -/* ---------------- hash empty ---------------- */ -static hash_entry_t *hash_empty(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(sc->unentry);} - -/* ---------------- hash syntax ---------------- */ -static s7_int hash_map_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(syntax_symbol(key)));} - -static hash_entry_t *hash_equal_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int loc = hash_loc(sc, table, key) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((is_syntax(hash_entry_key(x))) && - (syntax_symbol(hash_entry_key(x)) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */ - return(x); - return(sc->unentry); -} - -/* ---------------- hash symbols ---------------- */ -static s7_int hash_map_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(key));} - -static hash_entry_t *hash_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - for (hash_entry_t *x = hash_table_element(table, pointer_map(key) & hash_table_mask(table)); x; x = hash_entry_next(x)) - if (key == hash_entry_key(x)) - return(x); - return(sc->unentry); -} - - -/* ---------------- hash numbers ---------------- */ -static s7_int hash_float_location(s7_double x) {return(((is_NaN(x)) || (is_inf(x))) ? 0 : (s7_int)floor(fabs(x)));} - -static s7_int hash_map_int(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(s7_int_abs(integer(key)));} -static s7_int hash_map_real(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(hash_float_location(real(key)));} -static s7_int hash_map_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(hash_float_location(real_part(key)));} - -static s7_int hash_map_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* if numerator is -9223372036854775808, s7_int_abs overflows -- need to divide, then abs: -9223372036854775808/3: -3074457345618258602 3074457345618258602 - * (s7_int)floorl(fabsl(fraction(key))) is no good here, 3441313796169221281/1720656898084610641: 1 2 (in valgrind), - * floor ratio is 1: (- (* 2 1720656898084610641) 3441313796169221281) -> 1 - * or (gmp:) 1.999999999999999999418826611445214136431E0, so the floorl(fabsl) version is wrong - */ - return(s7_int_abs(numerator(key) / denominator(key))); -} - -#if WITH_GMP -static s7_int hash_map_big_int(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* may need to use quotient here */ - mpz_abs(sc->mpz_1, big_integer(key)); - return(mpz_get_si(sc->mpz_1)); /* returns the bits that fit */ -} - -static s7_int hash_map_big_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - mpq_abs(sc->mpq_1, big_ratio(key)); - mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_1), mpq_denref(sc->mpq_1)); - return(mpz_get_si(sc->mpz_1)); -} - -static s7_int hash_map_big_real_1(s7_scheme *sc, s7_pointer table, mpfr_t key) -{ - if ((mpfr_nan_p(key)) || (mpfr_inf_p(key))) return(0); - mpfr_abs(sc->mpfr_1, key, MPFR_RNDN); - /* mpfr_get_si returns most-positive-int if > 2^63! luckily there aren't any more of these */ - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); /* floor not round */ - return(mpz_get_si(sc->mpz_1)); -} - -static s7_int hash_map_big_real(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return(hash_map_big_real_1(sc, table, big_real(key))); -} - -static s7_int hash_map_big_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return(hash_map_big_real_1(sc, table, mpc_realref(big_complex(key)))); -} -#endif - -static hash_entry_t *find_number_in_bin(s7_scheme *sc, hash_entry_t *bin, s7_pointer key) -{ - s7_double old_eps = sc->equivalent_float_epsilon; - bool (*equiv)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = equivalents[type(key)]; - sc->equivalent_float_epsilon = sc->hash_table_float_epsilon; - for (; bin; bin = hash_entry_next(bin)) - if (equiv(sc, key, hash_entry_key(bin), NULL)) - { - sc->equivalent_float_epsilon = old_eps; - return(bin); - } - sc->equivalent_float_epsilon = old_eps; - return(NULL); -} - -static hash_entry_t *hash_number_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* for equivalent? and =, kind of complicated because two bins can be involved if the key is close to an integer */ -#if WITH_GMP - /* first try loc from hash_loc, then get key-floor(key) [with abs], and check against - * epsilon: diff < eps call find big in bin-1, diff > 1.0-eps call same in bin+1 - */ - s7_int loc1, hash_mask = hash_table_mask(table); - s7_int loc = hash_loc(sc, table, key); - s7_int hash_loc = loc & hash_mask; - hash_entry_t *i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key); - if (i1) return(i1); - - if (is_real(key)) - { - s7_pointer res = any_real_to_mpfr(sc, key, sc->mpfr_1); - if (res) return(sc->unentry); - } - else - if (is_t_complex(key)) - mpfr_set_d(sc->mpfr_1, real_part(key), MPFR_RNDN); - else mpfr_set(sc->mpfr_1, mpc_realref(big_complex(key)), MPFR_RNDN); - - /* mpfr_1 is big_real, so we can use hash_loc of big_real (and can ignore NaN's): */ - mpfr_abs(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - mpfr_add_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD); - loc1 = mpz_get_si(sc->mpz_1); - if (loc1 != loc) - { - if (loc1 == hash_table_mask(table)) loc1 = 0; - hash_loc = loc1 & hash_mask; - i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key); - return((i1) ? i1 : sc->unentry); - } - mpfr_sub_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD); - loc1 = mpz_get_si(sc->mpz_1); - if (loc1 != loc) - { - if (loc1 < 0) loc1 = hash_table_mask(table); - hash_loc = loc1 & hash_mask; - i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key); - if (i1) return(i1); - } - return(sc->unentry); -#else - s7_double keyval = (is_real(key)) ? s7_real(key) : real_part(key); - s7_double fprobe = fabs(keyval); - s7_int iprobe = (s7_int)floor(fprobe); - s7_double bin_dist = fprobe - iprobe; - s7_int loc = iprobe & hash_table_mask(table); - hash_entry_t *i1 = find_number_in_bin(sc, hash_table_element(table, loc), key); - if (i1) return(i1); - - if (bin_dist <= sc->hash_table_float_epsilon) /* maybe closest is below iprobe, key+eps>iprobe but key maps to iprobe-1 */ - i1 = find_number_in_bin(sc, hash_table_element(table, (loc > 0) ? loc - 1 : hash_table_mask(table)), key); - else - if (bin_dist >= (1.0 - sc->hash_table_float_epsilon)) - i1 = find_number_in_bin(sc, hash_table_element(table, (loc < hash_table_mask(table)) ? loc + 1 : 0), key); - return((i1) ? i1 : sc->unentry); -#endif -} - -static hash_entry_t *hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ -#if WITH_GMP - if ((is_t_integer(key)) || (is_t_big_integer(key))) -#else - if (is_t_integer(key)) -#endif - { - s7_int hash_mask = hash_table_mask(table); - hash_entry_t *x; -#if WITH_GMP - s7_int kv = (is_t_integer(key)) ? integer(key) : mpz_get_si(big_integer(key)); -#else - s7_int kv = integer(key); -#endif - s7_int loc = s7_int_abs(kv) & hash_mask; - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) -#if WITH_GMP - if (is_t_integer(hash_entry_key(x))) - { - if (integer(hash_entry_key(x)) == kv) - return(x); - } - else - if ((is_t_big_integer(hash_entry_key(x))) && - (mpz_get_si(big_integer(hash_entry_key(x))) == kv)) - return(x); -#else - if (integer(hash_entry_key(x)) == kv) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_float(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* if a hash-table has only t_real keys, its checker is hash_float, but we might use a t_big_real key */ -#if WITH_GMP - if ((is_t_real(key)) || (is_t_big_real(key))) -#else - if (is_t_real(key)) -#endif - { - s7_double keyval; - s7_int loc, hash_mask; -#if WITH_GMP - if (is_t_real(key)) - { - keyval = real(key); - if (is_NaN(keyval)) return(sc->unentry); - } - else - { - if (mpfr_nan_p(big_real(key))) return(sc->unentry); - keyval = mpfr_get_d(big_real(key), MPFR_RNDN); - } -#else - keyval = real(key); - if (is_NaN(keyval)) return(sc->unentry); -#endif - hash_mask = hash_table_mask(table); - loc = hash_float_location(keyval) & hash_mask; - - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_real(hash_entry_key(x))) && - (keyval == real(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_real(hash_entry_key(x))) && - (mpfr_cmp_d(big_real(hash_entry_key(x)), keyval) == 0) && - (!mpfr_nan_p(big_real(hash_entry_key(x))))) - return(x); -#endif - }} - return(sc->unentry); -} - -static hash_entry_t *hash_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int hash_mask = hash_table_mask(table); - s7_int loc = hash_loc(sc, table, key) & hash_mask; - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (num_eq_b_7pp(sc, key, hash_entry_key(x))) - return(x); - return(sc->unentry); -} - -static hash_entry_t *hash_real_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ -#if WITH_GMP - if ((is_t_real(key)) && (is_NaN(real(key)))) return(sc->unentry); - if ((is_t_big_real(key)) && (mpfr_nan_p(big_real(key)))) return(sc->unentry); - return(hash_num_eq(sc, table, key)); -#else - return((is_NaN(s7_real(key))) ? sc->unentry : hash_num_eq(sc, table, key)); -#endif -} - -static hash_entry_t *hash_complex_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ -#if WITH_GMP - if ((is_t_complex(key)) && ((is_NaN(real_part(key))) || (is_NaN(imag_part(key))))) return(sc->unentry); - if ((is_t_big_complex(key)) && ((mpfr_nan_p(mpc_realref(big_complex(key)))) || (mpfr_nan_p(mpc_imagref(big_complex(key)))))) return(sc->unentry); - return(hash_num_eq(sc, table, key)); -#else - return(((is_NaN(real_part(key))) || (is_NaN(imag_part(key)))) ? sc->unentry : hash_num_eq(sc, table, key)); -#endif -} - -static hash_entry_t *hash_number_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_number(key)) - { -#if (!WITH_GMP) - s7_int hash_mask = hash_table_mask(table); - hash_map_t map = hash_table_mapper(table)[type(key)]; - if (hash_table_checker(table) == hash_int) /* surely by far the most common case? only ints */ - { - s7_int keyi = integer(key); - s7_int loc = map(sc, table, key) & hash_mask; - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (keyi == integer(hash_entry_key(x))) /* not in gmp, hash_int as eq_func, what else can key be but t_integer? */ - return(x); - } - else -#endif - return((is_real(key)) ? hash_real_num_eq(sc, table, key) : hash_complex_num_eq(sc, table, key)); - } - return(sc->unentry); -} - - -/* ---------------- hash characters ---------------- */ -static s7_int hash_map_char(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(character(key));} - -static hash_entry_t *hash_char(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_character(key)) - { - /* return(hash_eq(sc, table, key)); - * but I think if we get here at all, we have to be using default_hash_checks|maps -- see hash_symbol above. - */ - s7_int loc = character(key) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (key == hash_entry_key(x)) - return(x); - } - return(sc->unentry); -} - -#if (!WITH_PURE_S7) -static s7_int hash_map_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(upper_character(key));} - -static hash_entry_t *hash_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_character(key)) - { - s7_int hash_mask = hash_table_mask(table); - s7_int loc = hash_loc(sc, table, key) & hash_mask; - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (upper_character(key) == upper_character(hash_entry_key(x))) - return(x); - } - return(sc->unentry); -} -#endif - - -/* ---------------- hash strings ---------------- */ -static s7_int hash_map_string(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (string_hash(key) == 0) - string_hash(key) = raw_string_hash((const uint8_t *)string_value(key), string_length(key)); - return(string_hash(key)); -} - -static hash_entry_t *hash_string(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_string(key)) - { - hash_entry_t *x; - s7_int key_len = string_length(key), hash_mask = hash_table_mask(table); - uint64_t hash; - const char *key_str = string_value(key); - - if (string_hash(key) == 0) - string_hash(key) = raw_string_hash((const uint8_t *)string_value(key), string_length(key)); - hash = string_hash(key); - if (key_len <= 8) - { - for (x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) - if ((hash == string_hash(hash_entry_key(x))) && - (key_len == string_length(hash_entry_key(x)))) - return(x); - } - else - for (x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) - if ((hash == string_hash(hash_entry_key(x))) && - (key_len == string_length(hash_entry_key(x))) && /* these are scheme strings, so we can't assume 0=end of string */ - (strings_are_equal_with_length(key_str, string_value(hash_entry_key(x)), key_len))) - return(x); - } - return(sc->unentry); -} - -#if (!WITH_PURE_S7) -static s7_int hash_map_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int len = string_length(key); - return((len == 0) ? 0 : (len + (uppers[(int32_t)(string_value(key)[0])] << 4))); -} - -static hash_entry_t *hash_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_string(key)) - { - s7_int hash_mask = hash_table_mask(table); - s7_int hash = hash_map_ci_string(sc, table, key); - for (hash_entry_t *x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) - if (scheme_strequal_ci(key, hash_entry_key(x))) - return(x); - } - return(sc->unentry); -} -#endif - - -/* ---------------- hash eq? ---------------- */ -static s7_int hash_map_nil(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(type(key));} - -static s7_int hash_map_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(key));} - -static hash_entry_t *hash_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* explicit eq? as hash equality func or (for example) symbols as keys */ - s7_int hash_mask = hash_table_mask(table); - s7_int loc = pointer_map(key) & hash_mask; /* hash_map_eq */ - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (key == hash_entry_key(x)) - return(x); - return(sc->unentry); -} - -/* ---------------- hash eqv? ---------------- */ -static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - hash_entry_t *x; - s7_int hash_mask = hash_table_mask(table); - s7_int loc = hash_loc(sc, table, key) & hash_mask; - if (is_number(key)) - { -#if WITH_GMP - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (numbers_are_eqv(sc, key, hash_entry_key(x))) - return(x); -#else - uint8_t key_type = type(key); - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((key_type == type(hash_entry_key(x))) && - (numbers_are_eqv(sc, key, hash_entry_key(x)))) - return(x); -#endif - } - else - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (s7_is_eqv(sc, key, hash_entry_key(x))) - return(x); - return(sc->unentry); -} - -/* ---------------- hash equal? ---------------- */ -static s7_int hash_map_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* hash-tables are equal if key/values match independent of table size and entry order. - * if not using equivalent?, hash_table_checker|mapper must also be the same. - * Keys are supposed to be constant while keys, so a hash-table shouldn't be a key of itself. - */ - return(hash_table_entries(key)); -} - -static s7_int hash_map_int_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (vector_length(key) == 0) - return(0); - if (vector_length(key) == 1) - return(s7_int_abs(int_vector(key, 0))); - return(vector_length(key) + s7_int_abs(int_vector(key, 0)) + s7_int_abs(int_vector(key, 1))); /* overflow is ok here (in + or abs), as long as it's consistent */ -} - -static s7_int hash_map_byte_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (byte_vector_length(key) == 0) - return(0); - if (byte_vector_length(key) == 1) - return((s7_int)byte_vector(key, 0)); - return(byte_vector_length(key) + byte_vector(key, 0) + byte_vector(key, 1)); -} - -static s7_int hash_map_float_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (vector_length(key) == 0) - return(0); - if (vector_length(key) == 1) - return(hash_float_location(float_vector(key, 0))); - return(vector_length(key) + hash_float_location(float_vector(key, 0)) + hash_float_location(float_vector(key, 1))); -} - -static s7_int hash_map_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if ((vector_length(key) == 0) || - (is_sequence(vector_element(key, 0)))) - return(vector_length(key)); - if ((vector_length(key) == 1) || - (is_sequence(vector_element(key, 1)))) - return(hash_loc(sc, table, vector_element(key, 0))); - return(vector_length(key) + hash_loc(sc, table, vector_element(key, 0)) + hash_loc(sc, table, vector_element(key, 1))); /* see above */ -} - - -static s7_int hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_pointer f = hash_table_procedures_mapper(table); - if (f == sc->unused) - error_nr(sc, make_symbol(sc, "hash-map-recursion", 18), - set_elist_1(sc, wrap_string(sc, "hash-table map function called recursively", 42))); - /* check_stack_size(sc); -- perhaps clear typers as well here or save/restore hash-table-procedures */ - gc_protect_via_stack(sc, f); - hash_table_set_procedures_mapper(table, sc->unused); - sc->value = s7_call(sc, f, set_plist_1(sc, key)); - unstack(sc); - hash_table_set_procedures_mapper(table, f); - if (!s7_is_integer(sc->value)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "hash-table map function should return an integer: ~S", 52), sc->value)); - return(integer(sc->value)); -} - -static s7_int hash_map_let(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* lets are equal if same symbol/value pairs, independent of order, taking into account shadowing - * (length (inlet 'a 1 'a 2)) = 2 - * but this counts as just one entry from equal?'s point of view, so if more than one entry, we have a problem. - * (equal? (inlet 'a 1) (inlet 'a 3 'a 2 'a 1)) = #t - * also currently equal? follows outlet, but that is ridiculous here, so in this case hash equal? - * is not the same as equal? Surely anyone using lets as keys wants eq? - */ - s7_pointer slot; - s7_int slots; - - if ((key == sc->rootlet) || - (!tis_slot(let_slots(key)))) - return(0); - slot = let_slots(key); - if (!tis_slot(next_slot(slot))) - { - if (is_sequence(slot_value(slot))) /* avoid loop if cycles */ - return(pointer_map(slot_symbol(slot))); - return(pointer_map(slot_symbol(slot)) + hash_loc(sc, table, slot_value(slot))); - } - slots = 0; - for (; tis_slot(slot); slot = next_slot(slot)) - if (!is_matched_symbol(slot_symbol(slot))) - { - set_match_symbol(slot_symbol(slot)); - slots++; - } - for (slot = let_slots(key); tis_slot(slot); slot = next_slot(slot)) - clear_match_symbol(slot_symbol(slot)); - - if (slots != 1) - return(slots); - slot = let_slots(key); - if (is_sequence(slot_value(slot))) /* avoid loop if cycles */ - return(pointer_map(slot_symbol(slot))); - return(pointer_map(slot_symbol(slot)) + hash_loc(sc, table, slot_value(slot))); -} - -static hash_entry_t *hash_equal_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int loc = hash_loc(sc, table, key) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_key(x) == key) - return(x); - return(sc->unentry); -} - -static hash_entry_t *hash_equal_integer(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int keyint = integer(key); - s7_int loc = s7_int_abs(keyint) & hash_table_mask(table); /* hash_loc -> hash_map_integer */ - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_integer(hash_entry_key(x))) && - (keyint == integer(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_integer(hash_entry_key(x))) && - (mpz_cmp_si(big_integer(hash_entry_key(x)), keyint) == 0)) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_equal_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int keynum = numerator(key), keyden = denominator(key); - s7_int loc = s7_int_abs(keynum / keyden) & hash_table_mask(table); /* hash_loc -> hash_map_ratio */ - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_ratio(hash_entry_key(x))) && - (keynum == numerator(hash_entry_key(x))) && - (keyden == denominator(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_ratio(hash_entry_key(x))) && - (keynum == mpz_get_si(mpq_numref(big_ratio(hash_entry_key(x))))) && - (keyden == mpz_get_si(mpq_denref(big_ratio(hash_entry_key(x)))))) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_equal_real(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int loc; - s7_double keydbl = real(key); - if (is_NaN(keydbl)) return(sc->unentry); - loc = hash_float_location(keydbl) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_real(hash_entry_key(x))) && - (keydbl == real(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_real(hash_entry_key(x))) && - (mpfr_cmp_d(big_real(hash_entry_key(x)), keydbl) == 0) && - (!mpfr_nan_p(big_real(hash_entry_key(x))))) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_equal_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_int loc; - s7_double keyrl = real_part(key); - s7_double keyim = imag_part(key); -#if WITH_GMP - if ((is_NaN(keyrl)) || (is_NaN(keyim))) return(sc->unentry); -#endif - loc = hash_float_location(keyrl) & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_complex(hash_entry_key(x))) && - (keyrl == real_part(hash_entry_key(x))) && - (keyim == imag_part(hash_entry_key(x)))) - return(x); -#if WITH_GMP - if ((is_t_big_complex(hash_entry_key(x))) && - (mpfr_cmp_d(mpc_realref(big_complex(hash_entry_key(x))), keyrl) == 0) && - (mpfr_cmp_d(mpc_imagref(big_complex(hash_entry_key(x))), keyim) == 0) && - (!mpfr_nan_p(mpc_realref(big_complex(hash_entry_key(x))))) && - (!mpfr_nan_p(mpc_imagref(big_complex(hash_entry_key(x)))))) - return(x); -#endif - } - return(sc->unentry); -} - -static hash_entry_t *hash_equal_any(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - bool (*equal)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = equals[type(key)]; - s7_int hash = hash_loc(sc, table, key); - s7_int loc = hash & hash_table_mask(table); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_raw_hash(x) == hash) - if (equal(sc, key, hash_entry_key(x), NULL)) - return(x); - return(sc->unentry); -} - - -/* ---------------- hash c_functions ---------------- */ -static s7_int hash_map_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - s7_function f = c_function_call(hash_table_procedures_mapper(table)); - return(integer(f(sc, with_list_t1(key)))); -} - -static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key); - -static hash_entry_t *hash_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_pair(hash_table_procedures(table))) - { - s7_int hash_mask = hash_table_mask(table); - s7_function f = c_function_call(hash_table_procedures_checker(table)); - s7_int hash = hash_loc(sc, table, key); - s7_int loc = hash & hash_mask; - set_car(sc->t2_1, key); - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_raw_hash(x) == hash) - { - set_car(sc->t2_2, hash_entry_key(x)); - if (is_true(sc, f(sc, sc->t2_1))) - return(x); - } - return(sc->unentry); - } - return(hash_equal(sc, table, key)); -} - -static int32_t len_upto_8(s7_pointer p) -{ - int32_t i = 0; /* unrolling this loop saves 10-15% */ - for (s7_pointer x = p; (is_pair(x)) && (i < 8); i++, x = cdr(x)); - return(i); -} - -static s7_int hash_map_pair(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* len+loc(car) is not horrible, but it means (for example) every list '(set! ...) is hashed to the same location, - * so at least we need to take cadr into account if possible. Better would combine the list_length - * with stats like symbols/pairs/constants at top level, then use those to spread it out over all the locs. - */ - s7_pointer p1 = cdr(key); - s7_int loc = 0; - - if (!is_sequence(car(key))) - loc = hash_loc(sc, table, car(key)) + 1; - else - if ((is_pair(car(key))) && - (!is_sequence(caar(key)))) - loc = hash_loc(sc, table, caar(key)) + 1; - if (is_pair(p1)) - { - if (!is_sequence(car(p1))) - loc += hash_loc(sc, table, car(p1)) + 1; - else - if ((is_pair(car(p1))) && - (!is_sequence(caar(p1)))) - loc += hash_loc(sc, table, caar(p1)) + 1; - } - loc = (loc << 3) | len_upto_8(key); - return(loc); -} - -static hash_entry_t *hash_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (is_pair(hash_table_procedures(table))) - { - s7_int hash_mask = hash_table_mask(table); - s7_pointer f = hash_table_procedures_checker(table); - s7_int hash = hash_loc(sc, table, key); - s7_int loc = hash & hash_mask; - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_raw_hash(x) == hash) - if (is_true(sc, s7_call(sc, f, set_plist_2(sc, key, hash_entry_key(x))))) - return(x); - return(sc->unentry); - } - return(hash_equal(sc, table, key)); -} - -static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return((*(equal_hash_checks[type(key)]))(sc, table, key)); -} - -/* ---------------- hash equivalent? ---------------- */ -static hash_entry_t *hash_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - hash_entry_t *x; - s7_int hash, loc; - - if (is_number(key)) - { -#if WITH_GMP - if (!is_nan_b_7p(sc, key)) - return(hash_number_equivalent(sc, table, key)); -#else - x = hash_number_equivalent(sc, table, key); - if ((x != sc->unentry) || (!is_nan_b_7p(sc, key))) - return(x); -#endif - for (x = hash_table_element(table, 0); x; x = hash_entry_next(x)) /* NaN is mapped to 0 */ - if (is_nan_b_7p(sc, hash_entry_key(x))) /* all NaN's are the same to equivalent? */ - return(x); - return(sc->unentry); - } - hash = hash_loc(sc, table, key); - loc = hash & hash_table_mask(table); - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_key(x) == key) - return(x); - - for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((hash_entry_raw_hash(x) == hash) && - (s7_is_equivalent(sc, hash_entry_key(x), key))) - return(x); - return(sc->unentry); -} - -static bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash) -{ - return((is_null(hash_table_procedures(hash))) && - (hash_table_mapper(hash) == default_hash_map) && - (hash_table_checker(hash) != hash_equal) && - (hash_table_checker(hash) != hash_equivalent) && - (hash_table_checker(hash) != hash_closure) && - (hash_table_checker(hash) != hash_c_function)); -} - - -/* -------------------------------- make-hash-table -------------------------------- */ -s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size) -{ - s7_pointer table; - block_t *els; - /* size is rounded up to the next power of 2 */ - - if (size < 2) - size = 2; - else - if ((size & (size - 1)) != 0) /* already 2^n ? */ - { - if ((size & (size + 1)) != 0) /* already 2^n - 1 ? */ - { - size--; - size |= (size >> 1); - size |= (size >> 2); - size |= (size >> 4); - size |= (size >> 8); - size |= (size >> 16); - size |= (size >> 32); - } - size++; - } - els = (block_t *)callocate(sc, size * sizeof(hash_entry_t *)); - new_cell(sc, table, T_HASH_TABLE | T_SAFE_PROCEDURE); - hash_table_mask(table) = size - 1; - hash_table_set_block(table, els); - hash_table_elements(table) = (hash_entry_t **)(block_data(els)); - hash_table_checker(table) = hash_empty; - hash_table_mapper(table) = default_hash_map; - hash_table_entries(table) = 0; - hash_table_set_procedures(table, sc->nil); - add_hash_table(sc, table); - return(table); -} - -static bool compatible_types(s7_scheme *sc, s7_pointer eq_type, s7_pointer value_type) -{ - if (eq_type == sc->T) return(true); - if (eq_type == value_type) return(true); - if (eq_type == sc->is_number_symbol) /* only = among built-ins, so other cases aren't needed */ - return((value_type == sc->is_integer_symbol) || - (value_type == sc->is_real_symbol) || - (value_type == sc->is_complex_symbol) || - (value_type == sc->is_rational_symbol)); - return(false); -} - -static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args); -static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args); - -static s7_pointer g_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - #define H_make_hash_table "(make-hash-table (size 8) eq-func typer) returns a new hash table. eq-func is the function \ -used to check equality of keys; it usually defaults to equal?. typer sets the types of the keys and values that are allowed \ -in the table; it is a cons, defaulting to (cons #t #t) which means any types are allowed.\n" - #define Q_make_hash_table s7_make_signature(sc, 4, sc->is_hash_table_symbol, sc->is_integer_symbol, \ - s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) - s7_int size = sc->default_hash_table_length; - - if (is_not_null(args)) - { - s7_pointer p = car(args); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, caller, args, sc->type_names[T_INTEGER], 1)); - size = s7_integer_clamped_if_gmp(sc, p); - if (size <= 0) /* we need s7_int here to catch (make-hash-table most-negative-fixnum) etc */ - out_of_range_error_nr(sc, caller, int_one, p, wrap_string(sc, "it should be a positive integer", 31)); - if ((size > sc->max_vector_length) || - (size >= (1LL << 32LL))) - out_of_range_error_nr(sc, caller, int_one, p, it_is_too_large_string); - - if (is_not_null(cdr(args))) - { - s7_pointer proc; - s7_pointer ht = s7_make_hash_table(sc, size); - /* check for typers */ - if (is_pair(cddr(args))) - { - s7_pointer typers = caddr(args); - if (is_pair(typers)) - { - s7_pointer keyp = car(typers), valp = cdr(typers); - if ((keyp != sc->T) || (valp != sc->T)) /* one of them is a type checker */ - { - if (((keyp != sc->T) && (!is_c_function(keyp)) && (!is_any_closure(keyp))) || - ((valp != sc->T) && (!is_c_function(valp)) && (!is_any_closure(valp)))) - wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "(key-type . value-type)", 23)); - - if ((keyp != sc->T) && - (!s7_is_aritable(sc, keyp, 1))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), - caller, typers)); - hash_table_set_procedures(ht, make_hash_table_procedures(sc)); - hash_table_set_key_typer(ht, keyp); - hash_table_set_value_typer(ht, valp); - if (is_c_function(keyp)) - { - if (!c_function_name(keyp)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), - caller, typers)); - if (c_function_has_simple_elements(keyp)) - set_has_simple_keys(ht); - if (!c_function_symbol(keyp)) - c_function_symbol(keyp) = make_symbol(sc, c_function_name(keyp), c_function_name_length(keyp)); - if (symbol_type(c_function_symbol(keyp)) != T_FREE) - set_has_hash_key_type(ht); - /* c_function_marker is not currently used in this context */ - - /* now a consistency check for eq-func and key type */ - proc = cadr(args); - if (is_c_function(proc)) - { - s7_pointer eq_sig = c_function_signature(proc); - if ((eq_sig) && - (is_pair(eq_sig)) && - (is_pair(cdr(eq_sig))) && - (!compatible_types(sc, cadr(eq_sig), c_function_symbol(keyp)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, the key type function is not compatible with the equality function: ~S", 97), - caller, typers)); - }} - else - if ((is_any_closure(keyp)) && - (!is_symbol(find_closure(sc, keyp, closure_let(keyp))))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), - caller, typers)); - if ((valp != sc->T) && - (!s7_is_aritable(sc, valp, 1))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), - caller, typers)); - if (is_c_function(valp)) - { - if (!c_function_name(valp)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), - caller, typers)); - if (c_function_has_simple_elements(valp)) - set_has_simple_values(ht); - if (!c_function_symbol(valp)) - c_function_symbol(valp) = make_symbol(sc, c_function_name(valp), c_function_name_length(valp)); - if (symbol_type(c_function_symbol(valp)) != T_FREE) - set_has_hash_value_type(ht); - } - else - if ((is_any_closure(valp)) && - (!is_symbol(find_closure(sc, valp, closure_let(valp))))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), - caller, typers)); - set_is_typed_hash_table(ht); - }} - else - if (typers != sc->F) - wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "either #f or (cons key-type-check value-type-check)", 51)); - } - - /* check eq_func */ - proc = cadr(args); - - if (is_c_function(proc)) - { - hash_set_chosen(ht); - - if (!s7_is_aritable(sc, proc, 2)) - wrong_type_error_nr(sc, caller, 2, proc, an_eq_func_string); - - if (c_function_call(proc) == g_is_equal) - { - hash_table_checker(ht) = hash_equal; - return(ht); - } - if (c_function_call(proc) == g_is_equivalent) - { - hash_table_checker(ht) = hash_equivalent; - hash_table_mapper(ht) = equivalent_hash_map; /* needed only by hash_table_equal_1 (checker_locked looks at mapper?!) */ - return(ht); - } - if (c_function_call(proc) == g_is_eq) - { - hash_table_checker(ht) = hash_eq; - hash_table_mapper(ht) = eq_hash_map; - return(ht); - } - if (c_function_call(proc) == g_strings_are_equal) - { - hash_table_checker(ht) = hash_string; - hash_table_mapper(ht) = string_eq_hash_map; - return(ht); - } -#if (!WITH_PURE_S7) - if (c_function_call(proc) == g_strings_are_ci_equal) - { - hash_table_checker(ht) = hash_ci_string; - hash_table_mapper(ht) = string_ci_eq_hash_map; - return(ht); - } - if (c_function_call(proc) == g_chars_are_ci_equal) - { - hash_table_checker(ht) = hash_ci_char; - hash_table_mapper(ht) = char_ci_eq_hash_map; - return(ht); - } -#endif - if (c_function_call(proc) == g_chars_are_equal) - { - hash_table_checker(ht) = hash_char; - hash_table_mapper(ht) = char_eq_hash_map; - return(ht); - } - if (c_function_call(proc) == g_num_eq) - { - if ((is_typed_hash_table(ht)) && - (hash_table_key_typer(ht) == global_value(sc->is_integer_symbol))) - hash_table_checker(ht) = hash_int; - else hash_table_checker(ht) = hash_number_num_eq; - return(ht); - } - if (c_function_call(proc) == g_is_eqv) - { - hash_table_checker(ht) = hash_eqv; - return(ht); - } - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "~A second argument, ~S, is not a built-in function it can handle", 64), caller, proc)); - } - /* proc not c_function */ - else - { - if (is_pair(proc)) - { - s7_pointer checker = car(proc), mapper = cdr(proc); - - hash_set_chosen(ht); - if (!((is_any_c_function(checker)) || - (is_any_closure(checker)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: first entry of type info, ~A, is ~A, but should be a function", 65), - caller, checker, type_name_string(sc, checker))); - if (!((is_any_c_function(mapper)) || - (is_any_closure(mapper)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: second entry of type info, ~A, is ~A, but should be a function", 66), - caller, mapper, type_name_string(sc, mapper))); - - if (!(s7_is_aritable(sc, checker, 2))) - wrong_type_error_nr(sc, caller, 2, checker, wrap_string(sc, "a function of two arguments", 27)); - if (!(s7_is_aritable(sc, mapper, 1))) - wrong_type_error_nr(sc, caller, 2, mapper, wrap_string(sc, "a function of one argument", 26)); - - if (is_any_c_function(checker)) - { - s7_pointer sig = c_function_signature(checker); - if ((sig) && - (is_pair(sig)) && - (car(sig) != sc->is_boolean_symbol)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A checker function, ~S, should return a boolean value", 54), caller, checker)); - hash_table_checker(ht) = hash_c_function; - } - else hash_table_checker(ht) = hash_closure; - - if (is_any_c_function(mapper)) - { - s7_pointer sig = c_function_signature(mapper); - if ((sig) && - (is_pair(sig)) && - (car(sig) != sc->is_integer_symbol)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A mapper function, ~S, should return an integer", 48), caller, mapper)); - hash_table_mapper(ht) = c_function_hash_map; - } - else hash_table_mapper(ht) = closure_hash_map; - - if (is_null(hash_table_procedures(ht))) - hash_table_set_procedures(ht, make_hash_table_procedures(sc)); - hash_table_set_procedures_checker(ht, car(proc)); /* proc = cadr(args) */ - hash_table_set_procedures_mapper(ht, cdr(proc)); - return(ht); - } - if (proc != sc->F) wrong_type_error_nr(sc, caller, 2, proc, wrap_string(sc, "a cons of two functions", 23)); - return(ht); - }}} - return(s7_make_hash_table(sc, size)); -} - -static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args) -{ - return(g_make_hash_table_1(sc, args, sc->make_hash_table_symbol)); -} - - -/* -------------------------------- make-weak-hash-table -------------------------------- */ -static s7_pointer g_make_weak_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_make_weak_hash_table "(make-weak-hash-table (size 8) eq-func typers) returns a new weak hash table" - #define Q_make_weak_hash_table s7_make_signature(sc, 4, sc->is_weak_hash_table_symbol, sc->is_integer_symbol, \ - s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) - s7_pointer table = g_make_hash_table_1(sc, args, sc->make_weak_hash_table_symbol); - set_weak_hash_table(table); - weak_hash_iters(table) = 0; - return(table); -} - -static const char *hash_table_checker_name(s7_scheme *sc, s7_pointer ht) -{ - if (hash_table_checker(ht) == hash_equal) return("equal?"); - if (hash_table_checker(ht) == hash_equivalent) return("equivalent?"); - if (hash_table_checker(ht) == hash_eq) return("eq?"); - if (hash_table_checker(ht) == hash_eqv) return("eqv?"); - if (hash_table_checker(ht) == hash_string) return("string=?"); -#if (!WITH_PURE_S7) - if (hash_table_checker(ht) == hash_ci_string) return("string-ci=?"); - if (hash_table_checker(ht) == hash_ci_char) return("char-ci=?"); -#endif - if (hash_table_checker(ht) == hash_char) return("char=?"); - if (hash_table_checker(ht) == hash_number_num_eq) return("="); - return("#f"); -} - - -/* -------------------------------- weak-hash-table? -------------------------------- */ -static s7_pointer g_is_weak_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_is_weak_hash_table "(weak-hash-table? obj) returns #t if obj is a weak hash-table" - #define Q_is_weak_hash_table sc->pl_bt - #define is_weak_hash(p) ((is_hash_table(p)) && (is_weak_hash_table(p))) - check_boolean_method(sc, is_weak_hash, sc->is_weak_hash_table_symbol, args); -} - -static void init_hash_maps(void) -{ - for (int32_t i = 0; i < NUM_TYPES; i++) - { - default_hash_map[i] = hash_map_nil; - string_eq_hash_map[i] = hash_map_nil; - char_eq_hash_map[i] = hash_map_nil; -#if (!WITH_PURE_S7) - string_ci_eq_hash_map[i] = hash_map_nil; - char_ci_eq_hash_map[i] = hash_map_nil; -#endif - closure_hash_map[i] = hash_map_closure; - c_function_hash_map[i] = hash_map_c_function; - eq_hash_map[i] = hash_map_eq; - - equal_hash_checks[i] = hash_equal_any; - default_hash_checks[i] = hash_equal; - } - default_hash_map[T_CHARACTER] = hash_map_char; - default_hash_map[T_SYMBOL] = hash_map_symbol; - default_hash_map[T_SYNTAX] = hash_map_syntax; - default_hash_map[T_STRING] = hash_map_string; - default_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector; - default_hash_map[T_HASH_TABLE] = hash_map_hash_table; - default_hash_map[T_VECTOR] = hash_map_vector; - default_hash_map[T_INT_VECTOR] = hash_map_int_vector; - default_hash_map[T_FLOAT_VECTOR] = hash_map_float_vector; - default_hash_map[T_LET] = hash_map_let; - default_hash_map[T_PAIR] = hash_map_pair; - - default_hash_map[T_INTEGER] = hash_map_int; - default_hash_map[T_RATIO] = hash_map_ratio; - default_hash_map[T_REAL] = hash_map_real; - default_hash_map[T_COMPLEX] = hash_map_complex; -#if WITH_GMP - default_hash_map[T_BIG_INTEGER] = hash_map_big_int; - default_hash_map[T_BIG_RATIO] = hash_map_big_ratio; - default_hash_map[T_BIG_REAL] = hash_map_big_real; - default_hash_map[T_BIG_COMPLEX] = hash_map_big_complex; -#endif - - string_eq_hash_map[T_STRING] = hash_map_string; - string_eq_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector; - char_eq_hash_map[T_CHARACTER] = hash_map_char; -#if (!WITH_PURE_S7) - string_ci_eq_hash_map[T_STRING] = hash_map_ci_string; - char_ci_eq_hash_map[T_CHARACTER] = hash_map_ci_char; -#endif - - for (int32_t i = 0; i < NUM_TYPES; i++) equivalent_hash_map[i] = default_hash_map[i]; - - equal_hash_checks[T_SYNTAX] = hash_equal_syntax; - equal_hash_checks[T_SYMBOL] = hash_equal_eq; - equal_hash_checks[T_CHARACTER] = hash_equal_eq; - equal_hash_checks[T_INTEGER] = hash_equal_integer; - equal_hash_checks[T_RATIO] = hash_equal_ratio; - equal_hash_checks[T_REAL] = hash_equal_real; - equal_hash_checks[T_COMPLEX] = hash_equal_complex; - - default_hash_checks[T_STRING] = hash_string; - default_hash_checks[T_INTEGER] = hash_int; - default_hash_checks[T_REAL] = hash_float; - default_hash_checks[T_SYMBOL] = hash_symbol; - default_hash_checks[T_CHARACTER] = hash_char; -} - -static void resize_hash_table(s7_scheme *sc, s7_pointer table) -{ - s7_int entries = hash_table_entries(table); - hash_entry_t **old_els = hash_table_elements(table); - s7_pointer dproc = hash_table_procedures(table); /* new block_t so we need to pass this across */ - s7_int old_size = hash_table_mask(table) + 1; - s7_int new_size = old_size * 4; - s7_int hash_mask = new_size - 1; - block_t *np = (block_t *)callocate(sc, new_size * sizeof(hash_entry_t *)); - hash_entry_t **new_els = (hash_entry_t **)(block_data(np)); - - for (s7_int i = 0; i < old_size; i++) - { - hash_entry_t *n; - for (hash_entry_t *x = old_els[i]; x; x = n) - { - s7_int loc = hash_entry_raw_hash(x) & hash_mask; - n = hash_entry_next(x); - hash_entry_next(x) = new_els[loc]; - new_els[loc] = x; - }} - liberate(sc, hash_table_block(table)); - hash_table_set_block(table, np); - hash_table_elements(table) = new_els; - hash_table_mask(table) = hash_mask; /* was new_size - 1 14-Jun-21 */ - hash_table_set_procedures(table, dproc); - hash_table_entries(table) = entries; -} - - -/* -------------------------------- hash-table-ref -------------------------------- */ -s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return(hash_entry_value((*hash_table_checker(table))(sc, table, key))); -} - -static s7_pointer g_hash_table_ref(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_ref "(hash-table-ref table key) returns the value associated with key in the hash table" - #define Q_hash_table_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T) - - s7_pointer table = car(args), nt; - if (!is_hash_table(table)) - return(method_or_bust(sc, table, sc->hash_table_ref_symbol, args, sc->type_names[T_HASH_TABLE], 1)); - nt = s7_hash_table_ref(sc, table, cadr(args)); - - if (is_pair(cddr(args))) - return(ref_index_checked(sc, global_value(sc->hash_table_ref_symbol), nt, args)); - return(nt); -} - -static s7_pointer g_hash_table_ref_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer table = car(args); - if (!is_hash_table(table)) - return(method_or_bust(sc, table, sc->hash_table_ref_symbol, args, sc->type_names[T_HASH_TABLE], 1)); - return(hash_entry_value((*hash_table_checker(table))(sc, table, cadr(args)))); -} - -static s7_pointer hash_table_ref_p_pp(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - if (!is_hash_table(table)) - return(method_or_bust(sc, table, sc->hash_table_ref_symbol, set_plist_2(sc, table, key), sc->type_names[T_HASH_TABLE], 1)); - return(hash_entry_value((*hash_table_checker(table))(sc, table, key))); -} - -static bool op_implicit_hash_table_ref_a(s7_scheme *sc) -{ - s7_pointer s = lookup_checked(sc, car(sc->code)); - if (!is_hash_table(s)) {sc->last_function = s; return(false);} - sc->value = s7_hash_table_ref(sc, s, fx_call(sc, cdr(sc->code))); - return(true); -} - -static bool op_implicit_hash_table_ref_aa(s7_scheme *sc) -{ - s7_pointer in_obj, out_key; - s7_pointer table = lookup_checked(sc, car(sc->code)); - if (!is_hash_table(table)) {sc->last_function = table; return(false);} - out_key = fx_call(sc, cdr(sc->code)); - in_obj = s7_hash_table_ref(sc, table, out_key); - if (is_hash_table(in_obj)) - sc->value = s7_hash_table_ref(sc, in_obj, fx_call(sc, cddr(sc->code))); - else sc->value = implicit_pair_index_checked(sc, table, in_obj, set_plist_2(sc, out_key, fx_call(sc, cddr(sc->code)))); /* -> implicit_index */ - return(true); -} - -static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if (args == 2) - { - s7_pointer key = caddr(expr); - if ((is_pair(key)) && (car(key) == sc->substring_symbol) && (is_global(sc->substring_symbol))) - set_c_function(key, sc->substring_uncopied); - return(sc->hash_table_ref_2); - } - return(f); -} - - -/* -------------------------------- hash-table-set! -------------------------------- */ -static s7_pointer remove_from_hash_table(s7_scheme *sc, s7_pointer table, hash_entry_t *p) -{ - hash_entry_t *x; - s7_int hash_mask, loc; - - if (p == sc->unentry) return(sc->F); - hash_mask = hash_table_mask(table); - loc = hash_entry_raw_hash(p) & hash_mask; - x = hash_table_element(table, loc); - if (x == p) - hash_table_element(table, loc) = hash_entry_next(x); - else - { - hash_entry_t *y; - for (y = x, x = hash_entry_next(x); x; y = x, x = hash_entry_next(x)) - if (x == p) - { - hash_entry_next(y) = hash_entry_next(x); - break; - }} - hash_table_entries(table)--; - if ((hash_table_entries(table) == 0) && - (hash_table_mapper(table) == default_hash_map)) - { - hash_table_checker(table) = hash_empty; - hash_clear_chosen(table); - } - liberate_block(sc, x); - return(sc->F); -} - -static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table) -{ - s7_int len = hash_table_mask(table) + 1; - hash_entry_t **entries = hash_table_elements(table); - for (s7_int i = 0; i < len; i++) - { - hash_entry_t *nxp, *lxp = entries[i]; - for (hash_entry_t *xp = entries[i]; xp; xp = nxp) - { - nxp = hash_entry_next(xp); - if (is_free_and_clear(hash_entry_key(xp))) - { - if (xp == entries[i]) - { - entries[i] = nxp; - lxp = nxp; - } - else hash_entry_next(lxp) = nxp; - liberate_block(sc, xp); - hash_table_entries(table)--; - if (hash_table_entries(table) == 0) - { - if (hash_table_mapper(table) == default_hash_map) - { - hash_table_checker(table) = hash_empty; - hash_clear_chosen(table); - } - return; - }} - else lxp = xp; - }} -} - -static void hash_table_set_default_checker(s7_pointer table, uint8_t typ) -{ - if (hash_table_checker(table) != default_hash_checks[typ]) - { - if (hash_table_checker(table) == hash_empty) - hash_table_checker(table) = default_hash_checks[typ]; - else - { - hash_table_checker(table) = hash_equal; - hash_set_chosen(table); - }} -} - -static s7_pointer hash_table_typer_symbol(s7_scheme *sc, s7_pointer typer) -{ - if (typer == sc->T) - return(sc->T); - return((is_c_function(typer)) ? c_function_symbol(typer) : find_closure(sc, typer, closure_let(typer))); -} - -static void check_hash_types(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) -{ - if (has_hash_key_type(table)) /* symbol_type and c_function_symbol exist and symbol_type is not T_FREE */ - { - if ((uint8_t)symbol_type(c_function_symbol(hash_table_key_typer(table))) != type(key)) - { - const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_key_typer(table)), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, wrap_string(sc, "hash-table-set! key", 19), 2, key, wrap_string(sc, tstr, safe_strlen(tstr))); - }} - else - { - s7_pointer kf = hash_table_key_typer(table); - if (kf != sc->T) - { - s7_pointer type_ok; - if (is_c_function(kf)) - type_ok = c_function_call(kf)(sc, set_plist_1(sc, key)); - else type_ok = s7_apply_function(sc, kf, set_plist_1(sc, key)); - if (type_ok == sc->F) - { - const char *descr = hash_table_typer_name(sc, hash_table_key_typer(table)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! second argument ~$, is ~A, but the hash-table's key type checker, ~A, rejects it", 96), - key, type_name_string(sc, key), wrap_string(sc, descr, safe_strlen(descr)))); - }}} - if (has_hash_value_type(table)) - { - if ((uint8_t)symbol_type(c_function_symbol(hash_table_value_typer(table))) != type(value)) - { - const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, sc->hash_table_set_symbol, 3, value, wrap_string(sc, tstr, safe_strlen(tstr))); - }} - else - { - s7_pointer vf = hash_table_value_typer(table); - if (vf != sc->T) - { - s7_pointer type_ok; - if (is_c_function(vf)) - type_ok = c_function_call(vf)(sc, set_plist_1(sc, value)); - else type_ok = s7_apply_function(sc, vf, set_plist_1(sc, value)); - if (type_ok == sc->F) - { - const char *descr = hash_table_typer_name(sc, hash_table_value_typer(table)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! third argument ~$, is ~A, but the hash-table's value type checker, ~A, rejects it", 97), - value, type_name_string(sc, value), wrap_string(sc, descr, safe_strlen(descr)))); - }}} -} - -static void check_hash_table_checker(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - /* check type -- raise error if incompatible with eq func set by make-hash-table */ - if (hash_table_checker(table) == hash_number_num_eq) - { - if (!is_number(key)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is =", 69), - key, type_name_string(sc, key))); - } - else - if (hash_table_checker(table) == hash_eq) - { - if (is_number(key)) /* (((type(key) >= T_INTEGER) && (type(key) < T_C_MACRO)) || (type(key) == T_PAIR)), but we might want eq? */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is eq?", 71), - key, type_name_string(sc, key))); - } - else -#if WITH_PURE_S7 - if (((hash_table_checker(table) == hash_string) && (!is_string(key))) || - ((hash_table_checker(table) == hash_char) && (!is_character(key)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70), - key, type_name_string(sc, key), - (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol : sc->char_eq_symbol)); -#else - if ((((hash_table_checker(table) == hash_string) || (hash_table_checker(table) == hash_ci_string)) && - (!is_string(key))) || - (((hash_table_checker(table) == hash_char) || (hash_table_checker(table) == hash_ci_char)) && - (!is_character(key)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70), - key, type_name_string(sc, key), - (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol : - ((hash_table_checker(table) == hash_ci_string) ? sc->string_ci_eq_symbol : - ((hash_table_checker(table) == hash_char) ? sc->char_eq_symbol : sc->char_ci_eq_symbol)))); -#endif -} - -s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) -{ - s7_int hash_mask, loc; - hash_entry_t *p, *x; - - if (value == sc->F) - return(remove_from_hash_table(sc, table, (*hash_table_checker(table))(sc, table, key))); - - if ((is_typed_hash_table(table)) && - (sc->safety >= NO_SAFETY)) - check_hash_types(sc, table, key, value); - - x = (*hash_table_checker(table))(sc, table, key); - if (x != sc->unentry) - { - hash_entry_set_value(x, T_Ext(value)); - return(value); - } - /* hash_entry_raw_hash(x) can save the hash_loc from the lookup operations, but at some added complexity in - * all the preceding code. This saves about 5% compute time best case in this function. - */ - if (!hash_chosen(table)) - hash_table_set_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */ - else - if (sc->safety > NO_SAFETY) - check_hash_table_checker(sc, table, key); - - p = mallocate_block(sc); - hash_entry_key(p) = key; - hash_entry_set_value(p, T_Ext(value)); - hash_entry_set_raw_hash(p, hash_loc(sc, table, key)); - hash_mask = hash_table_mask(table); - loc = hash_entry_raw_hash(p) & hash_mask; - hash_entry_next(p) = hash_table_element(table, loc); - hash_table_element(table, loc) = p; - hash_table_entries(table)++; - if (hash_table_entries(table) > hash_mask) - resize_hash_table(sc, table); - return(value); -} - -static s7_pointer g_hash_table_set(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table_set "(hash-table-set! table key value) sets the value associated with key in the hash table to value" - #define Q_hash_table_set s7_make_signature(sc, 4, sc->T, sc->is_hash_table_symbol, sc->T, sc->T) - - s7_pointer table = car(args); - if (!is_mutable_hash_table(table)) - return(mutable_method_or_bust(sc, table, sc->hash_table_set_symbol, args, sc->type_names[T_HASH_TABLE], 1)); - return(s7_hash_table_set(sc, table, cadr(args), caddr(args))); -} - -static s7_pointer hash_table_set_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) -{ - if (!is_mutable_hash_table(p1)) /* is_hash_table(p1) is here */ - return(mutable_method_or_bust_ppp(sc, p1, sc->hash_table_set_symbol, p1, p2, p3, sc->type_names[T_HASH_TABLE], 1)); - return(s7_hash_table_set(sc, p1, p2, p3)); -} - -static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if ((args == 3) && (optimize_op(expr) == HOP_SAFE_C_SSA)) - { - s7_pointer val = cadddr(expr); - if ((is_pair(val)) && (car(val) == sc->add_symbol) && (is_proper_list_3(sc, val)) && - ((cadr(val) == int_one) || (caddr(val) == int_one))) - { - s7_pointer add1 = (cadr(val) == int_one) ? caddr(val) : cadr(val); - if ((is_pair(add1)) && (car(add1) == sc->or_symbol) && (is_proper_list_3(sc, add1)) && - (caddr(add1) == int_zero)) - { - s7_pointer or1 = cadr(add1); - if ((is_pair(or1)) && (car(or1) == sc->hash_table_ref_symbol) && (is_proper_list_3(sc, or1)) && - (cadr(or1) == cadr(expr)) && (caddr(or1) == caddr(expr))) - /* (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)) */ - set_optimize_op(expr, HOP_HASH_TABLE_INCREMENT); - }}} - return(f); -} - - -/* -------------------------------- hash-table -------------------------------- */ -static inline s7_pointer hash_table_add(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) -{ - s7_int hash, hash_mask, loc; - hash_entry_t *p; - - if (!hash_chosen(table)) - hash_table_set_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */ - - hash_mask = hash_table_mask(table); - hash = hash_loc(sc, table, key); - loc = hash & hash_mask; - - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((hash_entry_raw_hash(x) == hash) && - (s7_is_equal(sc, hash_entry_key(x), key))) - return(value); - - p = mallocate_block(sc); - hash_entry_key(p) = key; - hash_entry_set_value(p, T_Ext(value)); - hash_entry_set_raw_hash(p, hash); - hash_entry_next(p) = hash_table_element(table, loc); - hash_table_element(table, loc) = p; - hash_table_entries(table)++; - if (hash_table_entries(table) > hash_mask) - resize_hash_table(sc, table); - return(value); -} - -static s7_pointer g_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) -{ - s7_pointer ht; - s7_int len = proper_list_length(args); - if (len & 1) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~A got an odd number of arguments: ~S", 37), caller, args)); - len /= 2; - ht = s7_make_hash_table(sc, (len > sc->default_hash_table_length) ? len : sc->default_hash_table_length); - if (len > 0) - for (s7_pointer x = args, y = cdr(args); is_pair(x); x = cddr(x), y = unchecked_cdr(cdr(y))) - if (car(y) != sc->F) - hash_table_add(sc, ht, car(x), car(y)); - return(ht); -} - -static s7_pointer g_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_hash_table "(hash-table ...) returns a hash-table containing the symbol/value pairs passed as its arguments. \ -That is, (hash-table 'a 1 'b 2) returns a new hash-table with the two key/value pairs preinstalled." - #define Q_hash_table s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->T) - return(g_hash_table_1(sc, args, sc->hash_table_symbol)); -} - -static s7_pointer g_hash_table_2(s7_scheme *sc, s7_pointer args) -{ - s7_pointer ht = s7_make_hash_table(sc, sc->default_hash_table_length); - if (cadr(args) != sc->F) - hash_table_add(sc, ht, car(args), cadr(args)); - return(ht); -} - - -/* -------------------------------- weak-hash-table -------------------------------- */ -static s7_pointer g_weak_hash_table(s7_scheme *sc, s7_pointer args) -{ - #define H_weak_hash_table "(weak-hash-table ...) returns a weak-hash-table containing the symbol/value pairs passed as its arguments. \ -That is, (weak-hash-table 'a 1 'b 2) returns a new weak-hash-table with the two key/value pairs preinstalled." - #define Q_weak_hash_table Q_hash_table - - s7_pointer table = g_hash_table_1(sc, args, sc->weak_hash_table_symbol); - set_weak_hash_table(table); - weak_hash_iters(table) = 0; - return(table); -} - -static s7_pointer hash_table_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - return((args == 2) ? sc->hash_table_2 : f); -} - -static void check_old_hash(s7_scheme *sc, s7_pointer old_hash, s7_pointer new_hash, s7_int start, s7_int end) -{ - s7_int count = 0; - s7_int old_len = hash_table_mask(old_hash) + 1; - hash_entry_t **old_lists = hash_table_elements(old_hash); - for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - if (count >= end) - return; - if (count >= start) - check_hash_types(sc, new_hash, hash_entry_key(x), hash_entry_value(x)); - } -} - -static s7_pointer hash_table_copy(s7_scheme *sc, s7_pointer old_hash, s7_pointer new_hash, s7_int start, s7_int end) -{ - s7_int old_len, new_mask, count = 0; - hash_entry_t **old_lists, **new_lists; - - if (is_typed_hash_table(new_hash)) - check_old_hash(sc, old_hash, new_hash, start, end); - - old_len = hash_table_mask(old_hash) + 1; - new_mask = hash_table_mask(new_hash); - old_lists = hash_table_elements(old_hash); - new_lists = hash_table_elements(new_hash); - - if (hash_table_entries(new_hash) == 0) - { - if ((start == 0) && - (end >= hash_table_entries(old_hash))) - { - for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - s7_int loc = hash_entry_raw_hash(x) & new_mask; - hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); - hash_entry_next(p) = new_lists[loc]; - new_lists[loc] = p; - } - hash_table_entries(new_hash) = hash_table_entries(old_hash); - return(new_hash); - } - for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - if (count >= end) - { - hash_table_entries(new_hash) = end - start; - return(new_hash); - } - if (count >= start) - { - s7_int loc = hash_entry_raw_hash(x) & new_mask; - hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); - hash_entry_next(p) = new_lists[loc]; - new_lists[loc] = p; - } - count++; - } - hash_table_entries(new_hash) = count - start; - return(new_hash); - } - - /* this can't be optimized much because we have to look for key matches (we're copying old_hash into the existing, non-empty new_hash) */ - for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - if (count >= end) - return(new_hash); - if (count >= start) - { - hash_entry_t *y = (*hash_table_checker(new_hash))(sc, new_hash, hash_entry_key(x)); - if (y != sc->unentry) - hash_entry_set_value(y, hash_entry_value(x)); - else - { - s7_int loc = hash_entry_raw_hash(x) & new_mask; - hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); - hash_entry_next(p) = new_lists[loc]; - new_lists[loc] = p; - hash_table_entries(new_hash)++; - if (!hash_chosen(new_hash)) - hash_table_set_default_checker(new_hash, type(hash_entry_key(x))); - }} - count++; - } - return(new_hash); -} - -static s7_pointer hash_table_fill(s7_scheme *sc, s7_pointer args) -{ - s7_pointer table = car(args), val = cadr(args); - if (is_immutable(table)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->fill_symbol, table)); - - if (hash_table_entries(table) > 0) - { - hash_entry_t **entries = hash_table_elements(table); - s7_int len = hash_table_mask(table) + 1; /* minimum len is 2 (see s7_make_hash_table) */ - if (val == sc->F) /* hash-table-ref returns #f if it can't find a key, so val == #f here means empty the table */ - { - hash_entry_t **hp = entries; - hash_entry_t **hn = (hash_entry_t **)(hp + len); - for (; hp < hn; hp++) - { - if (*hp) - { - hash_entry_t *p = *hp; - while (hash_entry_next(p)) p = hash_entry_next(p); - hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = *hp; - } - hp++; - if (*hp) - { - hash_entry_t *p = *hp; - while (hash_entry_next(p)) p = hash_entry_next(p); - hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = *hp; - }} - if (len >= 8) - memclr64(entries, len * sizeof(hash_entry_t *)); - else memclr(entries, len * sizeof(hash_entry_t *)); - if (hash_table_mapper(table) == default_hash_map) - { - hash_table_checker(table) = hash_empty; - hash_clear_chosen(table); - } - hash_table_entries(table) = 0; - return(val); - } - if ((is_typed_hash_table(table)) && - (((is_c_function(hash_table_value_typer(table))) && - (c_function_call(hash_table_value_typer(table))(sc, set_plist_1(sc, val)) == sc->F)) || - ((is_any_closure(hash_table_value_typer(table))) && - (s7_apply_function(sc, hash_table_value_typer(table), set_plist_1(sc, val)) == sc->F)))) - { - const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, sc->fill_symbol, 2, val, wrap_string(sc, tstr, safe_strlen(tstr))); - } - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *x = entries[i]; x; x = hash_entry_next(x)) - hash_entry_set_value(x, val); - /* keys haven't changed, so no need to mess with hash_table_checker */ - } - return(val); -} - -static s7_pointer hash_table_reverse(s7_scheme *sc, s7_pointer old_hash) -{ - s7_int len = hash_table_mask(old_hash) + 1; - hash_entry_t **old_lists = hash_table_elements(old_hash); - s7_pointer new_hash = s7_make_hash_table(sc, len); - s7_int gc_loc = gc_protect_1(sc, new_hash); - - /* old_hash checker/mapper functions don't always make sense reversed, although the key/value typers might be ok */ - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - s7_hash_table_set(sc, new_hash, hash_entry_value(x), hash_entry_key(x)); - s7_gc_unprotect_at(sc, gc_loc); - return(new_hash); -} - - -/* -------------------------------- functions -------------------------------- */ -bool s7_is_function(s7_pointer p) {return(is_c_function(p));} - -static s7_pointer fallback_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops) {return(f);} - -static void s7_function_set_class(s7_scheme *sc, s7_pointer f, s7_pointer base_f) -{ - c_function_class(f) = c_function_class(base_f); - c_function_set_base(f, base_f); -} - -static s7_pointer make_function(s7_scheme *sc, const char *name, s7_function f, s7_int req, s7_int opt, bool rst, const char *doc, s7_pointer x, c_proc_t *ptr) -{ - uint32_t ftype = T_C_FUNCTION; - - if ((req == 0) && (rst)) - ftype = T_C_RST_NO_REQ_FUNCTION; - set_full_type(x, ftype); - - c_function_data(x) = ptr; - c_function_call(x) = f; /* f is T_App but needs cast */ - c_function_set_base(x, x); - c_function_set_setter(x, sc->F); - c_function_name(x) = name; /* (procedure-name proc) => (format #f "~A" proc) */ - c_function_name_length(x) = safe_strlen(name); - c_function_documentation(x) = (doc) ? make_semipermanent_c_string(sc, doc) : NULL; - c_function_signature(x) = sc->F; - - c_function_min_args(x) = req; - c_function_optional_args(x) = opt; /* T_C_FUNCTION_STAR type may be set later, so T_Fst not usable here */ - c_function_max_args(x) = (rst) ? MAX_ARITY : req + opt; - - c_function_class(x) = ++sc->f_class; - c_function_chooser(x) = fallback_chooser; - c_function_opt_data(x) = NULL; - c_function_marker(x) = NULL; - c_function_symbol(x) = NULL; - return(x); -} - -static c_proc_t *alloc_semipermanent_function(s7_scheme *sc) -{ - #define ALLOC_FUNCTION_SIZE 256 - if (sc->alloc_function_k == ALLOC_FUNCTION_SIZE) - { - sc->alloc_function_cells = (c_proc_t *)Malloc(ALLOC_FUNCTION_SIZE * sizeof(c_proc_t)); - add_saved_pointer(sc, sc->alloc_function_cells); - sc->alloc_function_k = 0; - } - return(&(sc->alloc_function_cells[sc->alloc_function_k++])); -} - -s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - s7_pointer x = alloc_pointer(sc); - x = make_function(sc, name, f, required_args, optional_args, rest_arg, doc, x, alloc_semipermanent_function(sc)); - unheap(sc, x); - return(x); -} - -s7_pointer s7_make_safe_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - s7_pointer p = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc); - set_type_bit(p, T_SAFE_PROCEDURE); - return(p); -} - -s7_pointer s7_make_typed_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc, s7_pointer signature) -{ - s7_pointer func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc); - set_type_bit(func, T_SAFE_PROCEDURE); - if (signature) c_function_signature(func) = signature; - return(func); -} - - -/* -------------------------------- procedure? -------------------------------- */ -bool s7_is_procedure(s7_pointer x) {return(is_procedure(x));} - -static s7_pointer g_is_procedure(s7_scheme *sc, s7_pointer args) -{ - #define H_is_procedure "(procedure? obj) returns #t if obj is a procedure" - #define Q_is_procedure sc->pl_bt - return(make_boolean(sc, is_procedure(car(args)))); -} - - -static void s7_function_set_setter(s7_scheme *sc, s7_pointer getter, s7_pointer setter) -{ - /* this is internal, used only with c_function setters, so we don't need to worry about the GC mark choice */ - c_function_set_setter(global_value(getter), global_value(setter)); -} - -s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_body(p) : sc->nil);} -s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_let(p) : sc->nil);} -s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_args(p) : sc->nil);} - - -/* -------------------------------- procedure-source -------------------------------- */ -static s7_pointer procedure_type_to_symbol(s7_scheme *sc, int32_t type) -{ - switch (type) - { - case T_CLOSURE: return(sc->lambda_symbol); - case T_CLOSURE_STAR: return(sc->lambda_star_symbol); - case T_MACRO: return(sc->macro_symbol); - case T_MACRO_STAR: return(sc->macro_star_symbol); - case T_BACRO: return(sc->bacro_symbol); - case T_BACRO_STAR: return(sc->bacro_star_symbol); - default: if (S7_DEBUGGING) fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); - } - return(sc->lambda_symbol); -} - -static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args) -{ - #define H_procedure_source "(procedure-source func) tries to return the definition of func" - #define Q_procedure_source s7_make_signature(sc, 2, sc->is_list_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) - /* make it look like a scheme-level lambda */ - s7_pointer p = car(args); - - if (is_symbol(p)) - { - if ((symbol_ctr(p) == 0) || ((p = s7_symbol_value(sc, p)) == sc->undefined)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "procedure-source arg, '~S, is unbound", 37), car(args))); - } - if ((is_c_function(p)) || (is_c_macro(p))) - return(sc->nil); - - check_method(sc, p, sc->procedure_source_symbol, set_plist_1(sc, p)); - if (has_closure_let(p)) - { - s7_pointer body = closure_body(p); - /* perhaps if this function has been removed from the heap, it would be better to use copy_body (as in s7_copy)? */ - if (is_safe_closure_body(body)) - clear_safe_closure_body(body); - return(append_in_place(sc, list_2(sc, procedure_type_to_symbol(sc, type(p)), closure_args(p)), body)); - } - if (!is_procedure(p)) - sole_arg_wrong_type_error_nr(sc, sc->procedure_source_symbol, p, a_procedure_or_a_macro_string); - return(sc->nil); -} - - -/* -------------------------------- *current-function* -------------------------------- */ -static s7_pointer let_to_function(s7_scheme *sc, s7_pointer e) -{ - if ((e == sc->rootlet) || (!is_let(e))) - return(sc->F); - if (!((is_funclet(e)) || (is_maclet(e)))) - return(sc->F); - if ((has_let_file(e)) && - (let_file(e) <= (s7_int)sc->file_names_top) && - (let_line(e) > 0)) - return(list_3(sc, funclet_function(e), sc->file_names[let_file(e)], make_integer(sc, let_line(e)))); - return(funclet_function(e)); -} - -static s7_pointer g_function(s7_scheme *sc, s7_pointer args) -{ - #define H_function "(*function* e) returns the current function in e" - #define Q_function s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol) - - s7_pointer e, sym = NULL, fname, fval; - if (is_null(args)) /* (*function*) is akin to __func__ in C */ - { - for (e = sc->curlet; is_let(e); e = let_outlet(e)) - if ((is_funclet(e)) || (is_maclet(e))) - break; - return(let_to_function(sc, e)); - } - e = car(args); - if (!is_let(e)) - sole_arg_wrong_type_error_nr(sc, sc->_function__symbol, e, sc->type_names[T_LET]); - if (is_pair(cdr(args))) - { - sym = cadr(args); - if (!is_symbol(sym)) - wrong_type_error_nr(sc, sc->_function__symbol, 2, sym, sc->type_names[T_SYMBOL]); - } - - if (e == sc->rootlet) - return(sc->F); - if (!((is_funclet(e)) || (is_maclet(e)))) - e = let_outlet(e); - if (is_null(cdr(args))) - return(let_to_function(sc, e)); - - if ((e == sc->rootlet) || (!is_let(e))) - return(sc->F); - if (!((is_funclet(e)) || (is_maclet(e)))) - return(sc->F); - - if (is_keyword(sym)) - sym = keyword_symbol(sym); - fname = funclet_function(e); - fval = s7_symbol_local_value(sc, fname, e); - - if (sym == sc->name_symbol) return(fname); - if (sym == sc->signature_symbol) return(s7_signature(sc, fval)); - if (sym == sc->arity_symbol) return(s7_arity(sc, fval)); - if (sym == sc->documentation_symbol) return(s7_make_string(sc, s7_documentation(sc, fval))); - if (sym == sc->value_symbol) return(fval); - if ((sym == sc->line_symbol) && (has_let_file(e))) return(make_integer(sc, let_line(e))); - if ((sym == sc->file_symbol) && (has_let_file(e))) return(sc->file_names[let_file(e)]); - if (sym == make_symbol(sc, "funclet", 7)) return(e); - if (sym == make_symbol(sc, "source", 6)) return(g_procedure_source(sc, set_plist_1(sc, fval))); - if ((sym == make_symbol(sc, "arglist", 7)) && ((is_any_closure(fval)) || (is_any_macro(fval)))) return(closure_args(fval)); - return(sc->F); -} - - -/* -------------------------------- funclet -------------------------------- */ -s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_let(p) : sc->rootlet);} - -static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args) -{ - #define H_funclet "(funclet func) tries to return a function's definition environment" - #define Q_funclet s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \ - s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_symbol_symbol)) - s7_pointer p = car(args), e; - if (is_symbol(p)) - { - if ((symbol_ctr(p) == 0) || ((p = s7_symbol_value(sc, p)) == sc->undefined)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "funclet argument, '~S, is unbound", 33), car(args))); /* not p here */ - } - check_method(sc, p, sc->funclet_symbol, args); - - if (!((is_any_procedure(p)) || (is_c_object(p)))) - sole_arg_wrong_type_error_nr(sc, sc->funclet_symbol, p, a_procedure_or_a_macro_string); - e = find_let(sc, p); - if ((is_null(e)) && - (!is_c_object(p))) /* rootlet is not the c_object let */ - return(sc->rootlet); - return(e); -} - - -/* -------------------------------- s7_define_function and friends -------------------------------- - * - * all c_func* are semipermanent, but they might be local: (let () (load "libm.scm" (curlet)) ...) - * but there's no way to tell in general that the let is not exported. - */ -s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); - return(sym); -} - -s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - /* returns (string->symbol name), not the c_proc_t func */ - s7_pointer func = s7_make_safe_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); - return(sym); -} - -s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature) -{ - /* returns (string->symbol name), not the c_proc_t func */ - s7_pointer func = s7_make_typed_function(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature); - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); - c_function_set_marker(func, NULL); - return(sym); -} - -static s7_pointer define_bool_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int optional_args, const char *doc, s7_pointer signature, int32_t sym_to_type, - void (*marker)(s7_pointer p, s7_int top), - bool simple, s7_function bool_setter) -{ - s7_pointer bfunc; - s7_pointer func = s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc, signature); - s7_pointer sym = make_symbol_with_strlen(sc, name); - s7_define(sc, sc->nil, sym, func); - if (sym_to_type != T_FREE) - symbol_set_type(sym, sym_to_type); - c_function_symbol(func) = sym; - c_function_set_marker(func, marker); - if (simple) c_function_set_has_simple_elements(func); - c_function_set_bool_setter(func, bfunc = s7_make_safe_function(sc, name, bool_setter, 2, 0, false, NULL)); - c_function_set_has_bool_setter(func); - c_function_set_setter(bfunc, func); - set_is_bool_function(bfunc); - return(sym); -} - -s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature) -{ - /* returns (string->symbol name), not the c_proc_t func */ - s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - if (signature) c_function_signature(func) = signature; - s7_define(sc, sc->nil, sym, func); - return(sym); -} - -s7_pointer s7_define_semisafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature) -{ - s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - if (signature) c_function_signature(func) = signature; - set_is_semisafe(func); - s7_define(sc, sc->nil, sym, func); - return(sym); -} - -s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) -{ - s7_pointer func, local_args; - char *internal_arglist; - s7_int n_args, len = safe_strlen(arglist); - s7_int gc_loc; - block_t *b = inline_mallocate(sc, len + 4); - - internal_arglist = (char *)block_data(b); - internal_arglist[0] = '\''; - internal_arglist[1] = '('; - memcpy((void *)(internal_arglist + 2), (void *)arglist, len); - internal_arglist[len + 2] = ')'; - internal_arglist[len + 3] = '\0'; - local_args = s7_eval_c_string(sc, internal_arglist); - gc_loc = gc_protect_1(sc, local_args); - liberate(sc, b); - n_args = s7_list_length(sc, local_args); - if (n_args < 0) - { - s7_warn(sc, 256, "%s rest argument is not supported in C-side define*: %s\n", name, arglist); - n_args = -n_args; - } - func = s7_make_function(sc, name, fnc, 0, n_args, false, doc); - - if (n_args > 0) - { - s7_pointer p = local_args; - s7_pointer *names = (s7_pointer *)permalloc(sc, n_args * sizeof(s7_pointer)); - s7_pointer *defaults = (s7_pointer *)permalloc(sc, n_args * sizeof(s7_pointer)); - - set_full_type(func, T_C_FUNCTION_STAR | T_UNHEAP); /* unheap from s7_make_function */ - c_function_call_args(func) = NULL; - c_function_arg_names(func) = names; - c_function_arg_defaults(func) = defaults; - c_func_set_simple_defaults(func); - /* (define* (f :allow-other-keys) 32) -> :allow-other-keys can't be the only parameter: (:allow-other-keys) */ - - for (s7_int i = 0; i < n_args; p = cdr(p), i++) - { - s7_pointer arg = car(p); - if (arg == sc->allow_other_keys_keyword) - { - if (is_not_null(cdr(p))) - s7_warn(sc, 256, "%s :allow-other-keys should be the last parameter: %s\n", name, arglist); - if (p == local_args) - s7_warn(sc, 256, "%s :allow-other-keys can't be the only parameter: %s\n", name, arglist); - c_function_set_allow_other_keys(func); /* local_args is local, so it can't carry the bit */ - n_args--; - c_function_optional_args(func) = n_args; - c_function_max_args(func) = n_args; /* apparently not counting keywords */ - } - else - if (is_pair(arg)) /* there is a default */ - { - names[i] = symbol_to_keyword(sc, car(arg)); - defaults[i] = cadr(arg); - remove_from_heap(sc, cadr(arg)); - if ((is_pair(defaults[i])) || - (is_normal_symbol(defaults[i]))) - { - c_func_clear_simple_defaults(func); - mark_function[T_C_FUNCTION_STAR] = mark_c_proc_star; - }} - else - { - if (arg == sc->rest_keyword) - s7_warn(sc, 256, "%s :rest is not supported in C-side define*: %s\n", name, arglist); - names[i] = symbol_to_keyword(sc, arg); - defaults[i] = sc->F; - }}} - else set_full_type(func, T_C_FUNCTION | T_UNHEAP); - - s7_gc_unprotect_at(sc, gc_loc); - return(func); -} - -s7_pointer s7_make_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) -{ - s7_pointer func = s7_make_function_star(sc, name, fnc, arglist, doc); - set_full_type(func, full_type(func) | T_SAFE_PROCEDURE); /* don't step on the c_func_has_simple_defaults flag */ - if (is_c_function_star(func)) /* thunk -> c_function */ - c_function_call_args(func) = semipermanent_list(sc, c_function_optional_args(func)); - return(func); -} - -static void define_function_star_1(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, bool safe, s7_pointer signature) -{ - s7_pointer func; - if (safe) - func = s7_make_safe_function_star(sc, name, fnc, arglist, doc); - else func = s7_make_function_star(sc, name, fnc, arglist, doc); - s7_define(sc, sc->nil, make_symbol_with_strlen(sc, name), func); - if (signature) c_function_signature(func) = signature; -} - -void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) -{ - define_function_star_1(sc, name, fnc, arglist, doc, false, NULL); -} - -void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) -{ - define_function_star_1(sc, name, fnc, arglist, doc, true, NULL); -} - -void s7_define_typed_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, s7_pointer signature) -{ - define_function_star_1(sc, name, fnc, arglist, doc, true, signature); -} - - -s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) -{ - s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); - s7_pointer sym = make_symbol_with_strlen(sc, name); - set_full_type(func, T_C_MACRO | T_DONT_EVAL_ARGS | T_UNHEAP); /* s7_make_function includes T_UNHEAP */ - s7_define(sc, sc->nil, sym, func); - return(sym); -} - - -/* -------------------------------- macro? -------------------------------- */ -bool s7_is_macro(s7_scheme *sc, s7_pointer x) {return(is_any_macro(x));} -static bool is_macro_b(s7_pointer x) {return(is_any_macro(x));} - -static s7_pointer g_is_macro(s7_scheme *sc, s7_pointer args) -{ - #define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro" - #define Q_is_macro sc->pl_bt - check_boolean_method(sc, is_any_macro, sc->is_macro_symbol, args); -} - -static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args); - -static s7_pointer s7_macroexpand(s7_scheme *sc, s7_pointer mac, s7_pointer args) -{ - int32_t arg_len; - if (!s7_is_proper_list(sc, args)) - return(sc->F); - - arg_len = proper_list_length(args); - if (!closure_is_aritable(sc, mac, closure_args(mac), arg_len)) - return(sc->F); - - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = mac; - sc->args = args; - sc->curlet = make_let(sc, closure_let(sc->code)); - eval(sc, OP_APPLY_LAMBDA); - return(sc->value); -} - - -/* -------------------------------- documentation -------------------------------- */ -const char *s7_documentation(s7_scheme *sc, s7_pointer x) -{ - s7_pointer val; - if (is_symbol(x)) - { - if (is_keyword(x)) return(NULL); - if (symbol_has_help(x)) - return(symbol_help(x)); - x = s7_symbol_value(sc, x); /* this is needed by Snd */ - } - if ((is_any_c_function(x)) || - (is_c_macro(x))) - return((char *)c_function_documentation(x)); - - if (is_syntax(x)) - return(syntax_documentation(x)); - - val = funclet_entry(sc, x, sc->local_documentation_symbol); - if ((val) && (is_string(val))) - return(string_value(val)); - - if (has_closure_let(x)) - { - val = closure_body(x); - if ((is_pair(val)) && (is_string(car(val)))) - return((char *)string_value(car(val))); - } - return(NULL); -} - -static s7_pointer g_documentation(s7_scheme *sc, s7_pointer args) -{ - #define H_documentation "(documentation obj) returns obj's documentation string" - #define Q_documentation s7_make_signature(sc, 2, sc->is_string_symbol, sc->T) /* should (documentation 1) be an error? */ - - s7_pointer p = car(args); - if (is_symbol(p)) - { - if ((symbol_has_help(p)) && - (is_global(p))) - return(s7_make_string(sc, symbol_help(p))); - p = s7_symbol_value(sc, p); - } - /* (documentation func) should act like (documentation abs) -- available without (openlet (funclet func)) or (openlet func) - * so we check that case ahead of time here, rather than going through check_method which does not - * call find_let unless has_active_methods(sc, func). Adding T_HAS_METHODS to all closures causes other troubles. - */ - if (has_closure_let(p)) - { - s7_pointer func = funclet_entry(sc, p, sc->documentation_symbol); - if (func) - return(s7_apply_function(sc, func, args)); - func = closure_body(p); - if ((is_pair(func)) && (is_string(car(func)))) - return(car(func)); - } - /* it would be neat if this would work (define x (let ((+documentation+ "hio")) (vector 1 2 3))) (documentation x) */ - check_method(sc, p, sc->documentation_symbol, args); - return(s7_make_string(sc, s7_documentation(sc, p))); -} - -const char *s7_set_documentation(s7_scheme *sc, s7_pointer sym, const char *new_doc) -{ - if (is_keyword(sym)) return(NULL); - if (is_symbol(sym)) - { - symbol_set_has_help(sym); - symbol_set_help(sym, copy_string(new_doc)); - add_saved_pointer(sc, symbol_help(sym)); - } - return(new_doc); -} - - -/* -------------------------------- help -------------------------------- */ -const char *s7_help(s7_scheme *sc, s7_pointer obj) -{ - if (is_syntax(obj)) - return(syntax_documentation(obj)); - - if (is_symbol(obj)) - { - /* here look for name */ - if (s7_documentation(sc, obj)) - return(s7_documentation(sc, obj)); - obj = s7_symbol_value(sc, obj); - } - if (is_any_procedure(obj)) - return(s7_documentation(sc, obj)); - - if (obj == sc->s7_starlet) - return("*s7* is a let that gives access to s7's internal state: e.g. (*s7* 'print-length)"); - - /* if is string, apropos? (can scan symbol table) */ - return(NULL); -} - -static s7_pointer g_help(s7_scheme *sc, s7_pointer args) -{ - #define H_help "(help obj) returns obj's documentation" - #define Q_help s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_boolean_symbol), sc->T) - const char *doc; - check_method(sc, car(args), sc->help_symbol, args); - doc = s7_help(sc, car(args)); - return((doc) ? s7_make_string(sc, doc) : sc->F); -} - - -/* -------------------------------- signature -------------------------------- */ -static void init_signatures(s7_scheme *sc) -{ - sc->string_signature = s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol); - sc->byte_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol); - sc->vector_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol); - sc->float_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_float_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol); - sc->int_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol); - sc->c_object_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T); - sc->let_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol); - sc->hash_table_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T); - sc->pair_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol); -} - -static s7_pointer g_signature(s7_scheme *sc, s7_pointer args) -{ - #define H_signature "(signature obj) returns obj's signature" - #define Q_signature s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T) - - s7_pointer p = car(args); - switch (type(p)) - { - case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: - case T_C_FUNCTION_STAR: case T_C_MACRO: - return((s7_pointer)c_function_signature(p)); - - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - { - s7_pointer func = funclet_entry(sc, p, sc->local_signature_symbol); - if (func) return(func); - func = funclet_entry(sc, p, sc->signature_symbol); - return((func) ? s7_apply_function(sc, func, args) : sc->F); - } - - case T_VECTOR: - if (vector_length(p) == 0) return(sc->F); /* sig () is #f so sig #() should be #f */ - if (!is_typed_vector(p)) - return(sc->vector_signature); - { - s7_pointer lst = list_3(sc, typed_vector_typer_symbol(sc, p), sc->is_vector_symbol, sc->is_integer_symbol); - set_cdddr(lst, cddr(lst)); - return(lst); - } - - case T_FLOAT_VECTOR: return((vector_length(p) == 0) ? sc->F : sc->float_vector_signature); - case T_INT_VECTOR: return((vector_length(p) == 0) ? sc->F : sc->int_vector_signature); - case T_BYTE_VECTOR: return((vector_length(p) == 0) ? sc->F : sc->byte_vector_signature); - case T_PAIR: return(sc->pair_signature); - case T_STRING: return(sc->string_signature); - - case T_HASH_TABLE: - if (is_typed_hash_table(p)) - return(list_3(sc, - hash_table_typer_symbol(sc, hash_table_value_typer(p)), - sc->is_hash_table_symbol, - hash_table_typer_symbol(sc, hash_table_key_typer(p)))); - return(sc->hash_table_signature); - - case T_ITERATOR: - p = iterator_sequence(p); - if ((is_hash_table(p)) || (is_let(p))) /* cons returned -- would be nice to include the car/cdr types if known */ - return(list_1(sc, sc->is_pair_symbol)); - p = g_signature(sc, set_plist_1(sc, p)); - return(list_1(sc, (is_pair(p)) ? car(p) : sc->T)); - - case T_C_OBJECT: - check_method(sc, p, sc->signature_symbol, args); - return(sc->c_object_signature); - - case T_LET: - check_method(sc, p, sc->signature_symbol, args); - return(sc->let_signature); - - case T_SYMBOL: - /* this used to get the symbol's value and call g_signature on that */ - { - s7_pointer slot = lookup_slot_from(p, sc->curlet); - if ((is_slot(slot)) && (slot_has_setter(slot))) - { - s7_pointer setter = slot_setter(slot); - p = g_signature(sc, set_plist_1(sc, setter)); - if (is_pair(p)) - return(list_1(sc, car(p))); - }} - break; - - default: - break; - } - return(sc->F); -} - -s7_pointer s7_signature(s7_scheme *sc, s7_pointer func) {return(g_signature(sc, set_plist_1(sc, func)));} - - -/* -------------------------------- dynamic-wind -------------------------------- */ -static s7_pointer closure_or_f(s7_scheme *sc, s7_pointer p) -{ - s7_pointer body; - if (!is_closure(p)) return(p); - body = closure_body(p); - if (is_pair(cdr(body))) return(p); - if (!is_pair(car(body))) return(sc->F); - return((caar(body) == sc->quote_symbol) ? sc->F : p); -} - -static s7_pointer make_baffled_closure(s7_scheme *sc, s7_pointer inp) -{ - /* for dynamic-wind to protect initial and final functions from call/cc */ - s7_pointer nclo = make_closure_unchecked(sc, sc->nil, closure_body(inp), type(inp), 0); /* always preceded by new dw cell */ - s7_pointer let = make_let(sc, closure_let(inp)); /* let_outlet(let) = closure_let(inp) */ - set_baffle_let(let); - set_let_baffle_key(let, sc->baffle_ctr++); - closure_set_let(nclo, let); - return(nclo); -} - -static bool is_dwind_thunk(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_MACRO: case T_BACRO: case T_CLOSURE: case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: - return(is_null(closure_args(x))); /* this case does not match is_aritable -- it could be loosened -- arity=0 below would need fixup */ - case T_C_FUNCTION: - return(c_function_is_aritable(x, 0)); - case T_C_FUNCTION_STAR: - return(c_function_max_args(x) >= 0); - case T_C_MACRO: - return((c_macro_min_args(x) <= 0) && (c_macro_max_args(x) >= 0)); - case T_GOTO: case T_CONTINUATION: case T_C_RST_NO_REQ_FUNCTION: - return(true); - } - return(x == sc->F); /* (dynamic-wind #f (lambda () 3) #f) */ -} - -static s7_pointer g_dynamic_wind_unchecked(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p, inp, outp; - - new_cell(sc, p, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ - dynamic_wind_in(p) = closure_or_f(sc, car(args)); - dynamic_wind_body(p) = cadr(args); - dynamic_wind_out(p) = closure_or_f(sc, caddr(args)); - - inp = dynamic_wind_in(p); - if ((is_any_closure(inp)) && (!is_safe_closure(inp))) /* wrap this use of inp in a with-baffle */ - dynamic_wind_in(p) = make_baffled_closure(sc, inp); - - outp = dynamic_wind_out(p); - if ((is_any_closure(outp)) && (!is_safe_closure(outp))) - dynamic_wind_out(p) = make_baffled_closure(sc, outp); - - /* since we don't care about the in and out results, and they are thunks, if the body is not a pair, - * or is a quoted thing, we just ignore that function. - */ - push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); /* args will be the saved result, code = s7_dynwind_t obj */ - if (inp != sc->F) - { - dynamic_wind_state(p) = DWIND_INIT; - push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(p)); - } - else - { - dynamic_wind_state(p) = DWIND_BODY; - push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_body(p)); - } - return(sc->F); -} - -static s7_pointer g_dynamic_wind_init(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p, inp = closure_or_f(sc, car(args)); - new_cell(sc, p, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ - dynamic_wind_in(p) = inp; - dynamic_wind_body(p) = cadr(args); - dynamic_wind_out(p) = sc->F; - if ((is_any_closure(inp)) && (!is_safe_closure(inp))) /* wrap this use of inp in a with-baffle */ - dynamic_wind_in(p) = make_baffled_closure(sc, inp); - push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); /* args will be the saved result, code = s7_dynwind_t obj */ - dynamic_wind_state(p) = DWIND_INIT; - push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(p)); - return(sc->F); -} - -static s7_pointer g_dynamic_wind_body(s7_scheme *sc, s7_pointer args) -{ - push_stack(sc, OP_APPLY, sc->nil, cadr(args)); - return(sc->F); -} - -static s7_pointer g_dynamic_wind(s7_scheme *sc, s7_pointer args) -{ - #define H_dynamic_wind "(dynamic-wind init body finish) calls init, then body, then finish, \ -each a function of no arguments, guaranteeing that finish is called even if body is exited" - #define Q_dynamic_wind s7_make_signature(sc, 4, sc->values_symbol, \ - s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol), \ - sc->is_procedure_symbol, \ - s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol)) - - if (!is_dwind_thunk(sc, car(args))) - return(method_or_bust(sc, car(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 1)); - if (!is_thunk(sc, cadr(args))) - return(method_or_bust(sc, cadr(args), sc->dynamic_wind_symbol, args, a_thunk_string, 2)); - if (!is_dwind_thunk(sc, caddr(args))) - return(method_or_bust(sc, caddr(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 3)); - - /* this won't work: - (let ((final (lambda (a b c) (list a b c)))) - (dynamic-wind - (lambda () #f) - (lambda () (set! final (lambda () (display "in final")))) - final)) - * but why not? 'final' is a thunk by the time it is evaluated. catch (the error handler) is similar. - * It can't work here because we set up the dynamic_wind_out slot below and - * even if the thunk check was removed, we'd still be trying to apply the original function. - */ - return(g_dynamic_wind_unchecked(sc, args)); -} - -static bool is_lambda(s7_scheme *sc, s7_pointer sym) -{ - return((sym == sc->lambda_symbol) && (symbol_id(sym) == 0)); /* do we need (!sc->in_with_let) ? */ - /* symbol_id=0 means it has never been rebound (T_GLOBAL might not be set for initial stuff) */ -} - -static int32_t is_ok_thunk(s7_scheme *sc, s7_pointer arg) /* used only in dynamic_wind_chooser */ -{ - /* 0 = not ok, 1 = ok but not simple, 2 = ok body is just #f, 3 = #f */ - if (arg == sc->F) return(3); - if ((is_pair(arg)) && - (is_lambda(sc, car(arg))) && - (is_pair(cdr(arg))) && - (is_null(cadr(arg))) && /* (lambda () ...) */ - (is_pair(cddr(arg))) && - (s7_is_proper_list(sc, cddr(arg)))) - return(((is_null(cdddr(arg))) && (caddr(arg) == sc->F)) ? 2 : 1); /* 2: (lambda () #f) */ - return(0); -} - -static s7_pointer dynamic_wind_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool unused_ops) -{ - if ((args == 3) && - (is_ok_thunk(sc, caddr(expr)))) - { - int32_t init = is_ok_thunk(sc, cadr(expr)); - int32_t end = is_ok_thunk(sc, cadddr(expr)); - if ((init > 1) && (end > 1)) return(sc->dynamic_wind_body); - if ((init > 0) && (end > 1)) return(sc->dynamic_wind_init); - if ((init > 0) && (end > 0)) return(sc->dynamic_wind_unchecked); - } - return(f); -} - -s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish) -{ - /* this is essentially s7_call with a dynamic-wind wrapper around "body" */ - declare_jump_info(); - store_jump_info(sc); - set_jump_info(sc, DYNAMIC_WIND_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - } - else - { - s7_pointer p; - push_stack_direct(sc, OP_EVAL_DONE); /* this is ok because we have called setjmp etc */ - sc->args = sc->nil; - new_cell(sc, p, T_DYNAMIC_WIND); - dynamic_wind_in(p) = T_Ext(init); - dynamic_wind_body(p) = T_Ext(body); - dynamic_wind_out(p) = T_Ext(finish); - push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); - if (init != sc->F) - { - dynamic_wind_state(p) = DWIND_INIT; - sc->code = init; - } - else - { - dynamic_wind_state(p) = DWIND_BODY; - sc->code = body; - } - eval(sc, OP_APPLY); - } - restore_jump_info(sc); - - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); -} - -static void op_unwind_output(s7_scheme *sc) -{ - bool is_file = is_file_port(sc->code); - - if ((is_output_port(sc->code)) && - (!port_is_closed(sc->code))) - s7_close_output_port(sc, sc->code); /* may call fflush */ - if (((is_output_port(sc->args)) && - (!port_is_closed(sc->args))) || - (sc->args == sc->F)) - set_current_output_port(sc, sc->args); - if ((is_file) && - (is_multiple_value(sc->value))) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static void op_unwind_input(s7_scheme *sc) -{ - /* sc->code is an input port */ - if (!port_is_closed(sc->code)) - s7_close_input_port(sc, sc->code); - if ((is_input_port(sc->args)) && - (!port_is_closed(sc->args))) - set_current_input_port(sc, sc->args); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static bool op_dynamic_wind(s7_scheme *sc) -{ - if (dynamic_wind_state(sc->code) == DWIND_INIT) - { - dynamic_wind_state(sc->code) = DWIND_BODY; - push_stack(sc, OP_DYNAMIC_WIND, sc->nil, sc->code); - sc->code = dynamic_wind_body(sc->code); - sc->args = sc->nil; - return(true); /* goto apply */ - } - if (dynamic_wind_state(sc->code) == DWIND_BODY) - { - dynamic_wind_state(sc->code) = DWIND_FINISH; - if (dynamic_wind_out(sc->code) != sc->F) - { - push_stack(sc, OP_DYNAMIC_WIND, sc->value, sc->code); - sc->code = dynamic_wind_out(sc->code); - sc->args = sc->nil; - return(true); - } - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(false); /* goto start */ - } - if (is_multiple_value(sc->args)) /* (+ 1 (dynamic-wind (lambda () #f) (lambda () (values 2 3 4)) (lambda () #f)) 5) */ - sc->value = splice_in_values(sc, multiple_value(sc->args)); - else sc->value = sc->args; /* value saved above */ - return(false); -} - - -/* -------------------------------- c-object? -------------------------------- */ -bool s7_is_c_object(s7_pointer p) {return(is_c_object(p));} - -static s7_pointer g_is_c_object(s7_scheme *sc, s7_pointer args) -{ - #define H_is_c_object "(c-object? obj) returns #t is obj is a c-object." - #define Q_is_c_object sc->pl_bt - s7_pointer obj = car(args); - if (is_c_object(obj)) return(sc->T); - if (!has_active_methods(sc, obj)) return(sc->F); - return(apply_boolean_method(sc, obj, sc->is_c_object_symbol)); -} - - -/* -------------------------------- c-object-type -------------------------------- */ -static noreturn void apply_error_nr(s7_scheme *sc, s7_pointer obj, s7_pointer args) -{ - /* the operator type is needed here else the error message is confusing: - * (apply '+ (list 1 2))) -> ;attempt to apply + to (1 2)? - * but using current_code(sc) to get the context is not optimal: - * (1 (bignum 4))) -> ;attempt to apply an integer 1 to (4) in (bignum 4)? - */ - if (is_null(obj)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "attempt to apply nil to ~S in ~S?", 33), - args, current_code(sc))); - error_nr(sc, sc->syntax_error_symbol, - set_elist_5(sc, wrap_string(sc, "attempt to apply ~A ~S to ~S in ~S?", 35), - type_name_string(sc, obj), obj, args, current_code(sc))); -} - -static void fallback_free(void *value) {} -static void fallback_mark(void *value) {} - -static s7_pointer fallback_ref(s7_scheme *sc, s7_pointer args) {apply_error_nr(sc, car(args), cdr(args)); return(NULL);} -static s7_pointer fallback_set(s7_scheme *sc, s7_pointer args) {syntax_error_nr(sc, "attempt to set ~S?", 18, car(args)); return(NULL);} -static s7_pointer fallback_length(s7_scheme *sc, s7_pointer obj) {return(sc->F);} - -s7_int s7_c_object_type(s7_pointer obj) {return((is_c_object(obj)) ? c_object_type(obj) : -1);} - -static s7_pointer g_c_object_type(s7_scheme *sc, s7_pointer args) -{ - #define H_c_object_type "(c-object-type obj) returns the c_object's type tag." - #define Q_c_object_type s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_c_object_symbol) - - s7_pointer p = car(args); - if (is_c_object(p)) - return(make_integer(sc, c_object_type(p))); /* this is the c_object_types table index = tag */ - - /* method or bust with only one arg -- sole_arg_method_or_bust? */ - if (!has_active_methods(sc, p)) - sole_arg_wrong_type_error_nr(sc, sc->c_object_type_symbol, p, sc->type_names[T_C_OBJECT]); - return(find_and_apply_method(sc, p, sc->c_object_type_symbol, args)); -} - -static s7_pointer g_c_object_set(s7_scheme *sc, s7_pointer args) /* called in c_object_set_function */ -{ - s7_pointer obj = car(args); - if (!is_c_object(obj)) /* (call/cc (setter (block))) will call c-object-set! with the continuation as the argument! */ - wrong_type_error_nr(sc, make_symbol(sc, "c-object-set!", 13), 1, obj, sc->type_names[T_C_OBJECT]); - return((*(c_object_set(sc, obj)))(sc, args)); -} - -s7_int s7_make_c_type(s7_scheme *sc, const char *name) -{ - c_object_t *c_type; - s7_int tag = sc->num_c_object_types++; - - if (tag >= sc->c_object_types_size) - { - if (sc->c_object_types_size == 0) - { - sc->c_object_types_size = 8; - sc->c_object_types = (c_object_t **)Calloc(sc->c_object_types_size, sizeof(c_object_t *)); - } - else - { - sc->c_object_types_size = tag * 2; - sc->c_object_types = (c_object_t **)Realloc((void *)(sc->c_object_types), sc->c_object_types_size * sizeof(c_object_t *)); - }} - c_type = (c_object_t *)Calloc(1, sizeof(c_object_t)); /* Malloc+field=NULL is slightly faster here */ - sc->c_object_types[tag] = c_type; - c_type->type = tag; - c_type->scheme_name = make_permanent_string(name); - c_type->getter = sc->F; - c_type->setter = sc->F; - c_type->free = fallback_free; - c_type->mark = fallback_mark; - c_type->ref = fallback_ref; - c_type->set = fallback_set; - c_type->outer_type = T_C_OBJECT; - c_type->length = fallback_length; - /* all other fields are NULL */ - return(tag); -} - -void s7_c_type_set_gc_free(s7_scheme *sc, s7_int tag, s7_pointer (*gc_free)(s7_scheme *sc, s7_pointer obj)) {sc->c_object_types[tag]->gc_free = gc_free;} -void s7_c_type_set_gc_mark(s7_scheme *sc, s7_int tag, s7_pointer (*gc_mark)(s7_scheme *sc, s7_pointer obj)) {sc->c_object_types[tag]->gc_mark = gc_mark;} -void s7_c_type_set_equal(s7_scheme *sc, s7_int tag, bool (*equal)(void *value1, void *value2)) {sc->c_object_types[tag]->eql = equal;} -void s7_c_type_set_is_equal(s7_scheme *sc, s7_int tag, s7_pointer (*is_equal)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->equal = is_equal;} -void s7_c_type_set_copy(s7_scheme *sc, s7_int tag, s7_pointer (*copy)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->copy = copy;} -void s7_c_type_set_fill(s7_scheme *sc, s7_int tag, s7_pointer (*fill)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->fill = fill;} -void s7_c_type_set_reverse(s7_scheme *sc, s7_int tag, s7_pointer (*reverse)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->reverse = reverse;} -void s7_c_type_set_to_list(s7_scheme *sc, s7_int tag, s7_pointer (*to_list)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->to_list = to_list;} -void s7_c_type_set_to_string(s7_scheme *sc, s7_int tag, s7_pointer (*to_string)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->to_string = to_string;} - -void s7_c_type_set_length(s7_scheme *sc, s7_int tag, s7_pointer (*length)(s7_scheme *sc, s7_pointer args)) -{ - sc->c_object_types[tag]->length = (length) ? length : fallback_length; /* is_sequence(c_obj) is #t so we need a length method */ -} - -void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int tag, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args)) -{ - sc->c_object_types[tag]->equivalent = is_equivalent; -} - -void s7_c_type_set_free(s7_scheme *sc, s7_int tag, void (*gc_free)(void *value)) -{ - sc->c_object_types[tag]->free = (gc_free) ? gc_free : fallback_free; -} - -void s7_c_type_set_mark(s7_scheme *sc, s7_int tag, void (*mark)(void *value)) -{ - sc->c_object_types[tag]->mark = (mark) ? mark : fallback_mark; -} - -void s7_c_type_set_ref(s7_scheme *sc, s7_int tag, s7_pointer (*ref)(s7_scheme *sc, s7_pointer args)) -{ - sc->c_object_types[tag]->ref = (ref) ? ref : fallback_ref; - sc->c_object_types[tag]->outer_type = (sc->c_object_types[tag]->ref == fallback_ref) ? T_C_OBJECT : (T_C_OBJECT | T_SAFE_PROCEDURE); -} - -void s7_c_type_set_getter(s7_scheme *sc, s7_int tag, s7_pointer getter) -{ - if ((S7_DEBUGGING) && (getter) && (!is_c_function(getter))) fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, __LINE__, getter); - sc->c_object_types[tag]->getter = (getter) ? getter : sc->F; -} - -void s7_c_type_set_set(s7_scheme *sc, s7_int tag, s7_pointer (*set)(s7_scheme *sc, s7_pointer args)) -{ - sc->c_object_types[tag]->set = (set) ? set : fallback_set; -} - -void s7_c_type_set_setter(s7_scheme *sc, s7_int tag, s7_pointer setter) -{ - if ((S7_DEBUGGING) && (setter) && (!is_c_function(setter))) fprintf(stderr, "%s[%d]: %p is not a c_function\n", __func__, __LINE__, setter); - sc->c_object_types[tag]->setter = (setter) ? setter : sc->F; -} - -void *s7_c_object_value(s7_pointer obj) {return(c_object_value(obj));} - -void *s7_c_object_value_checked(s7_pointer obj, s7_int type) -{ - if ((is_c_object(obj)) && (c_object_type(obj) == type)) - return(c_object_value(obj)); - return(NULL); -} - -static s7_pointer make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let, bool with_gc) -{ - s7_pointer x; - new_cell(sc, x, sc->c_object_types[type]->outer_type); - - /* c_object_info(x) = &(sc->c_object_types[type]); */ - /* that won't work because c_object_types can move when it is realloc'd and the old stuff is freed by realloc - * and since we're checking (for example) ref_2 existence as not null, we can't use a table of c_object_t's! - * Using mallocate (s7_make_c_object_with_data) is faster, but not enough to warrant the code. - */ - c_object_type(x) = type; - c_object_value(x) = value; - c_object_set_let(x, (let == sc->rootlet) ? sc->nil : let); - c_object_s7(x) = sc; - if (with_gc) add_c_object(sc, x); - return(x); -} - -s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let) -{ - return(make_c_object_with_let(sc, type, value, let, true)); -} - -s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value) -{ - return(make_c_object_with_let(sc, type, value, sc->nil, true)); -} - -s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value) -{ - return(make_c_object_with_let(sc, type, value, sc->nil, false)); -} - -s7_pointer s7_c_object_let(s7_pointer obj) {return(c_object_let(obj));} - -s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e) -{ - if ((!is_immutable(obj)) && - (is_let(e))) - c_object_set_let(obj, (e == sc->rootlet) ? sc->nil : e); - return(e); -} - -static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj) -{ - return((*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj))); -} - -static s7_int c_object_length_to_int(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer res = (*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj)); - if (s7_is_integer(res)) - return(s7_integer_clamped_if_gmp(sc, res)); - return(-1); -} - -static s7_pointer copy_c_object(s7_scheme *sc, s7_pointer args) -{ - s7_pointer obj = car(args); - check_method(sc, obj, sc->copy_symbol, args); - if (!c_object_copy(sc, obj)) - missing_method_error_nr(sc, sc->copy_symbol, obj); - return((*(c_object_copy(sc, obj)))(sc, args)); -} - -static s7_pointer c_object_type_to_let(s7_scheme *sc, s7_pointer cobj) -{ - return(internal_inlet(sc, 4, - sc->name_symbol, c_object_scheme_name(sc, cobj), - sc->setter_symbol, (c_object_set(sc, cobj) != fallback_set) ? sc->c_object_set_function : sc->F)); - /* should we make new wrappers every time this is called? or save the let somewhere and reuse it? */ -} - -static void apply_c_object(s7_scheme *sc) /* -------- applicable c_object -------- */ -{ - sc->value = (*(c_object_ref(sc, sc->code)))(sc, set_ulist_1(sc, sc->code, sc->args)); - set_car(sc->u1_1, sc->F); -} - -static bool op_implicit_c_object_ref_a(s7_scheme *sc) -{ - s7_pointer c = lookup_checked(sc, car(sc->code)); - if (!is_c_object(c)) {sc->last_function = c; return(false);} - set_car(sc->t2_2, fx_call(sc, cdr(sc->code))); - set_car(sc->t2_1, c); /* fx_call above might use sc->t2* */ - sc->value = (*(c_object_ref(sc, c)))(sc, sc->t2_1); - return(true); -} - - -/* -------- dilambda -------- */ - -s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer envir, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, - const char *documentation) -{ - s7_pointer get_func, set_func; - char *internal_set_name; - s7_int len, name_len; - - if (!name) return(sc->F); - name_len = safe_strlen(name); - len = 16 + name_len; - internal_set_name = (char *)permalloc(sc, len); - internal_set_name[0] = '\0'; - catstrs_direct(internal_set_name, "[set-", name, "]", (const char *)NULL); - get_func = s7_make_safe_function(sc, name, getter, get_req_args, get_opt_args, false, documentation); - s7_define(sc, envir, make_symbol(sc, name, name_len), get_func); - set_func = s7_make_safe_function(sc, internal_set_name, setter, set_req_args, set_opt_args, false, documentation); - c_function_set_setter(get_func, set_func); - return(get_func); -} - -s7_pointer s7_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, - const char *documentation) -{ - return(s7_dilambda_with_environment(sc, sc->nil, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation)); -} - -s7_pointer s7_typed_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, - const char *documentation, - s7_pointer get_sig, s7_pointer set_sig) -{ - s7_pointer get_func = s7_dilambda(sc, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation); - s7_pointer set_func = c_function_setter(get_func); - if (get_sig) c_function_signature(get_func) = get_sig; - if (set_sig) c_function_signature(set_func) = set_sig; - return(get_func); -} - - -/* -------------------------------- dilambda? -------------------------------- */ -bool s7_is_dilambda(s7_pointer obj) -{ - switch (type(obj)) - { - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - return(is_any_procedure(closure_setter_or_map_list(obj))); /* type >= T_CLOSURE (excludes goto/continuation) */ - case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION_STAR: - return(is_any_procedure(c_function_setter(obj))); - case T_C_MACRO: - return(is_any_procedure(c_macro_setter(obj))); - } - return(false); -} - -static s7_pointer g_is_dilambda(s7_scheme *sc, s7_pointer args) -{ - #define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter." - #define Q_is_dilambda sc->pl_bt - check_boolean_method(sc, s7_is_dilambda, sc->is_dilambda_symbol, args); -} - - -/* -------------------------------- dilambda -------------------------------- */ -static s7_pointer g_dilambda(s7_scheme *sc, s7_pointer args) -{ - #define H_dilambda "(dilambda getter setter) sets getter's setter to be setter." - #define Q_dilambda s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->is_procedure_symbol) - - s7_pointer getter = car(args), setter; - if (!is_any_procedure(getter)) - wrong_type_error_nr(sc, sc->dilambda_symbol, 1, getter, a_procedure_or_a_macro_string); - - setter = cadr(args); - if (!is_any_procedure(setter)) - wrong_type_error_nr(sc, sc->dilambda_symbol, 2, setter, a_procedure_or_a_macro_string); - - s7_set_setter(sc, getter, setter); - return(getter); -} - - -/* -------------------------------- arity -------------------------------- */ -static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args) -{ - /* x_args is unprocessed -- it is exactly the list as used in the closure[*] definition */ - int32_t len; - - if (is_symbol(x_args)) /* any number of args is ok */ - return(cons(sc, int_zero, max_arity)); - if (closure_arity_unknown(x)) - closure_set_arity(x, s7_list_length(sc, x_args)); - len = closure_arity(x); - if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ - return(cons(sc, make_integer(sc, -len), max_arity)); - return(cons(sc, make_integer(sc, len), make_integer_unchecked(sc, len))); -} - -static void closure_star_arity_1(s7_scheme *sc, s7_pointer x, s7_pointer args) -{ - if (closure_arity_unknown(x)) - { - if (is_null(args)) - closure_set_arity(x, 0); - else - if ((is_symbol(args)) || (allows_other_keys(args))) - closure_set_arity(x, -1); - else - { - s7_pointer p; - int32_t i; - for (i = 0, p = args; is_pair(p); i++, p = cdr(p)) /* is_pair(p) so (f1 a . b) will end with b not null */ - { - s7_pointer arg = car(p); - if (arg == sc->rest_keyword) - break; - } - closure_set_arity(x, ((is_null(p)) ? i : -1)); /* see below */ - }} -} - -static s7_pointer closure_star_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args) -{ - closure_star_arity_1(sc, x, x_args); - return((closure_arity(x) == -1) ? cons(sc, int_zero, max_arity) : cons(sc, int_zero, make_integer(sc, closure_arity(x)))); -} - -static int32_t closure_arity_to_int(s7_scheme *sc, s7_pointer x) -{ - /* not lambda* here */ - if (closure_arity_unknown(x)) - { - int32_t i; - s7_pointer b; - for (i = 0, b = closure_args(x); is_pair(b); i++, b = cdr(b)) {}; - if (is_null(b)) - closure_set_arity(x, i); - else - { - if (i == 0) - return(-1); - closure_set_arity(x, -i); - }} - return(closure_arity(x)); -} - -static int32_t closure_star_arity_to_int(s7_scheme *sc, s7_pointer x) -{ - /* not lambda here */ - closure_star_arity_1(sc, x, closure_args(x)); - return(closure_arity(x)); -} - -s7_pointer s7_arity(s7_scheme *sc, s7_pointer x) -{ - switch (type(x)) - { - case T_C_FUNCTION: - return(cons(sc, make_integer(sc, c_function_min_args(x)), make_integer_unchecked(sc, c_function_max_args(x)))); - case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION_STAR: - return(cons(sc, int_zero, make_integer(sc, c_function_max_args(x)))); - case T_MACRO: case T_BACRO: case T_CLOSURE: - return(closure_arity_to_cons(sc, x, closure_args(x))); - case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: - return(closure_star_arity_to_cons(sc, x, closure_args(x))); - case T_C_MACRO: - return(cons(sc, make_integer(sc, c_macro_min_args(x)), make_integer_unchecked(sc, c_macro_max_args(x)))); - case T_GOTO: case T_CONTINUATION: - return(cons(sc, int_zero, max_arity)); - case T_STRING: - return((string_length(x) == 0) ? sc->F : cons(sc, int_one, int_one)); - case T_LET: - return(cons(sc, int_one, int_one)); - case T_C_OBJECT: - check_method(sc, x, sc->arity_symbol, set_plist_1(sc, x)); - return((is_safe_procedure(x)) ? cons(sc, int_zero, max_arity) : sc->F); - case T_VECTOR: - if (vector_length(x) == 0) return(sc->F); - if (has_simple_elements(x)) return(cons(sc, int_one, make_integer(sc, vector_rank(x)))); - return(cons(sc, int_one, max_arity)); - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - return((vector_length(x) == 0) ? sc->F : cons(sc, int_one, make_integer(sc, vector_rank(x)))); - case T_PAIR: case T_HASH_TABLE: - return(cons(sc, int_one, max_arity)); - case T_ITERATOR: - return(cons(sc, int_zero, int_zero)); - case T_SYNTAX: - return(cons(sc, small_int(syntax_min_args(x)), (syntax_max_args(x) == -1) ? max_arity : small_int(syntax_max_args(x)))); - } - return(sc->F); -} - -static s7_pointer g_arity(s7_scheme *sc, s7_pointer args) -{ - #define H_arity "(arity obj) the min and max acceptable args for obj if it is applicable, otherwise #f." - #define Q_arity s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T) - /* check_method(sc, p, sc->arity_symbol, args); */ - return(s7_arity(sc, car(args))); -} - - -/* -------------------------------- aritable? -------------------------------- */ -static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args) -{ - /* x_args is unprocessed -- it is exactly the list as used in the closure definition */ - s7_int len; - - if (args == 0) - return(!is_pair(x_args)); - if (is_symbol(x_args)) /* any number of args is ok */ - return(true); - - len = closure_arity(x); - if (len == CLOSURE_ARITY_NOT_SET) - { - len = s7_list_length(sc, x_args); - closure_set_arity(x, len); - } - if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */ - return((-len) <= args); /* so we have enough to take care of the required args */ - return(args == len); /* in a normal lambda list, there are no other possibilities */ -} - -static bool closure_star_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args) -{ - if (is_symbol(x_args)) - return(true); - closure_star_arity_1(sc, x, x_args); - return((closure_arity(x) == -1) || - (args <= closure_arity(x))); -} - -bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args) -{ - switch (type(x)) - { - case T_C_FUNCTION: - return(c_function_is_aritable(x, args)); - case T_C_RST_NO_REQ_FUNCTION: - if ((x == initial_value(sc->hash_table_symbol)) || /* these two need a value for each key */ - (x == initial_value(sc->weak_hash_table_symbol))) - return((args & 1) == 0); - case T_C_FUNCTION_STAR: - return(c_function_max_args(x) >= args); - - case T_MACRO: case T_BACRO: case T_CLOSURE: - return(closure_is_aritable(sc, x, closure_args(x), args)); - - case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: - return(closure_star_is_aritable(sc, x, closure_args(x), args)); - - case T_C_MACRO: - return((c_macro_min_args(x) <= args) && - (c_macro_max_args(x) >= args)); - - case T_GOTO: case T_CONTINUATION: - return(true); - - case T_STRING: - return((args == 1) && (string_length(x) > 0)); /* ("" 0) -> error */ - - case T_C_OBJECT: - { - s7_pointer func; - if ((has_active_methods(sc, x)) && - ((func = find_method_with_let(sc, x, sc->is_aritable_symbol)) != sc->undefined)) - return(s7_apply_function(sc, func, set_plist_2(sc, x, make_integer(sc, args))) != sc->F); - return(is_safe_procedure(x)); - } - - case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - return((args > 0) && - (vector_length(x) > 0) && /* (#() 0) -> error */ - (args <= vector_rank(x))); - - case T_LET: case T_HASH_TABLE: case T_PAIR: /* for hash-table, this refers to (table 'key) */ - return(args == 1); - - case T_ITERATOR: - return(args == 0); - - case T_SYNTAX: - return((args >= syntax_min_args(x)) && ((args <= syntax_max_args(x)) || (syntax_max_args(x) == -1))); - } - return(false); -} - -static s7_pointer g_is_aritable(s7_scheme *sc, s7_pointer args) -{ - #define H_is_aritable "(aritable? obj num-args) returns #t if 'obj can be applied to 'num-args arguments." - #define Q_is_aritable s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->is_integer_symbol) - - s7_pointer n = cadr(args); - s7_int num; - - if (!s7_is_integer(n)) /* remember gmp case! */ - return(method_or_bust(sc, n, sc->is_aritable_symbol, args, sc->type_names[T_INTEGER], 2)); - - num = s7_integer_clamped_if_gmp(sc, n); - if (num < 0) - out_of_range_error_nr(sc, sc->is_aritable_symbol, int_two, n, it_is_negative_string); - if (num > MAX_ARITY) num = MAX_ARITY; - return(make_boolean(sc, s7_is_aritable(sc, car(args), num))); -} - -static bool is_aritable_b_7pp(s7_scheme *sc, s7_pointer f, s7_pointer i) {return(g_is_aritable(sc, set_plist_2(sc, f, i)) != sc->F);} - -static int32_t arity_to_int(s7_scheme *sc, s7_pointer x) -{ - int32_t args; - switch (type(x)) - { - case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION_STAR: - return(c_function_max_args(x)); - - case T_MACRO: case T_BACRO: case T_CLOSURE: - args = closure_arity_to_int(sc, x); - return((args < 0) ? MAX_ARITY : args); - - case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: - args = closure_star_arity_to_int(sc, x); - return((args < 0) ? MAX_ARITY : args); - - case T_C_MACRO: return(c_macro_max_args(x)); - case T_C_OBJECT: return(MAX_ARITY); - /* do vectors et al make sense here? */ - } - return(-1); -} - - -/* -------------------------------- sequence? -------------------------------- */ -static s7_pointer g_is_sequence(s7_scheme *sc, s7_pointer args) -{ - #define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)" - #define Q_is_sequence sc->pl_bt - check_boolean_method(sc, is_simple_sequence, sc->is_sequence_symbol, args); -} - -static bool is_sequence_b(s7_pointer p) {return(is_simple_sequence(p));} - - -/* -------------------------------- setter ------------------------------------------------ */ -static s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args) -{ - if (type(cadr(args)) != typer) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), - car(args), cadr(args), sc->type_names[type(cadr(args))], sc->type_names[typer])); - return(cadr(args)); -} - -static s7_pointer b_is_symbol_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_SYMBOL, args));} -static s7_pointer b_is_syntax_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_SYNTAX, args));} -static s7_pointer b_is_let_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_LET, args));} -static s7_pointer b_is_iterator_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_ITERATOR, args));} -static s7_pointer b_is_c_pointer_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_C_POINTER, args));} -static s7_pointer b_is_input_port_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_INPUT_PORT, args));} -static s7_pointer b_is_output_port_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_OUTPUT_PORT, args));} -static s7_pointer b_is_eof_object_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_EOF, args));} -static s7_pointer b_is_random_state_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_RANDOM_STATE, args));} -static s7_pointer b_is_char_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_CHARACTER, args));} -static s7_pointer b_is_string_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_STRING, args));} -static s7_pointer b_is_float_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_FLOAT_VECTOR, args));} -static s7_pointer b_is_int_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_INT_VECTOR, args));} -static s7_pointer b_is_byte_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_BYTE_VECTOR, args));} -static s7_pointer b_is_hash_table_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_HASH_TABLE, args));} -static s7_pointer b_is_continuation_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_CONTINUATION, args));} -static s7_pointer b_is_null_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_NIL, args));} -static s7_pointer b_is_pair_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_PAIR, args));} -static s7_pointer b_is_boolean_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_BOOLEAN, args));} -static s7_pointer b_is_undefined_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_UNDEFINED, args));} -static s7_pointer b_is_unspecified_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_UNSPECIFIED, args));} -static s7_pointer b_is_c_object_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_C_OBJECT, args));} -static s7_pointer b_is_goto_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_GOTO, args));} - -#define b_setter(sc, typer, args, str, len) \ - do { \ - if (!typer(cadr(args))) \ - error_nr(sc, sc->wrong_type_arg_symbol, \ - set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), \ - car(args), cadr(args), sc->type_names[type(cadr(args))], wrap_string(sc, str, len))); \ - return(cadr(args)); \ - } while (0) - -static s7_pointer b_is_number_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_complex, args, "a number", 8);} -static s7_pointer b_is_complex_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_complex, args, "a number", 8);} -static s7_pointer b_is_gensym_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_gensym, args, "a gensym", 8);} -static s7_pointer b_is_keyword_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_symbol_and_keyword, args, "a keyword", 9);} -static s7_pointer b_is_openlet_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, has_methods, args, "an open let", 11);} -static s7_pointer b_is_macro_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_macro, args, "a macro", 7);} -static s7_pointer b_is_integer_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_integer, args, "an integer", 10);} -static s7_pointer b_is_byte_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_byte, args, "an unsigned byte", 16);} -static s7_pointer b_is_real_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_real, args, "a real", 6);} -static s7_pointer b_is_float_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_t_real, args, "a float", 7);} -static s7_pointer b_is_rational_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_rational, args, "a rational", 10);} -static s7_pointer b_is_list_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_list, args, "a list", 6);} -static s7_pointer b_is_vector_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_vector, args, "a vector", 8);} -static s7_pointer b_is_procedure_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_procedure, args, "a procedure", 11);} -static s7_pointer b_is_dilambda_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_dilambda, args, "a dilambda", 10);} -static s7_pointer b_is_sequence_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_sequence, args, "a sequence", 10);} -static s7_pointer b_is_subvector_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_subvector, args, "a subvector", 11);} -static s7_pointer b_is_weak_hash_table_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_weak_hash_table, args, "a weak hash-table", 17);} - -static s7_pointer b_is_proper_list_setter(s7_scheme *sc, s7_pointer args) -{ - if (!s7_is_proper_list(sc, car(args))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), - car(args), cadr(args), sc->type_names[type(cadr(args))], wrap_string(sc, "a proper list", 13))); - return(cadr(args)); -} - -static s7_pointer setter_p_pp(s7_scheme *sc, s7_pointer p, s7_pointer e) -{ - if (!((is_let(e)) || (e == sc->rootlet) || (e == sc->nil))) - wrong_type_error_nr(sc, sc->setter_symbol, 2, e, sc->type_names[T_LET]); /* need to check this in case let arg is bogus */ - - switch (type(p)) - { - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - if (is_any_procedure(closure_setter(p))) /* setter already known */ - return(closure_setter(p)); - if (!closure_no_setter(p)) - { - s7_pointer f = funclet_entry(sc, p, sc->local_setter_symbol); /* look for +setter+, save value as closure_setter(p) */ - if (f) - { - if (f == sc->F) - { - closure_set_no_setter(p); - return(sc->F); - } - if (!is_any_procedure(f)) - sole_arg_wrong_type_error_nr(sc, sc->setter_symbol, p, wrap_string(sc, "a procedure or a reasonable facsimile thereof", 45)); - closure_set_setter(p, f); - return(f); - } - /* we used to search for setter here, but that can find the built-in setter causing an infinite loop (maybe check for that??) */ - closure_set_no_setter(p); - } - return(sc->F); - - case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: - return(c_function_setter(p)); - - case T_C_MACRO: - return(c_macro_setter(p)); -#if 0 - case T_GOTO: case T_CONTINUATION: - return(sc->F); -#endif - case T_C_OBJECT: - check_method(sc, p, sc->setter_symbol, set_plist_2(sc, p, e)); - return((c_object_set(sc, p) == fallback_set) ? sc->F : sc->c_object_set_function); /* for example ((setter obj) obj 0 1.0) if s7test block */ - /* this could wrap the setter as an s7_function giving p's class-name etc */ - - case T_LET: - check_method(sc, p, sc->setter_symbol, set_plist_2(sc, p, e)); - return(global_value(sc->let_set_symbol)); - - case T_ITERATOR: /* (set! (iter) val) doesn't fit the other setters */ - return((is_any_closure(iterator_sequence(p))) ? closure_setter(iterator_sequence(p)) : sc->F); - - case T_PAIR: return(global_value(sc->list_set_symbol)); /* or maybe initial-value? */ - case T_HASH_TABLE: return(global_value(sc->hash_table_set_symbol)); - case T_STRING: return(global_value(sc->string_set_symbol)); - case T_BYTE_VECTOR: return(global_value(sc->byte_vector_set_symbol)); - case T_VECTOR: return(global_value(sc->vector_set_symbol)); - case T_INT_VECTOR: return(global_value(sc->int_vector_set_symbol)); - case T_FLOAT_VECTOR: return(global_value(sc->float_vector_set_symbol)); - case T_SLOT: return((slot_has_setter(p)) ? slot_setter(p) : sc->F); - - case T_SYMBOL: /* (setter symbol let) */ - { - s7_pointer sym = p, slot, setter; - if (is_keyword(sym)) - return(sc->F); - if ((e == sc->rootlet) || (e == sc->nil)) - slot = global_slot(sym); - else - { - s7_pointer old_e = sc->curlet; - set_curlet(sc, e); - slot = lookup_slot_from(sym, sc->curlet); - set_curlet(sc, old_e); - } - if ((!is_slot(slot)) || (!slot_has_setter(slot))) return(sc->F); - setter = slot_setter(slot); - if (is_bool_function(setter)) return(c_function_setter(setter)); - return(setter); - }} -#if 0 - wrong_type_error_nr(sc, sc->setter_symbol, 1, p, wrap_string(sc, "something that might have a setter", 34)); /* this seems unfriendly -- why not return #f? */ - return(NULL); /* make tcc happy */ -#else - return(sc->F); -#endif -} - -static s7_pointer g_setter(s7_scheme *sc, s7_pointer args) -{ - #define H_setter "(setter obj let) returns the setter associated with obj" - #define Q_setter s7_make_signature(sc, 3, s7_make_signature(sc, 2, \ - sc->not_symbol, sc->is_procedure_symbol), sc->T, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol)) - return(setter_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->curlet)); -} - -s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj) {return(setter_p_pp(sc, obj, sc->curlet));} - - -/* -------------------------------- set-setter -------------------------------- */ -static void protect_setter(s7_scheme *sc, s7_pointer sym, s7_pointer acc) -{ - s7_int loc; - if (sc->protected_setters_size == sc->protected_setters_loc) - { - s7_int size = sc->protected_setters_size; - s7_int new_size = 2 * size; - block_t *ob = vector_block(sc->protected_setters); - block_t *nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); - block_info(nb) = NULL; - vector_block(sc->protected_setters) = nb; - vector_elements(sc->protected_setters) = (s7_pointer *)block_data(nb); - vector_length(sc->protected_setters) = new_size; - - ob = vector_block(sc->protected_setter_symbols); - nb = reallocate(sc, ob, new_size * sizeof(s7_pointer)); - vector_block(sc->protected_setter_symbols) = nb; - vector_elements(sc->protected_setter_symbols) = (s7_pointer *)block_data(nb); - vector_length(sc->protected_setter_symbols) = new_size; - - for (s7_int i = size; i < new_size; i++) - { - vector_element(sc->protected_setters, i) = sc->unused; - vector_element(sc->protected_setter_symbols, i) = sc->unused; - } - sc->protected_setters_size = new_size; - } - loc = sc->protected_setters_loc++; - vector_element(sc->protected_setters, loc) = acc; - vector_element(sc->protected_setter_symbols, loc) = sym; -} - -static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer args) -{ - s7_pointer func, slot; - if (is_keyword(sym)) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, sym, wrap_string(sc, "a normal symbol (a keyword can't be set)", 40)); - - if (is_pair(cddr(args))) - { - s7_pointer e = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))) */ - func = caddr(args); - if ((e == sc->rootlet) || (e == sc->nil)) - slot = global_slot(sym); - else - { - if (!is_let(e)) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, e, sc->type_names[T_LET]); - slot = lookup_slot_from(sym, e); - }} - else - { - slot = lookup_slot_from(sym, sc->curlet); /* (set! (setter 'x) (lambda (s v) ...)) */ - func = cadr(args); - } - if (!is_slot(slot)) - return(sc->F); - - if (func != sc->F) - { - if (sym == sc->setter_symbol) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter 'setter) to ~S", 32), func)); - if (is_syntax_or_qq(slot_value(slot))) /* (set! (setter 'begin) ...), qq is syntax sez r7rs */ - immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't set (setter '~S) to ~S", 28), sym, func)); - if (!is_any_procedure(func)) /* disallow continuation/goto here */ - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 3, func, wrap_string(sc, "a function or #f", 16)); - if ((!is_c_function(func)) || (!c_function_has_bool_setter(func))) - { - if (s7_is_aritable(sc, func, 3)) - set_has_let_arg(func); - else - if (!s7_is_aritable(sc, func, 2)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "symbol setter function, ~A, should take 2 or 3 arguments", 56), func)); - }} - if (slot == global_slot(sym)) - s7_set_setter(sc, sym, func); /* special GC protection for global vars */ - else slot_set_setter(slot, func); /* func might be #f */ - if (func != sc->F) - slot_set_has_setter(slot); - return(func); -} - -static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = car(args), setter; - if (is_symbol(p)) - return(symbol_set_setter(sc, p, args)); - if (p == sc->s7_starlet) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, p, wrap_string(sc, "something other than *s7*", 25)); - - setter = cadr(args); - if (setter != sc->F) - { - if (!is_any_procedure(setter)) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, setter, wrap_string(sc, "a procedure or #f", 17)); - if (arity_to_int(sc, setter) < 1) /* we need at least an arg for the set! value */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "setter function, ~A, should take at least one argument", 54), setter)); - } - switch (type(p)) - { - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - closure_set_setter(p, setter); - if (setter == sc->F) - closure_set_no_setter(p); - break; - - case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: - if (p == global_value(sc->setter_symbol)) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter setter) to ~S", 31), setter)); - c_function_set_setter(p, setter); - if ((is_any_closure(setter)) || - (is_any_macro(setter))) - add_setter(sc, p, setter); - break; - - case T_C_MACRO: - c_macro_set_setter(p, setter); - if ((is_any_closure(setter)) || - (is_any_macro(setter))) - add_setter(sc, p, setter); - break; - - default: /* (set! (setter 4) ...) or p==continuation etc */ - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, p, wrap_string(sc, "a symbol, a procedure, or a macro", 33)); - } - return(setter); -} - -s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter) -{ - if (is_symbol(p)) - { - if (slot_has_setter(global_slot(p))) - for (s7_int index = 0; index < sc->protected_setters_loc; index++) - if (vector_element(sc->protected_setter_symbols, index) == p) - { - s7_pointer old_func = vector_element(sc->protected_setters, index); - if ((is_any_procedure(old_func)) && /* i.e. not #f! */ - (is_immutable(old_func))) - return(setter); - vector_element(sc->protected_setters, index) = setter; - slot_set_setter(global_slot(p), setter); - if ((setter != sc->F) && (s7_is_aritable(sc, setter, 3))) - set_has_let_arg(setter); - return(setter); - } - if (setter != sc->F) - { - slot_set_has_setter(global_slot(p)); - protect_setter(sc, p, setter); - slot_set_setter(global_slot(p), setter); - if (s7_is_aritable(sc, setter, 3)) - set_has_let_arg(setter); - return(setter); - } - slot_set_setter(global_slot(p), setter); - return(setter); - } - return(g_set_setter(sc, set_plist_2(sc, p, setter))); -} - -/* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (setter 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix)) - * so set setter before use! - */ - -static s7_pointer call_c_function_setter(s7_scheme *sc, s7_pointer func, s7_pointer symbol, s7_pointer new_value) -{ - if (has_let_arg(func)) - return(c_function_call(func)(sc, with_list_t3(symbol, new_value, sc->curlet))); - return(c_function_call(func)(sc, with_list_t2(symbol, new_value))); -} - -static s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer new_value) /* see also op_set1 */ -{ - s7_pointer func = slot_setter(slot), result; - if (is_c_function(func)) - return(call_c_function_setter(sc, func, slot_symbol(slot), new_value)); - if (!is_any_procedure(func)) - return(new_value); - sc->temp10 = (has_let_arg(func)) ? list_3(sc, slot_symbol(slot), new_value, sc->curlet) : list_2(sc, slot_symbol(slot), new_value); - /* safe lists here are much slower -- the setters are called more often for some reason (see tset.scm) */ - result = s7_call(sc, func, sc->temp10); - sc->temp10 = sc->unused; - return(result); -} - -static s7_pointer bind_symbol_with_setter(s7_scheme *sc, opcode_t op, s7_pointer symbol, s7_pointer new_value) -{ - s7_pointer func = setter_p_pp(sc, symbol, sc->curlet); - if (is_c_function(func)) - return(call_c_function_setter(sc, func, symbol, new_value)); - if (!is_any_procedure(func)) - return(new_value); - sc->args = (has_let_arg(func)) ? list_3(sc, symbol, new_value, sc->curlet) : list_2(sc, symbol, new_value); - push_stack_direct(sc, op); - sc->code = func; - return(sc->no_value); /* this means the setter in set! needs to goto APPLY to get the new value */ -} - - -/* -------------------------------- hooks -------------------------------- */ -s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook) -{ - return(s7_symbol_local_value(sc, sc->body_symbol, closure_let(hook))); -} - -s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions) -{ - if (is_list(functions)) - let_set(sc, closure_let(hook), sc->body_symbol, functions); - return(functions); -} - - -/* -------------------------------- eq? eqv? equal? equivalent? -------------------------------- */ -bool s7_is_eq(s7_pointer obj1, s7_pointer obj2) -{ - return((obj1 == obj2) || /* so floats and NaNs might be eq? but not eqv? */ - ((is_unspecified(obj1)) && (is_unspecified(obj2)))); /* this is needed because this function is used by s7_b_pp */ -} - -static s7_pointer is_eq_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2) -{ - return(make_boolean(sc, ((obj1 == obj2) || ((is_unspecified(obj1)) && (is_unspecified(obj2)))))); -} - -static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args) -{ - #define H_is_eq "(eq? obj1 obj2) returns #t if obj1 is eq to (the same object as) obj2" - #define Q_is_eq sc->pcl_bt - return(make_boolean(sc, ((car(args) == cadr(args)) || - ((is_unspecified(car(args))) && (is_unspecified(cadr(args))))))); - /* (eq? (apply apply apply values '(())) #) should return #t */ -} - -bool s7_is_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ -#if WITH_GMP - if ((is_big_number(a)) || (is_big_number(b))) return(big_numbers_are_eqv(sc, a, b)); -#endif - if (type(a) != type(b)) return(false); - if ((a == b) && (!is_number(a))) /* if a is NaN, a == b doesn't mean (eqv? a b) */ - return(true); /* a == b means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */ - if (is_number(a)) return(numbers_are_eqv(sc, a, b)); - if (is_unspecified(a)) return(true); /* types are the same so we know b is also unspecified */ - return(false); -} - -static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args) -{ - #define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2" - #define Q_is_eqv sc->pcl_bt - return(make_boolean(sc, s7_is_eqv(sc, car(args), cadr(args)))); -} - -static s7_pointer is_eqv_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2) {return(make_boolean(sc, s7_is_eqv(sc, obj1, obj2)));} - -static bool floats_are_equivalent(s7_scheme *sc, s7_double x, s7_double y) -{ - s7_double diff; - if (x == y) return(true); - diff = fabs(x - y); - if (diff <= sc->equivalent_float_epsilon) return(true); - return((is_NaN(x)) && (is_NaN(y))); -} - -#if WITH_GMP -static bool big_floats_are_equivalent(s7_scheme *sc, mpfr_t x, mpfr_t y) -{ - /* protect mpfr_1 */ - if ((mpfr_nan_p(x)) || (mpfr_nan_p(y))) - return((mpfr_nan_p(x)) && (mpfr_nan_p(y))); - mpfr_sub(sc->mpfr_3, x, y, MPFR_RNDN); - mpfr_abs(sc->mpfr_3, sc->mpfr_3, MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_3, sc->equivalent_float_epsilon) <= 0); -} -#endif - -static bool eq_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci) {return(x == y);} - -static bool symbol_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) return(true); - if (!is_normal_symbol(y)) return(false); /* (equivalent? ''(1) '(1)) */ - return((is_slot(global_slot(x))) && /* the optimizer can replace the original symbol with its own */ - (is_syntax(global_value(x))) && - (is_slot(global_slot(y))) && - (is_syntax(global_value(y))) && - (syntax_symbol(global_value(x)) == syntax_symbol(global_value(y)))); -} - -static bool unspecified_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(is_unspecified(y)); -} - -static bool undefined_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((x == y) || - ((is_undefined(y)) && (undefined_name_length(x) == undefined_name_length(y)) && - (safe_strcmp(undefined_name(x), undefined_name(y))))); -} - -static bool is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((*(equals[type(x)]))(sc, x, y, ci)); -} - -static bool is_equivalent_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((*(equivalents[type(x)]))(sc, x, y, ci)); -} - -static bool c_pointer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - shared_info_t *nci = ci; - if (x == y) return(true); - if (!s7_is_c_pointer(y)) return(false); - if (c_pointer(x) != c_pointer(y)) return(false); - if (c_pointer_type(x) != c_pointer_type(y)) - { - if (!nci) nci = new_shared_info(sc); - if (!is_equivalent_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) - return(false); - } - if (c_pointer_info(x) != c_pointer_info(y)) - { - if (!nci) nci = new_shared_info(sc); - if (!is_equivalent_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) - return(false); - } - return(true); -} - -static bool c_pointer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - shared_info_t *nci = ci; - if (x == y) return(true); - if (!s7_is_c_pointer(y)) return(false); - if (c_pointer(x) != c_pointer(y)) return(false); - if (c_pointer_type(x) != c_pointer_type(y)) - { - if (!nci) nci = new_shared_info(sc); - if (!is_equal_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) - return(false); - } - if (c_pointer_info(x) != c_pointer_info(y)) - { - if (!nci) nci = new_shared_info(sc); - if (!is_equal_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) - return(false); - } - return(true); -} - -static bool string_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((is_string(y)) && (scheme_strings_are_equal(x, y))); -} - -static bool syntax_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return((is_syntax(y)) && (syntax_symbol(x) == syntax_symbol(y))); -} - -static bool port_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(x == y);} - -static bool port_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) return(true); - if (type(x) != type(y)) return(false); - if ((port_is_closed(x)) && (port_is_closed(y))) return(true); - if ((port_is_closed(x)) || (port_is_closed(y))) return(false); /* if either is closed, port_port (below) might be null */ - if (port_type(x) != port_type(y)) return(false); - switch (port_type(x)) - { - case STRING_PORT: - return((port_position(x) == port_position(y)) && - (port_data_size(x) == port_data_size(y)) && - (local_strncmp((const char *)port_data(x), (const char *)port_data(y), (is_input_port(x)) ? port_data_size(x) : port_position(x)))); - case FILE_PORT: - return((is_input_port(x)) && - (port_position(x) == port_position(y)) && - (local_strncmp((const char *)port_filename(x), (const char *)port_filename(y), port_filename_length(x)))); - case FUNCTION_PORT: - if (is_input_port(x)) - return(port_input_function(x) == port_input_function(y)); - return(port_output_function(x) == port_output_function(y)); - } - return(false); -} - -static void add_shared_ref(shared_info_t *ci, s7_pointer x, int32_t ref_x) -{ - /* called only in equality check, not printer */ - if (ci->top == ci->size) - enlarge_shared_info(ci); - set_collected(x); - ci->objs[ci->top] = x; - ci->refs[ci->top++] = ref_x; -} - -static Inline bool inline_equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) /* pair_equal:lg/list/io, [read] */ -{ - /* here we know x and y are pointers to the same type of structure */ - int32_t ref_y = (is_collected(y)) ? peek_shared_ref_1(ci, y) : 0; - if (is_collected(x)) - { - int32_t ref_x = peek_shared_ref_1(ci, x); - if (ref_y != 0) - return(ref_x == ref_y); /* this is a change from the macro version 16-Jan-20 -- only true returns from the caller */ - /* try to harmonize the new guy -- there can be more than one structure equal to the current one */ - if (ref_x != 0) - add_shared_ref(ci, y, ref_x); - } - else - if (ref_y != 0) - add_shared_ref(ci, x, ref_y); - else - { - /* assume neither x nor y is in the table, and that they should share a ref value, called only in equality check, not printer */ - if (ci->top >= ci->size2) enlarge_shared_info(ci); - set_collected(x); - set_collected(y); - ci->objs[ci->top] = x; - ci->refs[ci->top++] = ++ci->ref; - ci->objs[ci->top] = y; - ci->refs[ci->top++] = ci->ref; - } - return(false); -} - -static bool equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(inline_equal_ref(sc, x, y, ci));} - -static bool c_objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b, shared_info_t *ci) -{ - s7_pointer (*to_list)(s7_scheme *sc, s7_pointer args); - shared_info_t *nci = ci; - s7_pointer pa, pb; - - if (a == b) - return(true); - if (!is_c_object(b)) - return(false); - if (c_object_type(a) != c_object_type(b)) - return(false); - - if (c_object_equal(sc, a)) - return(((*(c_object_equal(sc, a)))(sc, set_clist_2(sc, a, b))) != sc->F); - if (c_object_eql(sc, a)) - return((*(c_object_eql(sc, a)))(c_object_value(a), c_object_value(b))); - - to_list = c_object_to_list(sc, a); - if (!to_list) - return(false); - if (ci) - { - if (equal_ref(sc, a, b, ci)) return(true); /* and nci == ci above */ - } - else nci = new_shared_info(sc); - - for (pa = to_list(sc, set_plist_1(sc, a)), pb = to_list(sc, set_plist_1(sc, b)); is_pair(pa) && (is_pair(pb)); pa = cdr(pa), pb = cdr(pb)) - if (!(is_equal_1(sc, car(pa), car(pb), nci))) - return(false); - return(pa == pb); /* presumably both are nil if successful */ -} - -#define check_equivalent_method(Sc, X, Y) \ - do { \ - if (has_active_methods(sc, X)) \ - { \ - s7_pointer equal_func = find_method_with_let(Sc, X, Sc->is_equivalent_symbol); \ - if (equal_func != Sc->undefined) \ - return(s7_boolean(Sc, s7_apply_function(Sc, equal_func, set_plist_2(Sc, X, Y)))); \ - }} \ - while (0) - -static bool c_objects_are_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - check_equivalent_method(sc, x, y); - if (c_object_equivalent(sc, x)) - return(((*(c_object_equivalent(sc, x)))(sc, set_plist_2(sc, x, y))) != sc->F); - return(c_objects_are_equal(sc, x, y, ci)); -} - -static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent) -{ - hash_entry_t **lists; - s7_int len; - shared_info_t *nci = ci; - hash_check_t hf; - bool (*eqf)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci); - - if (x == y) - return(true); - if (!is_hash_table(y)) - { - if (equivalent) - check_equivalent_method(sc, y, x); - return(false); - } - if ((ci) && (equal_ref(sc, x, y, ci))) return(true); - - if (hash_table_entries(x) != hash_table_entries(y)) - return(false); - if (hash_table_entries(x) == 0) - return(true); - if ((!equivalent) && ((hash_table_mapper(x) != default_hash_map) || (hash_table_mapper(y) != default_hash_map))) - { - if (hash_table_checker(x) != hash_table_checker(y)) - return(false); - if (hash_table_mapper(x) != hash_table_mapper(y)) - return(false); - } - - len = hash_table_mask(x) + 1; - lists = hash_table_elements(x); - if (!nci) nci = new_shared_info(sc); - eqf = (equivalent) ? is_equivalent_1 : is_equal_1; - - hf = hash_table_checker(y); - if ((hf != hash_equal) && (hf != hash_equivalent)) - { - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = lists[i]; p; p = hash_entry_next(p)) - { - hash_entry_t *y_val = hf(sc, y, hash_entry_key(p)); - if (y_val == sc->unentry) - return(false); - if (!eqf(sc, hash_entry_value(p), hash_entry_value(y_val), nci)) - return(false); - } - /* if we get here, every key/value in x has a corresponding key/value in y, and the number of entries match, - * so surely the tables are equal?? - * if ci not null or hash-table-checker is equal/eqivalent, can't use hf? - */ - return(true); - } - - /* we need to protect the current shared_info data (nci) here so the current hash_table_checker won't work -- - * outside equal?/eqivalent? they can safely assume that they can start a new shared_info process. - */ - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = lists[i]; p; p = hash_entry_next(p)) - { - s7_pointer key = hash_entry_key(p); - s7_int hash = hash_loc(sc, y, key); - s7_int loc = hash & hash_table_mask(y); - hash_entry_t *xe; - - for (xe = hash_table_element(y, loc); xe; xe = hash_entry_next(xe)) - if (hash_entry_raw_hash(xe) == hash) - if (eqf(sc, hash_entry_key(xe), key, nci)) - break; - if (!xe) - return(false); - if (!eqf(sc, hash_entry_value(p), hash_entry_value(xe), nci)) - return(false); - } - return(true); -} - -static bool hash_table_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(hash_table_equal_1(sc, x, y, ci, false));} -static bool hash_table_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(hash_table_equal_1(sc, x, y, ci, true));} - -static bool slots_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_t *nci) -{ - for (s7_pointer ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) - for (s7_pointer py = let_slots(ey); tis_slot(py); py = next_slot(py)) - if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ - return(is_equal_1(sc, slot_value(px), slot_value(py), nci)); - return(false); -} - -static bool slots_equivalent_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_t *nci) -{ - for (s7_pointer ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) - for (s7_pointer py = let_slots(ey); tis_slot(py); py = next_slot(py)) - if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ - return(is_equivalent_1(sc, slot_value(px), slot_value(py), nci)); - return(false); -} - -static bool let_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent) -{ - s7_pointer ex, ey, px, py; - shared_info_t *nci = ci; - int32_t x_len, y_len; - - if ((!is_let(y)) || (x == sc->rootlet) || (y == sc->rootlet)) - return(false); - - if ((ci) && (equal_ref(sc, x, y, ci))) return(true); - - clear_symbol_list(sc); - for (x_len = 0, ex = x; is_let(T_Lid(ex)); ex = let_outlet(ex)) - for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) - if (!symbol_is_in_list(sc, slot_symbol(px))) - { - add_symbol_to_list(sc, slot_symbol(px)); - x_len++; - } - - for (ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) - for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) - if (!symbol_is_in_list(sc, slot_symbol(py))) /* symbol in y, not in x */ - return(false); - - for (y_len = 0, ey = y; is_let(T_Lid(ey)); ey = let_outlet(ey)) - for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) - if (symbol_tag(slot_symbol(py)) != 0) - { - y_len++; - symbol_set_tag(slot_symbol(py), 0); - } - - if (x_len != y_len) /* symbol in x, not in y */ - return(false); - - if (!nci) nci = new_shared_info(sc); - - for (ex = x; is_let(T_Lid(ex)); ex = let_outlet(ex)) - for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) - if (symbol_tag(slot_symbol(px)) == 0) /* unshadowed */ - { - symbol_set_tag(slot_symbol(px), sc->syms_tag); /* values don't match */ - if (((!equivalent) && (!slots_match(sc, px, y, nci))) || - ((equivalent) && (!slots_equivalent_match(sc, px, y, nci)))) - return(false); - } - return(true); -} - -static bool let_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - /* x == y if all unshadowed vars match, leaving aside the rootlet, so that for any local variable, we get the same value in either x or y */ - return((x == y) || (let_equal_1(sc, x, y, ci, false))); -} - -/* what should these do if there are setters? */ -static bool let_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) return(true); - if (!is_global(sc->is_equivalent_symbol)) - { - check_equivalent_method(sc, x, y); - check_equivalent_method(sc, y, x); - } - return(let_equal_1(sc, x, y, ci, true)); -} - -static bool closure_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) - return(true); - if (type(x) != type(y)) - return(false); - if ((has_active_methods(sc, x)) && - (has_active_methods(sc, y))) - { - s7_pointer equal_func = find_method(sc, closure_let(x), sc->is_equal_symbol); - if (equal_func != sc->undefined) - return(s7_boolean(sc, s7_apply_function(sc, equal_func, set_plist_2(sc, x, y)))); - } - return(false); -} - -static bool closure_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (x == y) - return(true); - if (type(x) != type(y)) - return(false); - if (has_active_methods(sc, y)) - check_equivalent_method(sc, x, y); - /* not sure about this -- we can't simply check let_equal(closure_let(x), closure_let(y)) - * because locally defined constant functions on the second pass find the outer let. - */ - return((is_equivalent_1(sc, closure_args(x), closure_args(y), ci)) && - (is_equivalent_1(sc, closure_body(x), closure_body(y), ci))); -} - -static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_pointer px, py; - if (x == y) - return(true); - if (!is_pair(y)) - return(false); - if (!ci) - ci = new_shared_info(sc); - else - if (inline_equal_ref(sc, x, y, ci)) - return(true); - - if (!is_equal_1(sc, car(x), car(y), ci)) return(false); - for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py)) - { - if (!is_equal_1(sc, car(px), car(py), ci)) return(false); - if (inline_equal_ref(sc, px, py, ci)) return(true); - } - return((px == py) || (is_equal_1(sc, px, py, ci))); -} - -static bool pair_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_pointer px, py; - if (x == y) - return(true); - if (!is_pair(y)) - { - check_equivalent_method(sc, y, x); - return(false); - } - if (!ci) - ci = new_shared_info(sc); - else - if (inline_equal_ref(sc, x, y, ci)) - return(true); - - if (!is_equivalent_1(sc, car(x), car(y), ci)) return(false); - for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py)) - { - if (!is_equivalent_1(sc, car(px), car(py), ci)) return(false); - if (inline_equal_ref(sc, px, py, ci)) return(true); - } - return((px == py) || ((is_equivalent_1(sc, px, py, ci)))); -} - -static bool vector_rank_match(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - s7_int x_dims; - - if (!vector_has_dimension_info(x)) - return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1)); - x_dims = vector_ndims(x); - if (x_dims == 1) - return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1)); - if ((!vector_has_dimension_info(y)) || - (x_dims != vector_ndims(y))) - return(false); - - for (s7_int j = 0; j < x_dims; j++) - if (vector_dimension(x, j) != vector_dimension(y, j)) - return(false); - return(true); -} - -static bool iv_meq(s7_int *ex, s7_int *ey, s7_int len) -{ - s7_int i = 0, left = len - 8; - while (i <= left) - LOOP_8(if (ex[i] != ey[i]) return(false); i++); - for (; i < len; i++) - if (ex[i] != ey[i]) - return(false); - return(true); -} - -static bool byte_vector_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y) -{ - s7_int len = vector_length(x); - const uint8_t *xp = byte_vector_bytes(x); - const uint8_t *yp = byte_vector_bytes(y); - for (s7_int i = 0; i < len; i++) - if (xp[i] != yp[i]) - return(false); - return(true); -} - -static bool biv_meq(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len = vector_length(x); - const uint8_t *xp = byte_vector_bytes(x); - const s7_int *yp = int_vector_ints(y); - for (s7_int i = 0; i < len; i++) - if ((s7_int)(xp[i]) != yp[i]) - return(false); - return(true); -} - -#define base_vector_equal(sc, x, y) \ - do { \ - if (x == y) return(true); \ - len = vector_length(x); \ - if (len != vector_length(y)) return(false); \ - if (!vector_rank_match(sc, x, y)) return(false); \ - if (len == 0) return(true); \ - } while (0) - -static bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len; - shared_info_t *nci = ci; - - if (!is_any_vector(y)) return(false); - base_vector_equal(sc, x, y); /* sets len */ - if (type(x) != type(y)) - { - if ((is_int_vector(x)) && (is_byte_vector(y))) - return(biv_meq(sc, y, x, NULL)); - if ((is_byte_vector(x)) && (is_int_vector(y))) - return(biv_meq(sc, x, y, NULL)); - for (s7_int i = 0; i < len; i++) - if (!is_equal_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ - return(false); - return(true); - } - if (!has_simple_elements(x)) - { - if (ci) - { - if (equal_ref(sc, x, y, ci)) return(true); - } - else nci = new_shared_info(sc); - } - for (s7_int i = 0; i < len; i++) - if (!(is_equal_1(sc, vector_element(x, i), vector_element(y, i), nci))) - return(false); - return(true); -} - -static bool byte_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len; - if (!is_byte_vector(y)) - return(vector_equal(sc, x, y, ci)); - base_vector_equal(sc, x, y); - return(byte_vector_equal_1(sc, x, y)); -} - -static bool int_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len; - if (!is_int_vector(y)) - return(vector_equal(sc, x, y, ci)); - base_vector_equal(sc, x, y); - return(iv_meq(int_vector_ints(x), int_vector_ints(y), len)); -} - -static bool float_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - s7_int len; - if (!is_float_vector(y)) - return(vector_equal(sc, x, y, ci)); - base_vector_equal(sc, x, y); - for (s7_int i = 0; i < len; i++) - if (float_vector(x, i) != float_vector(y, i)) - return(false); - return(true); -} - -static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - /* if this is split like vector_equal above, remember it is called by iterator_equal_1 below */ - s7_int i, len; - shared_info_t *nci = ci; - - if (x == y) - return(true); - if (!is_any_vector(y)) - { - check_equivalent_method(sc, y, x); - return(false); - } - len = vector_length(x); - if (len != vector_length(y)) return(false); - if (len == 0) return(true); - if (!vector_rank_match(sc, x, y)) return(false); - - if (type(x) != type(y)) - { - /* (equivalent? (make-int-vector 3 0) (make-vector 3 0)) -> #t - * (equivalent? (make-float-vector 3 1.0) (vector 1 1 1)) -> #t - */ - if ((is_int_vector(x)) && (is_byte_vector(y))) - return(biv_meq(sc, y, x, NULL)); - if ((is_byte_vector(x)) && (is_int_vector(y))) - return(biv_meq(sc, x, y, NULL)); - for (i = 0; i < len; i++) - if (!is_equivalent_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ - return(false); - return(true); - } - - if (is_float_vector(x)) - { - s7_double *arr1 = float_vector_floats(x), *arr2 = float_vector_floats(y); - s7_double fudge = sc->equivalent_float_epsilon; - if (fudge == 0.0) - { - for (i = 0; i < len; i++) - if ((arr1[i] != arr2[i]) && - ((!is_NaN(arr1[i])) || (!is_NaN(arr2[i])))) - return(false); - } - else - if ((len & 0x3) == 0) - for (i = 0; i < len; ) - LOOP_4(if (!floats_are_equivalent(sc, arr1[i], arr2[i])) return(false); i++); - else - for (i = 0; i < len; i++) - if (!floats_are_equivalent(sc, arr1[i], arr2[i])) - return(false); - return(true); - } - if (is_int_vector(x)) - return(iv_meq(int_vector_ints(x), int_vector_ints(y), len)); - if (is_byte_vector(x)) - return(byte_vector_equal_1(sc, x, y)); - - if (!has_simple_elements(x)) - { - if (ci) - { - if (equal_ref(sc, x, y, ci)) return(true); - } - else nci = new_shared_info(sc); - } - for (i = 0; i < len; i++) - if (!(is_equivalent_1(sc, vector_element(x, i), vector_element(y, i), nci))) - return(false); - return(true); -} - -static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent) -{ - s7_pointer x_seq, y_seq, xs, ys; - - if (x == y) return(true); - if (!is_iterator(y)) return(false); - - x_seq = iterator_sequence(x); - y_seq = iterator_sequence(y); - - switch (type(x_seq)) - { - case T_STRING: - return((is_string(y_seq)) && - (iterator_position(x) == iterator_position(y)) && - (iterator_length(x) == iterator_length(y)) && - (string_equal(sc, x_seq, y_seq, ci))); - - case T_VECTOR: case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: - return((is_any_vector(y_seq)) && - (iterator_position(x) == iterator_position(y)) && - (iterator_length(x) == iterator_length(y)) && - ((equivalent) ? (vector_equivalent(sc, x_seq, y_seq, ci)) : - ((is_normal_vector(x_seq)) ? (vector_equal(sc, x_seq, y_seq, ci)) : - ((is_float_vector(x_seq)) ? (float_vector_equal(sc, x_seq, y_seq, ci)) : - ((is_int_vector(x_seq)) ? (int_vector_equal(sc, x_seq, y_seq, ci)) : - (byte_vector_equal(sc, x_seq, y_seq, ci))))))); - - /* iterator_next is a function (pair_iterate, iterator_finished etc) */ - case T_PAIR: - if (iterator_next(x) != iterator_next(y)) return(false); /* even if seqs are equal, one might be at end */ - if (equivalent) - { - if (!pair_equivalent(sc, x_seq, y_seq, ci)) - return(false); - } - else - if (!pair_equal(sc, x_seq, y_seq, ci)) - return(false); - - for (xs = x_seq, ys = y_seq; is_pair(xs) && is_pair(ys); xs = cdr(xs), ys = cdr(ys)) - if (xs == iterator_current(x)) - return(ys == iterator_current(y)); - return(is_null(xs) && is_null(ys)); - - case T_NIL: /* (make-iterator #()) works, so () should too */ - return(is_null(y_seq)); /* perhaps for equivalent case, check position in y as well as pair(seq(y))? */ - - case T_C_OBJECT: - if ((is_c_object(y_seq)) && - (iterator_position(x) == iterator_position(y)) && - (iterator_length(x) == iterator_length(y))) - { - if (equivalent) - return(c_objects_are_equivalent(sc, x_seq, y_seq, ci)); - return(c_objects_are_equal(sc, x_seq, y_seq, ci)); - } - return(false); - - case T_LET: - if (!is_let(y_seq)) return(false); - if (iterator_next(x) != iterator_next(y)) return(false); - if (x_seq == sc->rootlet) - return(iterator_position(x) == iterator_position(y)); /* y_seq must also be sc->rootlet since nexts are the same (rootlet_iterate) */ - if (equivalent) - { - if (!let_equivalent(sc, x_seq, y_seq, ci)) - return(false); - } - else - if (!let_equal(sc, x_seq, y_seq, ci)) - return(false); - - for (xs = let_slots(x_seq), ys = let_slots(y_seq); tis_slot(xs) && tis_slot(ys); xs = next_slot(xs), ys = next_slot(ys)) - if (xs == iterator_current_slot(x)) - return(ys == iterator_current_slot(y)); - return(is_slot_end(xs) && is_slot_end(ys)); - - case T_HASH_TABLE: - if (!is_hash_table(y_seq)) return(false); - if (hash_table_entries(x_seq) != hash_table_entries(y_seq)) return(false); - if (hash_table_entries(x_seq) == 0) return(true); - if (iterator_position(x) != iterator_position(y)) return(false); - if (!equivalent) - return(hash_table_equal(sc, x_seq, y_seq, ci)); - return(hash_table_equivalent(sc, x_seq, y_seq, ci)); - - case T_CLOSURE: case T_CLOSURE_STAR: - return(x_seq == y_seq); /* or closure_equal/equivalent? */ - - default: - break; - } - return(false); -} - -static bool iterator_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(iterator_equal_1(sc, x, y, ci, false));} -static bool iterator_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(iterator_equal_1(sc, x, y, ci, true));} - -#if WITH_GMP -static bool big_integer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - /* (equal? 1 1.0) -> #f */ - if (is_t_big_integer(y)) - return(mpz_cmp(big_integer(x), big_integer(y)) == 0); - return((is_t_integer(y)) && (mpz_cmp_si(big_integer(x), integer(y)) == 0)); -} - -static bool big_ratio_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_big_ratio(y)) - return(mpq_equal(big_ratio(x), big_ratio(y))); - if (is_t_ratio(y)) - return((numerator(y) == mpz_get_si(mpq_numref(big_ratio(x)))) && - (denominator(y) == mpz_get_si(mpq_denref(big_ratio(x))))); - return(false); -} - -static bool big_real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_big_real(y)) - return(mpfr_equal_p(big_real(x), big_real(y))); - if (is_t_real(y)) - { - if (mpfr_nan_p(big_real(x))) return(false); - return((!is_NaN(real(y))) && - (mpfr_cmp_d(big_real(x), real(y)) == 0)); - } - return(false); -} - -static bool big_complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x))))) - return(false); - if (is_t_big_complex(y)) - return((!mpfr_nan_p(mpc_realref(big_complex(y)))) && - (!mpfr_nan_p(mpc_imagref(big_complex(y)))) && - (mpc_cmp(big_complex(x), big_complex(y)) == 0)); - if (is_t_complex(y)) - return((!is_NaN(real_part(y))) && - (!is_NaN(imag_part(y))) && - (mpfr_cmp_d(mpc_realref(big_complex(x)), real_part(y)) == 0) && - (mpfr_cmp_d(mpc_imagref(big_complex(x)), imag_part(y)) == 0)); - return(false); -} -#endif - -static bool integer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_integer(y)) - return(integer(x) == integer(y)); -#if WITH_GMP - if (is_t_big_integer(y)) - return(mpz_cmp_si(big_integer(y), integer(x)) == 0); -#endif - return(false); -} - -/* apparently ratio_equal is predefined in g++ -- name collision on mac */ -static bool fraction_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_ratio(y)) - return((numerator(x) == numerator(y)) && - (denominator(x) == denominator(y))); -#if WITH_GMP - if (is_t_big_ratio(y)) - return((numerator(x) == mpz_get_si(mpq_numref(big_ratio(y)))) && - (denominator(x) == mpz_get_si(mpq_denref(big_ratio(y))))); -#endif - return(false); -} - -static bool real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_real(y)) - return(real(x) == real(y)); -#if WITH_GMP - if (is_t_big_real(y)) - return((!is_NaN(real(x))) && - (!mpfr_nan_p(big_real(y))) && - (mpfr_cmp_d(big_real(y), real(x)) == 0)); -#endif - return(false); -} - -static bool complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - if (is_t_complex(y)) - return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))); -#if WITH_GMP - if (is_t_big_complex(y)) - { - if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) || - (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) - return(false); - return((mpfr_cmp_d(mpc_realref(big_complex(y)), real_part(x)) == 0) && - (mpfr_cmp_d(mpc_imagref(big_complex(y)), imag_part(x)) == 0)); - } -#endif - return(false); -} - -#if WITH_GMP -static bool big_integer_or_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool int_case) -{ - if (int_case) - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - else mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - - switch (type(y)) - { - case T_INTEGER: - if (int_case) - return(mpz_cmp_si(big_integer(x), integer(y)) == 0); - mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_RATIO: - mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_REAL: - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_COMPLEX: - mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); - if (!big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) - return(false); - if (is_NaN(imag_part(y))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN); - return(mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0); - case T_BIG_INTEGER: - if (int_case) - return(mpz_cmp(big_integer(x), big_integer(y)) == 0); - mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_REAL: - return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); - case T_BIG_COMPLEX: - if (big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) - { - if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); - }} - return(false); -} - -static bool big_integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(big_integer_or_ratio_equivalent(sc, x, y, ci, true)); -} - -static bool big_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - return(big_integer_or_ratio_equivalent(sc, x, y, ci, false)); -} - - -static bool big_real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_RATIO: - mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_REAL: - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_COMPLEX: - mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); - if (!big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)) - return(false); - if (is_NaN(imag_part(y))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN); - return(mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0); - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)); - case T_BIG_REAL: - return(big_floats_are_equivalent(sc, big_real(x), big_real(y))); - case T_BIG_COMPLEX: - if (big_floats_are_equivalent(sc, big_real(x), mpc_realref(big_complex(y)))) - { - if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); - }} - return(false); -} - -static bool big_complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - switch (type(y)) - { - case T_INTEGER: - mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_RATIO: - mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_REAL: - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_COMPLEX: - mpfr_set_d(sc->mpfr_1, imag_part(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_BIG_REAL: - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), big_real(y))) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); - case T_BIG_COMPLEX: - return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), mpc_realref(big_complex(y)))) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), mpc_imagref(big_complex(y))))); - } - return(false); -} - -static bool both_floats_are_equivalent(s7_scheme *sc, s7_pointer y) -{ - if (!big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) - return(false); - if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); -} -#endif - -static bool integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - return(integer(x) == integer(y)); - case T_RATIO: - return(floats_are_equivalent(sc, (double)integer(x), fraction(y))); - case T_REAL: - return(floats_are_equivalent(sc, (double)integer(x), real(y))); - case T_COMPLEX: - return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && - (floats_are_equivalent(sc, (double)integer(x), real_part(y)))); -#if WITH_GMP - case T_BIG_INTEGER: - return(mpz_cmp_si(big_integer(y), integer(x)) == 0); - case T_BIG_RATIO: - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_REAL: - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); - case T_BIG_COMPLEX: - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - return(both_floats_are_equivalent(sc, y)); -#endif - } - return(false); -} - -static bool fraction_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - return(floats_are_equivalent(sc, (double)fraction(x), integer(y))); - case T_RATIO: - return(floats_are_equivalent(sc, (double)fraction(x), fraction(y))); - case T_REAL: - return(floats_are_equivalent(sc, (double)fraction(x), real(y))); - case T_COMPLEX: - return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && - (floats_are_equivalent(sc, fraction(x), real_part(y)))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, fraction(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN); - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_REAL: - mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); - case T_BIG_COMPLEX: - mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN); - return(both_floats_are_equivalent(sc, y)); -#endif - } - return(false); -} - -static bool real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - return(floats_are_equivalent(sc, real(x), integer(y))); - case T_RATIO: - return(floats_are_equivalent(sc, real(x), fraction(y))); - case T_REAL: - return(floats_are_equivalent(sc, real(x), real(y))); - case T_COMPLEX: - return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && - (floats_are_equivalent(sc, real(x), real_part(y)))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); - case T_BIG_REAL: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); - case T_BIG_COMPLEX: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(both_floats_are_equivalent(sc, y)); -#endif - } - return(false); -} - -static bool complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ - switch (type(y)) - { - case T_INTEGER: - return((floats_are_equivalent(sc, real_part(x), integer(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_RATIO: - return((floats_are_equivalent(sc, real_part(x), fraction(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_REAL: - return((floats_are_equivalent(sc, real_part(x), real(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_COMPLEX: - return((floats_are_equivalent(sc, real_part(x), real_part(y))) && - (floats_are_equivalent(sc, imag_part(x), imag_part(y)))); -#if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real_part(x), MPFR_RNDN); - return((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - return((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_BIG_REAL: - mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); - return((big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); - case T_BIG_COMPLEX: - mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, imag_part(x), MPFR_RNDN); - return((big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) && - (big_floats_are_equivalent(sc, sc->mpfr_2, mpc_imagref(big_complex(y))))); -#endif - } - return(false); -} - -static bool random_state_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) -{ -#if WITH_GMP - return(x == y); -#else - return((x == y) || - ((is_random_state(y)) && - (random_seed(x) == random_seed(y)) && - (random_carry(x) == random_carry(y)))); -#endif -} - -static void init_equals(void) -{ - for (int32_t i = 0; i < NUM_TYPES; i++) {equals[i] = eq_equal; equivalents[i] = eq_equal;} - equals[T_SYMBOL] = eq_equal; - equals[T_C_POINTER] = c_pointer_equal; - equals[T_UNSPECIFIED] = unspecified_equal; - equals[T_UNDEFINED] = undefined_equal; - equals[T_STRING] = string_equal; - equals[T_SYNTAX] = syntax_equal; - equals[T_C_OBJECT] = c_objects_are_equal; - equals[T_RANDOM_STATE] = random_state_equal; - equals[T_ITERATOR] = iterator_equal; - equals[T_INPUT_PORT] = port_equal; - equals[T_OUTPUT_PORT] = port_equal; - equals[T_MACRO] = closure_equal; - equals[T_MACRO_STAR] = closure_equal; - equals[T_BACRO] = closure_equal; - equals[T_BACRO_STAR] = closure_equal; - equals[T_CLOSURE] = closure_equal; - equals[T_CLOSURE_STAR] = closure_equal; - equals[T_HASH_TABLE] = hash_table_equal; - equals[T_LET] = let_equal; - equals[T_PAIR] = pair_equal; - equals[T_VECTOR] = vector_equal; - equals[T_INT_VECTOR] = int_vector_equal; - equals[T_BYTE_VECTOR] = byte_vector_equal; - equals[T_FLOAT_VECTOR] = float_vector_equal; - equals[T_INTEGER] = integer_equal; - equals[T_RATIO] = fraction_equal; - equals[T_REAL] = real_equal; - equals[T_COMPLEX] = complex_equal; -#if WITH_GMP - equals[T_BIG_INTEGER] = big_integer_equal; - equals[T_BIG_RATIO] = big_ratio_equal; - equals[T_BIG_REAL] = big_real_equal; - equals[T_BIG_COMPLEX] = big_complex_equal; -#endif - equivalents[T_SYMBOL] = symbol_equivalent; - equivalents[T_C_POINTER] = c_pointer_equivalent; - equivalents[T_UNSPECIFIED] = unspecified_equal; - equivalents[T_UNDEFINED] = undefined_equal; - equivalents[T_STRING] = string_equal; - equivalents[T_SYNTAX] = syntax_equal; - equivalents[T_C_OBJECT] = c_objects_are_equivalent; - equivalents[T_RANDOM_STATE] = random_state_equal; - equivalents[T_ITERATOR] = iterator_equivalent; - equivalents[T_INPUT_PORT] = port_equivalent; - equivalents[T_OUTPUT_PORT] = port_equivalent; - equivalents[T_MACRO] = closure_equivalent; - equivalents[T_MACRO_STAR] = closure_equivalent; - equivalents[T_BACRO] = closure_equivalent; - equivalents[T_BACRO_STAR] = closure_equivalent; - equivalents[T_CLOSURE] = closure_equivalent; - equivalents[T_CLOSURE_STAR] = closure_equivalent; - equivalents[T_HASH_TABLE] = hash_table_equivalent; - equivalents[T_LET] = let_equivalent; - equivalents[T_PAIR] = pair_equivalent; - equivalents[T_VECTOR] = vector_equivalent; - equivalents[T_INT_VECTOR] = vector_equivalent; - equivalents[T_FLOAT_VECTOR] = vector_equivalent; - equivalents[T_BYTE_VECTOR] = vector_equivalent; - equivalents[T_INTEGER] = integer_equivalent; - equivalents[T_RATIO] = fraction_equivalent; - equivalents[T_REAL] = real_equivalent; - equivalents[T_COMPLEX] = complex_equivalent; -#if WITH_GMP - equivalents[T_BIG_INTEGER] = big_integer_equivalent; - equivalents[T_BIG_RATIO] = big_ratio_equivalent; - equivalents[T_BIG_REAL] = big_real_equivalent; - equivalents[T_BIG_COMPLEX] = big_complex_equivalent; -#endif -} - -bool s7_is_equal(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equals[type(x)]))(sc, x, y, NULL));} -bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equivalents[type(x)]))(sc, x, y, NULL));} - -static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args) -{ - #define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2" - #define Q_is_equal sc->pcl_bt - return(make_boolean(sc, is_equal_1(sc, car(args), cadr(args), NULL))); -} - -static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args) -{ - #define H_is_equivalent "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2." - #define Q_is_equivalent sc->pcl_bt - return(make_boolean(sc, is_equivalent_1(sc, car(args), cadr(args), NULL))); -} - -static s7_pointer is_equal_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((is_equal_1(sc, a, b, NULL)) ? sc->T : sc->F);} -static s7_pointer is_equivalent_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((is_equivalent_1(sc, a, b, NULL)) ? sc->T : sc->F);} - - -/* ---------------------------------------- length, copy, fill ---------------------------------------- */ -static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst); /* why isn't this in s7.h? */ - -static s7_pointer (*length_functions[256])(s7_scheme *sc, s7_pointer obj); -static s7_pointer any_length(s7_scheme *sc, s7_pointer obj) {return(sc->F);} - -static s7_pointer pair_length(s7_scheme *sc, s7_pointer a) -{ - s7_int i = 0; - s7_pointer slow = a, fast = a; /* we know a is a pair, don't start with fast = cdr(a)! else if a len = 3, we never match */ - while (true) - { - LOOP_4(fast = cdr(fast); i++; if (!is_pair(fast)) return(make_integer(sc, (is_null(fast)) ? i : -i))); - slow = cdr(slow); - if (fast == slow) return(real_infinity); - } - return(real_infinity); -} - -static s7_pointer nil_length(s7_scheme *sc, s7_pointer lst) {return(int_zero);} -static s7_pointer v_length(s7_scheme *sc, s7_pointer v) {return(make_integer(sc, vector_length(v)));} -static s7_pointer str_length(s7_scheme *sc, s7_pointer v) {return(make_integer(sc, string_length(v)));} -static s7_pointer bv_length(s7_scheme *sc, s7_pointer v) {return(make_integer(sc, byte_vector_length(v)));} -static s7_pointer h_length(s7_scheme *sc, s7_pointer lst) {return(make_integer(sc, hash_table_mask(lst) + 1));} -static s7_pointer iter_length(s7_scheme *sc, s7_pointer lst) {return(s7_length(sc, iterator_sequence(lst)));} - -static s7_pointer c_obj_length(s7_scheme *sc, s7_pointer lst) -{ - if (!is_global(sc->length_symbol)) - check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst)); - return(c_object_length(sc, lst)); -} - -static s7_pointer lt_length(s7_scheme *sc, s7_pointer lst) -{ - if (!is_global(sc->length_symbol)) - check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst)); - return(make_integer(sc, let_length(sc, lst))); -} - -static s7_pointer fnc_length(s7_scheme *sc, s7_pointer lst) -{ - return((has_active_methods(sc, lst)) ? make_integer(sc, closure_length(sc, lst)) : sc->F); -} - -static s7_pointer ip_length(s7_scheme *sc, s7_pointer port) -{ - if (port_is_closed(port)) - return(sc->F); /* or 0? */ - if (is_string_port(port)) - return(make_integer(sc, port_data_size(port))); /* length of string we're reading */ -#if (!MS_WINDOWS) - if (is_file_port(port)) - { - long len; - long cur_pos = ftell(port_file(port)); - fseek(port_file(port), 0, SEEK_END); - len = ftell(port_file(port)); - rewind(port_file(port)); - fseek(port_file(port), cur_pos, SEEK_SET); - return(make_integer(sc, len)); - } -#endif - return(sc->F); -} - -static s7_pointer op_length(s7_scheme *sc, s7_pointer port) -{ - if (port_is_closed(port)) - return(sc->F); /* or 0? */ - return((is_string_port(port)) ? make_integer(sc, port_position(port)) : sc->F); /* length of string we've written */ -} - -static s7_pointer rs_length(s7_scheme *sc, s7_pointer port) {return((WITH_GMP) ? sc->F : int_two);} - -static void init_length_functions(void) -{ - for (int32_t i = 0; i < 256; i++) length_functions[i] = any_length; - length_functions[T_NIL] = nil_length; - length_functions[T_PAIR] = pair_length; - length_functions[T_VECTOR] = v_length; - length_functions[T_FLOAT_VECTOR] = v_length; - length_functions[T_INT_VECTOR] = v_length; - length_functions[T_STRING] = str_length; - length_functions[T_BYTE_VECTOR] = bv_length; - length_functions[T_ITERATOR] = iter_length; - length_functions[T_HASH_TABLE] = h_length; - length_functions[T_C_OBJECT] = c_obj_length; - length_functions[T_LET] = lt_length; - length_functions[T_CLOSURE] = fnc_length; - length_functions[T_CLOSURE_STAR] = fnc_length; - length_functions[T_INPUT_PORT] = ip_length; - length_functions[T_OUTPUT_PORT] = op_length; - length_functions[T_RANDOM_STATE] = rs_length; -} - -static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst) {return((*length_functions[unchecked_type(lst)])(sc, lst));} - -static s7_pointer g_length(s7_scheme *sc, s7_pointer args) -{ - #define H_length "(length obj) returns the length of obj, which can be a list, vector, string, input-port, or hash-table. \ -The length of a dotted list does not include the final cdr, and is returned as a negative number. A circular \ -list has infinite length. Length of anything else returns #f." - #define Q_length s7_make_signature(sc, 2, s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_infinite_symbol, sc->not_symbol), sc->T) - return((*length_functions[unchecked_type(car(args))])(sc, car(args))); -} - -/* length_p_p = s7_length */ - - -/* -------------------------------- copy -------------------------------- */ -static s7_pointer string_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer val) -{ - if (is_character(val)) - { - string_value(str)[loc] = s7_character(val); - return(val); - } - set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not a character", 25)); - set_caddr(sc->elist_3, val); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); - return(NULL); -} - -static s7_pointer string_getter(s7_scheme *sc, s7_pointer str, s7_int loc) -{ - return(chars[(uint8_t)(string_value(str)[loc])]); /* cast needed else (copy (string (integer->char 255))...) is trouble */ -} - -static s7_pointer c_object_setter(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val) -{ - return((*(c_object_set(sc, obj)))(sc, with_list_t3(obj, make_integer(sc, loc), val))); -} - -static s7_pointer c_object_getter(s7_scheme *sc, s7_pointer obj, s7_int loc) -{ - return((*(c_object_ref(sc, obj)))(sc, set_plist_2(sc, obj, make_integer(sc, loc)))); -} - -static s7_pointer let_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val) -{ - /* loc is irrelevant here, val has to be of the form (cons symbol value) - * if symbol is already in e, its value is changed, otherwise a new slot is added to e - */ - if (is_pair(val)) - { - s7_pointer sym = car(val); - if (is_symbol(sym)) - { - s7_pointer slot; - if (is_keyword(sym)) sym = keyword_symbol(sym); /* else make_slot will mark the keyword as local confusing odd_bits etc */ - slot = slot_in_let(sc, e, sym); - if (is_slot(slot)) - checked_slot_set_value(sc, slot, cdr(val)); - else add_slot_checked_with_id(sc, e, sym, cdr(val)); - return(cdr(val)); - }} - set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not (cons symbol value)", 33)); - set_caddr(sc->elist_3, val); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); - return(sc->wrong_type_arg_symbol); -} - -static s7_pointer hash_table_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val) -{ - /* loc is irrelevant here, e is the hash-table, val has to be of the form (cons key value) - * if key is already in e, its value is changed, otherwise a new slot is added to e, cadr(elist_3) is caller - */ - if (!is_pair(val)) - { - set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not (cons key value)", 30)); - set_caddr(sc->elist_3, val); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); - } - return(s7_hash_table_set(sc, e, car(val), cdr(val))); -} - - -static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer caller, s7_pointer source, s7_pointer args) -{ - s7_pointer dest; - switch (type(source)) - { - case T_STRING: - return(make_string_with_length(sc, string_value(source), string_length(source))); - - case T_C_OBJECT: - return(copy_c_object(sc, args)); - - case T_RANDOM_STATE: - return(random_state_copy(sc, args)); - - case T_HASH_TABLE: /* this has to copy nearly everything */ - { - s7_pointer new_hash = s7_make_hash_table(sc, hash_table_mask(source) + 1); - s7_int gc_loc = gc_protect_1(sc, new_hash); - hash_table_checker(new_hash) = hash_table_checker(source); - if (hash_chosen(source)) hash_set_chosen(new_hash); - hash_table_mapper(new_hash) = hash_table_mapper(source); - hash_table_set_procedures(new_hash, copy_hash_table_procedures(sc, source)); - hash_table_copy(sc, source, new_hash, 0, hash_table_entries(source)); - if (is_typed_hash_table(source)) - { - set_is_typed_hash_table(new_hash); - if (has_hash_key_type(source)) set_has_hash_key_type(new_hash); - if (has_hash_value_type(source)) set_has_hash_value_type(new_hash); - if (has_simple_keys(source)) set_has_simple_keys(new_hash); - if (has_simple_values(source)) set_has_simple_values(new_hash); - } - s7_gc_unprotect_at(sc, gc_loc); - return(new_hash); - } - - case T_ITERATOR: - return(iterator_copy(sc, source)); - - case T_LET: - check_method(sc, source, sc->copy_symbol, args); - return(let_copy(sc, source)); /* this copies only the local let and points to outer lets */ - - case T_CLOSURE: case T_CLOSURE_STAR: - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - check_method(sc, source, sc->copy_symbol, args); - return(copy_closure(sc, source)); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - return(s7_vector_copy(sc, source)); /* "shallow" copy */ - - case T_VECTOR: - { - s7_int len = vector_length(source); - s7_pointer vec; - if (!is_typed_vector(source)) - return(s7_vector_copy(sc, source)); - if (len == 0) - return(make_simple_vector(sc, 0)); - vec = make_vector_1(sc, len, NOT_FILLED, T_VECTOR); - set_typed_vector(vec); - typed_vector_set_typer(vec, typed_vector_typer(source)); - if (has_simple_elements(source)) set_has_simple_elements(vec); - s7_vector_fill(sc, vec, vector_element(source, 0)); - if (vector_rank(source) > 1) - return(make_multivector(sc, vec, g_vector_dimensions(sc, set_plist_1(sc, source)))); /* see g_subvector to avoid g_vector_dimensions */ - add_vector(sc, vec); - return(vec); - } - - case T_PAIR: /* top level only, as in the other cases, checks for circles */ - return(copy_any_list(sc, source)); - - case T_INTEGER: - new_cell(sc, dest, T_INTEGER); - integer(dest) = integer(source); - return(dest); - case T_RATIO: - new_cell(sc, dest, T_RATIO); - numerator(dest) = numerator(source); - denominator(dest) = denominator(source); - return(dest); - case T_REAL: - new_cell(sc, dest, T_REAL); - set_real(dest, real(source)); - return(dest); - case T_COMPLEX: - new_cell(sc, dest, T_COMPLEX); - set_real_part(dest, real_part(source)); - set_imag_part(dest, imag_part(source)); - return(dest); -#if WITH_GMP - case T_BIG_INTEGER: return(mpz_to_big_integer(sc, big_integer(source))); - case T_BIG_RATIO: return(mpq_to_big_ratio(sc, big_ratio(source))); - case T_BIG_REAL: return(mpfr_to_big_real(sc, big_real(source))); - case T_BIG_COMPLEX: return(mpc_to_number(sc, big_complex(source))); -#endif - - case T_C_POINTER: - dest = s7_make_c_pointer_with_type(sc, c_pointer(source), c_pointer_type(source), c_pointer_info(source)); - c_pointer_weak1(dest) = c_pointer_weak1(source); - c_pointer_weak2(dest) = c_pointer_weak2(source); - return(dest); - } - return(source); -} - -static s7_pointer copy_p_p(s7_scheme *sc, s7_pointer source) {return(copy_source_no_dest(sc, sc->copy_symbol, source, set_plist_1(sc, source)));} - -static s7_pointer copy_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7_int dest_start, s7_int dest_end, s7_int source_start) -{ - /* types equal, but not a let (handled in s7_copy_1), returns NULL if not copied here */ - s7_int i, j; - s7_int source_len = dest_end - dest_start; - switch (type(source)) - { - case T_PAIR: - { - s7_pointer pd, ps; - for (ps = source, i = 0; i < source_start; i++) - ps = cdr(ps); - for (pd = dest, i = 0; i < dest_start; i++) - pd = cdr(pd); - for (; (i < dest_end) && is_pair(ps) && is_pair(pd); i++, ps = cdr(ps), pd = cdr(pd)) - set_car(pd, car(ps)); - return(dest); - } - - case T_VECTOR: - if (is_typed_vector(dest)) - { - s7_pointer *els = vector_elements(source); - for (i = source_start, j = dest_start; j < dest_end; i++, j++) - typed_vector_setter(sc, dest, j, els[i]); /* types are equal, so source is a normal vector */ - } - else memcpy((void *)((vector_elements(dest)) + dest_start), (void *)((vector_elements(source)) + source_start), source_len * sizeof(s7_pointer)); - return(dest); - - case T_INT_VECTOR: - memcpy((void *)((int_vector_ints(dest)) + dest_start), (void *)((int_vector_ints(source)) + source_start), source_len * sizeof(s7_int)); - return(dest); - case T_FLOAT_VECTOR: - memcpy((void *)((float_vector_floats(dest)) + dest_start), (void *)((float_vector_floats(source)) + source_start), source_len * sizeof(s7_double)); - return(dest); - case T_BYTE_VECTOR: - if (is_string(dest)) - memcpy((void *)(string_value(dest) + dest_start), (void *)((byte_vector_bytes(source)) + source_start), source_len * sizeof(uint8_t)); - else memcpy((void *)(byte_vector_bytes(dest) + dest_start), (void *)((byte_vector_bytes(source)) + source_start), source_len * sizeof(uint8_t)); - return(dest); - - case T_STRING: - if (is_string(dest)) - memcpy((void *)(string_value(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len); - else memcpy((void *)(byte_vector_bytes(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len); - return(dest); - - case T_RANDOM_STATE: -#if (!WITH_GMP) - random_seed(dest) = random_seed(source); - random_carry(dest) = random_carry(source); -#endif - return(dest); - - case T_C_OBJECT: - { - s7_pointer (*cref)(s7_scheme *sc, s7_pointer args) = c_object_ref(sc, source); - s7_pointer (*cset)(s7_scheme *sc, s7_pointer args) = c_object_set(sc, dest); - s7_pointer mi = make_mutable_integer(sc, 0); - s7_int gc_loc1 = gc_protect_1(sc, mi); - s7_pointer mj = make_mutable_integer(sc, 0); - s7_int gc_loc2 = gc_protect_1(sc, mj); - - for (i = source_start, j = dest_start; i < dest_end; i++, j++) - { - integer(mi) = i; - integer(mj) = j; - set_car(sc->t3_3, cref(sc, with_list_t2(source, mi))); - set_car(sc->t3_1, dest); - set_car(sc->t3_2, mj); - cset(sc, sc->t3_1); - } - s7_gc_unprotect_at(sc, gc_loc1); - s7_gc_unprotect_at(sc, gc_loc2); - free_cell(sc, mi); - free_cell(sc, mj); - return(dest); - } - - case T_LET: - return(NULL); - - case T_HASH_TABLE: - { - s7_pointer p; - gc_protect_via_stack(sc, source); - p = hash_table_copy(sc, source, dest, source_start, source_start + source_len); - unstack(sc); - if ((hash_table_checker(source) != hash_table_checker(dest)) && - (hash_table_mapper(dest) == default_hash_map)) - { - if (hash_table_checker(dest) == hash_empty) - hash_table_checker(dest) = hash_table_checker(source); /* copy hash_table_procedures also? what about the mapper? see hash_table_copy */ - else - { - hash_table_checker(dest) = hash_equal; - hash_set_chosen(dest); - }} - return(p); - } - - default: - return(dest); - } - return(NULL); -} - -static noreturn void copy_element_error_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, int32_t desired_type) -{ - set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), - caller, wrap_integer(sc, num), element, type_name_string(sc, element), sc->type_names[desired_type]); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); -} - -static noreturn void copy_element_error_with_type_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, s7_pointer desired_type) -{ - set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), - caller, wrap_integer(sc, num), element, type_name_string(sc, element), desired_type); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); -} - -static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) -{ - #define H_copy "(copy obj) returns a copy of obj, (copy src dest) copies src into dest, (copy src dest start end) copies src from start to end." - /* #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol) */ - /* this is not right when c-object types are handled in lint -- a generator or Snd object need not consider itself a sequence, - * but it can provide a copy method. So, I think I'll just use #t - */ - #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->T, sc->T, sc->is_integer_symbol) - - s7_pointer source = car(args), dest; - s7_int i, j, dest_len, start, end, source_len; - s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val) = NULL; - s7_pointer (*get)(s7_scheme *sc, s7_pointer obj, s7_int loc) = NULL; - bool have_indices; - - if (is_null(cdr(args))) /* (copy obj) */ - return(copy_source_no_dest(sc, caller, source, args)); - - dest = T_Ext(cadr(args)); - if ((dest == sc->readable_keyword) && (!is_pair(source))) - error_nr(sc, sc->out_of_range_symbol, - set_elist_1(sc, wrap_string(sc, "copy argument 2, :readable, only works if the source is a pair", 62))); - - if ((is_immutable(dest)) && - (dest != sc->readable_keyword) && - (dest != sc->nil)) /* error_hook copies with cadr(args) :readable, so it's currently NULL */ - wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a mutable object", 16)); /* so this segfaults if not checking for :readable */ - - have_indices = (is_pair(cddr(args))); - if ((source == dest) && (!have_indices)) - return(dest); - - switch (type(source)) - { - case T_PAIR: - if (dest == sc->readable_keyword) /* a kludge, but I can't think of anything less stupid */ - { - if (have_indices) /* it seems to me that the start/end args here don't make any sense so... */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: start/end indices make no sense with :readable: ~S", 54), caller, args)); - return(copy_body(sc, source)); - } - end = s7_list_length(sc, source); - if (end == 0) - end = circular_list_entries(source); - else - if (end < 0) end = -end; - break; - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - get = vector_getter(source); - end = vector_length(source); - break; - - case T_STRING: - get = string_getter; - end = string_length(source); - break; - - case T_HASH_TABLE: - if (source == dest) return(dest); - end = hash_table_entries(source); - break; - - case T_RANDOM_STATE: - get = random_state_getter; - end = 2; - break; - - case T_C_OBJECT: - if (c_object_copy(sc, source)) - { - s7_pointer x = (*(c_object_copy(sc, source)))(sc, args); - if (x == dest) - return(dest); - } - check_method(sc, source, sc->copy_symbol, args); - get = c_object_getter; - end = c_object_length_to_int(sc, source); - break; - - case T_LET: - if (source == dest) return(dest); - check_method(sc, source, sc->copy_symbol, args); - if (source == sc->rootlet) - wrong_type_error_nr(sc, caller, 1, source, wrap_string(sc, "a sequence other than the rootlet", 33)); - if ((!have_indices) && (is_let(dest)) && (dest != sc->s7_starlet)) - { - s7_pointer slot; - if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */ - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - s7_make_slot(sc, dest, slot_symbol(slot), slot_value(slot)); - else - if ((has_let_fallback(source)) && - (has_let_fallback(dest))) - { - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && - (slot_symbol(slot) != sc->let_set_fallback_symbol)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - /* this copies reversing the order -- if shadowing, this unshadows, tmp has in-order copy code, but it's too much effort */ - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - return(dest); - } - end = let_length(sc, source); - break; - - case T_NIL: - end = 0; - if (is_sequence(dest)) - break; - - default: - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), caller, source, dest)); - } - - start = 0; - if (have_indices) - { - s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); - if (p != sc->unused) return(p); - } - if ((start == 0) && (source == dest)) - return(dest); - - source_len = end - start; - if (source_len == 0) - { - if (!is_sequence(dest)) - wrong_type_error_nr(sc, caller, 2, dest, a_sequence_string); - return(dest); - } - - switch (type(dest)) - { - case T_PAIR: - dest_len = source_len; - break; - - case T_INT_VECTOR: - case T_BYTE_VECTOR: - if (is_float_vector(source)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~A", 17), caller, source, sc->type_names[type(dest)])); - case T_FLOAT_VECTOR: - set = vector_setter(dest); - dest_len = vector_length(dest); - break; - - case T_VECTOR: - set = (is_typed_vector(dest)) ? typed_vector_setter : vector_setter(dest); - dest_len = vector_length(dest); - break; - - case T_STRING: - set = string_setter; - dest_len = string_length(dest); - set_cadr(sc->elist_3, caller); /* for possible error handling in string_setter */ - break; - - case T_HASH_TABLE: - set = hash_table_setter; - dest_len = source_len; - set_cadr(sc->elist_3, caller); /* for possible error handling in hash_table_setter */ - break; - - case T_C_OBJECT: - /* if source or dest is c_object, call its copy function before falling back on the get/set functions */ - if (c_object_copy(sc, dest)) - { - s7_pointer x = (*(c_object_copy(sc, dest)))(sc, args); - if (x == dest) - return(dest); - } - set = c_object_setter; - dest_len = c_object_length_to_int(sc, dest); - break; - - case T_LET: - if (dest == sc->rootlet) - wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other rootlet", 24)); - if (dest == sc->s7_starlet) - wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other than *s7*", 26)); - set = let_setter; - dest_len = source_len; /* grows via set, so dest_len isn't relevant */ - set_cadr(sc->elist_3, caller); /* for possible error handling in let_setter */ - break; - - case T_NIL: - return(sc->nil); - - case T_RANDOM_STATE: - set = random_state_setter; - dest_len = 2; - break; - - default: - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), caller, source, dest)); - } - - if (dest_len == 0) - return(dest); - - /* end is source_len if not set explicitly */ - if (dest_len < source_len) - { - end = dest_len + start; - source_len = dest_len; - } - - if ((source != dest) && - ((type(source) == type(dest)) || - ((is_string_or_byte_vector(source)) && - (is_string_or_byte_vector(dest))))) - { - s7_pointer res = copy_to_same_type(sc, dest, source, 0, source_len, start); - if (res) return(res); - } - - switch (type(source)) - { - case T_PAIR: - { - s7_pointer p = source; - i = 0; - if (start > 0) - for (i = 0; i < start; i++) - p = cdr(p); - /* dest won't be a pair here if source != dest -- the pair->pair case was caught above */ - if (source == dest) /* here start != 0 (see above) */ - for (s7_pointer dp = source /* i = start */; i < end; i++, p = cdr(p), dp = cdr(dp)) - set_car(dp, car(p)); - else - if (is_string(dest)) - { - char *dst = string_value(dest); - for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) - { - if (!is_character(car(p))) - copy_element_error_nr(sc, caller, i + 1, car(p), T_CHARACTER); - dst[j] = character(car(p)); - }} - else - if ((is_normal_vector(dest)) && (set != typed_vector_setter)) - { - s7_pointer *els = vector_elements(dest); - for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) - els[j] = car(p); - } - else - for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) - set(sc, dest, j, car(p)); - return(dest); - } - - case T_LET: - if (source == sc->s7_starlet) /* *s7* */ - { - s7_pointer iter = s7_make_iterator(sc, sc->s7_starlet); - s7_int gc_loc = s7_gc_protect(sc, iter); - for (i = 0; i < start; i++) - { - s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) - { - s7_gc_unprotect_at(sc, gc_loc); - return(dest); - }} - if (is_pair(dest)) /* (append '(1) *s7* ()) */ - { - s7_pointer p; - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - { - s7_pointer val = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - set_car(p, val); - }} - else - for (i = start, j = 0; i < end; i++, j++) - { - s7_pointer val = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - set(sc, dest, j, val); - } - s7_gc_unprotect_at(sc, gc_loc); - } - else - { - /* source and dest can't be rootlet (checked above), dest also can't be *s7* */ - s7_pointer slot = let_slots(source); - for (i = 0; i < start; i++) slot = next_slot(slot); - if (is_pair(dest)) - { - s7_pointer p; - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p), slot = next_slot(slot)) - set_car(p, cons_unchecked(sc, slot_symbol(slot), slot_value(slot))); - } - else - if (is_let(dest)) - { - if ((has_let_fallback(source)) && - (has_let_fallback(dest))) - { - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && - (slot_symbol(slot) != sc->let_set_fallback_symbol)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - for (i = start; i < end; i++, slot = next_slot(slot)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - if (is_hash_table(dest)) - for (i = start; i < end; i++, slot = next_slot(slot)) - s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); /* if value=#f, dest will not contain symbol */ - else - if ((is_normal_vector(dest)) && (set != typed_vector_setter)) - { - s7_pointer *els = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) - els[j] = cons_unchecked(sc, slot_symbol(slot), slot_value(slot)); - } - else - for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) - set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot))); - } - return(dest); - - case T_HASH_TABLE: - { - s7_int loc = -1, skip = start; - hash_entry_t **elements = hash_table_elements(source); - hash_entry_t *x = NULL; - - while (skip > 0) - { - while (!x) x = elements[++loc]; - skip--; - x = hash_entry_next(x); - } - if (is_pair(dest)) - { - s7_pointer p; - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - { - while (!x) x = elements[++loc]; - set_car(p, cons_unchecked(sc, hash_entry_key(x), hash_entry_value(x))); - x = hash_entry_next(x); - }} - else - if (is_let(dest)) - { - for (i = start; i < end; i++) - { - s7_pointer symbol; - while (!x) x = elements[++loc]; - symbol = hash_entry_key(x); - if (!is_symbol(symbol)) - copy_element_error_nr(sc, caller, i + 1, symbol, T_SYMBOL); - if (is_constant_symbol(sc, symbol)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A into ~A: ~A is a constant", 28), caller, dest, symbol)); - if ((symbol != sc->let_ref_fallback_symbol) && - (symbol != sc->let_set_fallback_symbol)) - add_slot_checked_with_id(sc, dest, symbol, hash_entry_value(x)); /* ...unchecked... if size ok */ - x = hash_entry_next(x); - }} - else - { - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - { - while (!x) x = elements[++loc]; - set(sc, dest, j, cons_unchecked(sc, hash_entry_key(x), hash_entry_value(x))); - x = hash_entry_next(x); - }} - return(dest); - } - - case T_VECTOR: - { - s7_pointer *vals = vector_elements(source); - if (is_float_vector(dest)) - { - s7_double *dst = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = real_to_double(sc, vals[i], symbol_name(caller)); - return(dest); - } - if (is_int_vector(dest)) - { - s7_int *dst = int_vector_ints(dest); - for (i = start, j = 0; i < end; i++, j++) - { - if (!s7_is_integer(vals[i])) - copy_element_error_nr(sc, caller, i + 1, vals[i], T_INTEGER); - dst[j] = s7_integer_clamped_if_gmp(sc, vals[i]); - } - return(dest); - } - if (is_string(dest)) - { - char *dst = string_value(dest); - for (i = start, j = 0; i < end; i++, j++) - { - if (!is_character(vals[i])) - copy_element_error_nr(sc, caller, i + 1, vals[i], T_CHARACTER); - dst[j] = character(vals[i]); - } - return(dest); - } - if (is_byte_vector(dest)) - { - uint8_t *dst = (uint8_t *)byte_vector_bytes(dest); - for (i = start, j = 0; i < end; i++, j++) - { - s7_int byte; - if (!s7_is_integer(vals[i])) - copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); - byte = s7_integer_clamped_if_gmp(sc, vals[i]); - if ((byte >= 0) && (byte < 256)) - dst[j] = (uint8_t)byte; - else copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); - } - return(dest); - }} - break; - - case T_FLOAT_VECTOR: - { - s7_double *src = float_vector_floats(source); - /* int-vector destination can't normally work, fractional parts get rounded away */ - if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = make_real_unchecked(sc, src[i]); - return(dest); - }} - break; - - case T_INT_VECTOR: - { - s7_int *src = int_vector_ints(source); - if (is_float_vector(dest)) - { - s7_double *dst = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = (s7_double)(src[i]); - return(dest); - } - if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) - /* this could check that the typer is integer? (similarly elsewhere): - * (typed_vector_typer(dest) != global_value(sc->is_integer_symbol)) ? - */ - { - s7_pointer *dst = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = make_integer_unchecked(sc, src[i]); - return(dest); - } - if (is_string(dest)) - { - for (i = start, j = 0; i < end; i++, j++) - { - if ((src[i] < 0) || (src[i] > 255)) - copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); - string_value(dest)[j] = (uint8_t)(src[i]); - } - return(dest); - } - if (is_byte_vector(dest)) - { - for (i = start, j = 0; i < end; i++, j++) - { - if ((src[i] < 0) || (src[i] > 255)) - copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); - byte_vector(dest, j) = (uint8_t)(src[i]); - } - return(dest); - }} - break; - - case T_BYTE_VECTOR: - if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = small_int(byte_vector(source, i)); - return(dest); - } - if (is_int_vector(dest)) - { - s7_int *els = int_vector_ints(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_int)((uint8_t)(byte_vector(source, i))); - return(dest); - } - if (is_float_vector(dest)) - { - s7_double *els = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_double)((uint8_t)(byte_vector(source, i))); - return(dest); - } - break; - - case T_STRING: - if ((is_normal_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = chars[(uint8_t)string_value(source)[i]]; - return(dest); - } - if (is_int_vector(dest)) - { - s7_int *els = int_vector_ints(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_int)((uint8_t)(string_value(source)[i])); - return(dest); - } - if (is_float_vector(dest)) - { - s7_double *els = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_double)((uint8_t)(string_value(source)[i])); - return(dest); - } - break; - } - - if (is_pair(dest)) - { - s7_pointer p; - if (is_float_vector(source)) - { - s7_double *els = float_vector_floats(source); - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, make_real_unchecked(sc, els[i])); - } - else - if (is_int_vector(source)) - { - s7_int *els = int_vector_ints(source); - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, make_integer_unchecked(sc, els[i])); - } - else - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, get(sc, source, i)); - } - else /* if source == dest here, we're moving data backwards, so this is safe in either case */ - for (i = start, j = 0; i < end; i++, j++) - set(sc, dest, j, get(sc, source, i)); - /* some choices probably should raise an error, but don't: - * (copy (make-hash-table) "1") ; nothing to copy (empty hash table), so no error - */ - return(dest); -} - -s7_pointer s7_copy(s7_scheme *sc, s7_pointer args) {return(s7_copy_1(sc, sc->copy_symbol, args));} -#define g_copy s7_copy - - -/* -------------------------------- reverse -------------------------------- */ -s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) /* just pairs */ -{ - /* reverse list -- produce new list (other code assumes this function does not return the original!) */ - s7_pointer x, p; - - if (is_null(a)) return(a); - if (!is_pair(cdr(a))) - return((is_null(cdr(a))) ? list_1(sc, car(a)) : cons(sc, cdr(a), car(a))); /* don't return 'a' itself */ - sc->w = list_1(sc, car(a)); - for (x = cdr(a), p = a; is_pair(x); x = cdr(x), p = cdr(p)) - { - sc->w = cons(sc, car(x), sc->w); - if (is_pair(cdr(x))) - { - x = cdr(x); - sc->w = cons_unchecked(sc, car(x), sc->w); - } - if (x == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */ - break; - } - p = (is_null(x)) ? sc->w : cons(sc, x, sc->w); /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return () here */ - sc->w = sc->unused; - return(p); -} - -/* s7_reverse sometimes tacks extra nodes on the end of a reversed circular list (it detects the cycle too late) - * (let ((lst (list 0))) (set! (cdr lst) lst) (reverse lst)) -> (#1=(0 . #1#) 0 0 0) - */ - -static s7_pointer reverse_p_p(s7_scheme *sc, s7_pointer p) -{ - s7_pointer np = sc->nil; - sc->temp3 = p; - switch (type(p)) - { - case T_NIL: - return(sc->nil); - - case T_PAIR: - return(s7_reverse(sc, p)); - - case T_STRING: - { - char *dest, *source = string_value(p); - s7_int len = string_length(p); - char *end = (char *)(source + len); - np = make_empty_string(sc, len, '\0'); - dest = (char *)(string_value(np) + len); - while (source < end) *(--dest) = *source++; - } - break; - - case T_BYTE_VECTOR: - { - uint8_t *dest; - const uint8_t *source = byte_vector_bytes(p); - s7_int len = byte_vector_length(p); - const uint8_t *end = (const uint8_t *)(source + len); - np = make_simple_byte_vector(sc, len); - dest = (uint8_t *)(byte_vector_bytes(np) + len); - while (source < end) *(--dest) = *source++; - } - break; - - case T_INT_VECTOR: - { - s7_int *dest, *source = int_vector_ints(p); - s7_int len = vector_length(p); - s7_int *end = (s7_int *)(source + len); - if (vector_rank(p) > 1) - np = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, p)), int_zero), sc->make_int_vector_symbol); - else np = make_simple_int_vector(sc, len); - dest = (s7_int *)(int_vector_ints(np) + len); - while (source < end) *(--dest) = *source++; - } - break; - - case T_FLOAT_VECTOR: - { - s7_double *dest, *source = float_vector_floats(p); - s7_int len = vector_length(p); - s7_double *end = (s7_double *)(source + len); - if (vector_rank(p) > 1) - np = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, p)), real_zero), sc->make_float_vector_symbol); - else np = make_simple_float_vector(sc, len); - dest = (s7_double *)(float_vector_floats(np) + len); - while (source < end) *(--dest) = *source++; - } - break; - - case T_VECTOR: - { - s7_pointer *dest, *source = vector_elements(p); - s7_int len = vector_length(p); - s7_pointer *end = (s7_pointer *)(source + len); - if (vector_rank(p) > 1) - np = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, p)))); - else np = make_simple_vector(sc, len); - dest = (s7_pointer *)(vector_elements(np) + len); - while (source < end) *(--dest) = *source++; - if (is_typed_vector(p)) - { - set_typed_vector(np); - typed_vector_set_typer(np, typed_vector_typer(p)); - if (has_simple_elements(p)) set_has_simple_elements(np); - }} - break; - - case T_HASH_TABLE: - return(hash_table_reverse(sc, p)); - - case T_C_OBJECT: - check_method(sc, p, sc->reverse_symbol, set_plist_1(sc, p)); - if (!c_object_reverse(sc, p)) - syntax_error_nr(sc, "attempt to reverse ~S?", 22, p); - return((*(c_object_reverse(sc, p)))(sc, set_plist_1(sc, p))); - - case T_LET: - check_method(sc, p, sc->reverse_symbol, set_plist_1(sc, p)); - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't reverse let: ~S", 21), p)); - - default: - return(sole_arg_method_or_bust_p(sc, p, sc->reverse_symbol, a_sequence_string)); - } - return(np); -} - -static s7_pointer g_reverse(s7_scheme *sc, s7_pointer args) -{ - #define H_reverse "(reverse lst) returns a list with the elements of lst in reverse order. reverse \ -also accepts a string or vector argument." - #define Q_reverse s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_sequence_symbol) - return(reverse_p_p(sc, car(args))); -} - -static s7_pointer any_list_reverse_in_place(s7_scheme *sc, s7_pointer term, s7_pointer list) -{ - s7_pointer p, result; - if (is_null(list)) return(term); - p = list; - result = term; - while (true) - { - s7_pointer q = cdr(p); - if (is_null(q)) - { - set_cdr(p, result); - return(p); - } - if ((is_pair(q)) && (!is_immutable_pair(q))) - { - set_cdr(p, result); - result = p; - p = q; - } - else return(sc->nil); /* improper or immutable */ - } - return(result); -} - -static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) -{ - #define H_reverse_in_place "(reverse! lst) reverses lst in place" - #define Q_reverse_in_place Q_reverse - - /* (reverse v) is only slighly faster than (reverse! (copy v)) */ - s7_pointer p = car(args); - switch (type(p)) - { - case T_NIL: - return(sc->nil); - - case T_PAIR: - if (is_immutable_pair(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_pointer np = any_list_reverse_in_place(sc, sc->nil, p); - if (is_null(np)) - wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a mutable, proper list", 22)); - return(np); - } - /* (reverse! p) is supposed to change p directly and lisp programmers expect reverse! to be fast - * so in a sense this is different from the other cases: it assumes (set! p (reverse! p)) - * To make (reverse! p) direct: - * for (l = p, r = cdr(p); is_pair(r); l = r, r = cdr(r)) opt1(r) = l; - * if (!is_null(r)) sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, a_proper_list_string); - * for (r = l, l = p; l != r; l = cdr(l)) {t = car(l); set_car(l, car(r)); set_car(r, t); if (cdr(l) != r) r = opt1(r);} - * immutable check is needed else (reverse! (catch #t 1 cons)) clobbers sc->wrong_type_arg_info - */ - - case T_BYTE_VECTOR: - case T_STRING: - if (is_immutable(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_int len; - uint8_t *bytes; - if (is_string(p)) - { - len = string_length(p); - bytes = (uint8_t *)string_value(p); - } - else - { - len = byte_vector_length(p); - bytes = byte_vector_bytes(p); - } - if (len < 2) return(p); - -#if (defined(__linux__)) && (defined(__GLIBC__)) /* need byteswp.h */ - /* this code (from StackOverflow with changes) is much faster: */ - #include - if ((len & 0x7f) == 0) - { - uint32_t *dst = (uint32_t *)(bytes + len - 4); - uint32_t *src = (uint32_t *)bytes; - while (src < dst) - { - uint32_t a, b; - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - }} - else - if ((len & 0x1f) == 0) /* 4-bytes at a time, 4 times per loop == 16 */ - { - uint32_t *dst = (uint32_t *)(bytes + len - 4); - uint32_t *src = (uint32_t *)bytes; - while (src < dst) - { - uint32_t a, b; - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - }} - else -#endif - { - char *s1 = (char *)bytes; - char *s2 = (char *)(s1 + len - 1); - while (s1 < s2) {char c; c = *s1; *s1++ = *s2; *s2-- = c;} - }} - break; - - case T_INT_VECTOR: - if (is_immutable_vector(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_int len = vector_length(p); - s7_int *s1 = int_vector_ints(p), *s2; - if (len < 2) return(p); - s2 = (s7_int *)(s1 + len - 1); - if ((len & 0x3f) == 0) /* 63 for 2 32's */ - while (s1 < s2) - { - s7_int c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else - if ((len & 0xf) == 0) /* not 0x7 -- odd multiple of 8 will leave center ints unreversed (we're moving 2 at a time) */ - while (s1 < s2) - { - s7_int c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else while (s1 < s2) {s7_int c; c = *s1; *s1++ = *s2; *s2-- = c;} - } - break; - - case T_FLOAT_VECTOR: - if (is_immutable_vector(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_int len = vector_length(p); - s7_double *s1 = float_vector_floats(p), *s2; - if (len < 2) return(p); - s2 = (s7_double *)(s1 + len - 1); - if ((len & 0x3f) == 0) /* 63 for 2 32's */ - while (s1 < s2) - { - s7_double c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else - if ((len & 0xf) == 0) - while (s1 < s2) - { - s7_double c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else while (s1 < s2) {s7_double c; c = *s1; *s1++ = *s2; *s2-- = c;} - } - break; - - case T_VECTOR: - if (is_immutable_vector(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - { - s7_int len = vector_length(p); - s7_pointer *s1 = vector_elements(p), *s2; - if (len < 2) return(p); - s2 = (s7_pointer *)(s1 + len - 1); - if ((len & 0x3f) == 0) /* 63 for 2 32's */ - while (s1 < s2) - { - s7_pointer c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else - if ((len & 0xf) == 0) - while (s1 < s2) - { - s7_pointer c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } - else while (s1 < s2) {s7_pointer c; c = *s1; *s1++ = *s2; *s2-- = c;} - } - break; - - default: - if (is_immutable(p)) - { - if (is_simple_sequence(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, a_sequence_string); - } - if ((is_simple_sequence(p)) && - (!has_active_methods(sc, p))) - sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, wrap_string(sc, "a vector, string, or list", 25)); - return(sole_arg_method_or_bust_p(sc, p, sc->reverseb_symbol, a_sequence_string)); - } - return(p); -} - - -/* -------------------------------- fill! -------------------------------- */ -static s7_pointer pair_fill(s7_scheme *sc, s7_pointer args) -{ - /* ambiguous ("tree-fill"?) but if it's like vector-fill, we just stomp on the top level */ - s7_pointer obj = car(args), val; - s7_int i, start = 0, end, len; - -#if WITH_HISTORY - if ((is_immutable_pair(obj)) && (obj != sc->eval_history1) && (obj != sc->eval_history2)) -#else - if (is_immutable_pair(obj)) -#endif - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->fill_symbol, obj)); - if (obj == global_value(sc->features_symbol)) - error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't fill! *features*", 22))); - if (obj == global_value(sc->libraries_symbol)) - error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't fill! *libraries*", 23))); - - val = cadr(args); - len = s7_list_length(sc, obj); - end = len; - if (end < 0) end = -end; else {if (end == 0) end = 123123123;} - if (!is_null(cddr(args))) - { - s7_pointer p = start_and_end(sc, sc->fill_symbol, args, 3, cddr(args), &start, &end); - if (p != sc->unused) return(p); - if (start == end) return(val); - } - if (len > 0) - { - s7_pointer p; - if (end < len) len = end; - for (i = 0, p = obj; i < start; p = cdr(p), i++); - for (; i < len; p = cdr(p), i++) set_car(p, val); - return(val); - } - i = 0; - for (s7_pointer x = obj, y = obj; ; i++) - { - if ((end > 0) && (i >= end)) - return(val); - if (i >= start) set_car(x, val); - if (!is_pair(cdr(x))) - { - if (!is_null(cdr(x))) - set_cdr(x, val); - return(val); - } - x = cdr(x); - if ((i & 1) != 0) y = cdr(y); - if (x == y) - return(val); - } - return(val); -} - -s7_pointer s7_fill(s7_scheme *sc, s7_pointer args) -{ - #define H_fill "(fill! obj val (start 0) end) fills obj with val" - #define Q_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->T, sc->is_integer_symbol) - - s7_pointer p = car(args); - switch (type(p)) - { - case T_STRING: return(g_string_fill_1(sc, sc->fill_symbol, args)); /* redundant type check here and below */ - case T_PAIR: return(pair_fill(sc, args)); - case T_HASH_TABLE: return(hash_table_fill(sc, args)); - case T_NIL: - if (!is_null(cddr(args))) /* (fill! () 1 21 #\a)? */ - syntax_error_nr(sc, "fill! () ... includes indices: ~S?", 34, cddr(args)); - return(cadr(args)); /* this parallels the empty vector case */ - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: - return(g_vector_fill_1(sc, sc->fill_symbol, args)); - case T_LET: - check_method(sc, p, sc->fill_symbol, args); - return(let_fill(sc, args)); - case T_C_OBJECT: - check_method(sc, p, sc->fill_symbol, args); - if (!c_object_fill(sc, p)) /* default is NULL (s7_make_c_type) */ - syntax_error_nr(sc, "attempt to fill ~S?", 19, p); - return((*(c_object_fill(sc, p)))(sc, args)); - default: - check_method(sc, p, sc->fill_symbol, args); - } - wrong_type_error_nr(sc, sc->fill_symbol, 1, p, a_sequence_string); /* (fill! 1 0) */ - return(NULL); -} - -#define g_fill s7_fill - - -/* -------------------------------- append -------------------------------- */ -static s7_int total_sequence_length(s7_scheme *sc, s7_pointer args, s7_pointer caller, uint8_t typ) -{ - s7_pointer p = args; - s7_int len = 0; - - for (s7_int i = 1; is_pair(p); p = cdr(p), i++) - { - s7_pointer seq = car(p); - s7_int n = sequence_length(sc, seq); - if ((n > 0) && - (typ != T_FREE) && - ((type(seq) == T_HASH_TABLE) || /* can't append hash-tables (no obvious meaning to the operation) */ - ((type(seq) == T_LET) && /* similarly for lets, unless this is a mock-string or something similar */ - ((!has_active_methods(sc, seq)) || (find_method(sc, seq, caller) == sc->undefined))))) - { - wrong_type_error_nr(sc, caller, i, seq, sc->type_names[typ]); - return(0); - } - if (n < 0) - { - wrong_type_error_nr(sc, caller, i, seq, (is_pair(seq)) ? a_proper_list_string : a_sequence_string); - return(0); - } - len += n; - } - return(len); -} - -static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_pointer caller) -{ - s7_pointer new_vec, p, pargs, vtyper = NULL; - s7_pointer *v_elements = NULL; - s7_double *fv_elements = NULL; - s7_int *iv_elements = NULL; - uint8_t *byte_elements = NULL; - s7_int i, len; - bool typed; - - s7_gc_protect_via_stack(sc, args); - len = total_sequence_length(sc, args, caller, (typ == T_VECTOR) ? T_FREE : ((typ == T_FLOAT_VECTOR) ? T_REAL : T_INTEGER)); - if (len > sc->max_vector_length) - { - unstack(sc); - error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S new vector length, ~D, is larger than (*s7* 'max-vector-length): ~D", 70), - caller, - wrap_integer(sc, len), - wrap_integer(sc, sc->max_vector_length))); - } - new_vec = make_vector_1(sc, len, (typ == T_VECTOR) ? FILLED : NOT_FILLED, typ); /* might hit GC in loop below so we can't use NOT_FILLED here (??) */ - typed = (typ == T_VECTOR); - set_stack_protected2(sc, new_vec); - add_vector(sc, new_vec); - if (len == 0) - { - unstack(sc); - return(new_vec); - } - if (typ == T_VECTOR) - v_elements = vector_elements(new_vec); - else - if (typ == T_FLOAT_VECTOR) - fv_elements = float_vector_floats(new_vec); - else - if (typ == T_INT_VECTOR) - iv_elements = int_vector_ints(new_vec); - else byte_elements = byte_vector_bytes(new_vec); - - pargs = list_2(sc, sc->F, new_vec); /* car set below */ - /* push_stack_no_let(sc, OP_GC_PROTECT, new_vec, pargs); */ - set_stack_protected3(sc, pargs); - for (i = 0, p = args; is_pair(p); p = cdr(p)) /* in-place copy by goofing with new_vec's elements pointer */ - { - s7_pointer x = car(p); - s7_int n = sequence_length(sc, x); - if (n > 0) - { - if ((typed) && (is_normal_vector(x)) && (is_typed_vector(x))) - { - if (!vtyper) - vtyper = typed_vector_typer(x); - else - if (vtyper != typed_vector_typer(x)) - typed = false; - } - else typed = false; - vector_length(new_vec) = n; - set_car(pargs, x); - s7_copy_1(sc, caller, pargs); /* not set_plist_2 here! */ - vector_length(new_vec) = 0; /* so GC doesn't march off the end */ - i += n; - if (typ == T_VECTOR) - vector_elements(new_vec) = (s7_pointer *)(v_elements + i); - else - if (typ == T_FLOAT_VECTOR) - float_vector_floats(new_vec) = (s7_double *)(fv_elements + i); - else - if (typ == T_INT_VECTOR) - int_vector_ints(new_vec) = (s7_int *)(iv_elements + i); - else byte_vector_bytes(new_vec) = (uint8_t *)(byte_elements + i); - }} - /* unstack(sc); */ /* free_cell(sc, pargs); */ /* this is trouble if any arg is openlet with append method -- e.g. block */ - - if (typ == T_VECTOR) - vector_elements(new_vec) = v_elements; - else - if (typ == T_FLOAT_VECTOR) - float_vector_floats(new_vec) = fv_elements; - else - if (typ == T_INT_VECTOR) - int_vector_ints(new_vec) = iv_elements; - else byte_vector_bytes(new_vec) = byte_elements; - vector_length(new_vec) = len; - if ((typed) && (vtyper)) - { - set_typed_vector(new_vec); - typed_vector_set_typer(new_vec, vtyper); - } - unstack(sc); - return(new_vec); -} - -static s7_pointer hash_table_append(s7_scheme *sc, s7_pointer args) -{ - s7_pointer new_hash, key_typer = NULL, value_typer = NULL; - bool typed = true; - s7_gc_protect_via_stack(sc, args); - check_stack_size(sc); - new_hash = s7_make_hash_table(sc, sc->default_hash_table_length); - set_stack_protected2(sc, new_hash); - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer seq = car(p); - if (!sequence_is_empty(sc, seq)) - { - s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, seq, new_hash)); - if ((typed) && (is_hash_table(seq)) && (is_typed_hash_table(seq))) - { - if (!key_typer) - { /* the equality/mapping procedures are either partly implicit or in hash-table-procedures -- a bit of a mess currently */ - key_typer = hash_table_key_typer(seq); - value_typer = hash_table_value_typer(seq); - } - else - if ((hash_table_key_typer(seq) != key_typer) || - (hash_table_value_typer(seq) != value_typer)) - typed = false; - } - else typed = false; - }} - if ((typed) && (key_typer)) - { - hash_table_set_procedures(new_hash, make_hash_table_procedures(sc)); - set_is_typed_hash_table(new_hash); - hash_table_set_key_typer(new_hash, key_typer); - hash_table_set_value_typer(new_hash, value_typer); - } - set_plist_2(sc, sc->nil, sc->nil); - unstack(sc); - return(new_hash); -} - -static s7_pointer let_append(s7_scheme *sc, s7_pointer args) -{ - s7_pointer new_let, e = car(args); - check_method(sc, e, sc->append_symbol, args); - s7_gc_protect_via_stack(sc, args); - new_let = make_let(sc, sc->nil); - set_stack_protected2(sc, new_let); - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - if (!sequence_is_empty(sc, car(p))) - s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, car(p), new_let)); - set_plist_2(sc, sc->nil, sc->nil); - unstack(sc); - return(new_let); -} - -static s7_pointer g_append(s7_scheme *sc, s7_pointer args) -{ - #define H_append "(append ...) returns its argument sequences appended into one sequence" - #define Q_append s7_make_circular_signature(sc, 0, 1, sc->T) - - if (is_null(args)) return(sc->nil); /* (append) -> () */ - if (is_null(cdr(args))) return(car(args)); /* (append ) -> */ - sc->value = args; - args = copy_proper_list(sc, args); /* copied since other args might invoke methods */ - sc->value = args; - switch (type(car(args))) - { - case T_NIL: return(g_list_append(sc, cdr(args))); - case T_PAIR: return(g_list_append(sc, args)); - case T_STRING: return(g_string_append_1(sc, args, sc->append_symbol)); - /* should this work in the generic append: (append "12" #\3) -- currently an error, (append (list 1 2) 3) -> '(1 2 . 3), but vector is error */ - case T_HASH_TABLE: return(hash_table_append(sc, args)); - case T_LET: return(let_append(sc, args)); - case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - return(vector_append(sc, args, type(car(args)), sc->append_symbol)); - default: check_method(sc, car(args), sc->append_symbol, args); - } - wrong_type_error_nr(sc, sc->append_symbol, 1, car(args), a_sequence_string); /* (append 1 0) */ - return(NULL); -} - -static s7_pointer append_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(g_append(sc, set_plist_3(sc, p1, p2, p3)));} - -s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - if (is_pair(a)) - { - s7_pointer q, p, np, op; - if ((!is_pair(b)) && (!is_null(b))) - return(g_list_append(sc, list_2(sc, a, b))); - q = list_1(sc, car(a)); - sc->temp8 = q; - for (op = a, p = cdr(a), np = q; (is_pair(p)) && (p != op); p = cdr(p), np = cdr(np), op = cdr(op)) - { - set_cdr(np, list_1_unchecked(sc, car(p))); p = cdr(p); np = cdr(np); - if (!is_pair(p)) break; - set_cdr(np, list_1(sc, car(p))); - } - if (!is_null(p)) - wrong_type_error_nr(sc, sc->append_symbol, 1, a, a_proper_list_string); - set_cdr(np, b); - sc->temp8 = sc->unused; - return(q); - } - if (is_null(a)) return(b); - return(g_append(sc, set_plist_2(sc, a, b))); -} - -static s7_pointer g_append_2(s7_scheme *sc, s7_pointer args) {return(s7_append(sc, car(args), cadr(args)));} - -static s7_pointer append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args == 2) return(sc->append_2); - return(f); -} - - -/* -------------------------------- object->let -------------------------------- */ -static s7_pointer byte_vector_to_list(s7_scheme *sc, const uint8_t *str, s7_int len) -{ - s7_pointer p; - if (len == 0) return(sc->nil); - check_free_heap_size(sc, len); - sc->w = sc->nil; - for (s7_int i = len - 1; i >= 0; i--) - sc->w = cons_unchecked(sc, small_int((uint32_t)(str[i])), sc->w); - p = sc->w; - sc->w = sc->unused; - return(p); -} - -static s7_pointer hash_table_to_list(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer x, iterator; - if (hash_table_entries(obj) <= 0) return(sc->nil); - iterator = s7_make_iterator(sc, obj); - gc_protect_via_stack(sc, iterator); - sc->w = sc->nil; - while (true) - { - x = s7_iterate(sc, iterator); - if (iterator_is_at_end(iterator)) break; - sc->w = cons(sc, x, sc->w); - } - x = sc->w; - sc->w = sc->unused; - unstack(sc); - return(x); -} - -static s7_pointer iterator_to_list(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer result = sc->nil, p = NULL; - s7_int results = 0; - while (true) - { - s7_pointer val = s7_iterate(sc, obj); - if ((val == ITERATOR_END) && - (iterator_is_at_end(obj))) - { - if (is_pair(result)) unstack(sc); - return(result); - } - if (sc->safety > NO_SAFETY) - { - results++; - if (results > 10000) - { - s7_warn(sc, 256, "iterator is creating a very long list!\n"); - results = S7_INT32_MIN; - }} - if (val != sc->no_value) - { - if (is_null(result)) - { - if (is_multiple_value(val)) - { - result = multiple_value(val); - clear_multiple_value(val); - for (p = result; is_pair(cdr(p)); p = cdr(p)); - } - else - { - result = list_1(sc, val); - p = result; - } - gc_protect_via_stack(sc, result); /* unstacked above */ - } - else - if (is_multiple_value(val)) - { - set_cdr(p, multiple_value(val)); - clear_multiple_value(val); - for (; is_pair(cdr(p)); p = cdr(p)); - } - else - { - set_cdr(p, list_1(sc, val)); - p = cdr(p); - }}} -} - -static s7_pointer c_obj_to_list(s7_scheme *sc, s7_pointer obj) /* "c_object_to_list" is the ->list method mentioned below */ -{ - int64_t len; - s7_pointer x, z, zc, result; - s7_int gc_z; - - if (c_object_to_list(sc, obj)) - return((*(c_object_to_list(sc, obj)))(sc, set_plist_1(sc, obj))); - - x = c_object_length(sc, obj); - if (!s7_is_integer(x)) return(sc->F); - len = s7_integer_clamped_if_gmp(sc, x); - if (len < 0) - return(sc->F); - if (len == 0) - return(sc->nil); - - result = make_list(sc, len, sc->nil); - sc->temp7 = result; - zc = make_mutable_integer(sc, 0); - z = list_2_unchecked(sc, obj, zc); - gc_z = gc_protect_1(sc, z); - x = result; - for (int64_t i = 0; i < len; i++, x = cdr(x)) /* used to save/restore sc->x|z here */ - { - integer(zc) = i; - set_car(x, (*(c_object_ref(sc, obj)))(sc, z)); - } - s7_gc_unprotect_at(sc, gc_z); - sc->temp7 = sc->unused; - return(result); -} - -static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) /* used only in format_to_port_1 and (map values ...) */ -{ - switch (type(obj)) - { - case T_STRING: return(string_to_list(sc, string_value(obj), string_length(obj))); - case T_BYTE_VECTOR: return(byte_vector_to_list(sc, byte_vector_bytes(obj), byte_vector_length(obj))); - case T_HASH_TABLE: return(hash_table_to_list(sc, obj)); - case T_ITERATOR: return(iterator_to_list(sc, obj)); - case T_C_OBJECT: return(c_obj_to_list(sc, obj)); - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: - return(s7_vector_to_list(sc, obj)); - case T_LET: -#if (!WITH_PURE_S7) - check_method(sc, obj, sc->let_to_list_symbol, set_plist_1(sc, obj)); -#endif - return(s7_let_to_list(sc, obj)); - } - return(obj); -} - - -/* ---------------- object->let ---------------- */ -static s7_pointer symbol_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let = internal_inlet(sc, 4, sc->value_symbol, obj, - sc->type_symbol, (is_keyword(obj)) ? sc->is_keyword_symbol : - ((is_gensym(obj)) ? sc->is_gensym_symbol : sc->is_symbol_symbol)); - if (!is_keyword(obj)) - { - s7_int gc_loc = gc_protect_1(sc, let); - s7_pointer val = s7_symbol_value(sc, obj); - if (!sc->current_value_symbol) - sc->current_value_symbol = make_symbol(sc, "current-value", 13); - s7_varlet(sc, let, sc->current_value_symbol, val); - s7_varlet(sc, let, sc->setter_symbol, setter_p_pp(sc, obj, sc->curlet)); - s7_varlet(sc, let, sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_symbol(obj))); - if (!is_undefined(val)) - { - const char *doc = s7_documentation(sc, obj); - if (doc) - s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); - } - s7_gc_unprotect_at(sc, gc_loc); - } - return(let); -} - -static s7_pointer random_state_to_let(s7_scheme *sc, s7_pointer obj) -{ -#if WITH_GMP - return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_random_state_symbol)); -#else - if (!sc->seed_symbol) - { - sc->seed_symbol = make_symbol(sc, "seed", 4); - sc->carry_symbol = make_symbol(sc, "carry", 5); - } - return(internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, sc->is_random_state_symbol, - sc->seed_symbol, make_integer(sc, random_seed(obj)), - sc->carry_symbol, make_integer(sc, random_carry(obj)))); -#endif -} - -static s7_pointer vector_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let; - s7_int gc_loc; - - if (!sc->dimensions_symbol) sc->dimensions_symbol = make_symbol(sc, "dimensions", 10); - if (!sc->original_vector_symbol) sc->original_vector_symbol = make_symbol(sc, "original-vector", 15); - let = internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, (is_subvector(obj)) ? cons(sc, sc->is_subvector_symbol, s7_type_of(sc, subvector_vector(obj))) : s7_type_of(sc, obj), - sc->size_symbol, s7_length(sc, obj), - sc->dimensions_symbol, g_vector_dimensions(sc, set_plist_1(sc, obj)), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_vector(obj))); - gc_loc = gc_protect_1(sc, let); - if (is_subvector(obj)) - { - s7_int pos = 0; - switch (type(obj)) /* correct type matters here: gcc 10.2 with -O2 segfaults otherwise, cast to intptr_t has a similar role in earlier gcc's */ - { - case T_VECTOR: pos = (s7_int)((intptr_t)(vector_elements(obj) - vector_elements(subvector_vector(obj)))); break; - case T_INT_VECTOR: pos = (s7_int)((intptr_t)(int_vector_ints(obj) - int_vector_ints(subvector_vector(obj)))); break; - case T_FLOAT_VECTOR: pos = (s7_int)((intptr_t)(float_vector_floats(obj) - float_vector_floats(subvector_vector(obj)))); break; - case T_BYTE_VECTOR: pos = (s7_int)((intptr_t)(byte_vector_bytes(obj) - byte_vector_bytes(subvector_vector(obj)))); break; - } - s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos)); - s7_varlet(sc, let, sc->original_vector_symbol, subvector_vector(obj)); - } - if (is_typed_vector(obj)) - s7_varlet(sc, let, sc->signature_symbol, g_signature(sc, set_plist_1(sc, obj))); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static void hash_table_checker_to_let(s7_scheme *sc, s7_pointer let, s7_pointer obj) -{ - if ((hash_table_checker(obj) == hash_eq) || - (hash_table_checker(obj) == hash_c_function) || - (hash_table_checker(obj) == hash_closure) || - (hash_table_checker(obj) == hash_equal_eq) || - (hash_table_checker(obj) == hash_equal_syntax) || - (hash_table_checker(obj) == hash_symbol)) - s7_varlet(sc, let, sc->function_symbol, sc->is_eq_symbol); - else - if (hash_table_checker(obj) == hash_eqv) - s7_varlet(sc, let, sc->function_symbol, sc->is_eqv_symbol); - else - if ((hash_table_checker(obj) == hash_equal) || - (hash_table_checker(obj) == hash_empty)) - s7_varlet(sc, let, sc->function_symbol, sc->is_equal_symbol); - else - if (hash_table_checker(obj) == hash_equivalent) - s7_varlet(sc, let, sc->function_symbol, sc->is_equivalent_symbol); - else - if ((hash_table_checker(obj) == hash_number_num_eq) || - (hash_table_checker(obj) == hash_int) || - (hash_table_checker(obj) == hash_float)) - s7_varlet(sc, let, sc->function_symbol, sc->num_eq_symbol); - else - if (hash_table_checker(obj) == hash_string) - s7_varlet(sc, let, sc->function_symbol, sc->string_eq_symbol); - else - if (hash_table_checker(obj) == hash_char) - s7_varlet(sc, let, sc->function_symbol, sc->char_eq_symbol); -#if (!WITH_PURE_S7) - else - if (hash_table_checker(obj) == hash_ci_char) - s7_varlet(sc, let, sc->function_symbol, sc->char_ci_eq_symbol); - else - if (hash_table_checker(obj) == hash_ci_string) - s7_varlet(sc, let, sc->function_symbol, sc->string_ci_eq_symbol); -#endif -} - -static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let; - s7_int gc_loc; - if (!sc->entries_symbol) - { - sc->entries_symbol = make_symbol(sc, "entries", 7); - sc->weak_symbol = make_symbol(sc, "weak", 4); - } - let = internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, sc->is_hash_table_symbol, - sc->size_symbol, s7_length(sc, obj), - sc->entries_symbol, make_integer(sc, hash_table_entries(obj)), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - gc_loc = gc_protect_1(sc, let); - if (is_weak_hash_table(obj)) - s7_varlet(sc, let, sc->weak_symbol, sc->T); - - if (is_typed_hash_table(obj)) - { - s7_pointer checker = hash_table_procedures_checker(obj); - if (checker == sc->T) /* perhaps typed because typers were set, but not checker/mapper */ - hash_table_checker_to_let(sc, let, obj); - else s7_varlet(sc, let, sc->function_symbol, list_2(sc, checker, hash_table_procedures_mapper(obj))); - s7_varlet(sc, let, sc->signature_symbol, - (is_typed_hash_table(obj)) ? - list_3(sc, - hash_table_typer_symbol(sc, hash_table_value_typer(obj)), - sc->is_hash_table_symbol, - hash_table_typer_symbol(sc, hash_table_key_typer(obj))) : - sc->hash_table_signature); - } - else hash_table_checker_to_let(sc, let, obj); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer iterator_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let, seq = iterator_sequence(obj); - s7_int gc_loc; - if (!sc->at_end_symbol) - { - sc->at_end_symbol = make_symbol(sc, "at-end", 6); - sc->sequence_symbol = make_symbol(sc, "sequence", 8); - } - let = internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, sc->is_iterator_symbol, - sc->at_end_symbol, s7_make_boolean(sc, iterator_is_at_end(obj)), - sc->sequence_symbol, iterator_sequence(obj)); - gc_loc = gc_protect_1(sc, let); - if (is_pair(seq)) - s7_varlet(sc, let, sc->size_symbol, s7_length(sc, seq)); - else - if (is_hash_table(seq)) - s7_varlet(sc, let, sc->size_symbol, make_integer(sc, hash_table_entries(seq))); - else s7_varlet(sc, let, sc->size_symbol, s7_length(sc, obj)); - if ((is_string(seq)) || - (is_any_vector(seq)) || - (seq == sc->rootlet) || - (is_c_object(seq)) || - (is_hash_table(seq))) - s7_varlet(sc, let, sc->position_symbol, make_integer(sc, iterator_position(obj))); - else - if (is_pair(seq)) - s7_varlet(sc, let, sc->position_symbol, iterator_current(obj)); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer let_to_let(s7_scheme *sc, s7_pointer obj) -{ - /* how to handle setters? - * (display (let ((e (let ((i 0)) (set! (setter 'i) integer?) (curlet)))) (object->let e))): - * "(inlet 'value (inlet 'i 0) 'type let? 'length 1 'open #f 'outlet () 'immutable? #f)" - */ - s7_pointer let; - s7_int gc_loc; - if (!sc->open_symbol) - { - sc->open_symbol = make_symbol(sc, "open", 4); - sc->alias_symbol = make_symbol(sc, "alias", 5); - } - let = internal_inlet(sc, 12, sc->value_symbol, obj, - sc->type_symbol, sc->is_let_symbol, - sc->size_symbol, s7_length(sc, obj), - sc->open_symbol, s7_make_boolean(sc, is_openlet(obj)), - sc->outlet_symbol, (obj == sc->rootlet) ? sc->nil : let_outlet(obj), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - gc_loc = gc_protect_1(sc, let); - if (obj == sc->rootlet) - s7_varlet(sc, let, sc->alias_symbol, sc->rootlet_symbol); - else - if (obj == sc->owlet) /* this can't happen, I think -- owlet is always copied first */ - s7_varlet(sc, let, sc->alias_symbol, sc->owlet_symbol); - else - if (is_funclet(obj)) - { - s7_varlet(sc, let, sc->function_symbol, funclet_function(obj)); - if ((has_let_file(obj)) && - (let_file(obj) <= (s7_int)sc->file_names_top) && - (let_line(obj) > 0) && - (let_line(obj) < 1000000)) - { - s7_varlet(sc, let, sc->file_symbol, sc->file_names[let_file(obj)]); - s7_varlet(sc, let, sc->line_symbol, make_integer(sc, let_line(obj))); - }} - else - if (obj == sc->s7_starlet) - { - s7_pointer iter = s7_make_iterator(sc, obj); - s7_int gc_loc1 = s7_gc_protect(sc, iter); - while (true) - { - s7_pointer x = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - s7_varlet(sc, let, car(x), cdr(x)); - } - s7_gc_unprotect_at(sc, gc_loc1); - } - if (has_active_methods(sc, obj)) - { - s7_pointer func = find_method(sc, obj, sc->object_to_let_symbol); - if (func != sc->undefined) - s7_apply_function(sc, func, set_plist_2(sc, obj, let)); - } - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer obj) -{ - s7_pointer let, clet = c_object_let(obj); - if (!sc->class_symbol) - { - sc->class_symbol = make_symbol(sc, "class", 5); - sc->c_object_let_symbol = make_symbol(sc, "c-object-let", 12); - } - let = internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, sc->is_c_object_symbol, - sc->c_object_type_symbol, make_integer(sc, c_object_type(obj)), - sc->c_object_let_symbol, clet, - sc->class_symbol, c_object_type_to_let(sc, obj)); - if ((is_let(clet)) && - ((has_active_methods(sc, clet)) || (has_active_methods(sc, obj)))) - { - s7_int gc_loc = gc_protect_1(sc, let); - s7_pointer func = find_method(sc, clet, sc->object_to_let_symbol); - if (func != sc->undefined) - s7_apply_function(sc, func, set_plist_2(sc, obj, let)); - s7_gc_unprotect_at(sc, gc_loc); - } - return(let); -} - -static s7_pointer port_to_let(s7_scheme *sc, s7_pointer obj) /* note the underbars! */ -{ - s7_pointer let; - s7_int gc_loc; - if (!sc->data_symbol) - { - sc->data_symbol = make_symbol(sc, "data", 4); - sc->port_type_symbol = make_symbol(sc, "port-type", 9); - sc->closed_symbol = make_symbol(sc, "closed", 6); - sc->file_info_symbol = make_symbol(sc, "file-info", 9); - } - let = internal_inlet(sc, 10, sc->value_symbol, obj, - /* obj as 'value means it will say "(closed)" when subsequently the let is displayed */ - sc->type_symbol, (is_input_port(obj)) ? sc->is_input_port_symbol : sc->is_output_port_symbol, - sc->port_type_symbol, (is_string_port(obj)) ? sc->string_symbol : ((is_file_port(obj)) ? sc->file_symbol : sc->function_symbol), - sc->closed_symbol, s7_make_boolean(sc, port_is_closed(obj)), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_port(obj))); - gc_loc = gc_protect_1(sc, let); - if (is_file_port(obj)) - { - s7_varlet(sc, let, sc->file_symbol, g_port_filename(sc, set_plist_1(sc, obj))); - if (is_input_port(obj)) - s7_varlet(sc, let, sc->line_symbol, g_port_line_number(sc, set_plist_1(sc, obj))); -#if (!MS_WINDOWS) - if ((!port_is_closed(obj)) && (obj != sc->standard_error) && (obj != sc->standard_input) && (obj != sc->standard_output)) - { - struct stat sb; - s7_varlet(sc, let, sc->file_symbol, make_integer(sc, fileno(port_file(obj)))); - if (fstat(fileno(port_file(obj)), &sb) != -1) - { - char c1[64], c2[64], str[512]; - int32_t bytes; - strftime(c1, 64, "%a %d-%b-%Y %H:%M", localtime(&sb.st_atime)); - strftime(c2, 64, "%a %d-%b-%Y %H:%M", localtime(&sb.st_mtime)); - bytes = snprintf(str, 512, "mode: #o%u, links: %ld, owner uid: %d gid: %d, size: %ld bytes, last file access: %s, last file modification: %s", - sb.st_mode, - (long)sb.st_nlink, - (int)sb.st_uid, (int)sb.st_gid, - (long)sb.st_size, - c1, c2); - s7_varlet(sc, let, sc->file_info_symbol, make_string_with_length(sc, (const char *)str, bytes)); - }} -#endif - } - if ((is_string_port(obj)) && /* file port might not have a data buffer */ - (port_data(obj)) && - (port_data_size(obj) > 0)) - { - s7_varlet(sc, let, sc->size_symbol, make_integer(sc, port_data_size(obj))); - s7_varlet(sc, let, sc->position_symbol, make_integer(sc, port_position(obj))); - /* I think port_data need not be null-terminated, but s7_make_string assumes it is: - * both valgrind and lib*san complain about the uninitialized data during strlen. - */ - s7_varlet(sc, let, sc->data_symbol, - make_string_with_length(sc, (const char *)port_data(obj), ((port_position(obj)) > 16) ? 16 : port_position(obj))); - } - if (is_function_port(obj)) - s7_varlet(sc, let, sc->function_symbol, port_string_or_function(obj)); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer closure_to_let(s7_scheme *sc, s7_pointer obj) -{ - const char *doc = s7_documentation(sc, obj); - s7_pointer sig = s7_signature(sc, obj); - s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, - sc->arity_symbol, s7_arity(sc, obj), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - s7_int gc_loc = gc_protect_1(sc, let); - - if (is_pair(sig)) - s7_varlet(sc, let, sc->local_signature_symbol, sig); - if (doc) - s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); - - if (is_let(closure_let(obj))) - { - s7_pointer flet = closure_let(obj); - if ((has_let_file(flet)) && - (let_file(flet) <= (s7_int)sc->file_names_top) && - (let_line(flet) > 0)) - { - s7_varlet(sc, let, sc->file_symbol, sc->file_names[let_file(flet)]); - s7_varlet(sc, let, sc->line_symbol, make_integer(sc, let_line(flet))); - }} - - if (closure_setter(obj) != sc->F) - s7_varlet(sc, let, sc->local_setter_symbol, closure_setter(obj)); - - if (!sc->source_symbol) - sc->source_symbol = make_symbol(sc, "source", 6); - s7_varlet(sc, let, sc->source_symbol, - append_in_place(sc, list_2(sc, procedure_type_to_symbol(sc, type(obj)), closure_args(obj)), - closure_body(obj))); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer c_pointer_to_let(s7_scheme *sc, s7_pointer obj) -{ - /* c_pointer_info can be a let and might have an object->let method (see c_object below) */ - if (!sc->c_type_symbol) - { - sc->c_type_symbol = make_symbol(sc, "c-type", 6); - sc->info_symbol = make_symbol(sc, "info", 4); - } - if (!sc->pointer_symbol) sc->pointer_symbol = make_symbol(sc, "pointer", 7); - return(internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, sc->is_c_pointer_symbol, - sc->pointer_symbol, make_integer(sc, (s7_int)((intptr_t)c_pointer(obj))), - sc->c_type_symbol, c_pointer_type(obj), - sc->info_symbol, c_pointer_info(obj))); -} - -static s7_pointer c_function_to_let(s7_scheme *sc, s7_pointer obj) -{ - const char *doc = s7_documentation(sc, obj); - s7_pointer sig = c_function_signature(obj); - s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, - sc->arity_symbol, s7_arity(sc, obj), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable(obj))); - s7_int gc_loc = gc_protect_1(sc, let); - - if (is_pair(sig)) - s7_varlet(sc, let, sc->local_signature_symbol, sig); - if (doc) - s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); - - if (c_function_setter(obj) != sc->F) /* c_macro_setter is the same underlying field */ - s7_varlet(sc, let, sc->local_setter_symbol, c_function_setter(obj)); - s7_gc_unprotect_at(sc, gc_loc); - return(let); -} - -static s7_pointer goto_to_let(s7_scheme *sc, s7_pointer obj) -{ - /* there's room in s7_cell to store the procedure, but we would have to mark it (goto escapes, context GC'd) */ - if (!sc->active_symbol) - { - sc->active_symbol = make_symbol(sc, "active", 6); - sc->goto_symbol = make_symbol(sc, "goto?", 5); - } - if (is_symbol(call_exit_name(obj))) - return(internal_inlet(sc, 8, sc->value_symbol, obj, sc->type_symbol, sc->goto_symbol, - sc->active_symbol, s7_make_boolean(sc, call_exit_active(obj)), - sc->name_symbol, call_exit_name(obj))); - return(internal_inlet(sc, 6, sc->value_symbol, obj, sc->type_symbol, sc->goto_symbol, - sc->active_symbol, s7_make_boolean(sc, call_exit_active(obj)))); -} - -static s7_pointer object_to_let_p_p(s7_scheme *sc, s7_pointer obj) -{ - switch (type(obj)) - { - case T_NIL: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_null_symbol)); - case T_UNSPECIFIED: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_unspecified_symbol)); - case T_UNDEFINED: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_undefined_symbol)); - case T_EOF: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_eof_object_symbol)); - case T_BOOLEAN: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_boolean_symbol)); - case T_CHARACTER: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_char_symbol)); - case T_SYMBOL: return(symbol_to_let(sc, obj)); - case T_RANDOM_STATE: return(random_state_to_let(sc, obj)); - case T_GOTO: return(goto_to_let(sc, obj)); - case T_C_POINTER: return(c_pointer_to_let(sc, obj)); - case T_ITERATOR: return(iterator_to_let(sc, obj)); - case T_HASH_TABLE: return(hash_table_to_let(sc, obj)); - case T_LET: return(let_to_let(sc, obj)); - case T_C_OBJECT: return(c_object_to_let(sc, obj)); - - case T_INTEGER: case T_BIG_INTEGER: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_integer_symbol)); - case T_RATIO: case T_BIG_RATIO: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_rational_symbol)); - case T_REAL: case T_BIG_REAL: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_real_symbol)); - case T_COMPLEX: case T_BIG_COMPLEX: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_complex_symbol)); - - case T_STRING: - return(internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, sc->is_string_symbol, - sc->size_symbol, str_length(sc, obj), - sc->mutable_symbol, s7_make_boolean(sc, !is_immutable_string(obj)))); - case T_PAIR: - return(internal_inlet(sc, 6, sc->value_symbol, obj, - sc->type_symbol, sc->is_pair_symbol, - sc->size_symbol, pair_length(sc, obj))); - case T_SYNTAX: - return(internal_inlet(sc, 6, sc->value_symbol, obj, - sc->type_symbol, sc->is_syntax_symbol, - sc->documentation_symbol, s7_make_string(sc, syntax_documentation(obj)))); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_VECTOR: - return(vector_to_let(sc, obj)); - - case T_CONTINUATION: /* perhaps include the continuation-key */ - if (is_symbol(continuation_name(obj))) - return(internal_inlet(sc, 6, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol, sc->name_symbol, continuation_name(obj))); - return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol)); - - case T_INPUT_PORT: case T_OUTPUT_PORT: - return(port_to_let(sc, obj)); - - case T_CLOSURE: case T_CLOSURE_STAR: case T_MACRO: case T_MACRO_STAR: case T_BACRO: case T_BACRO_STAR: - return(closure_to_let(sc, obj)); - - case T_C_MACRO: case T_C_FUNCTION_STAR: - case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: - return(c_function_to_let(sc, obj)); - - default: - return(sc->F); - } - return(sc->F); -} - -static s7_pointer g_object_to_let(s7_scheme *sc, s7_pointer args) -{ - #define H_object_to_let "(object->let obj) returns a let (namespace) describing obj." - #define Q_object_to_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->T) - return(object_to_let_p_p(sc, car(args))); -} - - -/* ---------------- stacktrace ---------------- */ -static s7_pointer stacktrace_find_caller(s7_scheme *sc, s7_pointer e) -{ - if ((is_let(e)) && (e != sc->rootlet)) - return(((is_funclet(e)) || (is_maclet(e))) ? funclet_function(e) : stacktrace_find_caller(sc, let_outlet(e))); - return(sc->F); -} - -static bool stacktrace_find_let(s7_scheme *sc, int64_t loc, s7_pointer e) -{ - return((loc > 0) && - ((stack_let(sc->stack, loc) == e) || - (stacktrace_find_let(sc, loc - 4, e)))); -} - -static int64_t stacktrace_find_error_hook_quit(s7_scheme *sc) -{ - for (int64_t i = current_stack_top(sc) - 1; i >= 3; i -= 4) - if (stack_op(sc->stack, i) == OP_ERROR_HOOK_QUIT) - return(i); - return(-1); -} - -static bool stacktrace_in_error_handler(s7_scheme *sc, int64_t loc) -{ - return((let_outlet(sc->owlet) == sc->curlet) || - (stacktrace_find_let(sc, loc * 4, let_outlet(sc->owlet))) || - (stacktrace_find_error_hook_quit(sc) > 0)); -} - -static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym) -{ - if (is_symbol(sym)) - { - s7_pointer f = s7_symbol_value(sc, sym); - return((is_procedure(f)) && - (hook_has_functions(sc->error_hook)) && - (direct_memq(f, s7_hook_functions(sc, sc->error_hook)))); - } - return(false); -} - -static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e, char *notes, - s7_int code_cols, s7_int total_cols, s7_int notes_start_col, - bool as_comment, int32_t depth) -{ - if (is_symbol(code)) - { - if ((!symbol_is_in_list(sc, code)) && - (!is_slot(global_slot(code)))) - { - s7_pointer val; - add_symbol_to_list(sc, code); - val = s7_symbol_local_value(sc, code, e); - if ((val) && - (val != sc->undefined) && - (!is_any_macro(val))) - { - int32_t typ = type(val); - if (typ < T_CONTINUATION) - { - char *objstr, *str; - s7_pointer objp; - s7_int new_note_len, notes_max; - bool new_notes_line = false, old_short_print = sc->short_print; - s7_int old_len = sc->print_length, objlen; - - if (notes_start_col < 0) notes_start_col = 50; - if (notes_start_col > total_cols) notes_start_col = 0; - notes_max = total_cols - notes_start_col; - sc->short_print = true; - if (sc->print_length > 4) sc->print_length = 4; - objp = s7_object_to_string(sc, val, true); - objstr = string_value(objp); - objlen = string_length(objp); - if ((objlen > notes_max) && - (notes_max > 5)) - { - objstr[notes_max - 4] = '.'; - objstr[notes_max - 3] = '.'; - objstr[notes_max - 2] = '.'; - objstr[notes_max - 1] = '\0'; - objlen = notes_max; - } - sc->short_print = old_short_print; - sc->print_length = old_len; - - new_note_len = symbol_name_length(code) + 3 + objlen; - /* we want to append this much info to the notes, but does it need a new line? */ - if (notes_start_col < code_cols) - new_notes_line = true; - else - if (notes) - { - char *last_newline = strrchr(notes, (int)'\n'); /* returns ptr to end if none = nil if not found? */ - s7_int cur_line_len = (last_newline) ? (strlen(notes) - strlen(last_newline)) : strlen(notes); - new_notes_line = ((cur_line_len + new_note_len) > notes_max); - } - if (new_notes_line) - { - const char *spaces = " "; - s7_int spaces_len = 80; - new_note_len += (4 + notes_start_col + ((notes) ? strlen(notes) : 0)); - str = (char *)Malloc(new_note_len); /* str[0] = '\0'; */ - catstrs_direct(str, - (notes) ? notes : "", - "\n", - (as_comment) ? "; " : "", - (spaces_len >= notes_start_col) ? (char *)(spaces + spaces_len - notes_start_col) : "", - (as_comment) ? "" : " ; ", - symbol_name(code), - ": ", - objstr, (const char *)NULL); - } - else - { - new_note_len += ((notes) ? strlen(notes) : 0) + 4; - str = (char *)Malloc(new_note_len); /* str[0] = '\0'; */ - catstrs_direct(str, - (notes) ? notes : "", - (notes) ? ", " : " ; ", - symbol_name(code), - ": ", - objstr, (const char *)NULL); - } - if (notes) free(notes); - return(str); - }}} - return(notes); - } - if ((is_pair(code)) && - (s7_list_length(sc, code) > 0) && - (depth < 32)) - { - notes = stacktrace_walker(sc, car(code), e, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 1); - return(stacktrace_walker(sc, cdr(code), e, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 2)); - } - return(notes); -} - -static block_t *stacktrace_add_func(s7_scheme *sc, s7_pointer f, s7_pointer code, const char *errstr, char *notes, s7_int code_max, bool as_comment) -{ - s7_int newlen, errlen = strlen(errstr); - char *newstr, *str; - block_t *newp, *b; - if ((is_symbol(f)) && - (f != car(code))) - { - newlen = symbol_name_length(f) + errlen + 10; - newp = mallocate(sc, newlen); - newstr = (char *)block_data(newp); /* newstr[0] = '\0'; */ - errlen = catstrs_direct(newstr, symbol_name(f), ": ", errstr, (const char *)NULL); - } - else - { - newlen = errlen + 8; - newp = mallocate(sc, newlen); - newstr = (char *)block_data(newp); /* newstr[0] = '\0'; */ - if ((errlen > 2) && (errstr[2] == '(')) - errlen = catstrs_direct(newstr, " ", errstr, (const char *)NULL); - else - { - memcpy((void *)newstr, (void *)errstr, errlen); - newstr[errlen] = '\0'; - }} - newlen = code_max + 8 + ((notes) ? strlen(notes) : 0); - b = mallocate(sc, newlen); - str = (char *)block_data(b); /* str[0] = '\0'; */ - - if (errlen >= code_max) - { - newstr[code_max - 4] = '.'; - newstr[code_max - 3] = '.'; - newstr[code_max - 2] = '.'; - newstr[code_max - 1] = '\0'; - catstrs_direct(str, (as_comment) ? "; " : "", newstr, (notes) ? notes : "", "\n", (const char *)NULL); - } - else - { - /* send out newstr, pad with spaces to code_max, then notes */ - s7_int len = catstrs_direct(str, (as_comment) ? "; " : "", newstr, (const char *)NULL); - if (notes) - { - s7_int i; - for (i = len; i < code_max - 1; i++) str[i] = ' '; - str[i] = '\0'; - catstrs(str, newlen, notes, "\n", (char *)NULL); - } - else catstrs(str, newlen, "\n", (char *)NULL); - } - liberate(sc, newp); - return(b); -} - -static s7_pointer stacktrace_1(s7_scheme *sc, s7_int frames_max, s7_int code_cols, s7_int total_cols, s7_int notes_start_col, bool as_comment) -{ - char *str = NULL; - block_t *strp = NULL; - int64_t loc, frames = 0; - int64_t top = (sc->stack_end - sc->stack_start) / 4; /* (*s7* 'stack_top), not current_stack_top! */ - clear_symbol_list(sc); - - if (stacktrace_in_error_handler(sc, top)) - { - s7_pointer err_code = slot_value(sc->error_code); - if ((is_pair(err_code)) && - (!tree_is_cyclic(sc, err_code))) - { - char *notes = NULL; - s7_pointer current_let = let_outlet(sc->owlet); - s7_pointer errstr = s7_object_to_string(sc, err_code, false); - s7_pointer f = stacktrace_find_caller(sc, current_let); /* this is a symbol */ - if ((is_let(current_let)) && - (current_let != sc->rootlet)) - notes = stacktrace_walker(sc, err_code, current_let, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); - strp = stacktrace_add_func(sc, f, err_code, string_value(errstr), notes, code_cols, as_comment); - str = (char *)block_data(strp); - } - loc = stacktrace_find_error_hook_quit(sc); /* if OP_ERROR_HOOK_QUIT is in the stack, jump past it! */ - if (loc > 0) top = (loc + 1) / 4; - } - for (loc = top - 1; loc > 0; loc--) - { - s7_int true_loc = (loc + 1) * 4 - 1; - s7_pointer code = stack_code(sc->stack, true_loc); - if ((is_pair(code)) && - (!tree_is_cyclic(sc, code))) - { - s7_pointer codep = s7_object_to_string(sc, code, false); - if (string_length(codep) > 0) - { - char *codestr = string_value(codep); - if ((!local_strcmp(codestr, "(result)")) && - (!local_strcmp(codestr, "(#f)")) && - (!strstr(codestr, "(stacktrace)")) && - (!strstr(codestr, "(stacktrace "))) - { - s7_pointer e = stack_let(sc->stack, true_loc); - s7_pointer f = stacktrace_find_caller(sc, e); - if (!stacktrace_error_hook_function(sc, f)) - { - char *notes = NULL, *newstr, *catstr; - block_t *newp, *catp; - s7_int newlen; - - frames++; - if (frames > frames_max) - return(block_to_string(sc, strp, safe_strlen((char *)block_data(strp)))); - - if ((is_let(e)) && (e != sc->rootlet)) - notes = stacktrace_walker(sc, code, e, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); - newp = stacktrace_add_func(sc, f, code, codestr, notes, code_cols, as_comment); - newstr = (char *)block_data(newp); - - if ((notes) && (notes != newstr) && (is_let(e)) && (e != sc->rootlet)) - free(notes); - - newlen = strlen(newstr) + 1 + ((str) ? strlen(str) : 0); - catp = mallocate(sc, newlen); - catstr = (char *)block_data(catp); - catstrs_direct(catstr, (str) ? str : "", newstr, (const char *)NULL); - liberate(sc, newp); - if (strp) liberate(sc, strp); - strp = catp; - str = (char *)block_data(strp); - }}}}} - return((strp) ? block_to_string(sc, strp, safe_strlen((char *)block_data(strp))) : nil_string); -} - -s7_pointer s7_stacktrace(s7_scheme *sc) -{ - return(stacktrace_1(sc, - s7_integer_clamped_if_gmp(sc, car(sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp(sc, cadr(sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp(sc, caddr(sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp(sc, cadddr(sc->stacktrace_defaults)), - s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4)))); -} - -static s7_pointer g_stacktrace(s7_scheme *sc, s7_pointer args) -{ - #define H_stacktrace "(stacktrace (max-frames 30) (code-cols 50) (total-cols 80) (note-col 50) as-comment) returns \ -a stacktrace as a string. Each line has two portions, the code being evaluated and a note giving \ -the value of local variables in that code. The first argument sets how many lines are displayed. \ -The next three arguments set the length and layout of those lines. 'as-comment' if #t causes each \ -line to be preceded by a semicolon." - #define Q_stacktrace s7_make_signature(sc, 6, \ - sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol, \ - sc->is_integer_symbol, sc->is_integer_symbol, sc->is_boolean_symbol) - - s7_int max_frames = 30, code_cols = 50, total_cols = 80, notes_start_col = 50; - bool as_comment = false; - - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - return(method_or_bust(sc, car(args), sc->stacktrace_symbol, args, sc->type_names[T_INTEGER], 1)); - max_frames = s7_integer_clamped_if_gmp(sc, car(args)); - if ((max_frames <= 0) || (max_frames > S7_INT32_MAX)) - max_frames = 30; - args = cdr(args); - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 2, car(args), sc->type_names[T_INTEGER]); - code_cols = s7_integer_clamped_if_gmp(sc, car(args)); - if ((code_cols <= 8) || (code_cols > 1024)) - code_cols = 50; - args = cdr(args); - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 3, car(args), sc->type_names[T_INTEGER]); - total_cols = s7_integer_clamped_if_gmp(sc, car(args)); - if ((total_cols <= code_cols) || (total_cols > S7_INT32_MAX)) - total_cols = 80; - args = cdr(args); - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 4, car(args), sc->type_names[T_INTEGER]); - notes_start_col = s7_integer_clamped_if_gmp(sc, car(args)); - if ((notes_start_col <= 0) || (notes_start_col > S7_INT32_MAX)) - notes_start_col = 50; - args = cdr(args); - if (!is_null(args)) - { - if (!is_boolean(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 5, car(args), sc->type_names[T_BOOLEAN]); - as_comment = s7_boolean(sc, car(args)); - }}}}} - return(stacktrace_1(sc, max_frames, code_cols, total_cols, notes_start_col, as_comment)); -} - - -/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */ - -s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry) -{ -#if WITH_HISTORY - set_current_code(sc, entry); -#endif - return(entry); -} - -s7_pointer s7_history(s7_scheme *sc) -{ -#if WITH_HISTORY - if (sc->cur_code == sc->history_sink) - return(sc->old_cur_code); -#endif - return(sc->cur_code); -} - -bool s7_history_enabled(s7_scheme *sc) -{ -#if WITH_HISTORY - return(sc->cur_code != sc->history_sink); -#else - return(false); -#endif -} - -bool s7_set_history_enabled(s7_scheme *sc, bool enabled) -{ -#if WITH_HISTORY - bool old_enabled = (sc->cur_code == sc->history_sink); - if (enabled) /* this needs to restore the old cur_code (saving its position in the history_buffer) */ - sc->cur_code = sc->old_cur_code; - else - if (sc->cur_code != sc->history_sink) - { - sc->old_cur_code = sc->cur_code; - sc->cur_code = sc->history_sink; - } - return(old_enabled); -#else - return(false); -#endif -} - -#if WITH_HISTORY -static s7_pointer history_cons(s7_scheme *sc, s7_pointer code, s7_pointer args) -{ - s7_pointer p = car(sc->history_pairs); - sc->history_pairs = cdr(sc->history_pairs); - set_car(p, code); - set_cdr(p, args); - return(p); -} -#else -#define history_cons(Sc, Code, Args) Code -#endif - - -/* -------------------------------- profile -------------------------------- */ -static void swap_stack(s7_scheme *sc, opcode_t new_op, s7_pointer new_code, s7_pointer new_args) -{ - s7_pointer code, args, e; - opcode_t op; - - sc->stack_end -= 4; - code = sc->stack_end[0]; - e = sc->stack_end[1]; - args = sc->stack_end[2]; - op = (opcode_t)(sc->stack_end[3]); /* this should be begin1 */ - if ((S7_DEBUGGING) && (op != OP_BEGIN_NO_HOOK) && (op != OP_BEGIN_HOOK)) - fprintf(stderr, "swap %s in %s\n", op_names[op], display(s7_name_to_value(sc, "estr"))); - push_stack(sc, new_op, new_args, new_code); - sc->stack_end[0] = code; - sc->stack_end[1] = e; - sc->stack_end[2] = args; - sc->stack_end[3] = (s7_pointer)op; - sc->stack_end += 4; -} - -static s7_pointer find_funclet(s7_scheme *sc, s7_pointer e) -{ - if ((e == sc->rootlet) || (!is_let(e))) return(sc->F); - if (!((is_funclet(e)) || (is_maclet(e)))) e = let_outlet(e); - if ((e == sc->rootlet) || (!is_let(e))) return(sc->F); - return(((is_funclet(e)) || (is_maclet(e))) ? e : sc->F); -} - -#define PD_INITIAL_SIZE 16 -enum {PD_CALLS = 0, PD_RECUR, PD_START, PD_ITOTAL, PD_ETOTAL, PD_BLOCK_SIZE}; - -static s7_pointer g_profile_out(s7_scheme *sc, s7_pointer args) -{ - s7_int pos = integer(car(args)) * PD_BLOCK_SIZE; - profile_data_t *pd = sc->profile_data; - s7_int *v = (s7_int *)(pd->timing_data + pos); - v[PD_RECUR]--; - if (v[PD_RECUR] == 0) - { - s7_int cur_time = (my_clock() - v[PD_START]); - v[PD_ITOTAL] += cur_time; - v[PD_ETOTAL] += (cur_time - pd->excl[pd->excl_top]); - pd->excl_top--; - pd->excl[pd->excl_top] += cur_time; - } - return(sc->F); -} - -static s7_pointer g_profile_in(s7_scheme *sc, s7_pointer args) /* only external func -- added to each profiled func by add_profile above */ -{ - #define H_profile_in "(profile-in e) is the profiler's hook into closures" - #define Q_profile_in s7_make_signature(sc, 3, sc->T, sc->is_integer_symbol, sc->is_let_symbol) - - s7_pointer e; - s7_int pos; - if (sc->profile == 0) return(sc-> F); - - pos = integer(car(args)); - e = find_funclet(sc, cadr(args)); - - if ((is_let(e)) && - (is_symbol(funclet_function(e)))) - { - s7_pointer func_name = funclet_function(e); - s7_int *v; - profile_data_t *pd = sc->profile_data; - - if (pos >= pd->size) - { - s7_int new_size = 2 * pos; - pd->funcs = (s7_pointer *)Realloc(pd->funcs, new_size * sizeof(s7_pointer)); - memclr((void *)(pd->funcs + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); - pd->timing_data = (s7_int *)Realloc(pd->timing_data, new_size * PD_BLOCK_SIZE * sizeof(s7_int)); - memclr((void *)(pd->timing_data + (pd->size * PD_BLOCK_SIZE)), (new_size - pd->size) * PD_BLOCK_SIZE * sizeof(s7_int)); - pd->let_names = (s7_pointer *)Realloc(pd->let_names, new_size * sizeof(s7_pointer)); - memclr((void *)(pd->let_names + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); - pd->files = (s7_pointer *)Realloc(pd->files, new_size * sizeof(s7_pointer)); - memclr((void *)(pd->files + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); - pd->lines = (s7_int *)Realloc(pd->lines, new_size * sizeof(s7_int)); - memclr((void *)(pd->lines + pd->size), (new_size - pd->size) * sizeof(s7_int)); - pd->size = new_size; - } - if (pd->funcs[pos] == NULL) - { - pd->funcs[pos] = func_name; - if (is_gensym(func_name)) sc->profiling_gensyms = true; - if (pos >= pd->top) pd->top = (pos + 1); - - /* perhaps add_profile needs to reuse ints if file/line exists? */ - if (is_symbol(sc->profile_prefix)) - { - s7_pointer let_name = s7_symbol_local_value(sc, sc->profile_prefix, e); - if (is_symbol(let_name)) pd->let_names[pos] = let_name; - } - if (has_let_file(e)) - { - pd->files[pos] = sc->file_names[let_file(e)]; - pd->lines[pos] = let_line(e); - }} - v = (s7_int *)(sc->profile_data->timing_data + (pos * PD_BLOCK_SIZE)); - v[PD_CALLS]++; - if (v[PD_RECUR] == 0) - { - v[PD_START] = my_clock(); - pd->excl_top++; - if (pd->excl_top == pd->excl_size) - { - pd->excl_size *= 2; - pd->excl = (s7_int *)Realloc(pd->excl, pd->excl_size * sizeof(s7_int)); - } - pd->excl[pd->excl_top] = 0; - } - v[PD_RECUR]++; - - /* this doesn't work in "continuation passing" code (e.g. cpstak.scm in the so-called standard benchmarks). - * swap_stack pushes dynamic_unwind, but we don't pop back to it, so the stack grows to the recursion depth. - */ - if (sc->stack_end >= sc->stack_resize_trigger) - { - #define PROFILE_MAX_STACK_SIZE 10000000 /* around 5G counting lets/arglists/slots, maybe an *s7* field for this? */ - if (sc->stack_size > PROFILE_MAX_STACK_SIZE) - error_nr(sc, make_symbol(sc, "stack-too-big", 13), - set_elist_2(sc, wrap_string(sc, "profiling stack size has grown past ~D", 38), wrap_integer(sc, PROFILE_MAX_STACK_SIZE))); - /* rather than raise an error, we could unwind the stack here, popping off all unwind entries, but this is - * a very rare problem, and the results will be confusing anyway. - */ - resize_stack(sc); - } - swap_stack(sc, OP_DYNAMIC_UNWIND_PROFILE, sc->profile_out, car(args)); - } - return(sc->F); -} - -static s7_pointer profile_info_out(s7_scheme *sc) -{ - s7_pointer p, pp, vs, vi, vn, vf, vl, matches; - s7_int i; - profile_data_t *pd = sc->profile_data; - if ((!pd) || (pd->top == 0)) return(sc->F); - p = make_list(sc, 7, sc->F); - sc->w = p; - set_car(p, vs = make_simple_vector(sc, pd->top)); - set_car(cdr(p), vi = make_simple_int_vector(sc, pd->top * PD_BLOCK_SIZE)); - set_car(cddr(p), make_integer(sc, ticks_per_second())); - pp = cdddr(p); - set_car(pp, vn = make_simple_vector(sc, pd->top)); - set_car(cdr(pp), vf = make_simple_vector(sc, pd->top)); - set_car(cddr(pp), vl = make_simple_int_vector(sc, pd->top)); - matches = cdddr(pp); - set_car(matches, sc->nil); - for (i = 0; i < pd->top; i++) - { - if (pd->funcs[i]) - { - vector_element(vs, i) = pd->funcs[i]; - if ((is_matched_symbol(pd->funcs[i])) && /* find ambiguous names */ - (!direct_memq(pd->funcs[i], car(matches)))) - set_car(matches, cons(sc, pd->funcs[i], car(matches))); - set_match_symbol(pd->funcs[i]); - } - else vector_element(vs, i) = sc->F; - vector_element(vn, i) = (!pd->let_names[i]) ? sc->F : pd->let_names[i]; - vector_element(vf, i) = (!pd->files[i]) ? sc->F : pd->files[i]; - } - for (i = 0; i < pd->top; i++) if (pd->funcs[i]) clear_match_symbol(pd->funcs[i]); - memcpy((void *)int_vector_ints(vl), (void *)pd->lines, pd->top * sizeof(s7_int)); - memcpy((void *)int_vector_ints(vi), (void *)pd->timing_data, pd->top * PD_BLOCK_SIZE * sizeof(s7_int)); - sc->w = sc->unused; - return(p); -} - -static s7_pointer clear_profile_info(s7_scheme *sc) -{ - if (sc->profile_data) - { - profile_data_t *pd = sc->profile_data; - memclr(pd->timing_data, pd->top * PD_BLOCK_SIZE * sizeof(s7_int)); - memclr(pd->funcs, pd->top * sizeof(s7_pointer)); - memclr(pd->let_names, pd->top * sizeof(s7_pointer)); - memclr(pd->files, pd->top * sizeof(s7_pointer)); - memclr(pd->lines, pd->top * sizeof(s7_int)); - pd->top = 0; - for (int32_t i = 0; i < pd->excl_top; i++) - pd->excl[i] = 0; - pd->excl_top = 0; - sc->profiling_gensyms = false; - } - return(sc->F); -} - -static s7_pointer make_profile_info(s7_scheme *sc) -{ - if (!sc->profile_data) - { - profile_data_t *pd = (profile_data_t *)Malloc(sizeof(profile_data_t)); - pd->size = PD_INITIAL_SIZE; - pd->excl_size = PD_INITIAL_SIZE; - pd->top = 0; - pd->excl_top = 0; - pd->funcs = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer)); - pd->let_names = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer)); - pd->files = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer)); - pd->lines = (s7_int *)Calloc(pd->size, sizeof(s7_int)); - pd->excl = (s7_int *)Calloc(pd->excl_size, sizeof(s7_int)); - pd->timing_data = (s7_int *)Calloc(pd->size * PD_BLOCK_SIZE, sizeof(s7_int)); - sc->profile_data = pd; - } - return(sc->F); -} - - -/* -------------------------------- dynamic-unwind -------------------------------- */ -static s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer e) -{ - if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) - fprintf(stderr, "%s[%d]: unexpected multiple-value! %s %s %s\n", __func__, __LINE__, display(func), display(e), display(sc->value)); - return(s7_apply_function(sc, func, set_plist_2(sc, e, sc->value))); /* s7_apply_function returns sc->value */ -} - -static s7_pointer g_dynamic_unwind(s7_scheme *sc, s7_pointer args) -{ - #define H_dynamic_unwind "(dynamic-unwind func arg) pushes func and arg on the stack, then (func arg) is called when the stack unwinds." - #define Q_dynamic_unwind s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->T) - - s7_pointer func = car(args); - if (((is_closure(func)) && (closure_arity_to_int(sc, func) == 2)) || - ((is_c_function(func)) && (c_function_is_aritable(func, 2))) || - ((is_closure_star(func)) && (closure_star_arity_to_int(sc, func) == 2)) || - ((is_c_function_star(func)) && (c_function_max_args(func) == 2))) - swap_stack(sc, OP_DYNAMIC_UNWIND, func, cadr(args)); - else wrong_type_error_nr(sc, sc->dynamic_unwind_symbol, 1, func, wrap_string(sc, "a procedure of two arguments", 28)); - return(cadr(args)); -} - - -/* -------------------------------- catch -------------------------------- */ -static s7_pointer g_catch(s7_scheme *sc, s7_pointer args) -{ - #define H_catch "(catch tag thunk handler) evaluates thunk; if an error occurs that matches the tag (#t matches all), the handler is called" - #define Q_catch s7_make_signature(sc, 4, sc->values_symbol, \ - s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_boolean_symbol), \ - sc->is_procedure_symbol, sc->is_procedure_symbol) - s7_pointer p, proc = cadr(args), err = caddr(args); - - /* Guile sets up the catch before looking for arg errors: (catch #t log (lambda args "hiho")) -> "hiho" - * which is consistent in that (catch #t (lambda () (log))...) should probably be the same as (catch #t log ...) - * but what if the error handler arg is messed up? Seems weird to handle args in reverse order with an intervening let etc. - */ - /* if (is_let(err)) check_method(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */ - - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]\n", __func__, __LINE__); - new_cell(sc, p, T_CATCH); - catch_tag(p) = car(args); - catch_goto_loc(p) = current_stack_top(sc); - catch_op_loc(p) = (int32_t)(sc->op_stack_now - sc->op_stack); - catch_set_handler(p, err); - catch_cstack(p) = sc->goto_start; - push_stack(sc, (intptr_t)((is_any_macro(err)) ? OP_CATCH_2 : OP_CATCH), args, p); - - /* not sure about these error checks -- they can be omitted */ - if (!is_thunk(sc, proc)) - wrong_type_error_nr(sc, sc->catch_symbol, 2, proc, a_thunk_string); - if (!is_applicable(err)) - wrong_type_error_nr(sc, sc->catch_symbol, 3, err, something_applicable_string); - - /* should we check here for (aritable? err 2)? (catch #t (lambda () 1) "hiho") -> 1 - * currently this is checked only if the error handler is called - */ - if (is_closure(proc)) /* not also lambda* here because we need to handle the arg defaults */ - { - /* is_thunk above checks is_aritable(proc, 0), but if it's (lambda args ...) we have to set up the let with args=() - * the case that caught this: (catch #t make-hook ...) - */ - sc->code = closure_body(proc); - if (is_symbol(closure_args(proc))) - sc->curlet = make_let_with_slot(sc, closure_let(proc), closure_args(proc), sc->nil); - else sc->curlet = inline_make_let(sc, closure_let(proc)); - push_stack_no_args_direct(sc, sc->begin_op); - } - else push_stack(sc, OP_APPLY, sc->nil, proc); - return(sc->F); -} - -s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler) -{ - s7_pointer p, result; - if (sc->stack_end == sc->stack_start) /* no stack! */ - push_stack_direct(sc, OP_EVAL_DONE); - - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]\n", __func__, __LINE__); - new_cell(sc, p, T_CATCH); - catch_tag(p) = tag; - catch_goto_loc(p) = current_stack_top(sc); - catch_op_loc(p) = (int32_t)(sc->op_stack_now - sc->op_stack); - catch_set_handler(p, error_handler); - catch_cstack(p) = sc->goto_start; - - if (!sc->longjmp_ok) - { - declare_jump_info(); - TRACK(sc); - store_jump_info(sc); - set_jump_info(sc, S7_CALL_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */ - (sc->stack_end == sc->stack_start)) - push_stack_op(sc, OP_ERROR_QUIT); - result = sc->value; - } - else - { - /* we've replaced our jump point, fix it in this catch too */ - catch_cstack(p) = &new_goto_start; - push_stack(sc, OP_CATCH, error_handler, p); - result = s7_call(sc, body, sc->nil); - if (((opcode_t)sc->stack_end[-1]) == OP_CATCH) sc->stack_end -= 4; - } - restore_jump_info(sc); - } - else - { - push_stack(sc, OP_CATCH, error_handler, p); - result = s7_call(sc, body, sc->nil); - if (((opcode_t)sc->stack_end[-1]) == OP_CATCH) sc->stack_end -= 4; - } - return(result); -} - -static void op_c_catch(s7_scheme *sc) -{ - /* (catch #t (lambda () (set! ("hi") #\a)) (lambda args args)) - * code is (catch #t (lambda () ....) (lambda args ....)) - */ - s7_pointer p, f = cadr(sc->code), args = cddr(sc->code), tag; - - /* defer making the error lambda */ - if (!is_pair(f)) /* (catch #t ...) or (catch sym ...) */ - tag = (is_symbol(f)) ? lookup_checked(sc, f) : f; - else tag = cadr(f); /* (catch 'sym ...) */ - - new_cell(sc, p, T_CATCH); /* the catch object sitting on the stack */ - catch_tag(p) = tag; - catch_goto_loc(p) = current_stack_top(sc); - catch_op_loc(p) = sc->op_stack_now - sc->op_stack; - catch_set_handler(p, cdadr(args)); /* not yet a closure... */ - catch_cstack(p) = sc->goto_start; - push_stack(sc, OP_CATCH_1, sc->code, p); /* code ignored here, except by GC */ - sc->curlet = inline_make_let(sc, sc->curlet); - sc->code = T_Pair(cddar(args)); -} - -static void op_c_catch_all(s7_scheme *sc) -{ - s7_pointer p; - new_cell(sc, p, T_CATCH); - catch_tag(p) = sc->T; - catch_goto_loc(p) = current_stack_top(sc); - catch_op_loc(p) = sc->op_stack_now - sc->op_stack; - catch_set_handler(p, sc->nil); - catch_cstack(p) = sc->goto_start; - push_stack(sc, OP_CATCH_ALL, opt2_con(sc->code), p); /* push_stack: op args code */ - sc->code = T_Pair(opt1_pair(cdr(sc->code))); /* the body of the first lambda (or car of it if catch_all_o) */ -} - -static void op_c_catch_all_a(s7_scheme *sc) -{ - op_c_catch_all(sc); - sc->value = fx_call(sc, sc->code); -} - - -/* -------------------------------- owlet -------------------------------- */ -/* error reporting info -- save filename and line number */ - -static s7_pointer init_owlet(s7_scheme *sc) -{ - s7_pointer p; /* watch out for order below */ - s7_pointer e = make_let(sc, sc->nil); - sc->temp3 = e; - sc->error_type = add_slot_checked_with_id(sc, e, make_symbol(sc, "error-type", 10), sc->F); /* the error type or tag ('division-by-zero) */ - sc->error_data = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-data", 10), sc->F); /* the message or information passed by the error function */ - sc->error_code = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-code", 10), sc->F); /* the code that s7 thinks triggered the error */ - sc->error_line = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-line", 10), p = make_permanent_integer(0)); /* the line number of that code */ - add_saved_pointer(sc, p); - sc->error_file = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-file", 10), sc->F); /* the file name of that code */ - sc->error_position = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-position", 14), p = make_permanent_integer(0)); /* file-byte position of that code */ - add_saved_pointer(sc, p); -#if WITH_HISTORY - sc->error_history = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-history", 13), sc->F); /* buffer of previous evaluations */ -#endif - sc->temp3 = sc->unused; - return(e); -} - -#if WITH_HISTORY -static s7_pointer cull_history(s7_scheme *sc, s7_pointer code) -{ - clear_symbol_list(sc); /* make a list of words banned from the history */ - add_symbol_to_list(sc, sc->s7_starlet_symbol); - add_symbol_to_list(sc, sc->eval_symbol); - add_symbol_to_list(sc, make_symbol(sc, "debug", 5)); - add_symbol_to_list(sc, make_symbol(sc, "trace-in", 8)); - add_symbol_to_list(sc, make_symbol(sc, "trace-out", 9)); - add_symbol_to_list(sc, sc->dynamic_unwind_symbol); - add_symbol_to_list(sc, make_symbol(sc, "history-enabled", 15)); - for (s7_pointer p = code; is_pair(p); p = cdr(p)) - { - if (tree_set_memq(sc, car(p))) - set_car(p, sc->nil); - if (cdr(p) == code) break; - } - return(code); -} -#endif - -static s7_pointer g_owlet(s7_scheme *sc, s7_pointer unused_args) -{ -#if WITH_HISTORY - #define H_owlet "(owlet) returns the environment at the point of the last error. \ -It has the additional local variables: error-type, error-data, error-code, error-line, error-file, and error-history." -#else - #define H_owlet "(owlet) returns the environment at the point of the last error. \ -It has the additional local variables: error-type, error-data, error-code, error-line, and error-file." -#endif - #define Q_owlet s7_make_signature(sc, 1, sc->is_let_symbol) - /* if owlet is not copied, (define e (owlet)), e changes as owlet does! */ - - s7_pointer e; - s7_int gc_loc; - bool old_gc = sc->gc_off; -#if WITH_HISTORY - slot_set_value(sc->error_history, cull_history(sc, slot_value(sc->error_history))); -#endif - e = let_copy(sc, sc->owlet); - gc_loc = gc_protect_1(sc, e); - - /* make sure the pairs/reals/strings/integers are copied: should be error-data, error-code, and error-history */ - sc->gc_off = true; - - for (s7_pointer x = let_slots(e); tis_slot(x); x = next_slot(x)) - if (is_pair(slot_value(x))) - { - s7_pointer new_list = copy_any_list(sc, slot_value(x)); - slot_set_value(x, new_list); - for (s7_pointer p = new_list, sp = p; is_pair(p); p = cdr(p), sp = cdr(sp)) - { - s7_pointer val = car(p); - if (is_t_real(val)) - set_car(p, make_real(sc, real(val))); - else - if (is_string(val)) - set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); - else - if (is_t_integer(val)) - set_car(p, make_integer(sc, integer(val))); - p = cdr(p); - if ((!is_pair(p)) || (p == sp)) break; - val = car(p); - if (is_t_real(val)) - set_car(p, make_real(sc, real(val))); - else - if (is_string(val)) - set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); - }} - sc->gc_off = old_gc; - s7_gc_unprotect_at(sc, gc_loc); - return(e); -} - - -/* -------- catch handlers -------- (don't free the catcher) */ -static void load_catch_cstack(s7_scheme *sc, s7_pointer c) -{ - if (catch_cstack(c)) - sc->goto_start = catch_cstack(c); -} - -static bool catch_all_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_pointer catcher = T_Cat(stack_code(sc->stack, i)); - sc->value = stack_args(sc->stack, i); /* error result, optimize_func_three_args -> op_c_catch_all etc */ - if (sc->value == sc->unused) sc->value = type; - sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(catcher)); - sc->stack_end = (s7_pointer *)(sc->stack_start + catch_goto_loc(catcher)); - load_catch_cstack(sc, catcher); - pop_stack(sc); - return(true); -} - -static bool catch_2_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - /* this is the macro-error-handler case from g_catch - * (let () (define-macro (m . args) (apply (car args) (cadr args))) (catch #t (lambda () (error abs -1)) m)) - */ - s7_pointer x = T_Cat(stack_code(sc->stack, i)); - if ((catch_tag(x) == sc->T) || (catch_tag(x) == type) || (type == sc->T)) - { - sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(x)); - sc->stack_end = (s7_pointer *)(sc->stack_start + catch_goto_loc(x)); - sc->code = catch_handler(x); - load_catch_cstack(sc, x); - if (needs_copied_args(sc->code)) - sc->args = list_2(sc, type, info); - else sc->args = with_list_t2(type, info); /* very unlikely: need c_macro as error catcher: (catch #t (lambda () (error 'oops)) require) */ - sc->cur_op = OP_APPLY; - return(true); - } - return(false); -} - -static bool catch_1_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_pointer x = T_Cat(stack_code(sc->stack, i)); - if ((catch_tag(x) == sc->T) || /* the normal case */ - (catch_tag(x) == type) || - (type == sc->T)) - { - opcode_t op = stack_op(sc->stack, i); - s7_pointer catcher = x, error_body, error_args; - s7_pointer error_func = catch_handler(catcher); - uint64_t loc = catch_goto_loc(catcher); - - init_temp(sc->y, type); - sc->value = info; - - sc->temp4 = stack_let(sc->stack, i); /* GC protect this, since we're moving the stack top below */ - sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(catcher)); - sc->stack_end = (s7_pointer *)(sc->stack_start + loc); - load_catch_cstack(sc, catcher); - - /* very often the error handler just returns either a constant ('error or #f), or - * the args passed to it, so there's no need to laboriously make a closure, - * and apply it -- just set sc->value to the closure body (or the args) and return. - * so first examine closure_body(error_func) - * if it is a constant, or quoted symbol, return that, - * if it is the args symbol, return (list type info) - */ - - /* if OP_CATCH_1, we deferred making the error handler until it is actually needed */ - if (op == OP_CATCH_1) - { - error_body = cdr(error_func); - error_args = car(error_func); - } - else - if (is_closure(error_func)) - { - error_body = closure_body(error_func); - error_args = closure_args(error_func); - } - else - { - error_body = NULL; - error_args = NULL; - } - if ((error_body) && (is_null(cdr(error_body)))) - { - s7_pointer y = NULL; - error_body = car(error_body); - if (is_pair(error_body)) - { - if (car(error_body) == sc->quote_symbol) - y = cadr(error_body); - else - if ((car(error_body) == sc->car_symbol) && - (is_pair(cdr(error_body))) && /* catch: (lambda (type info) (car)) */ - (cadr(error_body) == error_args)) - y = type; - } - else - if (!is_symbol(error_body)) - y = error_body; /* not pair or symbol */ - else - if (error_body == error_args) - y = list_2(sc, type, info); - else - if (is_keyword(error_body)) - y = error_body; - else - if ((is_pair(error_args)) && - (error_body == car(error_args))) - y = type; - if (y) - { - if ((SHOW_EVAL_OPS) && (loc > 4)) {fprintf(stderr, "about to pop_stack: \n"); s7_show_stack(sc);} - if (loc > 4) - pop_stack(sc); - /* we're at OP_CATCH, normally we want to pop that away, but (handwaving...) if we're coming - * from s7_eval (indirectly perhaps through s7_eval_c_string), we might push the OP_EVAL_DONE - * to end that call, but it's pushed at the precatch stack end (far beyond the catch loc). - * If we catch an error, catch unwinds to its starting point, and the pop_stack above - * puts us at the bottom of the stack (i.e. stack_end == stack_start), OP_EVAL_DONE. - * Now we return true, ending up back in eval, because the error handler jumped out of eval, - * back to wherever we were in eval when we hit the error. eval jumps back to the start - * of its loop, and pops the stack to see what to do next! So the (loc > 4) at least - * protects against stack underflow, but ideally we'd know we came from OP_CATCH+s7_eval. - * We can't do anything fancy here because we have to unwind the C stack as well as s7's stack. - * s7_eval doesn't know anything about the catches on the stack. We can't look back for - * OP_EVAL_DONE -- segfault in OP_BEGIN. Hmmmm. Perhaps catch should not unwind until the - * end? But we want the error handler to run as a part of the calling expression, and - * in any case the OP_EVAL_DONE is not useful (it marks the end of the no-error case). - */ - sc->value = y; - sc->y = sc->unused; - sc->temp4 = sc->unused; - sc->w = sc->unused; - if (loc == 4) - sc->code = cons(sc, sc->value, sc->nil); /* if we end up at op_begin, give it something it can handle */ - return(true); - }} - /* here type and info need to be GC protected (new_cell below), g_throw and error_nr, throw sc->w for type, but error_nr nothing currently */ - if (op == OP_CATCH_1) - { - s7_pointer p; - new_cell(sc, p, T_CLOSURE); - closure_set_args(p, car(error_func)); - closure_set_body(p, cdr(error_func)); - closure_set_setter(p, sc->F); - closure_set_arity(p, CLOSURE_ARITY_NOT_SET); - closure_set_let(p, sc->temp4); - sc->code = p; - if ((S7_DEBUGGING) && (!s7_is_aritable(sc, sc->code, 2))) fprintf(stderr, "%s[%d]: errfunc not aritable(2)!\n", __func__, __LINE__); - } - else - { - sc->code = error_func; - sc->y = sc->unused; - if (!s7_is_aritable(sc, sc->code, 2)) /* op_catch_1 from op_c_catch already checks this */ - wrong_number_of_args_error_nr(sc, "catch error handler should accept two arguments: ~S", sc->code); - } - sc->temp4 = sc->unused; - /* if user (i.e. yers truly!) copies/pastes the preceding lambda () into the - * error handler portion of the catch, he gets the inexplicable message: - * ;(): too many arguments: (a1 ()) - * when this apply tries to call the handler. So, we need a special case error check here! - */ - sc->args = list_2(sc, type, info); /* almost never able to skip this -- costs more to check! */ - sc->w = sc->unused; - sc->y = sc->unused; - sc->cur_op = OP_APPLY; - /* explicit eval needed if s7_call called into scheme where a caught error occurred (ex6 in exs7.c) - * but putting it here (via eval(sc, OP_APPLY)) means the C stack is not cleared correctly in non-s7-call cases, - * so defer it until s7_call - */ - return(true); - } - return(false); -} - -static bool catch_dynamic_wind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_pointer x = T_Dyn(stack_code(sc->stack, i)); - if (dynamic_wind_state(x) == DWIND_BODY) - { - dynamic_wind_state(x) = DWIND_FINISH; /* make sure an uncaught error in the exit thunk doesn't cause us to loop */ - if (dynamic_wind_out(x) != sc->F) - sc->value = s7_call(sc, dynamic_wind_out(x), sc->nil); - } - return(false); -} - -static bool catch_out_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_pointer x = T_Prt(stack_code(sc->stack, i)); /* "code" = port that we opened */ - s7_close_output_port(sc, x); - x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not # */ - if (x != sc->unused) - set_current_output_port(sc, x); - return(false); -} - -static bool catch_in_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_close_input_port(sc, stack_code(sc->stack, i)); /* "code" = port that we opened */ - if (stack_args(sc->stack, i) != sc->unused) - set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - return(false); -} - -static bool catch_read_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - pop_input_port(sc); - return(false); -} - -static bool catch_eval_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - return(false); -} - -static bool catch_barrier_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - if (is_input_port(stack_args(sc->stack, i))) /* (eval-string "'(1 .)") */ - { - if (current_input_port(sc) == stack_args(sc->stack, i)) - pop_input_port(sc); - s7_close_input_port(sc, stack_args(sc->stack, i)); - } - return(false); -} - -static bool catch_hook_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, stack_code(sc->stack, i)); - /* apparently there was an error during *error-hook* evaluation, but Rick wants the hook re-established anyway */ - (*reset_hook) = true; - /* avoid infinite loop -- don't try to (re-)evaluate (buggy) *error-hook*! */ - return(false); -} - -static bool catch_goto_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - call_exit_active(stack_args(sc->stack, i)) = false; - return(false); -} - -static bool catch_map_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - sc->map_call_ctr--; - if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} - return(false); -} - -static bool op_let_temp_done1(s7_scheme *sc); - -static bool catch_let_temporarily_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - /* this is aimed at let-temp error-hook... error -- not yet tested much */ - if ((!*reset_hook) && - (hook_has_functions(sc->error_hook))) - { - s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook); - - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil); - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs); - sc->code = sc->let_temp_hook; - sc->args = list_2(sc, type, info); - - push_stack_direct(sc, OP_EVAL_DONE); - sc->curlet = make_let(sc, closure_let(sc->code)); - eval(sc, OP_APPLY_LAMBDA); - - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, error_hook_funcs); - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil); - - sc->args = stack_args(sc->stack, i); - sc->code = stack_code(sc->stack, i); - set_curlet(sc, stack_let(sc->stack, i)); - - push_stack_direct(sc, OP_GC_PROTECT); - if (!op_let_temp_done1(sc)) - { - push_stack_direct(sc, OP_EVAL_DONE); - eval(sc, OP_SET_UNCHECKED); - }} - else let_temp_done(sc, stack_args(sc->stack, i), stack_let(sc->stack, i)); - return(false); -} - -static bool catch_let_temp_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - slot_set_value(stack_code(sc->stack, i), stack_args(sc->stack, i)); - return(false); -} - -static bool catch_let_temp_s7_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); - return(false); -} - -static bool catch_let_temp_s7_direct_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - sc->has_openlets = (stack_args(sc->stack, i) != sc->F); - return(false); -} - -static bool catch_dynamic_unwind_function(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook) -{ - /* if func has an error, s7_error will call it as it unwinds the stack -- an infinite loop. So, cancel the unwind first */ - stack_element(sc->stack, i) = (s7_pointer)OP_GC_PROTECT; - - /* we're in an error or throw, so there is no return value to report, but we need to decrement *debug-spaces* (if in debug) - * stack_let is the trace-in let at the point of the dynamic_unwind call - */ - if (sc->debug > 0) - { - s7_pointer spaces = lookup_slot_from(make_symbol(sc, "*debug-spaces*", 14), stack_let(sc->stack, i)); - if (is_slot(spaces)) - slot_set_value(spaces, make_integer(sc, max_i_ii(0LL, integer(slot_value(spaces)) - 2))); /* should involve only small_ints */ - } - return(false); -} - -typedef bool (*catch_function_t)(s7_scheme *sc, s7_int i, s7_pointer type, s7_pointer info, bool *reset_hook); -static catch_function_t catchers[NUM_OPS]; - -static void init_catchers(void) -{ - for (int32_t i = 0; i < NUM_OPS; i++) catchers[i] = NULL; - catchers[OP_CATCH_ALL] = catch_all_function; - catchers[OP_CATCH_2] = catch_2_function; - catchers[OP_CATCH_1] = catch_1_function; - catchers[OP_CATCH] = catch_1_function; - catchers[OP_DYNAMIC_WIND] = catch_dynamic_wind_function; - catchers[OP_DYNAMIC_UNWIND] = catch_dynamic_unwind_function; - catchers[OP_GET_OUTPUT_STRING] = catch_out_function; - catchers[OP_UNWIND_OUTPUT] = catch_out_function; - catchers[OP_UNWIND_INPUT] = catch_in_function; - catchers[OP_READ_DONE] = catch_read_function; /* perhaps an error during (read) */ - catchers[OP_EVAL_STRING] = catch_eval_function; - catchers[OP_BARRIER] = catch_barrier_function; - catchers[OP_DEACTIVATE_GOTO] = catch_goto_function; - catchers[OP_LET_TEMP_DONE] = catch_let_temporarily_function; - catchers[OP_LET_TEMP_UNWIND] = catch_let_temp_unwind_function; - catchers[OP_LET_TEMP_S7_UNWIND] = catch_let_temp_s7_unwind_function; - catchers[OP_LET_TEMP_S7_DIRECT_UNWIND] = catch_let_temp_s7_direct_unwind_function; - catchers[OP_ERROR_HOOK_QUIT] = catch_hook_function; - catchers[OP_MAP_UNWIND] = catch_map_unwind_function; -} - -/* -------------------------------- throw -------------------------------- */ -static s7_pointer g_throw(s7_scheme *sc, s7_pointer args) -{ - #define H_throw "(throw tag . info) is like (error ...) but it does not affect owlet. \ -It looks for an existing catch with a matching tag, and jumps to it if found. Otherwise it raises an error." - #define Q_throw s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T) - - bool ignored_flag = false; - s7_pointer type = car(args), info = cdr(args); - gc_protect_via_stack(sc, args); - /* type can be anything: (throw (list 1 2 3) (make-list 512)), sc->w and sc->value not good here for gc protection */ - - for (int64_t i = current_stack_top(sc) - 5; i >= 3; i -= 4) /* look for a catcher */ - { - catch_function_t catcher = catchers[stack_op(sc->stack, i)]; - if ((catcher) && - (catcher(sc, i, type, info, &ignored_flag))) - { - if (sc->longjmp_ok) LongJmp(*(sc->goto_start), THROW_JUMP); - return(sc->value); - }} - if (is_let(car(args))) - check_method(sc, car(args), sc->throw_symbol, args); - error_nr(sc, make_symbol(sc, "uncaught-throw", 14), - set_elist_3(sc, wrap_string(sc, "no catch found for (throw ~W~{~^ ~S~})", 38), type, info)); - return(sc->F); -} - - -/* -------------------------------- warn -------------------------------- */ -#if WITH_GCC -static __attribute__ ((format (printf, 3, 4))) void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) -#else -static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) /* len = max size of output string (for vsnprintf) */ -#endif -{ - if ((sc->error_port != sc->F) && (!sc->muffle_warnings)) - { - int32_t bytes; - va_list ap; - block_t *b = mallocate(sc, len); - char *str = (char *)block_data(b); - str[0] = '\0'; - va_start(ap, ctrl); - bytes = vsnprintf(str, len, ctrl, ap); - va_end(ap); - if (port_is_closed(sc->error_port)) - sc->error_port = sc->standard_error; - if ((bytes > 0) && (sc->error_port != sc->F)) - port_write_string(sc->error_port)(sc, str, bytes, sc->error_port); - liberate(sc, b); - } -} - - -/* -------------------------------- error -------------------------------- */ -static void fill_error_location(s7_scheme *sc) -{ - if (((is_input_port(current_input_port(sc))) && (is_loader_port(current_input_port(sc)))) || - (((sc->cur_op >= OP_READ_LIST) && (sc->cur_op <= OP_READ_DONE)))) - { - integer(slot_value(sc->error_line)) = port_line_number(current_input_port(sc)); - integer(slot_value(sc->error_position)) = port_position(current_input_port(sc)); - slot_set_value(sc->error_file, wrap_string(sc, port_filename(current_input_port(sc)), port_filename_length(current_input_port(sc)))); - } - else - { - integer(slot_value(sc->error_line)) = 0; - integer(slot_value(sc->error_position)) = 0; - slot_set_value(sc->error_file, sc->F); - } -} - -static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) -{ - bool reset_error_hook = false; - s7_pointer cur_code = current_code(sc); - - sc->format_depth = -1; - sc->object_out_locked = false; /* possible error in obj->str method after object_out has set this flag */ - sc->has_openlets = true; /* same problem -- we need a cleaner way to handle this, op_?_unwind */ - sc->value = info; /* feeble GC protection (otherwise info is sometimes freed in this function), throw also protects type */ - - if (sc->current_safe_list > 0) - clear_list_in_use(sc->safe_lists[sc->current_safe_list]); - slot_set_value(sc->error_type, type); - slot_set_value(sc->error_data, info); - - if (unchecked_type(sc->curlet) != T_LET) - sc->curlet = sc->nil; /* in the reader, the sc->curlet stack entry is mostly ignored, so it can be (and usually is) garbage */ - let_set_outlet(sc->owlet, sc->curlet); - slot_set_value(sc->error_code, cur_code); - -#if WITH_HISTORY - slot_set_value(sc->error_history, sc->cur_code); - if (sc->cur_code != sc->history_sink) - { - sc->cur_code = (sc->using_history1) ? sc->eval_history2 : sc->eval_history1; - sc->using_history1 = (!sc->using_history1); - pair_fill(sc, set_plist_2(sc, sc->cur_code, sc->nil)); - } -#endif - if (is_pair(cur_code)) - { - s7_int line = -1, file, position; - if (has_location(cur_code)) - { - line = pair_line_number(cur_code); - file = pair_file_number(cur_code); - position = pair_position(cur_code); - } - else /* try to find a plausible line number! */ - for (s7_pointer p = cur_code, sp = cur_code; is_pair(p); p = cdr(p), sp = cdr(sp)) - { - if ((is_pair(car(p))) && /* what about p itself? */ - (has_location(car(p)))) - { - line = pair_line_number(car(p)); - file = pair_file_number(car(p)); - position = pair_position(car(p)); - break; - } - p = cdr(p); - if ((!is_pair(p)) || (p == sp)) break; - if ((is_pair(car(p))) && - (has_location(car(p)))) - { - line = pair_line_number(car(p)); - file = pair_file_number(car(p)); - position = pair_position(car(p)); - break; - }} - if ((line <= 0) || (file < 0)) - fill_error_location(sc); - else - { - integer(slot_value(sc->error_line)) = line; - integer(slot_value(sc->error_position)) = position; - slot_set_value(sc->error_file, sc->file_names[file]); - }} - else fill_error_location(sc); - - /* look for a catcher, call catch*function in the error context (before unwinding the stack), outlet(owlet) is curlet */ - /* top is 1 past actual top, top - 1 is op, if op = OP_CATCH, top - 4 is the cell containing the catch struct */ - for (int64_t i = current_stack_top(sc) - 1; i >= 3; i -= 4) - { - catch_function_t catcher = catchers[stack_op(sc->stack, i)]; - if ((catcher) && - (catcher(sc, i, type, info, &reset_error_hook))) - { - if (SHOW_EVAL_OPS) {fprintf(stderr, "after catch: \n"); s7_show_stack(sc);} - if ((S7_DEBUGGING) && (!sc->longjmp_ok)) fprintf(stderr, "s7_error jump not available?\n"); - LongJmp(*(sc->goto_start), CATCH_JUMP); - }} - /* error not caught (but catcher might have been called and returned false) */ - - if ((!reset_error_hook) && - (hook_has_functions(sc->error_hook))) - { - s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook); - /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'args))))) */ - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil); - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs); - /* if the *error-hook* functions trigger an error, we had better not have hook_functions(*error-hook*) still set! */ - - /* here we have no catcher (anywhere!), we're headed back to the top-level(?), so error_hook_quit can call reset_stack? */ - push_stack(sc, OP_ERROR_HOOK_QUIT, sc->nil, error_hook_funcs); /* restore *error-hook* upon successful (or any!) evaluation */ - sc->code = sc->let_temp_hook; - sc->args = list_2(sc, type, info); - /* if we drop into the longjmp below, the hook functions are not called! - * OP_ERROR_HOOK_QUIT performs the longjmp, so it should be safe to go to eval. - */ - sc->curlet = make_let(sc, closure_let(sc->code)); - eval(sc, OP_APPLY_LAMBDA); - } - else - { - s7_int op = sc->print_length; - if (op < 32) sc->print_length = 32; - - if ((!is_output_port(sc->error_port)) || /* error-port can be #f */ - (port_is_closed(sc->error_port))) - sc->error_port = sc->standard_error; - /* if info is not a list, send object->string to current error port, - * else assume car(info) is a format control string, and cdr(info) are its args - * if at all possible, get some indication of where we are! - */ - - if ((!is_pair(info)) || - (!is_string(car(info)))) - format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_2(sc, type, info), false, 7); - else - { - /* it's possible that the error string is just a string -- not intended for format */ - if ((type != sc->format_error_symbol) && /* avoid an infinite loop of format errors */ - (strchr(string_value(car(info)), '~'))) - { - s7_int len = string_length(car(info)) + 8; - block_t *b = mallocate(sc, len); - char *errstr = (char *)block_data(b); - s7_int str_len = catstrs_direct(errstr, "\n;", string_value(car(info)), (const char *)NULL); - format_to_port(sc, sc->error_port, errstr, cdr(info), false, str_len); - liberate(sc, b); - } - else format_to_port(sc, sc->error_port, "\n;~S ~S", set_plist_2(sc, type, info), false, 7); /* 7 = ctrl str len */ - } - if (op < 32) sc->print_length = op; - - /* now display location at end */ - if (is_string(slot_value(sc->error_file))) - { - s7_newline(sc, sc->error_port); - format_to_port(sc, sc->error_port, "; ~A\n", - set_plist_1(sc, object_to_truncated_string(sc, cur_code, 40)), - false, 8); - format_to_port(sc, sc->error_port, "; ~A, line ~D, position: ~D\n", - set_plist_3(sc, slot_value(sc->error_file), slot_value(sc->error_line), slot_value(sc->error_position)), - false, 31); - } - else - { - if ((is_input_port(current_input_port(sc))) && - (port_file(current_input_port(sc)) != stdin) && - (!port_is_closed(current_input_port(sc)))) - { - const char *filename = port_filename(current_input_port(sc)); - int32_t line = port_line_number(current_input_port(sc)); - - if (filename) - format_to_port(sc, sc->error_port, "\n; ~A[~D]", - set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), - wrap_integer(sc, line)), false, 10); - else - if ((line > 0) && - (integer(slot_value(sc->error_line)) > 0)) - format_to_port(sc, sc->error_port, "\n; line ~D", set_plist_1(sc, wrap_integer(sc, line)), false, 11); - else - if (sc->input_port_stack_loc > 0) - { - s7_pointer p = sc->input_port_stack[sc->input_port_stack_loc - 1]; - if ((is_input_port(p)) && - (port_file(p) != stdin) && - (!port_is_closed(p))) - { - filename = port_filename(p); - line = port_line_number(p); - if (filename) - format_to_port(sc, sc->error_port, "\n; ~A[~D]", - set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), - wrap_integer(sc, line)), false, 10); - }}} - else - { - const char *call_name = sc->s7_call_name; - if (call_name) - { - sc->s7_call_name = NULL; - if ((sc->s7_call_file) && - (sc->s7_call_line >= 0)) - format_to_port(sc, sc->error_port, "\n; ~A ~A[~D]", - set_plist_3(sc, - s7_make_string_wrapper(sc, call_name), - s7_make_string_wrapper(sc, sc->s7_call_file), - wrap_integer(sc, sc->s7_call_line)), - false, 13); - }} - s7_newline(sc, sc->error_port); - } - /* look for __func__ in the error environment etc */ - if (sc->error_port != sc->F) - { - s7_pointer errp = s7_stacktrace(sc); - if (string_length(errp) > 0) - { - port_write_string(sc->error_port)(sc, string_value(errp), string_length(errp), sc->error_port); - port_write_character(sc->error_port)(sc, '\n', sc->error_port); - }} - else - if (is_pair(slot_value(sc->error_code))) - { - format_to_port(sc, sc->error_port, "; ~S", set_plist_1(sc, slot_value(sc->error_code)), false, 7); - s7_newline(sc, sc->error_port); - } - /* if (is_continuation(type)) - * go into repl here with access to continuation? Or expect *error-handler* to deal with it? - */ - sc->value = type; - sc->cur_op = OP_ERROR_QUIT; - } - /* if (sc->longjmp_ok) */ LongJmp(*(sc->goto_start), ERROR_JUMP); -} - -s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info) /* s7.h backwards compatibility */ -{ - error_nr(sc, type, info); - return(type); -} - -static noreturn void read_error_1_nr(s7_scheme *sc, const char *errmsg, bool string_error) -{ - /* reader errors happen before the evaluator gets involved, so forms such as: - * (catch #t (lambda () (car '( . ))) (lambda arg 'error)) - * do not catch the error if we simply signal an error when we encounter it. - */ - s7_pointer pt = current_input_port(sc); - - if (!string_error) - { - /* make an heroic effort to find where we slid off the tracks */ - if (is_string_port(current_input_port(sc))) - { - #define QUOTE_SIZE 40 - s7_int i, j, start = 0, end, slen, size; - char *recent_input = NULL; - - /* we can run off the end in cases like (eval-string "(. . ,.)") or (eval-string " (@ . ,.)") */ - if (port_position(pt) >= port_data_size(pt)) - port_position(pt) = port_data_size(pt) - 1; - - /* start at current position and look back a few chars */ - for (i = port_position(pt), j = 0; (i > 0) && (j < QUOTE_SIZE); i--, j++) - if ((port_data(pt)[i] == '\0') || (port_data(pt)[i] == '\n') || (port_data(pt)[i] == '\r')) - break; - start = i; - - /* start at current position and look ahead a few chars */ - size = port_data_size(pt); - for (i = port_position(pt), j = 0; (i < size) && (j < QUOTE_SIZE); i++, j++) - if ((port_data(pt)[i] == '\0') || (port_data(pt)[i] == '\n') || (port_data(pt)[i] == '\r')) - break; - end = i; - - slen = end - start; /* hopefully this is more or less the current line where the read error happened */ - if (slen > 0) - { - recent_input = (char *)Calloc(slen + 9, 1); - for (i = 0; i < (slen + 8); i++) recent_input[i] = '.'; - recent_input[3] = ' '; - recent_input[slen + 4] = ' '; - for (i = 0; i < slen; i++) recent_input[i + 4] = port_data(pt)[start + i]; - } - - if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 64; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - string_length(p) = snprintf(msg, len, "%s: %s %s[%u], last top-level form at: %s[%" ld64 "]", - errmsg, (recent_input) ? recent_input : "", port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line); - if (recent_input) free(recent_input); - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - else - { - s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + safe_strlen(sc->current_file) + 64; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - if ((sc->current_file) && - (sc->current_line >= 0)) - string_length(p) = snprintf(msg, len, "%s: %s, last top-level form at %s[%" ld64 "]", - errmsg, (recent_input) ? recent_input : "", - sc->current_file, sc->current_line); - else string_length(p) = snprintf(msg, len, "%s: %s", errmsg, (recent_input) ? recent_input : ""); - if (recent_input) free(recent_input); - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - }}} - - if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - s7_int nlen = 0; - s7_int len = safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 128; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - if (string_error) - nlen = snprintf(msg, len, "%s %s[%u],\n; possible culprit: \"%s...\"\n; last top-level form at %s[%" ld64 "]", - errmsg, port_filename(pt), port_line_number(pt), - sc->strbuf, sc->current_file, sc->current_line); - else nlen = snprintf(msg, len, "%s %s[%u], last top-level form at %s[%" ld64 "]", - errmsg, port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line); - string_length(p) = nlen; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - error_nr(sc, (string_error) ? sc->string_read_error_symbol : sc->read_error_symbol, - set_elist_1(sc, s7_make_string_wrapper(sc, (char *)errmsg))); -} - -static noreturn void read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, false);} -static noreturn void string_read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, true);} - -static s7_pointer g_error(s7_scheme *sc, s7_pointer args) -{ - #define H_error "(error type ...) signals an error. The 'type' can be used with catch to trap \ -particular errors. If the error is not caught, s7 treats the second argument as a format control string, \ -and applies it to the rest of the arguments." - #define Q_error s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T) - - if (is_string(car(args))) /* a CL-style error -- use tag='no-catch */ - error_nr(sc, make_symbol(sc, "no-catch", 8), args); - error_nr(sc, car(args), cdr(args)); - return(sc->unspecified); -} - -static char *truncate_string(char *form, s7_int len, use_write_t use_write) -{ - uint8_t *f = (uint8_t *)form; - s7_int i; - if (use_write != P_DISPLAY) - { - /* I guess we need to protect the outer double quotes in this case */ - for (i = len - 5; i >= (len / 2); i--) - if (is_white_space((int32_t)f[i])) - return(form); - i = len - 5; - if (i > 0) {form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '"'; form[i + 4] = '\0';} - else - if (len >= 2) - { - form[len - 1] = '"'; - form[len] = '\0'; - }} - else - { - for (i = len - 4; i >= (len / 2); i--) - if (is_white_space((int32_t)f[i])) - { - form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0'; - return(form); - } - i = len - 4; - if (i >= 0) {form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0';} - else form[len] = '\0'; - } - return(form); -} - -static s7_pointer object_to_truncated_string(s7_scheme *sc, s7_pointer p, s7_int len) -{ - char *s; - s7_int s_len; - s7_pointer strp; - sc->objstr_max_len = len + 2; - strp = s7_object_to_string(sc, p, false); - s = string_value(strp); - sc->objstr_max_len = S7_INT64_MAX; - s_len = string_length(strp); - if (s_len > len) - truncate_string(s, len, P_DISPLAY); - return(strp); -} - -static s7_pointer tree_descend(s7_scheme *sc, s7_pointer p, uint32_t line) -{ - s7_pointer tp; - if (!is_pair(p)) return(NULL); - if (has_location(p)) - { - uint32_t x = (uint32_t)pair_line_number(p); - if (x > 0) - { - if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */ - line = x; - else - if (x < line) - return(p); - }} - tp = tree_descend(sc, car(p), line); - return((tp) ? tp : tree_descend(sc, cdr(p), line)); -} - -static noreturn void missing_close_paren_error_nr(s7_scheme *sc) -{ - char *syntax_msg = NULL; - s7_pointer pt = current_input_port(sc); - - if ((unchecked_type(sc->curlet) != T_LET) && (sc->curlet != sc->nil)) - sc->curlet = sc->nil; - - /* check *missing-close-paren-hook* */ - if (hook_has_functions(sc->missing_close_paren_hook)) - { - s7_pointer result; - if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - integer(slot_value(sc->error_line)) = port_line_number(pt); - integer(slot_value(sc->error_position)) = port_position(pt); - slot_set_value(sc->error_file, wrap_string(sc, port_filename(pt), port_filename_length(pt))); - } - result = s7_call(sc, sc->missing_close_paren_hook, sc->nil); - if (result != sc->unspecified) - g_throw(sc, list_1(sc, result)); - } - - if (is_pair(sc->args)) - { - s7_pointer p = tree_descend(sc, sc->args, 0); - if ((p) && (is_pair(p)) && - (has_location(p))) - { - s7_pointer strp = object_to_truncated_string(sc, p, 40); - char *form = string_value(strp); - s7_int form_len = string_length(strp); - s7_int msg_len = form_len + 128; - syntax_msg = (char *)Malloc(msg_len); - snprintf(syntax_msg, msg_len, "; current form awaiting a close paren starts around line %u: %s", (uint32_t)pair_line_number(p), form); - }} - - if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - s7_int nlen; - s7_int len = port_filename_length(pt) + safe_strlen(sc->current_file) + safe_strlen(syntax_msg) + 128; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - if (syntax_msg) - { - nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]\n%s", - port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line, syntax_msg); - free(syntax_msg); - } - else nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]", - port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line); - string_length(p) = nlen; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - - if (syntax_msg) - { - s7_int len = safe_strlen(syntax_msg) + 128; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - len = catstrs(msg, len, "missing close paren\n", syntax_msg, "\n", (char *)NULL); - free(syntax_msg); - string_length(p) = len; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - if ((is_input_port(pt)) && - (!port_is_closed(pt)) && - (port_data(pt)) && - (port_position(pt) > 0)) - { - s7_pointer p = make_empty_string(sc, 128, '\0'); - s7_int pos = port_position(pt); - s7_int start = pos - 40; - char *msg = string_value(p); - memcpy((void *)msg, (void *)"missing close paren: ", 21); - if (start < 0) start = 0; - memcpy((void *)(msg + 21), (void *)(port_data(pt) + start), pos - start); - string_length(p) = 21 + pos - start; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "missing close paren", 19))); -} - -static noreturn void improper_arglist_error_nr(s7_scheme *sc) -{ - /* sc->code is the last (dotted) arg, sc->args is the arglist reversed not including sc->code - * the original was `(func ,@(reverse args) . ,code) essentially where func is sc->value or pop_op_stack(sc) - */ - s7_pointer func = pop_op_stack(sc); - if (sc->args == sc->nil) /* (abs . 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "attempt to evaluate (~S . ~S)?", 30), func, sc->code)); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "attempt to evaluate (~S ~S . ~S)?", 33), - func, sc->args = proper_list_reverse_in_place(sc, sc->args), sc->code)); -} - -static void op_error_hook_quit(s7_scheme *sc) -{ - let_set(sc, closure_let(sc->error_hook), sc->body_symbol, sc->code); /* restore old value */ - let_set(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil); - /* now mimic the end of the normal error handler. Since this error hook evaluation can happen - * in an arbitrary s7_call nesting, we can't just return from the current evaluation -- - * we have to jump to the original (top-level) call. Otherwise '# or whatever - * is simply treated as the (non-error) return value, and the higher level evaluations - * get confused. - */ - stack_reset(sc); /* is this necessary? is it a good idea?? */ - push_stack_op(sc, OP_ERROR_QUIT); /* added 3-Dec-16: try to make sure we actually exit! */ - sc->cur_op = OP_ERROR_QUIT; - if (sc->longjmp_ok) - LongJmp(*(sc->goto_start), ERROR_QUIT_JUMP); -} - - -/* -------------------------------- begin_hook -------------------------------- */ -void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val) {return(sc->begin_hook);} - -void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val)) -{ - sc->begin_hook = hook; - sc->begin_op = (hook) ? OP_BEGIN_HOOK : OP_BEGIN_NO_HOOK; -} - -static bool call_begin_hook(s7_scheme *sc) -{ - bool result = false; - /* originally begin_hook was bool (*hook)(s7_scheme *sc): the value was returned directly, - * rather than going through a *bool arg (&result below). That works in gcc (Linux/OSX), - * but does not work in MS Visual C++. In the latter, the compiler apparently completely - * eliminates any local, returning (for example) a thread-relative stack-allocated value - * directly, but then by the time we get here, that variable has vanished, and we get - * garbage. We had to thwart the optimization by adding if ((flag) && (!flag)) fprintf(...); - * So, in the new form (26-Jun-13), the value is passed directly into an s7 variable - * that I hope can't be optimized out of existence. - * - * cm/src/Scheme.cpp, used in Snd (listener looking for C-g I think) - * originally this facility was aimed at interrupting infinite loops, and the expected usage was: - * set begin_hook, eval-string(...), unset begin_hook - */ - opcode_t op = sc->cur_op; - push_stack_direct(sc, OP_BARRIER); - sc->begin_hook(sc, &result); - if (result) - { - s7_pointer cur_code = current_code(sc); - /* set (owlet) in case we were interrupted and need to see why something was hung */ - slot_set_value(sc->error_type, sc->F); - slot_set_value(sc->error_data, sc->value); /* was sc->F but we now clobber this below */ - slot_set_value(sc->error_code, cur_code); - if (has_location(cur_code)) - { - integer(slot_value(sc->error_line)) = (s7_int)pair_line_number(cur_code); - slot_set_value(sc->error_file, sc->file_names[pair_file_number(cur_code)]); - integer(slot_value(sc->error_position)) = (s7_int)pair_position(cur_code); - } - else - { - integer(slot_value(sc->error_line)) = 0; - integer(slot_value(sc->error_position)) = 0; - slot_set_value(sc->error_file, sc->F); - } -#if WITH_HISTORY - slot_set_value(sc->error_history, sc->F); -#endif - let_set_outlet(sc->owlet, sc->curlet); - sc->value = make_symbol(sc, "begin-hook-interrupt", 20); - /* otherwise the evaluator returns whatever random thing is in sc->value (normally #) - * which makes debugging unnecessarily difficult. ?? why not return something useful? make return s7_pointer*, not bool* - */ - s7_quit(sc); /* don't call gc here -- eval_c_string is the context -- allows interrupt of infinite loop */ - return(true); - } - pop_stack_no_op(sc); - sc->cur_op = op; /* for better error handling. otherwise we get "barrier" as the offending function name in syntax_error */ - return(false); -} - - -/* -------------------------------- apply -------------------------------- */ -static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d) -{ - /* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */ - s7_pointer p; - gc_protect_via_stack(sc, d); - p = cons(sc, car(d), cdr(d)); - sc->w = p; - while (is_not_null(cddr(p))) - { - d = cdr(d); - set_cdr(p, cons(sc, car(d), cdr(d))); - if (is_not_null(cdr(d))) - p = cdr(p); - } - unstack(sc); - set_cdr(p, cadr(p)); - return(sc->w); -} - -static noreturn void apply_list_error_nr(s7_scheme *sc, s7_pointer lst) -{ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "apply's last argument should be a proper list: ~S", 49), lst)); -} - -static s7_pointer g_apply(s7_scheme *sc, s7_pointer args) -{ - #define H_apply "(apply func ...) applies func to the rest of the arguments" - #define Q_apply s7_make_circular_signature(sc, 2, 3, sc->values_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_sequence_symbol), sc->T) - - /* can apply always be replaced with apply values? (apply + '(1 2 3)) is the same as (+ (apply values '(1 2 3))) - * not if apply* in disguise, I think: (apply + 1 2 ()) -> 3, (apply + 1 2 (apply values ())) -> error - */ - s7_pointer func = car(args); - if (!is_applicable(func)) - apply_error_nr(sc, func, args); - - if (is_null(cdr(args))) - { - push_stack(sc, OP_APPLY, sc->nil, func); - return(sc->nil); - } - if (is_safe_procedure(func)) - { - s7_pointer p, q; - for (q = args, p = cdr(args); is_not_null(cdr(p)); q = p, p = cdr(p)); - /* the last arg is supposed to be a list, it will be spliced onto the end of the previous arg list (if any) below */ - - if (!s7_is_proper_list(sc, car(p))) /* (apply + #f) etc, the cycle protection here is checked in s7test */ - apply_list_error_nr(sc, args); - set_cdr(q, car(p)); /* args affected, so don't depend on cdr(args) from above */ - - if (is_c_function(func)) /* handle in-place to get better error messages */ - { - s7_int len; - uint8_t typ = type(func); - if (typ == T_C_RST_NO_REQ_FUNCTION) - return(c_function_call(func)(sc, cdr(args))); - len = proper_list_length(cdr(args)); - if (c_function_max_args(func) < len) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, too_many_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); - if ((typ == T_C_FUNCTION) && - (len < c_function_min_args(func))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, not_enough_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); - return(c_function_call(func)(sc, cdr(args))); - } - push_stack(sc, OP_APPLY, cdr(args), func); - return(sc->nil); - } - sc->code = func; - sc->args = (is_null(cddr(args))) ? cadr(args) : apply_list_star(sc, cdr(args)); - if (!s7_is_proper_list(sc, sc->args)) - apply_list_error_nr(sc, sc->args); - - /* (define imp (immutable! (cons 0 (immutable! (cons 1 (immutable! (cons 2 ()))))))) - * (define (fop4 x y) (apply x y)) - * (display (object->string (apply (lambda (a . b) (cons a b)) imp) :readable)) -> (list 0 1 2) - * (display (object->string (fop4 (lambda (a . b) (cons a b)) imp) :readable)) -> (cons 0 (immutable! (cons 1 (immutable! (cons 2 ()) - * g_apply sees the first one and thinks the lambda arg is unsafe, apply_ss sees the second and thinks it is safe (hence the list is not copied), - * so calling sort on the first is fine, but on the second gets an immutable object error. - */ - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, sc->args) : sc->args; - push_stack_direct(sc, OP_APPLY); - return(sc->nil); -} - -s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args) -{ - TRACK(sc); - if (is_c_function(fnc)) - return(c_function_call(fnc)(sc, args)); - /* if [if (!is_applicable(fnc)) apply_error_nr(sc, fnc, sc->args);] here, needs_copied_args can be T_App */ - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = fnc; - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; - /* fprintf(stderr, "apply %s %s\n", display(sc->code), display(sc->args)); */ - eval(sc, OP_APPLY); - /* we're limited in choices here -- the caller might be (say) car(sc->t1_1) = fn_proc(...) where the fn_proc - * happens to fallback on a method -- we can't just push OP_APPLY and drop back into the evaluator normally. - */ - return(sc->value); -} - -static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args) -{ - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = func; - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; - sc->curlet = make_let(sc, closure_let(sc->code)); - eval(sc, OP_APPLY_LAMBDA); - return(sc->value); -} - -static inline s7_pointer apply_c_function(s7_scheme *sc, s7_pointer func, s7_pointer args); - -static s7_pointer implicit_index_checked(s7_scheme *sc, s7_pointer obj, s7_pointer in_obj, s7_pointer indices) -{ - if (!is_applicable(in_obj)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), - set_ulist_1(sc, obj, indices), cons(sc, in_obj, cdr(indices)), in_obj)); - return(implicit_index(sc, in_obj, cdr(indices))); -} - -static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices) -{ - /* (let ((lst '("12" "34"))) (lst 0 1)) -> #\2 - * (let ((lst (list #(1 2) #(3 4)))) (lst 0 1)) -> 2 - * this can get tricky: ((list (lambda (a) (+ a 1)) (lambda (b) (* b 2))) 1 2) -> 4 - * but what if func takes rest/optional args, etc: ((list (lambda args (car args))) 0 "hi" 0) - * should this return #\h or "hi"?? currently it is "hi" which is consistent with ((lambda args (car args)) "hi" 0) - * but ((lambda (arg) arg) "hi" 0) is currently an error (too many arguments) - * maybe it should be (((lambda (arg) arg) "hi") 0) -> #\h - */ - s7_pointer res, in_obj; - switch (type(obj)) - { - case T_VECTOR: /* (#(#(1 2) #(3 4)) 1 1) -> 4 */ - return(vector_ref_1(sc, obj, indices)); - - case T_FLOAT_VECTOR: - res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->float_vector_ref_symbol, T_FLOAT_VECTOR); - set_car(sc->u1_1, sc->F); - return(res); - - case T_INT_VECTOR: - res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->int_vector_ref_symbol, T_INT_VECTOR); - set_car(sc->u1_1, sc->F); - return(res); - - case T_BYTE_VECTOR: - res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->byte_vector_ref_symbol, T_BYTE_VECTOR); - set_car(sc->u1_1, sc->F); - return(res); - - case T_STRING: /* (#("12" "34") 0 1) -> #\2 */ - if (!is_null(cdr(indices))) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, obj, indices)); - if (!is_t_integer(car(indices))) - wrong_type_error_nr(sc, sc->string_ref_symbol, 2, car(indices), sc->type_names[T_INTEGER]); - return(string_ref_p_pi_unchecked(sc, obj, integer(car(indices)))); - - case T_PAIR: /* (#((1 2) (3 4)) 1 0) -> 3, (#((1 (2 3))) 0 1 0) -> 2 */ - in_obj = list_ref_1(sc, obj, car(indices)); - if (is_pair(cdr(indices))) - return(implicit_index_checked(sc, obj, in_obj, indices)); - return(in_obj); - - case T_HASH_TABLE: /* ((vector (hash-table '(a . 1) '(b . 2))) 0 'a) -> 1 */ - in_obj = s7_hash_table_ref(sc, obj, car(indices)); - if (is_pair(cdr(indices))) - return(implicit_index_checked(sc, obj, in_obj, indices)); - return(in_obj); - - case T_LET: - in_obj = let_ref(sc, obj, car(indices)); - if (is_pair(cdr(indices))) - return(implicit_index_checked(sc, obj, in_obj, indices)); - return(in_obj); - - case T_C_OBJECT: - res = (*(c_object_ref(sc, obj)))(sc, set_ulist_1(sc, obj, indices)); - set_car(sc->u1_1, sc->F); - return(res); - - case T_ITERATOR: /* indices is not nil, so this is an error */ - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, obj, indices)); - - case T_CLOSURE: case T_CLOSURE_STAR: - if (!is_safe_closure(obj)) /* s7_call can't work in general with unsafe stuff */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "can't call a (possibly unsafe) function implicitly: ~S ~S", 57), obj, indices)); - check_stack_size(sc); - sc->temp10 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* s7_call copies and this is safe? 2-Oct-22 (and below) */ - sc->value = s7_call(sc, obj, sc->temp10); - sc->temp10 = sc->unused; - if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "mv: %s %s %s\n", display(obj), display(indices), display(sc->value)); - /* if mv: sc->value = splice_in_values(sc, multiple_value(sc->value)); */ - return(sc->value); - - case T_C_FUNCTION: - return(apply_c_function(sc, obj, indices)); - - case T_C_RST_NO_REQ_FUNCTION: - return(c_function_call(obj)(sc, indices)); - - default: - if (!is_applicable(obj)) /* (apply (list cons cons) (list 1 2)) needs the argnum check mentioned below */ - apply_error_nr(sc, obj, indices); - sc->temp10 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* do not use sc->args here! */ - sc->value = s7_call(sc, obj, sc->temp10); - sc->temp10 = sc->unused; - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); - } -} - -static inline void fill_star_defaults(s7_scheme *sc, s7_pointer func, int32_t start_arg, int32_t n_args, s7_pointer par) -{ - s7_pointer *df = c_function_arg_defaults(func); - if (c_func_has_simple_defaults(func)) - for (int32_t i = start_arg; i < n_args; i++, par = cdr(par)) - set_car(par, df[i]); - else - for (int32_t i = start_arg; i < n_args; i++, par = cdr(par)) - { - s7_pointer defval = df[i]; - if (is_symbol(defval)) - set_car(par, lookup_checked(sc, defval)); - else set_car(par, (is_pair(defval)) ? s7_eval(sc, defval, sc->nil) : defval); - } -} - -static s7_pointer set_c_function_star_args(s7_scheme *sc) -{ - int32_t i, j; - s7_pointer arg, par, call_args, func = sc->code; - s7_pointer *df; - int32_t n_args = c_function_max_args(func); /* not counting keywords, I think */ - - if (is_safe_procedure(func)) - call_args = c_function_call_args(func); - else - { - call_args = make_list(sc, c_function_optional_args(func), sc->F); - gc_protect_via_stack(sc, call_args); - } - - /* assume at the start that there are no keywords */ - for (i = 0, arg = sc->args, par = call_args; (i < n_args) && (is_pair(arg)); i++, arg = cdr(arg), par = cdr(par)) - if (!is_symbol_and_keyword(car(arg))) - set_car(par, car(arg)); - else - { - s7_pointer kpar, karg; - int32_t ki; - /* oops -- there are keywords, change scanners (much duplicated code...) - * setting checked on the call_args here rather than parsing the parameters to use add_symbol_to_list - */ - for (kpar = call_args; kpar != par; kpar = cdr(kpar)) - set_checked(kpar); - for (; is_pair(kpar); kpar = cdr(kpar)) - clear_checked(kpar); - df = c_function_arg_names(func); - for (ki = i, karg = arg, kpar = par; (ki < n_args) && (is_pair(karg)); ki++, karg = cdr(karg)) - if (!is_symbol_and_keyword(car(karg))) - { - if (is_checked(kpar)) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, parameter_set_twice_string, car(kpar), sc->args)); - } - set_checked(kpar); - set_car(kpar, car(karg)); - kpar = cdr(kpar); - } - else - { - s7_pointer p; - for (j = 0, p = call_args; j < n_args; j++, p = cdr(p)) - if (df[j] == car(karg)) - break; - if (j == n_args) - { - if (!c_function_allows_other_keys(func)) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "~A: not a parameter name?", 25), car(karg))); - } - karg = cdr(karg); - if (is_null(karg)) /* (f :x) where f arglist includes :allow-other-keys */ - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(arg), sc->args)); - } - ki--; - } - else - { - if (is_checked(p)) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, car(p), sc->args)); - } - if (!is_pair(cdr(karg))) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(karg), sc->args)); - } - set_checked(p); - karg = cdr(karg); - set_car(p, car(karg)); - kpar = cdr(kpar); - }} - if ((!is_null(karg)) && (!c_function_allows_other_keys(func))) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); - } - if (ki < n_args) - { - df = c_function_arg_defaults(func); - if (c_func_has_simple_defaults(func)) - { - for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) - if (!is_checked(kpar)) - set_car(kpar, df[ki]); - } - else - for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) - if (!is_checked(kpar)) - { - s7_pointer defval = df[ki]; - if (is_symbol(defval)) - set_car(kpar, lookup_checked(sc, defval)); - else set_car(kpar, (is_pair(defval)) ? s7_eval(sc, defval, sc->nil) : defval); - }} - if (!is_safe_procedure(func)) unstack(sc); - return(call_args); - } - if (!is_null(arg)) - { - if (!is_safe_procedure(func)) unstack(sc); - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); - } - if (i < n_args) - fill_star_defaults(sc, func, i, n_args, par); - if (!is_safe_procedure(func)) unstack(sc); - return(call_args); -} - -static s7_pointer set_c_function_star_defaults(s7_scheme *sc, int32_t num) -{ - s7_pointer call_args, func = sc->code, par; - int32_t n_args = c_function_max_args(func); - - if (is_safe_procedure(func)) - call_args = c_function_call_args(func); - else - { - call_args = make_list(sc, c_function_optional_args(func), sc->F); - gc_protect_via_stack(sc, call_args); - } - par = call_args; - if (num == 1) - { - set_car(par, car(sc->args)); - par = cdr(par); - } - fill_star_defaults(sc, func, num, n_args, par); - if (!is_safe_procedure(func)) unstack(sc); - return(call_args); -} - -#define apply_c_function_star(Sc) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_args(Sc)) -#define apply_c_function_star_fill_defaults(Sc, Num) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_defaults(Sc, Num)) - -s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args) -{ - TRACK(sc); - if (is_c_function_star(fnc)) - { - sc->w = sc->args; - sc->z = sc->code; - sc->args = T_Ext(args); - sc->code = fnc; - apply_c_function_star(sc); - sc->args = sc->w; - sc->code = sc->z; - return(sc->value); - } - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = fnc; - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args; - eval(sc, OP_APPLY); - return(sc->value); -} - -/* -------------------------------- eval -------------------------------- */ -s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e) -{ - declare_jump_info(); - TRACK(sc); - if (sc->safety > NO_SAFETY) - { - if (!s7_is_valid(sc, code)) - s7_warn(sc, 256, "bad code argument to %s: %p\n", __func__, code); - if (!s7_is_valid(sc, e)) - s7_warn(sc, 256, "bad environment argument to %s: %p\n", __func__, e); - } - store_jump_info(sc); - set_jump_info(sc, EVAL_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - } - else - { - push_stack_direct(sc, OP_EVAL_DONE); - sc->code = code; - if ((e != sc->rootlet) && - (is_let(e))) - set_curlet(sc, e); - else sc->curlet = sc->nil; - eval(sc, OP_EVAL); - } - restore_jump_info(sc); - - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(sc->value); -} - -s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer e, const char *caller, const char *file, s7_int line) -{ - s7_pointer result; - if (caller) - { - sc->s7_call_name = caller; - sc->s7_call_file = file; - sc->s7_call_line = line; - } - result = s7_eval(sc, code, e); - if (caller) - { - sc->s7_call_name = NULL; - sc->s7_call_file = NULL; - sc->s7_call_line = -1; - } - return(result); -} - -static s7_pointer g_eval(s7_scheme *sc, s7_pointer args) -{ - #define H_eval "(eval code (let (curlet))) evaluates code in the environment let. 'let' \ -defaults to the curlet; to evaluate something in the top-level environment instead, \ -pass (rootlet):\n\ -\n\ - (define x 32) \n\ - (let ((x 3))\n\ - (eval 'x (rootlet)))\n\ -\n\ - returns 32" - #define Q_eval s7_make_signature(sc, 3, sc->values_symbol, sc->T, sc->is_let_symbol) - - if (is_not_null(cdr(args))) - { - s7_pointer e = cadr(args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->eval_symbol, 2, e, a_let_string); - set_curlet(sc, (e == sc->rootlet) ? sc->nil : e); - } - sc->code = car(args); - - if ((sc->safety > NO_SAFETY) && - (is_pair(sc->code))) - { - check_free_heap_size(sc, 8192); - sc->code = copy_body(sc, sc->code); - } - else - if (is_optimized(sc->code)) - clear_all_optimizations(sc, sc->code); /* clears "unsafe" ops, not all ops */ - - set_current_code(sc, sc->code); - if (current_stack_top(sc) < 12) - push_stack_op(sc, OP_BARRIER); - push_stack_direct(sc, OP_EVAL); - return(sc->nil); -} - - -s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args) -{ - if (is_c_function(func)) - return(c_function_call(func)(sc, args)); /* no check for wrong-number-of-args -- is that reasonable? maybe use apply_c_function(sc, func, args) */ - { - declare_jump_info(); - TRACK(sc); - set_current_code(sc, history_cons(sc, func, args)); - if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s: %s %s\n", __func__, display(func), display_80(args))); - - sc->temp4 = T_App(func); /* this is feeble GC protection */ - sc->temp2 = T_Lst(args); /* only use of temp2 */ - - store_jump_info(sc); - set_jump_info(sc, S7_CALL_SET_JUMP); - if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - - if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */ - (sc->stack_end == sc->stack_start)) - push_stack_op(sc, OP_ERROR_QUIT); - } - else - { - if (sc->safety > NO_SAFETY) - check_list_validity(sc, "s7_call", args); - push_stack_direct(sc, OP_EVAL_DONE); /* this saves the current evaluation and will eventually finish this (possibly) nested call */ - sc->code = func; - sc->args = (needs_copied_args(func)) ? copy_proper_list(sc, args) : args; - eval(sc, OP_APPLY); - } - restore_jump_info(sc); - /* don't clear temp4 or temp2 here -- lots of (Snd) code calls s7_call repeatedly and assumes the "func" arg is protected between calls */ - return(sc->value); - } -} - -s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line) -{ - s7_pointer result; - if (caller) - { - sc->s7_call_name = caller; - sc->s7_call_file = file; - sc->s7_call_line = line; - } - result = s7_call(sc, func, args); - if (caller) - { - sc->s7_call_name = NULL; - sc->s7_call_file = NULL; - sc->s7_call_line = -1; - } - return(result); -} - - -/* -------------------------------- type-of -------------------------------- */ -#if (!WITH_GCC) -static inline bool gen_type_match(s7_scheme *sc, s7_pointer val, uint8_t typ) /* opt3_byte = uint8_t */ -{ - return((type(val) == typ) || - ((has_active_methods(sc, val)) && - (apply_boolean_method(sc, val, sc->type_to_typers[typ]) != sc->F))); -} -#else -#define gen_type_match(Sc, Val, Typ) \ - ({s7_pointer _val_ = Val; \ - ((type(_val_) == Typ) || \ - ((has_active_methods(Sc, _val_)) && \ - (apply_boolean_method(Sc, _val_, Sc->type_to_typers[Typ]) != Sc->F)));}) -#endif - -static void init_typers(s7_scheme *sc) -{ - sc->type_to_typers[T_FREE] = sc->F; - sc->type_to_typers[T_PAIR] = sc->is_pair_symbol; - sc->type_to_typers[T_NIL] = sc->is_null_symbol; - sc->type_to_typers[T_UNUSED] = sc->F; - sc->type_to_typers[T_EOF] = sc->is_eof_object_symbol; - sc->type_to_typers[T_UNDEFINED] = sc->is_undefined_symbol; - sc->type_to_typers[T_UNSPECIFIED] = sc->is_unspecified_symbol; - sc->type_to_typers[T_BOOLEAN] = sc->is_boolean_symbol; - sc->type_to_typers[T_CHARACTER] = sc->is_char_symbol; - sc->type_to_typers[T_SYMBOL] = sc->is_symbol_symbol; /* and keyword? */ - sc->type_to_typers[T_SYNTAX] = sc->is_syntax_symbol; - sc->type_to_typers[T_INTEGER] = sc->is_integer_symbol; - sc->type_to_typers[T_RATIO] = sc->is_rational_symbol; - sc->type_to_typers[T_REAL] = sc->is_float_symbol; - sc->type_to_typers[T_COMPLEX] = sc->is_complex_symbol; - sc->type_to_typers[T_BIG_INTEGER] = sc->is_integer_symbol; - sc->type_to_typers[T_BIG_RATIO] = sc->is_rational_symbol; - sc->type_to_typers[T_BIG_REAL] = sc->is_float_symbol; - sc->type_to_typers[T_BIG_COMPLEX] = sc->is_complex_symbol; - sc->type_to_typers[T_STRING] = sc->is_string_symbol; - sc->type_to_typers[T_BYTE_VECTOR] = sc->is_byte_vector_symbol; - sc->type_to_typers[T_C_OBJECT] = sc->is_c_object_symbol; - sc->type_to_typers[T_VECTOR] = sc->is_vector_symbol; - sc->type_to_typers[T_INT_VECTOR] = sc->is_int_vector_symbol; - sc->type_to_typers[T_FLOAT_VECTOR] = sc->is_float_vector_symbol; - sc->type_to_typers[T_CATCH] = sc->F; - sc->type_to_typers[T_DYNAMIC_WIND] = sc->F; - sc->type_to_typers[T_HASH_TABLE] = sc->is_hash_table_symbol; - sc->type_to_typers[T_LET] = sc->is_let_symbol; - sc->type_to_typers[T_ITERATOR] = sc->is_iterator_symbol; - sc->type_to_typers[T_STACK] = sc->F; - sc->type_to_typers[T_COUNTER] = sc->F; - sc->type_to_typers[T_SLOT] = sc->F; - sc->type_to_typers[T_C_POINTER] = sc->is_c_pointer_symbol; - sc->type_to_typers[T_OUTPUT_PORT] = sc->is_output_port_symbol; - sc->type_to_typers[T_INPUT_PORT] = sc->is_input_port_symbol; - sc->type_to_typers[T_RANDOM_STATE] = sc->is_random_state_symbol; - sc->type_to_typers[T_GOTO] = sc->is_goto_symbol; - sc->type_to_typers[T_CONTINUATION] = sc->is_continuation_symbol; - sc->type_to_typers[T_CLOSURE] = sc->is_procedure_symbol; - sc->type_to_typers[T_CLOSURE_STAR] = sc->is_procedure_symbol; - sc->type_to_typers[T_C_MACRO] = sc->is_macro_symbol; - sc->type_to_typers[T_MACRO] = sc->is_macro_symbol; - sc->type_to_typers[T_MACRO_STAR] = sc->is_macro_symbol; - sc->type_to_typers[T_BACRO] = sc->is_macro_symbol; - sc->type_to_typers[T_BACRO_STAR] = sc->is_macro_symbol; - sc->type_to_typers[T_C_FUNCTION] = sc->is_procedure_symbol; - sc->type_to_typers[T_C_FUNCTION_STAR] = sc->is_procedure_symbol; - sc->type_to_typers[T_C_RST_NO_REQ_FUNCTION] = sc->is_procedure_symbol; -} - -s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg) {return(sc->type_to_typers[type(arg)]);} - -static s7_pointer g_type_of(s7_scheme *sc, s7_pointer args) -{ - #define H_type_of "(type-of obj) returns a symbol describing obj's type" - #define Q_type_of s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->not_symbol), sc->T) - return(sc->type_to_typers[type(car(args))]); -} - - -/* -------------------------------- exit emergency-exit -------------------------------- */ -void s7_quit(s7_scheme *sc) -{ - sc->longjmp_ok = false; - pop_input_port(sc); - stack_reset(sc); - push_stack_op_let(sc, OP_EVAL_DONE); -} - -static s7_pointer g_emergency_exit(s7_scheme *sc, s7_pointer args) -{ - #define H_emergency_exit "(emergency-exit obj) exits s7 immediately" - #define Q_emergency_exit s7_make_signature(sc, 2, sc->T, sc->T) - - s7_pointer obj; -#ifndef EXIT_SUCCESS - #define EXIT_SUCCESS 0 - #define EXIT_FAILURE 1 -#endif - if (is_null(args)) - _exit(EXIT_SUCCESS); /* r7rs spec says use _exit here */ - obj = car(args); - if (obj == sc->F) - _exit(EXIT_FAILURE); - if ((obj == sc->T) || (!s7_is_integer(obj))) - _exit(EXIT_SUCCESS); - _exit((int)s7_integer_clamped_if_gmp(sc, obj)); - return(sc->F); -} - -static s7_pointer g_exit(s7_scheme *sc, s7_pointer args) -{ - #define H_exit "(exit obj) exits s7" - #define Q_exit s7_make_signature(sc, 2, sc->T, sc->T) - /* calling s7_eval_c_string in an atexit function seems to be problematic -- it works, but args can be changed? longjmp perhaps? */ - - s7_quit(sc); - if (show_gc_stats(sc)) - s7_warn(sc, 256, "gc calls %" ld64 " total time: %f\n", sc->gc_calls, (double)(sc->gc_total_time) / ticks_per_second()); - return(g_emergency_exit(sc, args)); -} - -#if WITH_GCC -static s7_pointer g_abort(s7_scheme *sc, s7_pointer args) {abort(); return(NULL);} -#endif - - -/* -------------------------------- optimizer stuff -------------------------------- */ -/* There is a problem with cache misses: a bigger cache reduces one test from 24 seconds to 17 (cachegrind agrees). - * But how to optimize s7 for cache hits? The culprits are eval and gc. Looking at the numbers, - * I think the least affected tests are able to use opt_info optimization which makes everything local? - */ - -#if S7_DEBUGGING -static void check_t_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) -{ - if (let_slots(e) != lookup_slot_from(var, sc->curlet)) - { - fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", BOLD_TEXT, func, display(expr), display(var), display(sc->curlet), - (tis_slot(let_slots(e))) ? display(let_slots(e)) : "no slots", UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer t_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_t_1(sc, sc->curlet, func, expr, symbol); - return(slot_value(let_slots(sc->curlet))); -} - -static s7_pointer T_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_t_1(sc, let_outlet(sc->curlet), func, expr, symbol); - return(slot_value(let_slots(let_outlet(sc->curlet)))); -} - -static void check_u_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) -{ - if (next_slot(let_slots(e)) != lookup_slot_from(var, sc->curlet)) - { - fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", BOLD_TEXT, func, display(expr), display(var), display(e), - (tis_slot(next_slot(let_slots(e)))) ? display(next_slot(let_slots(e))) : "no next slot", UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer u_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_u_1(sc, sc->curlet, func, expr, symbol); - return(slot_value(next_slot(let_slots(sc->curlet)))); -} - -static s7_pointer U_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_u_1(sc, let_outlet(sc->curlet), func, expr, symbol); - return(slot_value(next_slot(let_slots(let_outlet(sc->curlet))))); -} - -static void check_v_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) -{ - if (next_slot(next_slot(let_slots(e))) != lookup_slot_from(var, sc->curlet)) - { - fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", BOLD_TEXT, func, display(expr), display(var), display(e), - (tis_slot(next_slot(next_slot(let_slots(e))))) ? display(next_slot(next_slot(let_slots(e)))) : "no next slot", UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer v_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_v_1(sc, sc->curlet, func, expr, symbol); - return(slot_value(next_slot(next_slot(let_slots(sc->curlet))))); -} - -static s7_pointer V_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_v_1(sc, let_outlet(sc->curlet), func, expr, symbol); - return(slot_value(next_slot(next_slot(let_slots(let_outlet(sc->curlet)))))); -} - -static void check_o_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var) -{ - s7_pointer slot = lookup_slot_from(var, sc->curlet); - if (lookup_slot_from(var, e) != slot) - { - fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", BOLD_TEXT, func, display(expr), display(var), display(e), - (tis_slot(slot)) ? display(slot) : "undefined", UNBOLD_TEXT); - if (sc->stop_at_error) abort(); - } -} - -static s7_pointer o_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr) -{ - check_o_1(sc, let_outlet(sc->curlet), func, expr, symbol); - return(inline_lookup_from(sc, symbol, let_outlet(sc->curlet))); -} - -#define t_lookup(Sc, Symbol, Expr) t_lookup_1(Sc, Symbol, __func__, Expr) -#define u_lookup(Sc, Symbol, Expr) u_lookup_1(Sc, Symbol, __func__, Expr) -#define v_lookup(Sc, Symbol, Expr) v_lookup_1(Sc, Symbol, __func__, Expr) -#define T_lookup(Sc, Symbol, Expr) T_lookup_1(Sc, Symbol, __func__, Expr) -#define U_lookup(Sc, Symbol, Expr) U_lookup_1(Sc, Symbol, __func__, Expr) -#define V_lookup(Sc, Symbol, Expr) V_lookup_1(Sc, Symbol, __func__, Expr) -#define o_lookup(Sc, Symbol, Expr) o_lookup_1(Sc, Symbol, __func__, Expr) -#else -#define t_lookup(Sc, Symbol, Expr) slot_value(let_slots(sc->curlet)) -#define u_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(sc->curlet))) -#define v_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(sc->curlet)))) -#define T_lookup(Sc, Symbol, Expr) slot_value(let_slots(let_outlet(sc->curlet))) -#define U_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(let_outlet(sc->curlet)))) -#define V_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(let_outlet(sc->curlet))))) -#define o_lookup(Sc, Symbol, Expr) inline_lookup_from(Sc, Symbol, let_outlet(Sc->curlet)) -#endif - -#define s_lookup(Sc, Sym, Expr) lookup(Sc, Sym) -#define g_lookup(Sc, Sym, Expr) lookup_global(Sc, Sym) - -/* arg here is the full expression */ -static s7_pointer fx_c(s7_scheme *sc, s7_pointer arg) {return(arg);} -static s7_pointer fx_q(s7_scheme *sc, s7_pointer arg) {return(cadr(arg));} -static s7_pointer fx_unsafe_s(s7_scheme *sc, s7_pointer arg) {return(lookup_checked(sc, T_Sym(arg)));} - -static s7_pointer fx_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, T_Sym(arg)));} -static s7_pointer fx_g(s7_scheme *sc, s7_pointer arg) {return((is_global(arg)) ? global_value(arg) : lookup(sc, arg));} -static s7_pointer fx_o(s7_scheme *sc, s7_pointer arg) {return(o_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_t(s7_scheme *sc, s7_pointer arg) {return(t_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_u(s7_scheme *sc, s7_pointer arg) {return(u_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_v(s7_scheme *sc, s7_pointer arg) {return(v_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_T(s7_scheme *sc, s7_pointer arg) {return(T_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_U(s7_scheme *sc, s7_pointer arg) {return(U_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_V(s7_scheme *sc, s7_pointer arg) {return(V_lookup(sc, T_Sym(arg), arg));} -static s7_pointer fx_c_nc(s7_scheme *sc, s7_pointer arg) {return(fc_call(sc, arg));} -static s7_pointer fx_cons_cc(s7_scheme *sc, s7_pointer arg) {return(cons(sc, cadr(arg), caddr(arg)));} -static s7_pointer fx_curlet(s7_scheme *sc, s7_pointer arg) {return(sc->curlet);} - -#define fx_c_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(fn_proc(arg)(sc, with_list_t1(Lookup(sc, cadr(arg), arg)))); \ - } - -fx_c_any(fx_c_s, s_lookup) -fx_c_any(fx_c_g, g_lookup) -fx_c_any(fx_c_t, t_lookup) -fx_c_any(fx_c_u, u_lookup) -fx_c_any(fx_c_v, v_lookup) -fx_c_any(fx_c_o, o_lookup) -fx_c_any(fx_c_T, T_lookup) -fx_c_any(fx_c_V, V_lookup) - -static s7_pointer fx_c_g_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup_global(sc, cadr(arg))));} -static s7_pointer fx_c_s_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg))));} -static s7_pointer fx_c_o_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, o_lookup(sc, cadr(arg), arg)));} -static s7_pointer fx_c_t_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg)));} -static s7_pointer fx_c_u_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, u_lookup(sc, cadr(arg), arg)));} -static s7_pointer fx_c_v_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, v_lookup(sc, cadr(arg), arg)));} - - -#define fx_car_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return((is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ - } - /* using car_p_p(val) here is exactly the same in speed according to callgrind */ - -fx_car_any(fx_car_s, s_lookup) -fx_car_any(fx_car_t, t_lookup) -fx_car_any(fx_car_u, u_lookup) -fx_car_any(fx_car_o, o_lookup) -fx_car_any(fx_car_T, T_lookup) -fx_car_any(fx_car_U, U_lookup) - - -#define fx_cdr_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return((is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \ - } - -fx_cdr_any(fx_cdr_s, s_lookup) -fx_cdr_any(fx_cdr_t, t_lookup) -fx_cdr_any(fx_cdr_u, u_lookup) -fx_cdr_any(fx_cdr_v, v_lookup) -fx_cdr_any(fx_cdr_o, o_lookup) -fx_cdr_any(fx_cdr_T, T_lookup) -fx_cdr_any(fx_cdr_U, U_lookup) - - -#define fx_cadr_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg)\ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return(((is_pair(val)) && (is_pair(cdr(val)))) ? cadr(val) : g_cadr(sc, set_plist_1(sc, val))); \ - } - -fx_cadr_any(fx_cadr_s, s_lookup) -fx_cadr_any(fx_cadr_t, t_lookup) -fx_cadr_any(fx_cadr_u, u_lookup) -fx_cadr_any(fx_cadr_o, o_lookup) - - -#define fx_cddr_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg)\ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return(((is_pair(val)) && (is_pair(cdr(val)))) ? cddr(val) : g_cddr(sc, set_plist_1(sc, val))); \ - } - -fx_cddr_any(fx_cddr_s, s_lookup) -fx_cddr_any(fx_cddr_t, t_lookup) -fx_cddr_any(fx_cddr_u, u_lookup) -fx_cddr_any(fx_cddr_o, o_lookup) - - -#define fx_add_s1_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) + 1)); \ - return(g_add_x1_1(sc, x, 1)); /* arg=(+ x 1) */ \ - } - -fx_add_s1_any(fx_add_s1, s_lookup) -fx_add_s1_any(fx_add_t1, t_lookup) -fx_add_s1_any(fx_add_u1, u_lookup) -fx_add_s1_any(fx_add_v1, v_lookup) -fx_add_s1_any(fx_add_T1, T_lookup) -fx_add_s1_any(fx_add_U1, U_lookup) -fx_add_s1_any(fx_add_V1, V_lookup) - - -static s7_pointer fx_num_eq_xi_1(s7_scheme *sc, s7_pointer args, s7_pointer val, s7_int y) -{ - if ((S7_DEBUGGING) && (is_t_integer(val))) fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, display(val)); - switch (type(val)) - { - case T_REAL: return(make_boolean(sc, real(val) == y)); - case T_RATIO: - case T_COMPLEX: return(sc->F); -#if WITH_GMP - case T_BIG_INTEGER: return(make_boolean(sc, mpz_cmp_si(big_integer(val), y) == 0)); - case T_BIG_REAL: return(make_boolean(sc, mpfr_cmp_si(big_real(val), y) == 0)); - case T_BIG_RATIO: - case T_BIG_COMPLEX: return(sc->F); -#endif - default: return(method_or_bust_pp(sc, val, sc->num_eq_symbol, val, cadr(args), a_number_string, 1)); - } - return(sc->T); -} - -static s7_pointer fx_num_eq_s0f(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, cadr(arg)); - if (is_t_real(val)) return(make_boolean(sc, real(val) == 0.0)); - return(make_boolean(sc, num_eq_b_7pp(sc, val, real_zero))); -} - -#define fx_num_eq_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer args = cdr(arg); \ - s7_pointer val = Lookup(sc, car(args), arg); \ - s7_int y = integer(cadr(args)); \ - return((is_t_integer(val)) ? make_boolean(sc, integer(val) == y) : \ - ((is_t_real(val)) ? make_boolean(sc, real(val) == y) : fx_num_eq_xi_1(sc, args, val, y))); \ -} - -fx_num_eq_si_any(fx_num_eq_si, s_lookup) -fx_num_eq_si_any(fx_num_eq_ti, t_lookup) -fx_num_eq_si_any(fx_num_eq_ui, u_lookup) -fx_num_eq_si_any(fx_num_eq_vi, v_lookup) -fx_num_eq_si_any(fx_num_eq_Ti, T_lookup) -fx_num_eq_si_any(fx_num_eq_oi, o_lookup) - -#define fx_num_eq_s0_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ - return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : fx_num_eq_xi_1(sc, cdr(arg), val, 0)); \ - } - -fx_num_eq_s0_any(fx_num_eq_s0, s_lookup) -fx_num_eq_s0_any(fx_num_eq_t0, t_lookup) -fx_num_eq_s0_any(fx_num_eq_u0, u_lookup) -fx_num_eq_s0_any(fx_num_eq_v0, v_lookup) - -static s7_pointer fx_num_eq_0s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, caddr(arg)); - return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : g_num_eq(sc, set_plist_2(sc, val, int_zero))); -} - - -static s7_pointer fx_random_i(s7_scheme *sc, s7_pointer arg) -{ -#if WITH_GMP - return(g_random_i(sc, cdr(arg))); -#else - return(make_integer(sc, (s7_int)(integer(cadr(arg)) * next_random(sc->default_random_state)))); -#endif -} - -#if (!WITH_GMP) -static s7_pointer fx_add_i_random(s7_scheme *sc, s7_pointer arg) -{ - s7_int x = integer(cadr(arg)); - s7_int y = opt3_int(cdr(arg)); /* cadadr */ - return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */ -} -#endif - -static s7_pointer fx_add_sf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_add_fs(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg)), 2));} -static s7_pointer fx_add_tf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg))), 1));} - -#define fx_add_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if ((!WITH_GMP) && (is_t_integer(x))) \ - { \ - if (HAVE_OVERFLOW_CHECKS) \ - { \ - s7_int val; \ - if (!add_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \ - return(make_integer(sc, val)); \ - } \ - else return(make_integer(sc, integer(x) + integer(opt2_con(cdr(arg))))); \ - } \ - return(add_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \ - } - -fx_add_si_any(fx_add_si, s_lookup) -fx_add_si_any(fx_add_ti, t_lookup) - -static s7_pointer fx_add_ss(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, s_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_ts(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, t_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_tu(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_ut(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_uv(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), v_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_us(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_add_vu(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, v_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));} - -#define fx_subtract_s1_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) - 1)); \ - return(minus_c1(sc, x)); \ - } - -fx_subtract_s1_any(fx_subtract_s1, s_lookup) -fx_subtract_s1_any(fx_subtract_t1, t_lookup) -fx_subtract_s1_any(fx_subtract_u1, u_lookup) -fx_subtract_s1_any(fx_subtract_v1, v_lookup) -fx_subtract_s1_any(fx_subtract_T1, T_lookup) -fx_subtract_s1_any(fx_subtract_U1, U_lookup) - - -#define fx_subtract_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if ((!WITH_GMP) && (is_t_integer(x))) \ - { \ - if (HAVE_OVERFLOW_CHECKS) \ - { \ - s7_int val; \ - if (!subtract_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \ - return(make_integer(sc, val)); \ - } \ - else return(make_integer(sc, integer(x) - integer(opt2_con(cdr(arg))))); \ - } \ - return(subtract_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \ - } - -fx_subtract_si_any(fx_subtract_si, s_lookup) -fx_subtract_si_any(fx_subtract_ti, t_lookup) -fx_subtract_si_any(fx_subtract_ui, u_lookup) - - -#define fx_subtract_sf_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_real(x)) \ - return(make_real(sc, real(x) - real(opt2_con(cdr(arg))))); /* caddr(arg) */ \ - return(g_subtract_2f(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_subtract_sf_any(fx_subtract_sf, s_lookup) -fx_subtract_sf_any(fx_subtract_tf, t_lookup) - - -#define fx_subtract_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) {return(subtract_p_pp(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg)));} - -fx_subtract_ss_any(fx_subtract_ss, s_lookup, s_lookup) -fx_subtract_ss_any(fx_subtract_ts, t_lookup, s_lookup) -fx_subtract_ss_any(fx_subtract_tu, t_lookup, u_lookup) -fx_subtract_ss_any(fx_subtract_ut, u_lookup, t_lookup) -fx_subtract_ss_any(fx_subtract_us, u_lookup, s_lookup) - - -static s7_pointer fx_subtract_fs(s7_scheme *sc, s7_pointer arg) -{ - s7_double n = real(cadr(arg)); - s7_pointer x = lookup(sc, opt2_sym(cdr(arg))); /* caddr(arg) */ - switch (type(x)) - { - case T_INTEGER: return(make_real(sc, n - integer(x))); - case T_RATIO: return(make_real(sc, n - fraction(x))); - case T_REAL: return(make_real(sc, n - real(x))); - case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x))); -#if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX: - return(subtract_p_pp(sc, cadr(arg), x)); -#endif - default: - return(method_or_bust_pp(sc, x, sc->subtract_symbol, cadr(arg), x, a_number_string, 2)); - } - return(x); -} - -#define fx_is_eq_sc_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(make_boolean(sc, Lookup(sc, cadr(arg), arg) == opt2_con(cdr(arg)))); /* fx_choose checks that the second arg is not unspecified */ \ - } - -fx_is_eq_sc_any(fx_is_eq_sc, s_lookup) -fx_is_eq_sc_any(fx_is_eq_tc, t_lookup) -fx_is_eq_sc_any(fx_is_eq_uc, u_lookup) - - -#define fx_is_eq_car_sq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer a = cdr(arg); \ - s7_pointer lst = Lookup(sc, opt3_sym(a), arg); \ - return(make_boolean(sc, (is_pair(lst)) ? (car(lst) == opt2_con(a)) : s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt2_con(a)))); \ - } - -fx_is_eq_car_sq_any(fx_is_eq_car_sq, s_lookup) -fx_is_eq_car_sq_any(fx_is_eq_car_tq, t_lookup) - - -static s7_pointer fx_is_eq_caar_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer a = cdr(arg); - s7_pointer lst = lookup(sc, opt3_sym(a)); - if ((is_pair(lst)) && (is_pair(car(lst)))) - return(make_boolean(sc, caar(lst) == opt2_con(a))); - return(make_boolean(sc, s7_is_eq(g_caar(sc, set_plist_1(sc, lst)), opt2_con(a)))); -} - -static s7_pointer fx_not_is_eq_car_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer lst = lookup(sc, opt1_sym(cdr(arg))); - if (is_pair(lst)) - return(make_boolean(sc, car(lst) != opt3_con(cdr(arg)))); - return(make_boolean(sc, !s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt3_con(cdr(arg))))); -} - -#define fx_is_pair_car_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return((is_pair(p)) ? make_boolean(sc, is_pair(car(p))) : g_is_pair(sc, set_plist_1(sc, g_car(sc, set_plist_1(sc, p))))); \ - } - -fx_is_pair_car_s_any(fx_is_pair_car_s, s_lookup) -fx_is_pair_car_s_any(fx_is_pair_car_t, t_lookup) - - -#define fx_is_pair_cdr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return((is_pair(p)) ? make_boolean(sc, is_pair(cdr(p))) : g_is_pair(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_pair_cdr_s_any(fx_is_pair_cdr_s, s_lookup) -fx_is_pair_cdr_s_any(fx_is_pair_cdr_t, t_lookup) -fx_is_pair_cdr_s_any(fx_is_pair_cdr_u, u_lookup) - - -#define fx_is_pair_cadr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cadr(p))) : g_is_pair(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_pair_cadr_s_any(fx_is_pair_cadr_s, s_lookup) -fx_is_pair_cadr_s_any(fx_is_pair_cadr_t, t_lookup) - - -#define fx_is_pair_cddr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cddr(p))) : g_is_pair(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_pair_cddr_s_any(fx_is_pair_cddr_s, s_lookup) -fx_is_pair_cddr_s_any(fx_is_pair_cddr_t, t_lookup) - - -#define fx_is_null_cdr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return((is_pair(p)) ? make_boolean(sc, is_null(cdr(p))) : g_is_null(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_null_cdr_s_any(fx_is_null_cdr_s, s_lookup) -fx_is_null_cdr_s_any(fx_is_null_cdr_t, t_lookup) - - -#define fx_is_null_cadr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cadr(p))) : g_is_null(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_null_cadr_s_any(fx_is_null_cadr_s, s_lookup) -fx_is_null_cadr_s_any(fx_is_null_cadr_t, t_lookup) - - -#define fx_is_null_cddr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cddr(p))) : g_is_null(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_null_cddr_s_any(fx_is_null_cddr_s, s_lookup) -fx_is_null_cddr_s_any(fx_is_null_cddr_t, t_lookup) - - -#define fx_is_symbol_cadr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_symbol(cadr(p))) : g_is_symbol(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \ - } - -fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_s, s_lookup) -fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_t, t_lookup) - -static s7_pointer fx_is_symbol_car_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = t_lookup(sc, opt2_sym(cdr(arg)), arg); - return(make_boolean(sc, (is_pair(val)) ? is_symbol(car(val)) : is_symbol(g_car(sc, set_plist_1(sc, val))))); -} - -static s7_pointer fx_floor_sqrt_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = lookup(sc, opt2_sym(cdr(arg))); -#if WITH_GMP - if ((is_t_big_integer(p)) && - (mpz_cmp_ui(big_integer(p), 0) >= 0)) /* p >= 0 */ - { - mpz_sqrt(sc->mpz_1, big_integer(p)); - return(mpz_to_integer(sc, sc->mpz_1)); - } -#else - if (!is_negative_b_7p(sc, p)) - return(make_integer(sc, (s7_int)floor(sqrt(s7_number_to_real_with_location(sc, p, sc->sqrt_symbol))))); -#endif - return(floor_p_p(sc, sqrt_p_p(sc, p))); -} - - -static s7_pointer fx_is_positive_u(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = u_lookup(sc, cadr(arg), arg); - if (is_t_integer(p1)) return(make_boolean(sc, integer(p1) > 0)); - return(make_boolean(sc, is_positive_b_7p(sc, p1))); -} - -static s7_pointer fx_is_zero_u(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_zero_b_7p(sc, u_lookup(sc, cadr(arg), arg))));} - -#define fx_real_part_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer z = Lookup(sc, cadr(arg), arg); \ - return((is_t_complex(z)) ? make_real(sc, real_part(z)) : real_part_p_p(sc, z)); \ - } - -fx_real_part_s_any(fx_real_part_s, s_lookup) -fx_real_part_s_any(fx_real_part_t, t_lookup) - -#define fx_imag_part_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer z = Lookup(sc, cadr(arg), arg); \ - return((is_t_complex(z)) ? make_real(sc, imag_part(z)) : imag_part_p_p(sc, z)); \ - } - -fx_imag_part_s_any(fx_imag_part_s, s_lookup) -fx_imag_part_s_any(fx_imag_part_t, t_lookup) /* not used in current timing tests */ - -#define fx_iterate_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer iter = Lookup(sc, cadr(arg), arg); \ - if (is_iterator(iter)) \ - return((iterator_next(iter))(sc, iter)); \ - return(method_or_bust_p(sc, iter, sc->iterate_symbol, sc->type_names[T_ITERATOR])); \ - } - -fx_iterate_s_any(fx_iterate_s, s_lookup) -fx_iterate_s_any(fx_iterate_o, o_lookup) -fx_iterate_s_any(fx_iterate_T, T_lookup) - - -static s7_pointer fx_length_s(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, lookup(sc, cadr(arg))));} -static s7_pointer fx_length_t(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, t_lookup(sc, cadr(arg), arg)));} - -static s7_pointer fx_num_eq_length_i(s7_scheme *sc, s7_pointer arg) -{ - /* avoid make_integer (and telescope opts), we get here with car=length expr, cadr=int */ - s7_int ilen = integer(opt2_con(cdr(arg))); /* is_t_integer checked in fx_choose */ - s7_pointer val = lookup(sc, opt3_sym(cdr(arg))); - - switch (type(val)) - { - case T_PAIR: return(make_boolean(sc, s7_list_length(sc, val) == ilen)); - case T_NIL: return(make_boolean(sc, ilen == 0)); - case T_STRING: return(make_boolean(sc, string_length(val) == ilen)); - case T_HASH_TABLE: return(make_boolean(sc, (hash_table_mask(val) + 1) == ilen)); - case T_C_OBJECT: return(make_boolean(sc, c_object_length_to_int(sc, val) == ilen)); - case T_LET: return(make_boolean(sc, let_length(sc, val) == ilen)); - - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: - return(make_boolean(sc, vector_length(val) == ilen)); - - case T_ITERATOR: - { - s7_pointer len = s7_length(sc, iterator_sequence(val)); - return(make_boolean(sc, (is_t_integer(len)) && (integer(len) == ilen))); - } - - case T_CLOSURE: - case T_CLOSURE_STAR: - if (has_active_methods(sc, val)) - return(make_boolean(sc, closure_length(sc, val) == ilen)); - /* fall through */ - - default: - sole_arg_wrong_type_error_nr(sc, sc->length_symbol, val, a_sequence_string); - /* here we already lost because we checked for the length above */ - } - return(sc->F); -} - -static s7_pointer fx_less_length_i(s7_scheme *sc, s7_pointer arg) -{ - s7_int ilen = integer(opt2_con(cdr(arg))); /* caddr(arg) */ - s7_pointer val = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg) */ - - switch (type(val)) - { - case T_PAIR: return(make_boolean(sc, s7_list_length(sc, val) < ilen)); - case T_NIL: return(make_boolean(sc, ilen > 0)); - case T_STRING: return(make_boolean(sc, string_length(val) < ilen)); - case T_HASH_TABLE: return(make_boolean(sc, (hash_table_mask(val) + 1) < ilen)); /* was <=? -- changed 15-Dec-15, then again 6-Jan-17: mask is len-1 */ - case T_C_OBJECT: return(make_boolean(sc, c_object_length_to_int(sc, val) < ilen)); - case T_LET: return(make_boolean(sc, let_length(sc, val) < ilen)); /* this works because let_length handles the length method itself! */ - - case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: - return(make_boolean(sc, vector_length(val) < ilen)); - - case T_ITERATOR: - { - s7_pointer len = s7_length(sc, iterator_sequence(val)); - return(make_boolean(sc, (is_t_integer(len)) && (integer(len) < ilen))); - } - - case T_CLOSURE: - case T_CLOSURE_STAR: - if (has_active_methods(sc, val)) - return(make_boolean(sc, closure_length(sc, val) < ilen)); - /* fall through */ - - default: - sole_arg_wrong_type_error_nr(sc, sc->length_symbol, val, a_sequence_string); /* no check method here because we checked above */ - } - return(sc->F); -} - -static s7_pointer fx_is_null_s(s7_scheme *sc, s7_pointer arg) {return((is_null(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_null_o(s7_scheme *sc, s7_pointer arg) {return((is_null(o_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} /* very few hits */ -static s7_pointer fx_is_null_t(s7_scheme *sc, s7_pointer arg) {return((is_null(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_null_u(s7_scheme *sc, s7_pointer arg) {return((is_null(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_null_v(s7_scheme *sc, s7_pointer arg) {return((is_null(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_null_T(s7_scheme *sc, s7_pointer arg) {return((is_null(T_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_symbol_s(s7_scheme *sc, s7_pointer arg) {return((is_symbol(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_symbol_t(s7_scheme *sc, s7_pointer arg) {return((is_symbol(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_symbol_u(s7_scheme *sc, s7_pointer arg) {return((is_symbol(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_eof_s(s7_scheme *sc, s7_pointer arg) {return((lookup(sc, cadr(arg)) == eof_object) ? sc->T : sc->F);} -static s7_pointer fx_is_eof_t(s7_scheme *sc, s7_pointer arg) {return((t_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F);} -static s7_pointer fx_is_eof_u(s7_scheme *sc, s7_pointer arg) {return((u_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F);} -static s7_pointer fx_is_type_s(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(lookup(sc, cadr(arg)))));} -static s7_pointer fx_is_type_t(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(t_lookup(sc, cadr(arg), arg))));} -static s7_pointer fx_is_type_u(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(u_lookup(sc, cadr(arg), arg))));} -#if WITH_GMP -static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer arg) {return((s7_is_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_integer_t(s7_scheme *sc, s7_pointer arg) {return((s7_is_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -#else -static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer arg) {return((is_t_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_integer_t(s7_scheme *sc, s7_pointer arg) {return((is_t_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -#endif -static s7_pointer fx_is_string_s(s7_scheme *sc, s7_pointer arg) {return((is_string(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_string_t(s7_scheme *sc, s7_pointer arg) {return((is_string(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_procedure_s(s7_scheme *sc, s7_pointer arg) {return((is_procedure(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_procedure_t(s7_scheme *sc, s7_pointer arg) {return((is_procedure(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_pair_s(s7_scheme *sc, s7_pointer arg) {return((is_pair(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_pair_t(s7_scheme *sc, s7_pointer arg) {return((is_pair(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_pair_u(s7_scheme *sc, s7_pointer arg) {return((is_pair(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_pair_v(s7_scheme *sc, s7_pointer arg) {return((is_pair(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_keyword_s(s7_scheme *sc, s7_pointer arg) {return((is_symbol_and_keyword(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_vector_s(s7_scheme *sc, s7_pointer arg) {return((is_any_vector(lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_is_vector_t(s7_scheme *sc, s7_pointer arg) {return((is_any_vector(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} -static s7_pointer fx_is_proper_list_s(s7_scheme *sc, s7_pointer arg) {return((s7_is_proper_list(sc, lookup(sc, cadr(arg)))) ? sc->T : sc->F);} -static s7_pointer fx_not_s(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, lookup(sc, cadr(arg)))));} -static s7_pointer fx_not_t(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, t_lookup(sc, cadr(arg), arg))));} -static s7_pointer fx_not_o(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, o_lookup(sc, cadr(arg), arg))));} -static s7_pointer fx_not_is_pair_s(s7_scheme *sc, s7_pointer arg) {return((is_pair(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_pair_t(s7_scheme *sc, s7_pointer arg) {return((is_pair(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_pair_u(s7_scheme *sc, s7_pointer arg) {return((is_pair(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_pair_v(s7_scheme *sc, s7_pointer arg) {return((is_pair(v_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_null_s(s7_scheme *sc, s7_pointer arg) {return((is_null(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_null_t(s7_scheme *sc, s7_pointer arg) {return((is_null(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_null_u(s7_scheme *sc, s7_pointer arg) {return((is_null(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_symbol_s(s7_scheme *sc, s7_pointer arg) {return((is_symbol(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);} -static s7_pointer fx_not_is_symbol_t(s7_scheme *sc, s7_pointer arg) {return((is_symbol(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);} - -#define fx_c_sc_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, Lookup(sc, cadr(arg), arg)); \ - set_car(sc->t2_2, opt2_con(cdr(arg))); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_sc_any(fx_c_sc, s_lookup) -fx_c_sc_any(fx_c_tc, t_lookup) -fx_c_sc_any(fx_c_uc, u_lookup) /* few hits */ -fx_c_sc_any(fx_c_vc, v_lookup) -fx_c_sc_any(fx_c_oc, o_lookup) - - -static s7_pointer fx_c_sc_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_c_si_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), integer(opt2_con(cdr(arg)))));} -static s7_pointer fx_c_ti_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));} -static s7_pointer fx_c_ti_remainder(s7_scheme *sc, s7_pointer arg) {return(remainder_p_pi(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));} -static s7_pointer fx_c_tc_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg))));} -static s7_pointer fx_vector_ref_tc(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pi(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));} - /* tc happens a lot, but others almost never */ - -static s7_pointer fx_memq_sc(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_memq_sc_3(s7_scheme *sc, s7_pointer arg) {return(memq_3_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_memq_tc(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg))));} -static s7_pointer fx_leq_sc(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_lt_sc(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_gt_sc(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} -static s7_pointer fx_geq_sc(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));} - -#define fx_char_eq_sc_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer c = Lookup(sc, cadr(arg), arg); \ - if (c == opt2_con(cdr(arg))) return(sc->T); \ - if (is_character(c)) return(sc->F); \ - return(method_or_bust(sc, cadr(arg), sc->char_eq_symbol, cdr(arg), sc->type_names[T_CHARACTER], 1)); \ - } - -fx_char_eq_sc_any(fx_char_eq_sc, s_lookup) -fx_char_eq_sc_any(fx_char_eq_tc, t_lookup) - - -#define fx_c_cs_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, opt1_con(cdr(arg))); /* cadr(arg) or cadadr */ \ - set_car(sc->t2_2, Lookup(sc, opt2_sym(cdr(arg)), arg)); /* caddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_cs_any(fx_c_cs, s_lookup) -fx_c_cs_any(fx_c_ct, t_lookup) -fx_c_cs_any(fx_c_cu, u_lookup) - - -static s7_pointer fx_c_ct_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, opt1_con(cdr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg))); -} - -static s7_pointer fx_cons_cs(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_cons_ct(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} - - -#define fx_c_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ - set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(arg)), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ -} - -fx_c_ss_any(fx_c_ss, s_lookup, s_lookup) -fx_c_ss_any(fx_c_st, s_lookup, t_lookup) -fx_c_ss_any(fx_c_ts, t_lookup, s_lookup) -fx_c_ss_any(fx_c_tu, t_lookup, u_lookup) -fx_c_ss_any(fx_c_uv, u_lookup, v_lookup) -fx_c_ss_any(fx_c_tU, t_lookup, U_lookup) - -static s7_pointer fx_memq_ss(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_memq_tu(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_assq_ss(s7_scheme *sc, s7_pointer arg) {return(assq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_vref_ss(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_vref_st(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_vref_ts(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, t_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_vref_tu(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_vref_ot(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_vref_gt(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_string_ref_ss(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_cons_ss(s7_scheme *sc, s7_pointer arg) {return(cons(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_cons_st(s7_scheme *sc, s7_pointer arg) {return(cons(sc, s_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_cons_ts(s7_scheme *sc, s7_pointer arg) {return(cons(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_cons_tu(s7_scheme *sc, s7_pointer arg) {return(cons(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_cons_tU(s7_scheme *sc, s7_pointer arg) {return(cons(sc, t_lookup(sc, cadr(arg), arg), U_lookup(sc, caddr(arg), arg)));} -/* static s7_pointer fx_cons_Ts(s7_scheme *sc, s7_pointer arg) {return(cons(sc, T_lookup(sc, cadr(arg), arg), s_lookup(sc, caddr(arg), arg)));} */ - -#define fx_c_ss_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \ - } - -fx_c_ss_direct_any(fx_c_ss_direct, s_lookup, s_lookup) -fx_c_ss_direct_any(fx_c_ts_direct, t_lookup, s_lookup) -fx_c_ss_direct_any(fx_c_tu_direct, t_lookup, u_lookup) -fx_c_ss_direct_any(fx_c_st_direct, s_lookup, t_lookup) -fx_c_ss_direct_any(fx_c_gt_direct, g_lookup, t_lookup) -fx_c_ss_direct_any(fx_c_tU_direct, t_lookup, U_lookup) - -static s7_pointer fx_multiply_ss(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_multiply_ts(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -/* static s7_pointer fx_multiply_Ts(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, T_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} */ -static s7_pointer fx_multiply_fs(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg)), 2));} -static s7_pointer fx_multiply_sf(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_multiply_tf(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_multiply_si(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, cadr(arg)), integer(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_multiply_ui(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, u_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg))), 1));} -static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, opt2_sym(cdr(arg))), integer(cadr(arg)), 2));} -static s7_pointer fx_multiply_tu(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} - -static inline s7_pointer fx_sqr_1(s7_scheme *sc, s7_pointer x) -{ - if (is_t_real(x)) return(make_real(sc, real(x) * real(x))); - -#if WITH_GMP - return(multiply_p_pp(sc, x, x)); -#else - switch (type(x)) - { -#if HAVE_OVERFLOW_CHECKS - case T_INTEGER: - { - s7_int val; - if (multiply_overflow(integer(x), integer(x), &val)) - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer sqr overflow: (* %" ld64 " %" ld64 ")\n", integer(x), integer(x)); - return(make_real(sc, (long_double)integer(x) * (long_double)integer(x))); - } - return(make_integer(sc, val)); - } - case T_RATIO: - { - s7_int num, den; - if ((multiply_overflow(numerator(x), numerator(x), &num)) || - (multiply_overflow(denominator(x), denominator(x), &den))) - return(make_real(sc, fraction(x) * fraction(x))); - return(make_ratio_with_div_check(sc, sc->multiply_symbol, num, den)); - } -#else - case T_INTEGER: return(make_integer(sc, integer(x) * integer(x))); - case T_RATIO: return(make_ratio(sc, numerator(x) * numerator(x), denominator(x) * denominator(x))); -#endif - case T_REAL: return(make_real(sc, real(x) * real(x))); - case T_COMPLEX: return(s7_make_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x))); - default: return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, x, a_number_string, 1)); - } - return(x); -#endif -} - -static s7_pointer fx_sqr_s(s7_scheme *sc, s7_pointer arg) {return(fx_sqr_1(sc, lookup(sc, cadr(arg))));} -static s7_pointer fx_sqr_t(s7_scheme *sc, s7_pointer arg) {return(fx_sqr_1(sc, t_lookup(sc, cadr(arg), arg)));} - -static s7_pointer fx_add_sqr_sqr(s7_scheme *sc, s7_pointer arg) /* tbig -- need t case here */ -{ - sc->temp5 = fx_sqr_1(sc, lookup(sc, car(opt1_pair(cdr(arg))))); /* cadadr(arg) */ - return(add_p_pp(sc, sc->temp5, fx_sqr_1(sc, lookup(sc, car(opt3_pair(arg)))))); /* cadaddr(arg) */ -} - -static s7_pointer fx_c_s_sqr(s7_scheme *sc, s7_pointer arg) /* call */ -{ - set_car(sc->t2_1, lookup(sc, cadr(arg))); - set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt2_sym(cdr(arg))))); /* cadaddr(arg) */ - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_c_sqr(s7_scheme *sc, s7_pointer arg) /* fb */ -{ - set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt1_sym(cdr(arg))))); /* cadaddr(arg) */ - set_car(sc->t2_1, cadr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_geq_ss(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_geq_ts(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_geq_st(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_geq_us(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, u_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_geq_vs(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, v_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_geq_tT(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), T_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_geq_tu(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_geq_TU(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, T_lookup(sc, cadr(arg), arg), U_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_geq_to(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_geq_vo(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, v_lookup(sc, cadr(arg), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_geq_ot(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} - -static s7_pointer fx_gt_ss(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_gt_ts(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_gt_to(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_gt_tu(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_gt_ut(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, u_lookup(sc, cadr(arg), arg), t_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_gt_tg(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), global_value(opt2_sym(cdr(arg)))));} - -static s7_pointer fx_gt_tT(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = t_lookup(sc, cadr(arg), arg); - s7_pointer p2 = T_lookup(sc, caddr(arg), arg); - return(((is_t_integer(p1)) && (is_t_integer(p2))) ? make_boolean(sc, integer(p1) > integer(p2)) : gt_p_pp(sc, p1, p2)); -} - -#define fx_gt_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_integer(x)) return(make_boolean(sc, integer(x) > integer(opt2_con(cdr(arg))))); \ - if (is_t_real(x)) return(make_boolean(sc, real(x) > integer(opt2_con(cdr(arg))))); \ - return(g_greater_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_gt_si_any(fx_gt_si, s_lookup) -fx_gt_si_any(fx_gt_ti, t_lookup) -fx_gt_si_any(fx_gt_ui, u_lookup) - -static s7_pointer fx_leq_ss(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_leq_ts(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_leq_tu(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} - -#define fx_leq_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_integer(x)) return(make_boolean(sc, integer(x) <= integer(opt2_con(cdr(arg))))); \ - return(g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_leq_si_any(fx_leq_si, s_lookup) -fx_leq_si_any(fx_leq_ti, t_lookup) -fx_leq_si_any(fx_leq_ui, u_lookup) -fx_leq_si_any(fx_leq_vi, v_lookup) - -static s7_pointer fx_lt_ss(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_lt_sg(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), lookup_global(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_lt_tg(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup_global(sc, opt2_sym(cdr(arg)))));} - -static s7_pointer fx_lt_gsg(s7_scheme *sc, s7_pointer arg) /* gsg is much faster than sss */ -{ - s7_pointer v1 = lookup_global(sc, cadr(arg)); - s7_pointer v2 = lookup(sc, opt1_sym(cdr(arg))); /* caddr(arg) */ - s7_pointer v3 = lookup_global(sc, opt2_sym(cdr(arg))); /* cadddr(arg) */ - if ((is_t_integer(v1)) && (is_t_integer(v2)) && (is_t_integer(v3))) - return(make_boolean(sc, ((integer(v1) < integer(v2)) && (integer(v2) < integer(v3))))); - if (!is_real(v3)) - wrong_type_error_nr(sc, sc->lt_symbol, 3, v3, sc->type_names[T_REAL]); /* else (< 2 1 1+i) returns #f */ - return(make_boolean(sc, (lt_b_7pp(sc, v1, v2)) && (lt_b_7pp(sc, v2, v3)))); -} - -static s7_pointer fx_lt_ts(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_lt_tT(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), T_lookup(sc, opt2_sym(cdr(arg)), cadr(arg))));} -static s7_pointer fx_lt_tu(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_lt_tU(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), U_lookup(sc, caddr(arg), arg)));} -static s7_pointer fx_lt_ut(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, u_lookup(sc, cadr(arg), arg), t_lookup(sc, caddr(arg), arg)));} - -static s7_pointer fx_lt_tf(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_real(x)) return(make_boolean(sc, real(x) < real(opt2_con(cdr(arg))))); - return(g_less_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ -} - -#define fx_lt_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_integer(x)) return(make_boolean(sc, integer(x) < integer(opt2_con(cdr(arg))))); \ - return(g_less_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_lt_si_any(fx_lt_si, s_lookup) -fx_lt_si_any(fx_lt_ti, t_lookup) - -static s7_pointer fx_lt_t0(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 0)); - return(g_less_xi(sc, set_plist_2(sc, x, int_zero))); -} - -static s7_pointer fx_lt_t1(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 1)); - return(g_less_xi(sc, set_plist_2(sc, x, int_one))); -} - -static s7_pointer fx_lt_t2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 2)); - return(g_less_xi(sc, set_plist_2(sc, x, int_two))); -} - -static s7_pointer fx_geq_tf(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_real(x)) return(make_boolean(sc, real(x) >= real(opt2_con(cdr(arg))))); - return(g_geq_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ -} - -#define fx_geq_si_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup(sc, cadr(arg), arg); \ - if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= integer(opt2_con(cdr(arg))))); \ - return(g_geq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \ - } - -fx_geq_si_any(fx_geq_si, s_lookup) -fx_geq_si_any(fx_geq_ti, t_lookup) - -static s7_pointer fx_geq_t0(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, cadr(arg), arg); - if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= 0)); - return(g_geq_xi(sc, set_plist_2(sc, x, int_zero))); -} - -#define fx_num_eq_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup1(sc, cadr(arg), arg); \ - s7_pointer y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ - return(make_boolean(sc, ((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y))); \ - } - -fx_num_eq_ss_any(fx_num_eq_ss, s_lookup, s_lookup) -fx_num_eq_ss_any(fx_num_eq_ts, t_lookup, s_lookup) -fx_num_eq_ss_any(fx_num_eq_to, t_lookup, o_lookup) -fx_num_eq_ss_any(fx_num_eq_tg, t_lookup, g_lookup) -fx_num_eq_ss_any(fx_num_eq_tT, t_lookup, T_lookup) -fx_num_eq_ss_any(fx_num_eq_tu, t_lookup, u_lookup) -fx_num_eq_ss_any(fx_num_eq_tv, t_lookup, v_lookup) -fx_num_eq_ss_any(fx_num_eq_ut, u_lookup, t_lookup) -fx_num_eq_ss_any(fx_num_eq_us, u_lookup, s_lookup) -fx_num_eq_ss_any(fx_num_eq_vs, v_lookup, s_lookup) -fx_num_eq_ss_any(fx_num_eq_uU, u_lookup, U_lookup) -fx_num_eq_ss_any(fx_num_eq_vU, v_lookup, U_lookup) - - -#define fx_is_eq_ss_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer x = Lookup1(sc, cadr(arg), arg); \ - s7_pointer y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ - return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); \ - } - -fx_is_eq_ss_any(fx_is_eq_ss, s_lookup, s_lookup) -fx_is_eq_ss_any(fx_is_eq_ts, t_lookup, s_lookup) -fx_is_eq_ss_any(fx_is_eq_tu, t_lookup, u_lookup) -fx_is_eq_ss_any(fx_is_eq_to, t_lookup, o_lookup) - - -static s7_pointer fx_not_is_eq_ss(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = lookup(sc, opt3_sym(arg)); - s7_pointer y = lookup(sc, opt1_sym(cdr(arg))); - return(make_boolean(sc, (x != y) && ((!is_unspecified(x)) || (!is_unspecified(y))))); -} - -static s7_pointer fx_not_is_eq_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = lookup(sc, opt2_sym(cdr(arg))); - s7_pointer y = opt3_con(cdr(arg)); - return(make_boolean(sc, (x != y) && ((!is_unspecified(x)) || (!is_unspecified(y))))); -} - -static s7_pointer x_hash_table_ref_ss(s7_scheme *sc, s7_pointer table, s7_pointer key) -{ - return((is_hash_table(table)) ? hash_entry_value((*hash_table_checker(table))(sc, table, key)) : g_hash_table_ref(sc, set_plist_2(sc, table, key))); -} - -static s7_pointer fx_hash_table_ref_ss(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));} -static s7_pointer fx_hash_table_ref_st(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));} -static s7_pointer fx_hash_table_ref_TV(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, T_lookup(sc, cadr(arg), arg), V_lookup(sc, opt2_sym(cdr(arg)), arg)));} - -static s7_pointer fx_hash_table_ref_car(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer table = lookup(sc, cadr(arg)); - s7_pointer lst = lookup(sc, opt2_sym(cdr(arg))); - if (!is_pair(lst)) - sole_arg_wrong_type_error_nr(sc, sc->car_symbol, lst, sc->type_names[T_PAIR]); - return((is_hash_table(table)) ? hash_entry_value((*hash_table_checker(table))(sc, table, car(lst))) : g_hash_table_ref(sc, set_plist_2(sc, table, car(lst)))); -} - - -static inline s7_pointer fx_hash_table_increment_1(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer arg) -{ - hash_entry_t *val; - if (!is_hash_table(table)) - return(mutable_method_or_bust_ppp(sc, table, sc->hash_table_set_symbol, table, key, fx_call(sc, cdddr(arg)), sc->type_names[T_HASH_TABLE], 1)); - val = (*hash_table_checker(table))(sc, table, key); - if (val != sc->unentry) - { - if (!is_t_integer(hash_entry_value(val))) - sole_arg_wrong_type_error_nr(sc, sc->add_symbol, cadddr(arg), sc->type_names[T_INTEGER]); - hash_entry_set_value(val, make_integer(sc, integer(hash_entry_value(val)) + 1)); - return(hash_entry_value(val)); - } - s7_hash_table_set(sc, table, key, int_one); - return(int_one); -} - -static s7_pointer fx_hash_table_increment(s7_scheme *sc, s7_pointer arg) -{ - return(fx_hash_table_increment_1(sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)), arg)); -} - - -static s7_pointer fx_lint_let_ref_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer sym; - s7_pointer lt = s_lookup(sc, opt2_sym(arg), arg); /* (var-ref local-var) -> local-var, opt_sym2(arg) == cadr(arg) */ - if (!is_pair(lt)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~S should be (cons name let), but it is ~S", 42), opt2_sym(arg), lt)); - lt = cdr(lt); - if (!is_let(lt)) wrong_type_error_nr(sc, sc->let_ref_symbol, 1, lt, a_let_string); - sym = opt2_sym(cdr(arg)); /* (let-ref (cdr v) 'ref) -> ref == opt3_sym(cdar(closure_body(opt1_lambda(arg)))); */ - for (s7_pointer y = let_slots(lt); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - return(slot_value(y)); - return(lint_let_ref_p_pp(sc, let_outlet(lt), sym)); -} - -static s7_pointer fx_memq_sq_2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = opt2_con(cdr(arg)); - s7_pointer obj = lookup(sc, cadr(arg)); - if (obj == car(p)) return(p); - return((obj == cadr(p)) ? cdr(p) : sc->F); -} - -static s7_pointer fx_c_cq(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, with_list_t2(cadr(arg), opt2_con(cdr(arg)))));} - -#define fx_c_sss_any(Name, Lookup1, Lookup2, Lookup3) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \ - set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \ - set_car(sc->t3_3, Lookup3(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_sss_any(fx_c_sss, s_lookup, s_lookup, s_lookup) -fx_c_sss_any(fx_c_sts, s_lookup, t_lookup, s_lookup) -fx_c_sss_any(fx_c_tus, t_lookup, u_lookup, s_lookup) -fx_c_sss_any(fx_c_tuv, t_lookup, u_lookup, v_lookup) - - -static s7_pointer fx_c_sss_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_sym(cdr(arg))), lookup(sc, opt2_sym(cdr(arg))))); -} - -static s7_pointer fx_c_tuv_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt1_sym(cdr(arg)), arg), v_lookup(sc, opt2_sym(cdr(arg)), arg))); -} - -static s7_pointer fx_vset_sts(s7_scheme *sc, s7_pointer arg) -{ - return(vector_set_p_ppp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt1_sym(cdr(arg)), arg), lookup(sc, opt2_sym(cdr(arg))))); -} - -static s7_pointer fx_vset_oto(s7_scheme *sc, s7_pointer arg) -{ - return(vector_set_p_ppp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt1_sym(cdr(arg)), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg))); -} - -#define fx_c_scs_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \ - set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \ - set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_scs_any(fx_c_scs, s_lookup, s_lookup) -fx_c_scs_any(fx_c_tcs, t_lookup, s_lookup) - - -#define fx_c_scs_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), opt1_con(cdr(arg)), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \ - } - -fx_c_scs_direct_any(fx_c_scs_direct, s_lookup, s_lookup) -fx_c_scs_direct_any(fx_c_tcu_direct, t_lookup, u_lookup) -fx_c_scs_direct_any(fx_c_tcs_direct, t_lookup, s_lookup) -fx_c_scs_direct_any(fx_c_TcU_direct, T_lookup, U_lookup) - - -static s7_pointer fx_c_scc(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */ - set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ - return(fn_proc(arg)(sc, sc->t3_1)); -} - -#define fx_c_css_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_2, Lookup1(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \ - set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \ - set_car(sc->t3_1, cadr(arg)); \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_css_any(fx_c_css, s_lookup, s_lookup) -fx_c_css_any(fx_c_ctv, t_lookup, v_lookup) - -static s7_pointer fx_c_csc(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_2, lookup(sc, opt1_sym(cdr(arg)))); /* caddr(arg) */ - set_car(sc->t3_1, opt3_con(cdr(arg))); /* cadr(arg) or maybe cadadr if quoted? */ - set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_ccs(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_3, lookup(sc, opt1_sym(cdr(arg)))); /* cadddr(arg) */ - set_car(sc->t3_1, cadr(arg)); /* maybe opt3_con? */ - set_car(sc->t3_2, opt2_con(cdr(arg))); /* caddr(arg) */ - return(fn_proc(arg)(sc, sc->t3_1)); -} - -#define fx_c_ssc_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \ - set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \ - set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_ssc_any(fx_c_ssc, s_lookup, s_lookup) -fx_c_ssc_any(fx_c_tuc, t_lookup, u_lookup) - -static s7_pointer fx_c_opncq(s7_scheme *sc, s7_pointer arg) -{ - return(fn_proc(arg)(sc, with_list_t1(fc_call(sc, cadr(arg))))); -} - -#define fx_c_opsq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t1_1, fn_proc(largs)(sc, with_list_t1(Lookup(sc, cadr(largs), largs)))); \ - return(fn_proc(arg)(sc, sc->t1_1)); \ - } - -fx_c_opsq_any(fx_c_opsq, s_lookup) -fx_c_opsq_any(fx_c_optq, t_lookup) - -static s7_pointer fx_c_optq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)))); -} - -#define fx_c_car_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - set_car(sc->t1_1, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ - return(fn_proc(arg)(sc, sc->t1_1)); \ - } - -fx_c_car_s_any(fx_c_car_s, s_lookup) -fx_c_car_s_any(fx_c_car_t, t_lookup) -fx_c_car_s_any(fx_c_car_u, u_lookup) - -#define fx_c_cdr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, opt2_sym(cdr(arg)), arg); \ - set_car(sc->t1_1, (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \ - return(fn_proc(arg)(sc, sc->t1_1)); \ - } - -fx_c_cdr_s_any(fx_c_cdr_s, s_lookup) -fx_c_cdr_s_any(fx_c_cdr_t, t_lookup) - -#define fx_is_type_opsq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t1_1, Lookup(sc, opt2_sym(cdr(arg)), arg)); \ - return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(fn_proc(cadr(arg))(sc, sc->t1_1)))); \ - } - -fx_is_type_opsq_any(fx_is_type_opsq, s_lookup) -fx_is_type_opsq_any(fx_is_type_optq, t_lookup) - -static s7_pointer fx_is_type_car_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, opt2_sym(cdr(arg))); - return(make_boolean(sc, (is_pair(val)) ? - ((uint8_t)(opt3_byte(cdr(arg))) == type(car(val))) : - ((uint8_t)(opt3_byte(cdr(arg))) == type(g_car(sc, set_plist_1(sc, val)))))); -} - -static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer func, val = t_lookup(sc, opt2_sym(cdr(arg)), arg); - if (is_pair(val)) - return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(car(val)))); - if (!has_active_methods(sc, val)) /* this verbosity saves 1/3 total compute time (overhead!) */ - wrong_type_error_nr(sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]); - func = find_method_with_let(sc, val, sc->car_symbol); - if (func == sc->undefined) - wrong_type_error_nr(sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]); - return(make_boolean(sc, type(s7_apply_function(sc, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); -} - -static s7_pointer fx_eq_weak1_type_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer func, val = lookup(sc, opt2_sym(cdr(arg))); - if (is_c_pointer(val)) /* (let? (c-pointer-weak1 val)) etc */ - return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(c_pointer_weak1(val)))); - if (!has_active_methods(sc, val)) /* calling g_c_pointer_weak1 here instead is much slower, error by itself is much faster! splitting out does not help */ - wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, 1, val, sc->type_names[T_C_POINTER]); - func = find_method_with_let(sc, val, sc->c_pointer_weak1_symbol); - if (func == sc->undefined) - wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, 1, val, sc->type_names[T_C_POINTER]); - return(make_boolean(sc, type(s7_apply_function(sc, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg)))); -} - -#define fx_not_opsq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t1_1, Lookup(sc, cadr(largs), arg)); \ - return((fn_proc(largs)(sc, sc->t1_1) == sc->F) ? sc->T : sc->F); \ - } - -fx_not_opsq_any(fx_not_opsq, s_lookup) -fx_not_opsq_any(fx_not_optq, t_lookup) - -static s7_pointer fx_not_car_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* cadadr */ - s7_pointer res = (is_pair(p)) ? car(p) : g_car(sc, set_plist_1(sc, p)); - return((res == sc->F) ? sc->T : sc->F); -} - - -#define fx_c_opssq_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, Lookup1(sc, opt3_sym(arg), arg)); \ - set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* or opt2_sym */ \ - return(fn_proc(arg)(sc, with_list_t1(fn_proc(cadr(arg))(sc, sc->t2_1)))); \ - } - -fx_c_opssq_any(fx_c_opssq, s_lookup, s_lookup) -fx_c_opssq_any(fx_c_optuq, t_lookup, u_lookup) -fx_c_opssq_any(fx_c_opstq, s_lookup, t_lookup) - - -#define fx_c_opssq_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, \ - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt3_sym(arg), arg), Lookup2(sc, opt1_sym(cdr(arg)), arg)))); \ - } - -fx_c_opssq_direct_any(fx_c_opssq_direct, s_lookup, s_lookup) -fx_c_opssq_direct_any(fx_c_opstq_direct, s_lookup, t_lookup) -fx_c_opssq_direct_any(fx_c_optuq_direct, t_lookup, u_lookup) - - -#define fx_not_opssq_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer larg = cadr(arg); \ - set_car(sc->t2_1, Lookup1(sc, cadr(larg), larg)); \ - set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(larg)), larg)); \ - return((fn_proc(larg)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); \ - } - -fx_not_opssq_any(fx_not_opssq, s_lookup, s_lookup) -fx_not_opssq_any(fx_not_oputq, u_lookup, t_lookup) - - -static s7_pointer fx_not_lt_ut(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer y = u_lookup(sc, opt3_sym(arg), arg); - s7_pointer x = t_lookup(sc, opt1_sym(cdr(arg)), arg); - return(make_boolean(sc, ((is_t_integer(x)) && (is_t_integer(y))) ? (integer(y) >= integer(x)) : geq_b_7pp(sc, y, x))); -} - -static s7_pointer fx_is_zero_remainder_car(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer t = t_lookup(sc, opt1_sym(cdr(arg)), arg); - s7_pointer u = u_lookup(sc, opt3_sym(arg), arg); - u = (is_pair(u)) ? car(u) : g_car(sc, set_plist_1(sc, u)); /* g_car much less overhead than car_p_p or simple_error(?) */ - if ((is_t_integer(u)) && (is_t_integer(t))) - return(make_boolean(sc, remainder_i_7ii(sc, integer(u), integer(t)) == 0)); - return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, u, t)))); -} - -static s7_pointer fx_is_zero_remainder_o(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer s = o_lookup(sc, opt3_sym(arg), arg); - s7_pointer t = t_lookup(sc, opt1_sym(cdr(arg)), arg); - if ((is_t_integer(s)) && (is_t_integer(t))) - return(make_boolean(sc, remainder_i_7ii(sc, integer(s), integer(t)) == 0)); - return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, s, t)))); -} - -#define fx_c_opscq_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t2_1, Lookup(sc, cadr(largs), largs)); \ - set_car(sc->t2_2, opt2_con(cdr(largs))); \ - return(fn_proc(arg)(sc, with_list_t1(fn_proc(largs)(sc, sc->t2_1)))); \ - } - -fx_c_opscq_any(fx_c_opscq, s_lookup) -fx_c_opscq_any(fx_c_optcq, t_lookup) - -static s7_pointer fx_is_zero_remainder_ti(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer larg = cdadr(arg); - s7_pointer t = t_lookup(sc, car(larg), arg); - s7_int u = integer(cadr(larg)); - if (is_t_integer(t)) return(make_boolean(sc, (integer(t) % u) == 0)); - return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pi(sc, t, u)))); -} - -static s7_pointer fx_not_opscq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, opt2_con(cdr(largs))); - return((fn_proc(largs)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); -} - -static s7_pointer fx_c_opcsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_2, lookup(sc, caddr(largs))); - set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ - return(fn_proc(arg)(sc, with_list_t1(fn_proc(largs)(sc, sc->t2_1)))); -} - -static s7_pointer fx_c_opcsq_c(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_2, lookup(sc, caddr(largs))); - set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_2, caddr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opcsq_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_2, lookup(sc, caddr(largs))); - set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_2, lookup(sc, caddr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opssq_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_2, lookup(sc, caddr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opssq_s_direct(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), - lookup(sc, caddr(arg)))); -} - -static s7_pointer fx_add_mul_opssq_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - s7_pointer a = lookup(sc, car(largs)); - s7_pointer b = lookup(sc, opt2_sym(largs)); - s7_pointer c = lookup(sc, caddr(arg)); - if ((is_t_integer(a)) && (is_t_integer(b)) && (is_t_integer(c))) -#if HAVE_OVERFLOW_CHECKS - { - s7_int val; - if ((multiply_overflow(integer(a), integer(b), &val)) || - (add_overflow(val, integer(c), &val))) - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply/add overflow: (+ (* %" ld64 " %" ld64 ") %" ld64 ")\n", integer(a), integer(b), integer(c)); - return(make_real(sc, ((long_double)integer(a) * (long_double)integer(b)) + (long_double)integer(c))); - } - return(make_integer(sc, val)); - } -#else - return(make_integer(sc, (integer(a) * integer(b)) + integer(c))); -#endif - return(add_p_pp(sc, multiply_p_pp(sc, a, b), c)); -} - -static s7_pointer fx_add_vref_s(s7_scheme *sc, s7_pointer arg) -{ - return(add_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))), lookup(sc, caddr(arg)))); -} - -static s7_pointer fx_add_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(add_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_subtract_vref_s(s7_scheme *sc, s7_pointer arg) -{ - return(subtract_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))), lookup(sc, caddr(arg)))); -} - -static s7_pointer fx_subtract_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(subtract_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_multiply_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(multiply_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_cons_cons_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - return(cons_unchecked(sc, cons(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg)))); -} - -#define fx_add_sqr_s_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p1 = Lookup(sc, car(opt3_pair(arg)), arg); \ - s7_pointer p3 = lookup(sc, caddr(arg)); \ - if ((is_t_complex(p1)) && (is_t_complex(p3))) \ - { \ - s7_double r = real_part(p1), i = imag_part(p1); \ - return(make_complex(sc, real_part(p3) + r * r - i * i, imag_part(p3) + 2.0 * r * i)); \ - } \ - return(add_p_pp(sc, fx_sqr_1(sc, p1), p3)); \ - } - -fx_add_sqr_s_any(fx_add_sqr_s, s_lookup) -fx_add_sqr_s_any(fx_add_sqr_T, T_lookup) - -static s7_pointer fx_add_sub_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - s7_pointer p1 = lookup(sc, car(largs)); - s7_pointer p2 = lookup(sc, opt2_sym(largs)); - s7_pointer p3 = lookup(sc, caddr(arg)); - if ((is_t_real(p1)) && (is_t_real(p2)) && (is_t_real(p3))) return(make_real(sc, real(p3) + real(p1) - real(p2))); - return(add_p_pp(sc, subtract_p_pp(sc, p1, p2), p3)); -} - -static s7_pointer fx_add_sub_tu_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = t_lookup(sc, car(cdadr(arg)), arg); - s7_pointer p2 = u_lookup(sc, cadr(cdadr(arg)), arg); - s7_pointer p3 = lookup(sc, caddr(arg)); - if ((is_t_real(p1)) && (is_t_real(p2)) && (is_t_real(p3))) return(make_real(sc, real(p3) + real(p1) - real(p2))); - return(add_p_pp(sc, subtract_p_pp(sc, p1, p2), p3)); -} - -static s7_pointer fx_gt_add_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */ - s7_pointer x1 = lookup(sc, car(largs)); - s7_pointer x2 = lookup(sc, opt2_sym(largs)); - s7_pointer x3 = lookup(sc, caddr(arg)); - if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) return(make_boolean(sc, (real(x1) + real(x2)) > real(x3))); - return(gt_p_pp(sc, add_p_pp(sc, x1, x2), x3)); -} - -static s7_pointer fx_gt_add_tu_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x1 = t_lookup(sc, car(cdadr(arg)), arg); - s7_pointer x2 = u_lookup(sc, cadr(cdadr(arg)), arg); - s7_pointer x3 = lookup(sc, caddr(arg)); - if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) return(make_boolean(sc, (real(x1) + real(x2)) > real(x3))); - return(gt_p_pp(sc, add_p_pp(sc, x1, x2), x3)); -} - -static s7_pointer fx_gt_vref_s(s7_scheme *sc, s7_pointer arg) -{ - return(gt_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))), lookup(sc, caddr(arg)))); -} - -static s7_pointer fx_geq_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(geq_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_is_eq_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(make_boolean(sc, lookup(sc, cadr(arg)) == vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_href_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(hash_table_ref_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_lref_s_vref(s7_scheme *sc, s7_pointer arg) -{ - return(let_ref(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_vref_s_add(s7_scheme *sc, s7_pointer arg) -{ - return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), add_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static inline s7_pointer fx_vref_vref_3(s7_scheme *sc, s7_pointer v1, s7_pointer p1, s7_pointer p2) -{ - if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) - { - s7_int i1 = integer(p1), i2 = integer(p2); - if ((i1 >= 0) && (i2 >= 0) && (i1 < vector_length(v1))) - { - s7_pointer v2 = vector_element(v1, i1); - if ((is_normal_vector(v2)) && (vector_rank(v2) == 1) && (i2 < vector_length(v2))) - return(vector_element(v2, i2)); - }} - return(vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p1), p2)); -} - -#define fx_vref_vref_ss_s_any(Name, Lookup1, Lookup2, Lookup3) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(fx_vref_vref_3(sc, Lookup1(sc, car(opt3_pair(arg)), arg), Lookup2(sc, opt2_sym(opt3_pair(arg)), arg), Lookup3(sc, caddr(arg), arg))); \ - } - -fx_vref_vref_ss_s_any(fx_vref_vref_ss_s, s_lookup, s_lookup, s_lookup) -fx_vref_vref_ss_s_any(fx_vref_vref_gs_t, g_lookup, s_lookup, t_lookup) -fx_vref_vref_ss_s_any(fx_vref_vref_go_t, g_lookup, o_lookup, t_lookup) -fx_vref_vref_ss_s_any(fx_vref_vref_tu_v, t_lookup, u_lookup, v_lookup) - -static s7_pointer fx_vref_vref_3_no_let(s7_scheme *sc, s7_pointer code) /* out one level from vref_vref_tu_v */ -{ - return(fx_vref_vref_3(sc, lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code)))); -} - -static s7_pointer fx_c_opscq_c(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, opt2_con(cdr(largs))); - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_2, caddr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -#define fx_c_opssq_c_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t2_1, Lookup1(sc, cadr(largs), largs)); \ - set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(largs)), largs)); \ - set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); \ - set_car(sc->t2_2, opt3_con(cdr(arg))); /* caddr */ \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_opssq_c_any(fx_c_opssq_c, s_lookup, s_lookup) -fx_c_opssq_c_any(fx_c_opstq_c, s_lookup, t_lookup) - - -static s7_pointer fx_c_opstq_c_direct(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cadr(arg); - return(((s7_p_pp_t)opt3_direct(arg))(sc, fn_proc(largs)(sc, set_plist_2(sc, lookup(sc, cadr(largs)), t_lookup(sc, caddr(largs), arg))), opt3_con(cdr(arg)))); -} - -static s7_pointer fx_is_eq_vref_opotq_c(s7_scheme *sc, s7_pointer arg) /* experiment, (eqv? <> char) is <>==char without error checks? */ -{ - s7_pointer largs = cdadr(arg); - return(make_boolean(sc, vector_ref_p_pp(sc, o_lookup(sc, car(largs), largs), t_lookup(sc, cadr(largs), arg)) == opt3_con(cdr(arg)))); -} - -#define fx_c_opsq_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = cadr(arg); \ - set_car(sc->t2_1, fn_proc(largs)(sc, with_list_t1(Lookup1(sc, cadr(largs), arg)))); /* also opt1_sym(cdr(arg)) */ \ - set_car(sc->t2_2, Lookup2(sc, opt3_sym(arg), arg)); /* caddr(arg) */ \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_opsq_s_any(fx_c_opsq_s, s_lookup, s_lookup) -fx_c_opsq_s_any(fx_c_optq_s, t_lookup, s_lookup) -fx_c_opsq_s_any(fx_c_opuq_t, u_lookup, t_lookup) - - -#define fx_c_opsq_s_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, \ - ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt1_sym(cdr(arg)), arg)), \ - Lookup2(sc, opt3_sym(arg), arg))); \ - } - -fx_c_opsq_s_direct_any(fx_c_opsq_s_direct, s_lookup, s_lookup) -fx_c_opsq_s_direct_any(fx_c_optq_s_direct, t_lookup, s_lookup) -fx_c_opsq_s_direct_any(fx_c_opuq_t_direct, u_lookup, t_lookup) - -#define fx_cons_car_s_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p = Lookup1(sc, opt1_sym(cdr(arg)), arg); \ - if (is_pair(p)) return(cons(sc, car(p), Lookup2(sc, opt3_sym(arg), arg))); \ - return(cons(sc, car_p_p(sc, p), Lookup2(sc, opt3_sym(arg), arg))); \ - } - -fx_cons_car_s_s_any(fx_cons_car_s_s, s_lookup, s_lookup) -fx_cons_car_s_s_any(fx_cons_car_t_s, t_lookup, s_lookup) -fx_cons_car_s_s_any(fx_cons_car_t_v, t_lookup, v_lookup) -fx_cons_car_s_s_any(fx_cons_car_u_t, u_lookup, t_lookup) - - -static s7_pointer fx_cons_opuq_t(s7_scheme *sc, s7_pointer arg) -{ - return(cons(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, u_lookup(sc, opt1_sym(cdr(arg)), arg)), t_lookup(sc, opt3_sym(arg), arg))); -} - -#define fx_c_opsq_cs_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_1, fn_proc(cadr(arg))(sc, with_list_t1(Lookup1(sc, opt3_sym(cdr(arg)), arg)))); /* cadadr(arg); */ \ - set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadaddr(arg) */ \ - set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg); */ \ - return(fn_proc(arg)(sc, sc->t3_1)); \ - } - -fx_c_opsq_cs_any(fx_c_opsq_cs, s_lookup, s_lookup) -fx_c_opsq_cs_any(fx_c_optq_cu, t_lookup, u_lookup) - - -#define fx_c_opsq_c_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, fn_proc(cadr(arg))(sc, with_list_t1(Lookup(sc, opt1_sym(cdr(arg)), arg)))); /* cadadr */ \ - set_car(sc->t2_2, opt2_con(cdr(arg))); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_opsq_c_any(fx_c_opsq_c, s_lookup) -fx_c_opsq_c_any(fx_c_optq_c, t_lookup) - - -static s7_pointer fx_c_optq_c_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), opt2_con(cdr(arg)))); -} - -static s7_pointer fx_c_optq_i_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_ii_t)opt3_direct(arg))(sc, ((s7_i_7p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), integer(opt2_con(cdr(arg))))); -} - -static s7_pointer fx_memq_car_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = opt2_con(cdr(arg)); - s7_pointer obj = lookup(sc, opt1_sym(cdr(arg))); - obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); - while (true) LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - return(sc->F); -} - -static s7_pointer fx_memq_car_s_2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = opt2_con(cdr(arg)); - s7_pointer obj = lookup(sc, opt1_sym(cdr(arg))); - obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj)); - if (obj == car(x)) return(x); - return((obj == cadr(x)) ? cdr(x) : sc->F); -} - -static s7_pointer fx_c_s_opssq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t2(lookup(sc, cadr(largs)), lookup(sc, opt2_sym(cdr(largs)))))); - set_car(sc->t2_1, lookup(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -#define fx_c_s_opssq_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = opt3_pair(arg); /* cdaddr(arg) */ \ - arg = cdr(arg); \ - return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), \ - ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), Lookup2(sc, opt2_sym(largs), largs)))); \ - } - -fx_c_s_opssq_direct_any(fx_c_s_opssq_direct, s_lookup, s_lookup) -fx_c_s_opssq_direct_any(fx_c_s_opstq_direct, s_lookup, t_lookup) -fx_c_s_opssq_direct_any(fx_c_t_opsuq_direct, t_lookup, u_lookup) - -static s7_pointer fx_vref_g_vref_gs(s7_scheme *sc, s7_pointer arg) -{ - return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), - vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); -} - -static s7_pointer fx_vref_g_vref_gt(s7_scheme *sc, s7_pointer arg) -{ - return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), - vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), t_lookup(sc, opt2_sym(opt3_pair(arg)), arg)))); -} - -static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t2(lookup(sc, cadr(largs)), lookup(sc, opt2_sym(cdr(largs)))))); - set_car(sc->t2_1, cadr(arg)); /* currently ( 'a ) goes to safe_c_ca so this works by inadvertence */ - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_c_opssq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, cadr(arg), /* see above */ - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), lookup(sc, opt1_sym(cdr(arg)))))); -} - -static s7_pointer fx_c_nc_opssq_direct(s7_scheme *sc, s7_pointer arg) /* clm2xen (* 1.0 (oscil g2 x2)) */ -{ - s7_double x2 = ((s7_d_pd_t)opt3_direct(cdr(arg)))(lookup(sc, opt3_sym(arg)), real_to_double(sc, lookup(sc, opt1_sym(cdr(arg))), __func__)); - return(((s7_p_dd_t)opt2_direct(cdr(arg)))(sc, real_to_double(sc, cadr(arg), __func__), x2)); -} - -static s7_pointer fx_multiply_c_opssq(s7_scheme *sc, s7_pointer arg) /* (* c=float (* x1 x2))! */ -{ - s7_pointer x1 = lookup(sc, opt3_sym(arg)); - s7_pointer x2 = lookup(sc, opt1_sym(cdr(arg))); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(cadr(arg)) * real(x1) * real(x2))); - return(multiply_p_pp(sc, cadr(arg), multiply_p_pp(sc, x1, x2))); -} - -#define fx_c_s_opscq_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = caddr(arg); \ - set_car(sc->t2_1, Lookup2(sc, cadr(largs), arg)); \ - set_car(sc->t2_2, opt2_con(cdr(largs))); \ - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); \ - set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_s_opscq_any(fx_c_s_opscq, s_lookup, s_lookup) -fx_c_s_opscq_any(fx_c_u_optcq, u_lookup, t_lookup) -/* also fx_c_T_optcq */ - -static s7_pointer fx_c_s_opscq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), opt1_con(cdr(arg))))); -} - -static s7_pointer fx_c_s_opsiq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), - ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), integer(opt1_con(cdr(arg)))))); -} - -static s7_pointer fx_c_u_optiq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, u_lookup(sc, cadr(arg), arg), - ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt3_sym(arg), arg), integer(opt1_con(cdr(arg)))))); -} - -static s7_pointer fx_c_t_opoiq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), - ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, o_lookup(sc, opt3_sym(arg), arg), integer(opt1_con(cdr(arg)))))); -} - -static s7_pointer fx_vref_p1(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer i = lookup(sc, opt3_sym(arg)); - s7_pointer v = lookup(sc, cadr(arg)); - if ((is_t_integer(i)) && (is_normal_vector(v)) && (vector_rank(v) == 1)) - { - s7_int index = integer(i) + 1; - if ((index >= 0) && (vector_length(v) > index)) - return(vector_element(v, index)); - } - return(vector_ref_p_pp(sc, v, g_add_xi(sc, i, 1, 2))); -} - -static s7_pointer fx_num_eq_add_s_si(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer i1 = lookup(sc, cadr(arg)); - s7_pointer i2 = lookup(sc, opt3_sym(arg)); - if ((is_t_integer(i1)) && (is_t_integer(i2))) - return(make_boolean(sc, integer(i1) == (integer(i2) + integer(opt1_con(cdr(arg)))))); - return(make_boolean(sc, num_eq_b_7pp(sc, i1, g_add_xi(sc, i2, integer(opt1_con(cdr(arg))), 2)))); -} - -static s7_pointer fx_num_eq_subtract_s_si(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer i1 = lookup(sc, cadr(arg)); - s7_pointer i2 = lookup(sc, opt3_sym(arg)); - if ((is_t_integer(i1)) && (is_t_integer(i2))) - return(make_boolean(sc, integer(i1) == (integer(i2) - integer(opt1_con(cdr(arg)))))); - return(make_boolean(sc, num_eq_b_7pp(sc, i1, g_sub_xi(sc, i2, integer(opt1_con(cdr(arg))))))); -} - -#define fx_c_t_opscq_direct_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), \ - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), opt1_con(cdr(arg))))); \ - } - -fx_c_t_opscq_direct_any(fx_c_t_opscq_direct, s_lookup) -fx_c_t_opscq_direct_any(fx_c_t_opucq_direct, u_lookup) - - -static s7_pointer fx_c_s_opsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs))))); - set_car(sc->t2_1, lookup(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -#define fx_c_s_opsq_direct_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - arg = cdr(arg); \ - return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), ((s7_p_p_t)opt3_direct(arg))(sc, Lookup2(sc, opt1_sym(arg), arg)))); /* cadadr */ \ - } - -fx_c_s_opsq_direct_any(fx_c_s_opsq_direct, s_lookup, s_lookup) -fx_c_s_opsq_direct_any(fx_c_t_opsq_direct, t_lookup, s_lookup) -fx_c_s_opsq_direct_any(fx_c_t_opuq_direct, t_lookup, u_lookup) -fx_c_s_opsq_direct_any(fx_c_u_opvq_direct, u_lookup, v_lookup) - -#define fx_c_s_car_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ - set_car(sc->t2_2, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ - set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_s_car_s_any(fx_c_s_car_s, s_lookup, s_lookup) -fx_c_s_car_s_any(fx_c_s_car_t, s_lookup, t_lookup) -fx_c_s_car_s_any(fx_c_t_car_u, t_lookup, u_lookup) -fx_c_s_car_s_any(fx_c_t_car_v, t_lookup, v_lookup) - - -#define fx_add_s_car_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val1 = Lookup1(sc, cadr(arg), arg); \ - s7_pointer val2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ - val2 = (is_pair(val2)) ? car(val2) : g_car(sc, set_plist_1(sc, val2)); \ - return(((is_t_integer(val1)) && (is_t_integer(val2))) ? make_integer(sc, integer(val1) + integer(val2)) : add_p_pp(sc, val1, val2)); \ - } - -fx_add_s_car_s_any(fx_add_s_car_s, s_lookup, s_lookup) -fx_add_s_car_s_any(fx_add_u_car_t, u_lookup, t_lookup) -fx_add_s_car_s_any(fx_add_t_car_v, t_lookup, v_lookup) - - -static s7_pointer fx_cons_s_cdr_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, opt2_sym(cdr(arg))); - val = (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val)); - return(cons(sc, lookup(sc, cadr(arg)), val)); -} - -static s7_pointer fx_c_op_s_opsqq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer outer = cadr(arg); - s7_pointer args = caddr(outer); - set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(lookup(sc, cadr(args))))); - set_car(sc->t2_1, lookup(sc, cadr(outer))); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(outer)(sc, sc->t2_1)))); -} - -static s7_pointer fx_not_op_s_opsqq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer outer = cadr(arg); - s7_pointer args = caddr(outer); - set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(lookup(sc, cadr(args))))); - set_car(sc->t2_1, lookup(sc, cadr(outer))); - return(((fn_proc(outer)(sc, sc->t2_1)) == sc->F) ? sc->T : sc->F); -} - -static s7_pointer fx_c_op_opsq_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer outer = cadr(arg); - s7_pointer args = cadr(outer); - set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(lookup(sc, cadr(args))))); - set_car(sc->t2_2, lookup(sc, caddr(outer))); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(outer)(sc, sc->t2_1)))); -} - -static s7_pointer fx_not_op_optq_sq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer outer = cadr(arg); - s7_pointer args = cadr(outer); - set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(t_lookup(sc, cadr(args), arg)))); - set_car(sc->t2_2, lookup(sc, caddr(outer))); - return((fn_proc(outer)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); -} - -static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = opt3_pair(arg); /* caddr(arg); */ - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs))))); - set_car(sc->t2_1, cadr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_c_opsq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, cadr(arg), ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt1_sym(cdr(arg)))))); -} - -/* perhaps fx_c_c_opt|T|Vq_direct tlet/tmisc */ - -static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - gc_protect_via_stack(sc, fn_proc(car(largs))(sc, with_list_t1(lookup(sc, cadar(largs))))); - largs = cadr(largs); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs))))); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opsq_opsq_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt3_direct(arg))(sc, - ((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadadr(arg))), /* no free field in arg or cdr(arg) */ - ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt1_sym(cdr(arg)))))); /* cadaddr(arg) */ -} - -static s7_pointer fx_c_optq_optq_direct(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* cadadr and cadaddr */ - return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt2_direct(cdr(arg)))(sc, x), ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, x))); -} - -#define fx_car_s_car_s_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer p1 = Lookup1(sc, opt1_sym(cdr(arg)), arg); \ - s7_pointer p2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); /* cadaddr(arg) */ \ - return(((s7_p_pp_t)opt3_direct(arg))(sc, (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1)), \ - (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2)))); \ - } - -fx_car_s_car_s_any(fx_car_s_car_s, s_lookup, s_lookup) -fx_car_s_car_s_any(fx_car_t_car_u, t_lookup, u_lookup) - - -static s7_pointer fx_cdr_s_cdr_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = lookup(sc, opt1_sym(cdr(arg))); - s7_pointer p2 = lookup(sc, opt2_sym(cdr(arg))); /* cadaddr(arg) */ - return(((s7_p_pp_t)opt3_direct(arg))(sc, (is_pair(p1)) ? cdr(p1) : g_cdr(sc, set_plist_1(sc, p1)), - (is_pair(p2)) ? cdr(p2) : g_cdr(sc, set_plist_1(sc, p2)))); -} - -static s7_pointer fx_is_eq_car_car_tu(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = t_lookup(sc, opt1_sym(cdr(arg)), arg); - s7_pointer p2 = u_lookup(sc, opt2_sym(cdr(arg)), arg); - p1 = (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1)); - p2 = (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2)); - return(make_boolean(sc, (p1 == p2) || ((is_unspecified(p1)) && (is_unspecified(p2))))); -} - -static s7_pointer fx_c_opsq_opssq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - gc_protect_via_stack(sc, fn_proc(car(largs))(sc, with_list_t1(lookup(sc, cadar(largs))))); - largs = cadr(largs); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); /* caddr(largs) */ - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opsq_optuq_direct(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - return(((s7_p_pp_t)opt3_direct(arg))(sc, - ((s7_p_p_t)opt2_direct(largs))(sc, lookup(sc, cadar(largs))), - ((s7_p_pp_t)opt3_direct(largs))(sc, t_lookup(sc, opt2_sym(cdr(largs)), arg), u_lookup(sc, opt1_sym(largs), arg)))); -} - -static s7_pointer fx_num_eq_car_v_add_tu(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); - s7_pointer p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); - s7_pointer p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); - if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3))) - return(make_boolean(sc, integer(p1) == (integer(p2) + integer(p3)))); - return(make_boolean(sc, num_eq_b_7pp(sc, p1, add_p_pp(sc, p2, p3)))); -} - -static s7_pointer fx_num_eq_car_v_subtract_tu(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); - s7_pointer p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); - s7_pointer p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); - if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3))) - return(make_boolean(sc, integer(p1) == (integer(p2) - integer(p3)))); - return(make_boolean(sc, num_eq_b_7pp(sc, p1, subtract_p_pp(sc, p2, p3)))); -} - -static s7_pointer fx_c_opssq_opsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - set_car(sc->t2_1, lookup(sc, cadar(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs)))); - gc_protect_via_stack(sc, fn_proc(car(largs))(sc, sc->t2_1)); - largs = cadr(largs); - set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs))))); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opssq_opssq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = cdr(arg); - set_car(sc->t2_1, lookup(sc, cadar(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs)))); - gc_protect_via_stack(sc, fn_proc(car(largs))(sc, sc->t2_1)); - largs = cadr(largs); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_sub_mul_mul(s7_scheme *sc, s7_pointer arg) /* (- (* s1 s2) (* s3 s4)) */ -{ - s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */ - s7_pointer s1 = lookup(sc, car(a1)); - s7_pointer s2 = lookup(sc, cadr(a1)); - s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ /* here and elsewhere this should be GC safe -- opssq->* (no methods?) etc */ - s7_pointer s3 = lookup(sc, car(a2)); - s7_pointer s4 = lookup(sc, cadr(a2)); - if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) && (is_t_real(s4))) - return(make_real(sc, (real(s3) * real(s4)) - (real(s1) * real(s2)))); - sc->temp5 = multiply_p_pp(sc, s1, s2); - return(subtract_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->temp5)); -} - -static s7_pointer fx_add_mul_mul(s7_scheme *sc, s7_pointer arg) /* (+ (* s1 s2) (* s3 s4)) */ -{ - s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */ - s7_pointer s1 = lookup(sc, car(a1)); - s7_pointer s2 = lookup(sc, cadr(a1)); - s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ - s7_pointer s3 = lookup(sc, car(a2)); - s7_pointer s4 = lookup(sc, cadr(a2)); - if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) && (is_t_real(s4))) - return(make_real(sc, (real(s3) * real(s4)) + (real(s1) * real(s2)))); - sc->temp5 = multiply_p_pp(sc, s1, s2); - return(add_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->temp5)); -} - -static s7_pointer fx_mul_sub_sub(s7_scheme *sc, s7_pointer arg) /* (* (- s1 s2) (- s3 s4)) */ -{ - s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */ - s7_pointer s1 = lookup(sc, car(a1)); - s7_pointer s2 = lookup(sc, cadr(a1)); - s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ - s7_pointer s3 = lookup(sc, car(a2)); - s7_pointer s4 = lookup(sc, cadr(a2)); - if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) && (is_t_real(s4))) - return(make_real(sc, (real(s3) - real(s4)) * (real(s1) - real(s2)))); - sc->temp5 = subtract_p_pp(sc, s1, s2); - return(multiply_p_pp(sc, subtract_p_pp(sc, s3, s4), sc->temp5)); -} - -static s7_pointer fx_lt_sub2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */ - sc->temp5 = subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))); - a1 = opt1_pair(cdr(arg)); /* cdadr(arg) */ - return(lt_p_pp(sc, subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->temp5)); -} - -static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer a1 = cdadr(arg); - s7_pointer v1 = lookup(sc, car(a1)); - s7_pointer p1 = lookup(sc, cadr(a1)); - s7_pointer p2 = lookup(sc, opt3_sym(arg)); /* caddaddr(arg)); */ - if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_normal_vector(v1)) && (vector_rank(v1) == 1))) - { - s7_int i1 = integer(p1), i2 = integer(p2); - if ((i1 >= 0) && (i1 <= vector_length(v1)) && (i2 >= 0) && (i2 < vector_length(v1))) - return(subtract_p_pp(sc, vector_ref_p_pi(sc, v1, i1), vector_ref_p_pi(sc, v1, i2))); - } - return(subtract_p_pp(sc, vector_ref_p_pp(sc, v1, p1), vector_ref_p_pp(sc, v1, p2))); -} - -static s7_pointer fx_c_op_opsqq(s7_scheme *sc, s7_pointer code) -{ - set_car(sc->t1_1, fn_proc(opt3_pair(code))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(code)))))); - set_car(sc->t1_1, fn_proc(cadr(code))(sc, sc->t1_1)); - return(fn_proc(code)(sc, sc->t1_1)); -} - -static s7_pointer fx_not_op_opsqq(s7_scheme *sc, s7_pointer code) -{ - set_car(sc->t1_1, fn_proc(opt3_pair(code))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(code)))))); - return((fn_proc(cadr(code))(sc, sc->t1_1) == sc->F) ? sc->T : sc->F); -} - -static s7_pointer fx_not_is_pair_opsq(s7_scheme *sc, s7_pointer code) -{ - return(make_boolean(sc, !is_pair(fn_proc(opt3_pair(code))(sc, set_plist_1(sc, lookup(sc, opt3_sym(cdr(code)))))))); -} - -static s7_pointer fx_string_ref_t_last(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_plast(sc, t_lookup(sc, cadr(arg), arg), int_zero));} - -static s7_pointer fx_c_a(s7_scheme *sc, s7_pointer arg) -{ - return(fn_proc(arg)(sc, with_list_t1(fx_call(sc, cdr(arg))))); -} - -static s7_pointer fx_c_a_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt3_direct(arg))(sc, fx_call(sc, cdr(arg))));} -static s7_pointer fx_not_a(s7_scheme *sc, s7_pointer arg) {return((fx_call(sc, cdr(arg)) == sc->F) ? sc->T : sc->F);} - -static s7_pointer fx_c_saa(s7_scheme *sc, s7_pointer arg) -{ - gc_protect_via_stack(sc, fx_call(sc, opt3_pair(arg))); /* opt3_pair=cddr */ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_2, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -#define fx_c_ssa_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); \ - set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg));\ - set_car(sc->t3_2, Lookup2(sc, car(opt3_pair(arg)), arg)); \ - return(fn_proc(arg)(sc, sc->t3_1));\ - } - -fx_c_ssa_any(fx_c_ssa, s_lookup, s_lookup) -fx_c_ssa_any(fx_c_tsa, t_lookup, s_lookup) -fx_c_ssa_any(fx_c_sta, s_lookup, t_lookup) - -static s7_pointer fx_c_ssa_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_ppp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, car(opt3_pair(arg))), fx_call(sc, cdr(opt3_pair(arg))))); -} - -static s7_pointer fx_c_ass(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_1, fx_call(sc, cdr(arg))); - set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg)))); - set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_agg(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_1, fx_call(sc, cdr(arg))); - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_sas(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_sca(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, lookup(sc, cadr(arg))); - set_car(sc->t3_2, car(opt3_pair(arg))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_Tca(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, T_lookup(sc, cadr(arg), arg)); - set_car(sc->t3_2, car(opt3_pair(arg))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_csa(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, cadr(arg)); - set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_cac(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_1, cadr(arg)); - set_car(sc->t3_3, cadr(opt3_pair(arg))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_aa(s7_scheme *sc, s7_pointer arg) -{ - /* check_stack_size(sc); */ - gc_protect_via_stack(sc, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, fx_call(sc, opt3_pair(arg))); /* cddr(arg) */ - set_car(sc->t2_1, T_Ext(stack_protected1(sc))); - unstack(sc); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_ca(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_2, fx_call(sc, cddr(arg))); - set_car(sc->t2_1, opt3_con(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_ac(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_1, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, opt3_con(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_ac_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, fx_call(sc, cdr(arg)), opt3_con(arg)));} - -static s7_pointer fx_is_eq_ac(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer y = opt3_con(arg); - s7_pointer x = fx_call(sc, cdr(arg)); - return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); -} - -#define fx_c_sa_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_2, fx_call(sc, cddr(arg))); \ - set_car(sc->t2_1, Lookup(sc, opt3_sym(arg), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_sa_any(fx_c_sa, s_lookup) -fx_c_sa_any(fx_c_ta, t_lookup) -fx_c_sa_any(fx_c_ua, u_lookup) - -static s7_pointer fx_c_za(s7_scheme *sc, s7_pointer arg) /* "z"=unsafe_s */ -{ - s7_pointer val = lookup_checked(sc, cadr(arg)); /* this can call an autoload function that steps on sc->t2_1 */ - set_car(sc->t2_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t2_1, val); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -#define fx_c_sa_direct_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), fx_call(sc, cddr(arg)))); \ - } - -fx_c_sa_direct_any(fx_c_sa_direct, s_lookup) -fx_c_sa_direct_any(fx_c_ua_direct, u_lookup) - -static s7_pointer fx_cons_ca(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt3_con(arg), fx_call(sc, cddr(arg))));} -static s7_pointer fx_cons_ac(s7_scheme *sc, s7_pointer arg) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(arg)), opt3_con(arg)));} -static s7_pointer fx_cons_sa(s7_scheme *sc, s7_pointer arg) {return(cons(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg))));} -static s7_pointer fx_cons_as(s7_scheme *sc, s7_pointer arg) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(arg)), lookup(sc, opt3_sym(arg))));} -static s7_pointer fx_cons_aa(s7_scheme *sc, s7_pointer arg) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))));} - -#define fx_c_as_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - set_car(sc->t2_1, fx_call(sc, cdr(arg))); \ - set_car(sc->t2_2, Lookup(sc, opt3_sym(arg), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ - } - -fx_c_as_any(fx_c_as, s_lookup) -fx_c_as_any(fx_c_at, t_lookup) - -static s7_pointer fx_c_as_direct(s7_scheme *sc, s7_pointer arg) -{ - return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, fx_call(sc, cdr(arg)), lookup(sc, opt3_sym(arg)))); -} - -static s7_pointer fx_add_as(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x1 = fx_call(sc, cdr(arg)); - s7_pointer x2 = lookup(sc, opt3_sym(arg)); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) + real(x2))); - return(add_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_multiply_sa(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x1 = lookup(sc, cadr(arg)); - s7_pointer x2 = fx_call(sc, cddr(arg)); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) * real(x2))); - return(multiply_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_subtract_aa(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x2; - s7_pointer x1 = fx_call(sc, cdr(arg)); - sc->value = x1; - x2 = fx_call(sc, opt3_pair(arg)); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) - real(x2))); - return(subtract_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_add_aa(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x2; - s7_pointer x1 = fx_call(sc, cdr(arg)); - sc->value = x1; - x2 = fx_call(sc, opt3_pair(arg)); - if (is_t_real(x1)) {if (is_t_real(x2)) return(make_real(sc, real(x1) + real(x2)));} - else if ((is_t_integer(x1)) && (is_t_integer(x2))) return(make_integer(sc, integer(x1) + integer(x2))); - /* maybe use add_if_overflow_to_real_or_big_integer, but that seems unnecessary currently */ - return(add_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_multiply_aa(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x2; - s7_pointer x1 = fx_call(sc, cdr(arg)); - sc->value = x1; - x2 = fx_call(sc, opt3_pair(arg)); - if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) * real(x2))); - return(multiply_p_pp(sc, x1, x2)); -} - -static s7_pointer fx_add_sa(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg))));} -static s7_pointer fx_number_to_string_aa(s7_scheme *sc, s7_pointer arg) {return(number_to_string_p_pp(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))));} - -static s7_pointer fx_c_3g(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_1, fx_call(sc, cdr(arg))); - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer arg) -{ - /* check_stack_size(sc); */ - gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_2, stack_protected2(sc)); - set_car(sc->t3_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_gac(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t3_2, fx_call(sc, opt3_pair(arg))); - set_car(sc->t3_3, cadr(opt3_pair(arg))); - set_car(sc->t3_1, lookup_global(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t3_1)); -} - -static s7_pointer fx_c_opaq_s(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_1, fn_proc(cadr(arg))(sc, with_list_t1(fx_call(sc, cdadr(arg))))); - set_car(sc->t2_2, lookup_checked(sc, caddr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_s_opaq(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_2, fn_proc(caddr(arg))(sc, with_list_t1(fx_call(sc, opt3_pair(arg))))); /* cdaddr(arg); */ - set_car(sc->t2_1, lookup_checked(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_opaq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cadr(arg); - set_car(sc->t1_1, fx_call(sc, cdr(p))); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(p)(sc, sc->t1_1)))); -} - -static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cadr(arg); - /* check_stack_size(sc); */ - gc_protect_via_stack(sc, fx_call(sc, cdr(p))); - set_car(sc->t2_2, fx_call(sc, cddr(p))); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(p)(sc, sc->t2_1)))); -} - -static s7_pointer fx_c_opsaq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cadr(arg); - set_car(sc->t2_2, fx_call(sc, cddr(p))); - set_car(sc->t2_1, lookup(sc, cadr(p))); - return(fn_proc(arg)(sc, with_list_t1(fn_proc(p)(sc, sc->t2_1)))); -} - -static s7_pointer fx_c_opaaaq(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg = cadr(code); - gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* cddr(arg) */ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); - set_car(sc->t3_1, stack_protected1(sc)); - set_car(sc->t3_2, stack_protected2(sc)); - unstack(sc); - return(fn_proc(code)(sc, with_list_t1(fn_proc(arg)(sc, sc->t3_1)))); -} - -static s7_pointer fx_c_s_opaaq(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg = caddr(code); - gc_protect_via_stack(sc, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, fx_call(sc, cddr(arg))); - set_car(sc->t2_1, stack_protected1(sc)); - set_car(sc->t2_2, fn_proc(arg)(sc, sc->t2_1)); - set_car(sc->t2_1, lookup(sc, cadr(code))); - unstack(sc); - return(fn_proc(code)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer res = cdr(code); - check_stack_size(sc); /* t718 pp cycles #f */ - gc_protect_2_via_stack(sc, fx_call(sc, res), fx_call(sc, cdr(res))); - res = cddr(res); - set_stack_protected3(sc, fx_call(sc, res)); - set_car(sc->t3_3, fx_call(sc, cdr(res))); - set_car(sc->t3_2, stack_protected3(sc)); - set_car(sc->t3_1, stack_protected2(sc)); - set_car(sc->t4_1, stack_protected1(sc)); - unstack(sc); - res = fn_proc(code)(sc, sc->t4_1); - set_car(sc->t4_1, sc->F); - return(res); -} - -static s7_pointer fx_c_4g(s7_scheme *sc, s7_pointer code) -{ /* all opts in use for code, opt1 free cdr(code), code opt3 is line_number, cdr(code) opt3 is arglen?? */ - s7_pointer res = cdr(code); - set_car(sc->t4_1, fx_call(sc, res)); - set_car(sc->t3_1, fx_call(sc, cdr(res))); - set_car(sc->t3_2, fx_call(sc, opt3_pair(code))); /* cddr(res) */ - set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(code)))); /* cdddr(res) */ - res = fn_proc(code)(sc, sc->t4_1); - set_car(sc->t4_1, sc->F); - return(res); -} - -static s7_pointer fx_c_c_opscq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_1, lookup(sc, cadr(largs))); - set_car(sc->t2_2, opt2_con(cdr(largs))); - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, cadr(arg)); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_s_opcsq(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer largs = caddr(arg); - set_car(sc->t2_2, lookup(sc, caddr(largs))); - set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */ - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); - set_car(sc->t2_1, lookup(sc, cadr(arg))); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_op_opssqq_s(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg = opt1_pair(cdr(code)); - set_car(sc->t2_1, lookup(sc, cadr(arg))); - set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg)))); - set_car(sc->t2_1, fn_proc(cadr(code))(sc, with_list_t1(fn_proc(arg)(sc, sc->t2_1)))); - set_car(sc->t2_2, lookup(sc, caddr(code))); - return(fn_proc(code)(sc, sc->t2_1)); -} - -static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg = opt1_pair(cdr(code)); - return(((s7_p_pp_t)opt3_direct(code))(sc, - ((s7_p_p_t)opt2_direct(cdr(code)))(sc, - ((s7_p_pp_t)opt3_direct(cdr(code)))(sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)))), - lookup(sc, caddr(code)))); -} - -static s7_pointer fx_c_ns(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p1, lst = safe_list_if_possible(sc, opt3_arglen(cdr(arg))); - if (in_heap(lst)) gc_protect_via_stack(sc, lst); - for (s7_pointer args = cdr(arg), p = lst; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, lookup(sc, car(args))); - p1 = fn_proc(arg)(sc, lst); - if (in_heap(lst)) unstack(sc); - else clear_list_in_use(lst); - return(p1); -} - -static s7_pointer fx_list_ns(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer lst = make_list(sc, opt3_arglen(cdr(arg)), sc->unused); - for (s7_pointer args = cdr(arg), p = lst; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, lookup(sc, car(args))); - return(lst); -} - -static s7_pointer fx_c_all_ca(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p1, lst = safe_list_if_possible(sc, opt3_arglen(cdr(code))); - if (in_heap(lst)) gc_protect_via_stack(sc, lst); - for (s7_pointer args = cdr(code), p = lst; is_pair(args); args = cdr(args), p = cddr(p)) - { - set_car(p, opt2_con(args)); - args = cdr(args); - set_car(cdr(p), fx_call(sc, args)); - } - p1 = fn_proc(code)(sc, lst); - if (in_heap(lst)) unstack(sc); - else clear_list_in_use(lst); - return(p1); -} - -static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code) -{ - s7_pointer new_e, sp = NULL; - int64_t id; - - new_cell(sc, new_e, T_LET | T_SAFE_PROCEDURE); - let_set_slots(new_e, slot_end(sc)); /* needed by add_slot_unchecked */ - let_set_outlet(new_e, sc->nil); - gc_protect_via_stack(sc, new_e); - - /* as in let, we need to call the var inits before making the new let, but a simpler equivalent is to make the new let - * but don't set its id yet, and don't set local_slot until end either because fx_call might refer to same-name symbol in outer let. - * That is, symbol_id=outer_let_id so lookup->local_slot, so we better not set local_slot ahead of time here. - * As far as I can tell, this is the only place we do fx_call at the time of new_slot with new let id unset. - */ - for (s7_pointer x = cdr(code); is_pair(x); x = cddr(x)) - { - s7_pointer symbol = car(x), value; - symbol = (is_symbol_and_keyword(symbol)) ? keyword_symbol(symbol) : cadr(symbol); /* (inlet ':allow-other-keys 3) */ - if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ - { - unstack(sc); - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); - } - value = fx_call(sc, cdr(x)); /* it's necessary to do this first, before add_slot_unchecked */ - if (!sp) - { - add_slot_unchecked_no_local(sc, new_e, symbol, value); - sp = let_slots(new_e); - } - else sp = add_slot_at_end_no_local(sc, sp, symbol, value); - } - id = ++sc->let_number; - let_set_id(new_e, id); - for (s7_pointer x = let_slots(new_e); tis_slot(x); x = next_slot(x)) - symbol_set_local_slot_unincremented(slot_symbol(x), id, x); /* was symbol_set_id(slot_symbol(x), id) */ - unstack(sc); - return(new_e); -} - -static s7_pointer fx_c_na(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer args, p, val = safe_list_if_possible(sc, opt3_arglen(cdr(arg))); - if (in_heap(val)) gc_protect_via_stack(sc, val); - for (args = cdr(arg), p = val; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - p = fn_proc(arg)(sc, val); - if (in_heap(val)) unstack(sc); - else clear_list_in_use(val); - return(p); -} - -static s7_pointer fx_vector_ns(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer args = cdr(arg); - s7_pointer vec = make_simple_vector(sc, opt3_arglen(cdr(arg))); - s7_pointer *els = (s7_pointer *)vector_elements(vec); - for (s7_int i = 0; is_pair(args); args = cdr(args), i++) - els[i] = lookup(sc, car(args)); - return(vec); -} - -static s7_pointer fx_vector_na(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer args = cdr(arg); - s7_pointer v = make_simple_vector(sc, opt3_arglen(cdr(arg))); /* was s7_make_vector */ - s7_pointer *els = vector_elements(v); - gc_protect_via_stack(sc, v); - normal_vector_fill(v, sc->nil); /* fx_calls below can trigger GC, so all elements of v must be legit */ - for (s7_int i = 0; is_pair(args); args = cdr(args), i++) - els[i] = fx_call(sc, args); - sc->value = v; /* full-s7test 12262 list_p_p case */ - unstack(sc); - return(v); -} - -static s7_pointer fx_if_a_a(s7_scheme *sc, s7_pointer arg) -{ - return((is_true(sc, fx_call(sc, cdr(arg)))) ? fx_call(sc, opt1_pair(arg)) : sc->unspecified); -} - -static s7_pointer fx_if_not_a_a(s7_scheme *sc, s7_pointer arg) -{ - return((is_false(sc, fx_call(sc, opt1_pair(arg)))) ? fx_call(sc, opt2_pair(arg)) : sc->unspecified); -} - -static s7_pointer fx_if_a_a_a(s7_scheme *sc, s7_pointer arg) -{ - return((is_true(sc, fx_call(sc, cdr(arg)))) ? fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg))); -} - -#define fx_if_s_a_a_any(Name, Lookup) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - return((Lookup(sc, cadr(arg), arg) != sc->F) ? fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg))); \ - } - -fx_if_s_a_a_any(fx_if_s_a_a, s_lookup) -fx_if_s_a_a_any(fx_if_o_a_a, o_lookup) /* diff s->o of ca 3 */ - - -static s7_pointer fx_if_and2_s_a(s7_scheme *sc, s7_pointer arg) -{ - return(((fx_call(sc, opt1_pair(arg)) == sc->F) || (fx_call(sc, opt2_pair(arg)) == sc->F)) ? fx_call(sc, cdddr(arg)) : lookup(sc, opt3_sym(arg))); -} - -static s7_pointer fx_if_not_a_a_a(s7_scheme *sc, s7_pointer arg) -{ - return((is_false(sc, fx_call(sc, opt1_pair(arg)))) ? fx_call(sc, opt2_pair(arg)) : fx_call(sc, opt3_pair(arg))); -} - -static s7_pointer fx_if_a_c_c(s7_scheme *sc, s7_pointer arg) {return((is_true(sc, fx_call(sc, cdr(arg)))) ? opt1_con(arg) : opt2_con(arg));} - -static s7_pointer fx_if_is_type_s_a_a(s7_scheme *sc, s7_pointer arg) -{ - if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(arg))), opt3_byte(cdr(arg)))) - return(fx_call(sc, cddr(arg))); - return(fx_call(sc, opt2_pair(arg))); /* cdddr(arg) */ -} - -static inline s7_pointer fx_and_2a(s7_scheme *sc, s7_pointer arg) /* arg is the full expr: (and ...) */ -{ - return((fx_call(sc, cdr(arg)) == sc->F) ? sc->F : fx_call(sc, cddr(arg))); -} - -static inline s7_pointer fx_and_s_2(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg) */ - return((fn_proc(cadr(arg))(sc, sc->t1_1) == sc->F) ? sc->F : fn_proc(caddr(arg))(sc, sc->t1_1)); -} - -static s7_pointer fx_and_or_2a_vref(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer or1 = cadr(arg); - s7_pointer arg11 = cdadr(or1); - s7_pointer v = lookup(sc, cadar(arg11)); - if ((is_normal_vector(v)) && (vector_rank(v) == 1)) - { - s7_pointer ip = lookup(sc, opt3_sym(or1)); - s7_pointer jp = lookup(sc, opt1_sym(or1)); - if ((is_t_integer(ip)) && (is_t_integer(jp))) - { - s7_int i = integer(ip), j = integer(jp); - if ((i >= 0) && (j >= 0) && - (i < vector_length(v)) && (j < vector_length(v)) && - (is_t_real(vector_element(v, i))) && (is_t_real(vector_element(v, j)))) - { - s7_pointer xp = lookup(sc, cadr(arg11)); - if (is_t_real(xp)) - { - s7_double vi = real(vector_element(v, i)), vj = real(vector_element(v, j)), xf = real(xp); - return(make_boolean(sc, ((vi > xf) || (xf >= vj)) && ((vj > xf) || (xf >= vi)))); - }}}} - return(fx_and_2a(sc, arg)); -} - -static s7_pointer fx_len2_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* isn't this unprotected from mock pair? */ /* opt1_sym == cadadr(arg) */ - return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_null(cddr(val))))); -} - -static s7_pointer fx_len3_t(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = t_lookup(sc, opt1_sym(cdr(arg)), arg); - return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_pair(cddr(val))))); -} - -static s7_pointer fx_and_3a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - if (fx_call(sc, p) == sc->F) return(sc->F); - p = cdr(p); - if (fx_call(sc, p) == sc->F) return(sc->F); - return(fx_call(sc, cdr(p))); -} - -static s7_pointer fx_and_n(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = sc->T; - for (s7_pointer p = cdr(arg); (is_pair(p)) && (x != sc->F); p = cdr(p)) /* in lg, 5/6 args appears to predominate */ - x = fx_call(sc, p); - return(x); -} - -static s7_pointer fx_or_2a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer val = fx_call(sc, p); - return((val != sc->F) ? val : fx_call(sc, cdr(p))); -} - -static s7_pointer fx_or_s_2(s7_scheme *sc, s7_pointer arg) -{ - /* the "s" is looked up once here -- not obvious how to use fx_call anyway */ - s7_pointer x = fn_proc(cadr(arg))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(arg))))); /* cadadr(arg); */ - return((x != sc->F) ? x : fn_proc(caddr(arg))(sc, sc->t1_1)); -} - -static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg)); */ - return(make_boolean(sc, (type(x) == opt3_int(arg)) || (type(x) == opt2_int(cdr(arg))))); -} - -static s7_pointer fx_not_symbol_or_keyword(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer val = lookup(sc, opt3_sym(arg)); - return(make_boolean(sc, (!is_symbol(val)) || (is_keyword(val)))); -} - -static s7_pointer fx_or_and_2a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer val = fx_call(sc, p); - if (val != sc->F) return(val); - p = opt3_pair(arg); /* cdadr(p); */ - val = fx_call(sc, p); - return((val == sc->F) ? val : fx_call(sc, cdr(p))); -} - -static s7_pointer fx_or_and_3a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer val = fx_call(sc, p); - if (val != sc->F) return(val); - p = opt3_pair(arg); /* cdadr(p); */ - val = fx_call(sc, p); - if (val == sc->F) return(val); - p = cdr(p); - val = fx_call(sc, p); - return((val == sc->F) ? val : fx_call(sc, cdr(p))); -} - -static s7_pointer fx_or_3a(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer val = fx_call(sc, p); - if (val != sc->F) return(val); - p = cdr(p); - val = fx_call(sc, p); - return((val != sc->F) ? val : fx_call(sc, cdr(p))); -} - -static s7_pointer fx_or_n(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer x = sc->F; - for (s7_pointer p = cdr(arg); (is_pair(p)) && (x == sc->F); p = cdr(p)) - x = fx_call(sc, p); - return(x); -} - -static s7_pointer fx_begin_aa(s7_scheme *sc, s7_pointer arg) -{ - fx_call(sc, cdr(arg)); - return(fx_call(sc, cddr(arg))); -} - -static s7_pointer fx_begin_na(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p; - for (p = cdr(arg); is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - return(fx_call(sc, p)); -} - -static s7_pointer fx_safe_thunk_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer f = opt1_lambda(code), result; - gc_protect_via_stack(sc, sc->curlet); - set_curlet(sc, closure_let(f)); - result = fx_call(sc, closure_body(f)); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also called from h_safe_closure_s_a in eval */ -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer op_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also called from h_safe_closure_s_a in eval */ -{ - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - return(fx_call(sc, closure_body(opt1_lambda(code)))); -} - -static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), t_lookup(sc, opt2_sym(code), code)); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_s_to_s(s7_scheme *sc, s7_pointer arg) -{ - return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, with_list_t1(lookup(sc, opt2_sym(arg))))); -} - -static s7_pointer fx_safe_closure_s_to_sc(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_2, opt3_con(cdr(arg))); - set_car(sc->t2_1, lookup(sc, opt2_sym(arg))); - return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1)); -} - -static s7_pointer fx_safe_closure_s_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, opt2_sym(arg)), opt3_con(cdr(arg))));} - -static s7_pointer fx_safe_closure_s_to_sub1(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = lookup(sc, opt2_sym(arg)); - if ((!WITH_GMP) && (is_t_integer(p))) - return(make_integer(sc, integer(p) - 1)); - return(minus_c1(sc, p)); -} - -static s7_pointer fx_safe_closure_s_to_add1(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = lookup(sc, opt2_sym(arg)); - if ((!WITH_GMP) && (is_t_integer(p))) - return(make_integer(sc, integer(p) + 1)); - return(g_add_x1_1(sc, p, 1)); -} - -static s7_pointer fx_c_ff(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer p = cdr(arg); - s7_pointer x = fx_proc(cdar(p))(sc, car(p)); - sc->value = x; - set_car(sc->t2_2, fx_proc(cdadr(p))(sc, cadr(p))); - set_car(sc->t2_1, x); - return(fn_proc(arg)(sc, sc->t2_1)); -} - -static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer arg) -{ - set_car(sc->t2_1, fx_call(sc, cdr(arg))); - set_car(sc->t2_2, opt3_con(cdr(arg))); - return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1)); -} - -static s7_pointer fx_safe_closure_a_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, fx_call(sc, cdr(arg)), opt3_con(cdr(arg))));} - -static s7_pointer fx_safe_closure_s_and_2a(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2a */ -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - code = cdar(closure_body(opt1_lambda(code))); - result = fx_call(sc, code); /* have to unwind the stack so this can't return */ - if (result != sc->F) - result = fx_call(sc, cdr(code)); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_s_and_pair(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2a with is_pair as first clause */ -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))); - code = cdar(closure_body(opt1_lambda(code))); - result = (is_pair(t_lookup(sc, cadar(code), code))) ? fx_call(sc, cdr(code)) : sc->F; /* pair? arg = func par, pair? is global, symbol_id=0 */ - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_a_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer op_safe_closure_a_a(s7_scheme *sc, s7_pointer code) -{ - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))); - return(fx_call(sc, closure_body(opt1_lambda(code)))); -} - -static s7_pointer fx_safe_closure_a_sqr(s7_scheme *sc, s7_pointer code) {return(fx_sqr_1(sc, fx_call(sc, cdr(code))));} -static s7_pointer fx_safe_closure_s_sqr(s7_scheme *sc, s7_pointer code) {return(fx_sqr_1(sc, lookup(sc, opt2_sym(code))));} - -static s7_pointer fx_safe_closure_a_and_2a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer and_arg = cdar(closure_body(opt1_lambda(code))); - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))); - result = fx_call(sc, and_arg); - if (result != sc->F) result = fx_call(sc, cdr(and_arg)); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_two_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code))); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer op_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) -{ - sc->curlet = update_let_with_two_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code))); - return(fx_call(sc, closure_body(opt1_lambda(code)))); -} - -static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer result; - gc_protect_via_stack(sc, sc->curlet); - sc->curlet = update_let_with_three_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code))); - result = fx_call(sc, closure_body(opt1_lambda(code))); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(result); -} - -static s7_pointer op_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) -{ - sc->curlet = update_let_with_three_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code))); - return(fx_call(sc, closure_body(opt1_lambda(code)))); -} - -static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p = cdr(code); - s7_pointer f = opt1_lambda(code); - gc_protect_2_via_stack(sc, sc->curlet, fx_call(sc, cdr(p))); /* this is needed even if one of the args is a symbol */ - sc->curlet = update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), stack_protected2(sc)); - p = fx_call(sc, closure_body(f)); - set_curlet(sc, stack_protected1(sc)); - unstack(sc); - return(p); -} - -static inline s7_pointer fx_cond_na_na(s7_scheme *sc, s7_pointer code) /* all tests are fxable, results are all fx, no =>, no missing results */ -{ - for (s7_pointer p = cdr(code); is_pair(p); p = cdr(p)) - if (is_true(sc, fx_call(sc, car(p)))) - { - for (p = cdar(p); is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - return(fx_call(sc, p)); - } - return(sc->unspecified); -} - -static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice); - -static s7_pointer fx_implicit_s7_starlet_ref_s(s7_scheme *sc, s7_pointer arg) {return(s7_starlet(sc, opt3_int(arg)));} -static s7_pointer fx_implicit_s7_starlet_print_length(s7_scheme *sc, s7_pointer arg) {return(make_integer(sc, sc->print_length));} -static s7_pointer fx_implicit_s7_starlet_safety(s7_scheme *sc, s7_pointer arg) {return(make_integer(sc, sc->safety));} - -static s7_function *fx_function = NULL; - -static bool is_fxable(s7_scheme *sc, s7_pointer p) -{ - if (!is_pair(p)) return(true); - if ((is_optimized(p)) && /* this is needed. In check_tc, for example, is_fxable can be confused by early optimize_op */ - (fx_function[optimize_op(p)])) - return(true); - return(is_proper_quote(sc, p)); -} - -static bool is_gxable(s7_pointer p) -{ - opcode_t op; - if (!is_optimized(p)) return(false); - op = optimize_op(p); - return((is_symbol(car(p))) && (symbol_ctr(car(p)) == 1) && - (op < FIRST_UNHOPPABLE_OP) && - (op > OP_GC_PROTECT) && - (fx_function[op | 1])); -} - -static int32_t fx_count(s7_scheme *sc, s7_pointer x) -{ - int32_t count = 0; - for (s7_pointer p = cdr(x); is_pair(p); p = cdr(p)) - if (is_fxable(sc, car(p))) - count++; - return(count); -} - -static bool is_code_constant(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? (car(p) == sc->quote_symbol) : is_constant(sc, p));} - -static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code); - -static s7_p_dd_t s7_p_dd_function(s7_pointer f); -static s7_p_pi_t s7_p_pi_function(s7_pointer f); -static s7_p_ii_t s7_p_ii_function(s7_pointer f); - -#define is_unchanged_global(P) \ - ((is_symbol(P)) && (is_global(P)) && (symbol_id(P) == 0) && \ - (is_slot(initial_slot(P))) && \ - (initial_value(P) == global_value(P))) - -#define is_global_and_has_func(P, Func) ((is_unchanged_global(P)) && (Func(global_value(P)))) /* Func = s7_p_pp_function and friends */ - -static bool fx_matches(s7_pointer symbol, s7_pointer target_symbol) {return((symbol == target_symbol) && (is_unchanged_global(symbol)));} - -typedef bool (safe_sym_t)(s7_scheme *sc, s7_pointer sym, s7_pointer e); - -/* #define fx_choose(Sc, Holder, E, Checker) fx_choose_1(Sc, Holder, E, Checker, __func__, __LINE__) */ -static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer cur_env, safe_sym_t *checker) /* , const char *func, int32_t line) */ -{ - s7_pointer arg = car(holder); - if (!is_pair(arg)) - { - if (is_symbol(arg)) - { - if ((is_keyword(arg)) || ((arg == sc->else_symbol) && (is_global(arg)))) return(fx_c); - return((is_global(arg)) ? fx_g : ((checker(sc, arg, cur_env)) ? fx_s : fx_unsafe_s)); - } - return(fx_c); - } - if (is_optimized(arg)) - { - switch (optimize_op(arg)) - { - case HOP_SAFE_C_NC: -#if (!WITH_GMP) - if (fn_proc(arg) == g_add_i_random) return(fx_add_i_random); -#endif - return((fn_proc(arg) == g_random_i) ? fx_random_i : ((fn_proc(arg) == g_cons) ? fx_cons_cc : fx_c_nc)); - - case OP_OR_2A: - if (fx_proc(cddr(arg)) == fx_and_2a) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_2a);} - if (fx_proc(cddr(arg)) == fx_and_3a) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_3a);} - if ((fx_proc(cdr(arg)) == fx_not_is_symbol_s) && (fx_proc(cddr(arg)) == fx_is_keyword_s) && (cadr(cadadr(arg)) == cadaddr(arg))) - { - /* (or (not (symbol? body)) (keyword? body)) */ - set_opt3_sym(arg, cadaddr(arg)); - return(fx_not_symbol_or_keyword); - } - return(fx_or_2a); - - case OP_AND_2A: - if ((fx_proc(cdr(arg)) == fx_or_2a) && (fx_proc(cddr(arg)) == fx_or_2a)) - { - s7_pointer o1 = cadr(arg), o2 = caddr(arg); - if ((fx_proc(cdr(o1)) == fx_gt_vref_s) && - (fx_proc(cddr(o1)) == fx_geq_s_vref) && - (fx_proc(cdr(o2)) == fx_gt_vref_s) && - (fx_proc(cddr(o2)) == fx_geq_s_vref)) - { - s7_pointer v = cadr(cadadr(o1)); - if ((v == cadr(cadadr(o2))) && (v == (cadr(caddaddr(o1)))) && (v == (cadr(caddaddr(o2))))) - { - s7_pointer x = caddadr(o1); - if ((x == caddadr(o2)) && (x == cadaddr(o1)) && (x == cadaddr(o2))) - { - s7_pointer i = caddr(cadadr(o1)), j = caddaddr(caddr(o1)); - if ((j == caddr(cadadr(o2))) && (i == caddaddr(caddr(o2)))) - { - set_opt1_sym(o1, j); - set_opt3_sym(o1, i); - return(fx_and_or_2a_vref); - }}}}} - return(fx_and_2a); - - case HOP_SAFE_C_S: - if (is_unchanged_global(car(arg))) /* mus-copy would work here but in tgen (for example) it's loading generators.scm with local mus-copy methods */ - { - uint8_t typ; - if (car(arg) == sc->cdr_symbol) return(fx_cdr_s); - if (car(arg) == sc->car_symbol) return(fx_car_s); - if (car(arg) == sc->cadr_symbol) return(fx_cadr_s); - if (car(arg) == sc->cddr_symbol) return(fx_cddr_s); - if (car(arg) == sc->is_null_symbol) return(fx_is_null_s); - if (car(arg) == sc->is_pair_symbol) return(fx_is_pair_s); - if (car(arg) == sc->is_symbol_symbol) return(fx_is_symbol_s); - if (car(arg) == sc->is_eof_object_symbol) return(fx_is_eof_s); - if (car(arg) == sc->is_integer_symbol) return(fx_is_integer_s); - if (car(arg) == sc->is_string_symbol) return(fx_is_string_s); - if (car(arg) == sc->not_symbol) return(fx_not_s); - if (car(arg) == sc->is_proper_list_symbol) return(fx_is_proper_list_s); - if (car(arg) == sc->is_vector_symbol) return(fx_is_vector_s); - if (car(arg) == sc->is_keyword_symbol) return(fx_is_keyword_s); - if (car(arg) == sc->is_procedure_symbol) return(fx_is_procedure_s); - if (car(arg) == sc->length_symbol) return(fx_length_s); - /* not read_char here... */ - typ = symbol_type(car(arg)); - if (typ > 0) - { - set_opt3_byte(cdr(arg), typ); - return(fx_is_type_s); - } - /* car_p_p (et al) does not look for a method so in: - * (define kar car) (load "mockery.scm") (let ((p (mock-pair '(1 2 3)))) (call-with-exit (lambda (x) (x (kar p))))) - * "kar" fails but not "car" because symbol_id(kar) == 0! symbol_id(car) > 0 because mockery provides a method for it. - */ - if (symbol_id(c_function_name_to_symbol(sc, global_value(car(arg)))) == 0) - { - s7_p_p_t f = s7_p_p_function(global_value(car(arg))); - if (f) - { - set_opt2_direct(cdr(arg), (s7_pointer)f); - if (f == real_part_p_p) return(fx_real_part_s); - if (f == imag_part_p_p) return(fx_imag_part_s); - if (f == iterate_p_p) return(fx_iterate_s); - if (f == car_p_p) return(fx_car_s); /* can happen if (define var-name car) etc */ - return((is_global(cadr(arg))) ? fx_c_g_direct : fx_c_s_direct); - }}} - return((is_global(cadr(arg))) ? fx_c_g : fx_c_s); - - case HOP_SAFE_C_SS: - if (fn_proc(arg) == g_cons) return(fx_cons_ss); - if (fx_matches(car(arg), sc->num_eq_symbol)) return(fx_num_eq_ss); - if (fn_proc(arg) == g_geq_2) return(fx_geq_ss); - if (fn_proc(arg) == g_greater_2) return(fx_gt_ss); - if (fn_proc(arg) == g_leq_2) return(fx_leq_ss); - if (fn_proc(arg) == g_less_2) return((is_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss); - if ((fx_matches(car(arg), sc->multiply_symbol)) && (cadr(arg) == caddr(arg))) return(fx_sqr_s); - if (fn_proc(arg) == g_multiply_2) return(fx_multiply_ss); - if (fn_proc(arg) == g_is_eq) return(fx_is_eq_ss); - if (fn_proc(arg) == g_add_2) return(fx_add_ss); - if (fn_proc(arg) == g_subtract_2) return(fx_subtract_ss); - if (fn_proc(arg) == g_hash_table_ref_2) return(fx_hash_table_ref_ss); - - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - if (car(arg) == sc->assq_symbol) return(fx_assq_ss); - if (car(arg) == sc->memq_symbol) return(fx_memq_ss); - if (car(arg) == sc->vector_ref_symbol) return(fx_vref_ss); - if (car(arg) == sc->string_ref_symbol) return(fx_string_ref_ss); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return(fx_c_ss_direct); - } - /* fx_c_ss_direct via b_7pp is slower than fx_c_ss + g_<> */ - return(fx_c_ss); - - case HOP_SAFE_C_NS: - if (fn_proc(arg) == g_list) return(fx_list_ns); /* it is no faster here to divide out the big list cases!? */ - return((fn_proc(arg) == g_vector) ? fx_vector_ns : fx_c_ns); - - case HOP_SAFE_C_opSq_S: - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caadr(arg), s7_p_p_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); - return(((car(arg) == sc->cons_symbol) && (caadr(arg) == sc->car_symbol)) ? fx_cons_car_s_s : fx_c_opsq_s_direct); - } - return(fx_c_opsq_s); - - case HOP_SAFE_C_SSS: - if ((fn_proc(arg) == g_less) && (is_global(cadr(arg))) && (is_global(cadddr(arg)))) return(fx_lt_gsg); - if (is_global_and_has_func(car(arg), s7_p_ppp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(car(arg))))); - return(fx_c_sss_direct); - } - return(fx_c_sss); - - case HOP_SAFE_C_SSA: - if (is_global_and_has_func(car(arg), s7_p_ppp_function)) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(car(arg))))); - return(fx_c_ssa_direct); - } - return(fx_c_ssa); - - case HOP_SAFE_C_SCS: - if (is_global_and_has_func(car(arg), s7_p_ppp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(car(arg))))); - return(fx_c_scs_direct); - } - return(fx_c_scs); - - case HOP_SAFE_C_AAA: - if ((fx_proc(cdr(arg)) == fx_g) && (fx_proc(cdddr(arg)) == fx_c)) return(fx_c_gac); - if ((is_unquoted_pair(cadr(arg))) || (is_unquoted_pair(caddr(arg))) || (is_unquoted_pair(cadddr(arg)))) return(fx_c_aaa); - return(fx_c_3g); - - case HOP_SAFE_C_4A: - set_opt3_pair(arg, cdddr(arg)); - for (s7_pointer p = cdr(arg); is_pair(p); p = cdr(p)) - if (is_unquoted_pair(car(p))) - return(fx_c_4a); - return(fx_c_4g); /* fx_c_ssaa doesn't save much */ - - case HOP_SAFE_C_S_opSSq: - { - s7_pointer s2 = caddr(arg); - if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) return(fx_c_s_sqr); - - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(car(s2), s7_p_pp_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(s2))))); - set_opt3_pair(arg, cdr(s2)); - if (car(s2) == sc->vector_ref_symbol) - { - if (car(arg) == sc->add_symbol) return(fx_add_s_vref); - if (car(arg) == sc->subtract_symbol) return(fx_subtract_s_vref); - if (car(arg) == sc->multiply_symbol) return(fx_multiply_s_vref); - if (car(arg) == sc->geq_symbol) return(fx_geq_s_vref); - if (car(arg) == sc->is_eq_symbol) return(fx_is_eq_s_vref); - if (car(arg) == sc->hash_table_ref_symbol) return(fx_href_s_vref); - if (car(arg) == sc->let_ref_symbol) return(fx_lref_s_vref); - if ((is_global(cadr(arg))) && (is_global(cadr(s2))) && (car(arg) == sc->vector_ref_symbol)) return(fx_vref_g_vref_gs); - } - if ((car(arg) == sc->vector_ref_symbol) && (car(s2) == sc->add_symbol)) return(fx_vref_s_add); - return(fx_c_s_opssq_direct); - } - return(fx_c_s_opssq); - } - - case HOP_SAFE_C_opSSq_S: - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caadr(arg), s7_p_pp_function))) - { - /* op_c_opgsq_t */ - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(arg))))); - set_opt3_pair(arg, cdadr(arg)); - if (caadr(arg) == sc->vector_ref_symbol) - { - if (car(arg) == sc->subtract_symbol) return(fx_subtract_vref_s); - if (car(arg) == sc->gt_symbol) return(fx_gt_vref_s); - if (car(arg) == sc->vector_ref_symbol) return(fx_vref_vref_ss_s); - if (car(arg) == sc->add_symbol) return(fx_add_vref_s); - } - if (car(arg) == sc->add_symbol) - { - if ((caadr(arg) == sc->multiply_symbol) && (cadadr(arg) == caddadr(arg))) return(fx_add_sqr_s); - if (caadr(arg) == sc->subtract_symbol) return(fx_add_sub_s); - } - if ((car(arg) == sc->cons_symbol) && (caadr(arg) == sc->cons_symbol)) return(fx_cons_cons_s); - /* also div(sub)[2] mul(div) */ - return(((car(arg) == sc->gt_symbol) && (caadr(arg) == sc->add_symbol)) ? fx_gt_add_s : - (((car(arg) == sc->add_symbol) && (caadr(arg) == sc->multiply_symbol)) ? fx_add_mul_opssq_s : fx_c_opssq_s_direct)); - } - return(fx_c_opssq_s); - - case HOP_SAFE_C_opSSq_opSSq: - { - s7_pointer s1 = cadr(arg), s2 = caddr(arg); - set_opt3_pair(arg, cdr(s2)); - if ((fx_matches(car(s1), sc->multiply_symbol)) && (car(s2) == sc->multiply_symbol)) - { - set_opt1_pair(cdr(arg), cdr(s1)); - if (car(arg) == sc->subtract_symbol) return(fx_sub_mul_mul); - if (car(arg) == sc->add_symbol) - return(((cadr(s1) == caddr(s1)) && (cadr(s2) == caddr(s2))) ? fx_add_sqr_sqr : fx_add_mul_mul); - } - if ((fx_matches(car(s1), sc->subtract_symbol)) && (car(s2) == sc->subtract_symbol)) - { - set_opt1_pair(cdr(arg), cdr(s1)); - if (car(arg) == sc->multiply_symbol) return(fx_mul_sub_sub); - if (car(arg) == sc->lt_symbol) return(fx_lt_sub2); - } - if ((fx_matches(car(arg), sc->subtract_symbol)) && - (fx_matches(car(s1), sc->vector_ref_symbol)) && - (car(s2) == sc->vector_ref_symbol) && - (cadr(s1) == cadr(s2))) - { - set_opt3_sym(arg, cadr(cdaddr(arg))); - return(fx_sub_vref2); - } - return(fx_c_opssq_opssq); - } - - case HOP_SAFE_C_opSq: - if (is_unchanged_global(caadr(arg))) - { - if (fx_matches(car(arg), sc->is_pair_symbol)) - { - if (caadr(arg) == sc->car_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_car_s);} - if (caadr(arg) == sc->cdr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_cdr_s);} - if (caadr(arg) == sc->cadr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_cadr_s);} - if (caadr(arg) == sc->cddr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_pair_cddr_s);} - } - if (fx_matches(car(arg), sc->is_null_symbol)) - { - if (caadr(arg) == sc->cdr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_null_cdr_s);} - if (caadr(arg) == sc->cadr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_null_cadr_s);} - if (caadr(arg) == sc->cddr_symbol) {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_null_cddr_s);} - } - if ((fx_matches(car(arg), sc->is_symbol_symbol)) && - (caadr(arg) == sc->cadr_symbol)) - {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_is_symbol_cadr_s);} - - if (fx_matches(car(arg), sc->not_symbol)) - { - if (caadr(arg) == sc->is_pair_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_pair_s);} - if (caadr(arg) == sc->is_null_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_null_s);} - if (caadr(arg) == sc->is_symbol_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_symbol_s);} - return(fx_not_opsq); - } - if ((fx_matches(car(arg), sc->floor_symbol)) && (caadr(arg) == sc->sqrt_symbol)) - {set_opt2_sym(cdr(arg), cadadr(arg)); return(fx_floor_sqrt_s);} - } - if (is_unchanged_global(car(arg))) /* (? (op arg)) where (op arg) might return a let with a ? method etc */ - { /* other possibility: fx_c_a */ - uint8_t typ = symbol_type(car(arg)); - if (typ > 0) /* h_safe_c here so the type checker isn't shadowed */ - { - set_opt2_sym(cdr(arg), cadadr(arg)); - set_opt3_byte(cdr(arg), typ); - if (fn_proc(cadr(arg)) == (s7_function)g_c_pointer_weak1) - return(fx_eq_weak1_type_s); - return(fx_matches(caadr(arg), sc->car_symbol) ? fx_is_type_car_s : fx_is_type_opsq); - }} - /* this should follow the is_type* check above */ - if (fx_matches(caadr(arg), sc->car_symbol)) - { - set_opt2_sym(cdr(arg), cadadr(arg)); - return(fx_c_car_s); - } - if (fx_matches(caadr(arg), sc->cdr_symbol)) - { - set_opt2_sym(cdr(arg), cadadr(arg)); - return(fx_c_cdr_s); - } - return(fx_c_opsq); - - case HOP_SAFE_C_SC: - if (is_unchanged_global(car(arg))) - { - if (car(arg) == sc->add_symbol) - { - if (is_t_real(caddr(arg))) return(fx_add_sf); - if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_add_s1 : fx_add_si); - } - if (car(arg) == sc->subtract_symbol) - { - if (is_t_real(caddr(arg))) return(fx_subtract_sf); - if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_subtract_s1 : fx_subtract_si); - } - if (car(arg) == sc->multiply_symbol) - { - if (is_t_real(caddr(arg))) return(fx_multiply_sf); - if (is_t_integer(caddr(arg))) return(fx_multiply_si); - } - if ((fn_proc(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2); - if ((fn_proc(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc); - - if ((is_t_integer(caddr(arg))) && (s7_p_pi_function(global_value(car(arg))))) - { - if (car(arg) == sc->num_eq_symbol) return((integer(caddr(arg)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); - if (car(arg) == sc->lt_symbol) return(fx_lt_si); - if (car(arg) == sc->leq_symbol) return(fx_leq_si); - if (car(arg) == sc->gt_symbol) return(fx_gt_si); - if (car(arg) == sc->geq_symbol) return(fx_geq_si); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg))))); - return(fx_c_si_direct); - } - if ((is_t_real(caddr(arg))) && (real(caddr(arg)) == 0.0) && (car(arg) == sc->num_eq_symbol)) return(fx_num_eq_s0f); - if ((s7_p_pp_function(global_value(car(arg)))) && (fn_proc(arg) != g_divide_by_2)) - { - if (car(arg) == sc->memq_symbol) - { - if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) return(fx_memq_sc_3); - return(fx_memq_sc); - } - if ((car(arg) == sc->char_eq_symbol) && (is_character(caddr(arg)))) return(fx_char_eq_sc); /* maybe fx_char_eq_newline */ - if (car(arg) == sc->lt_symbol) return(fx_lt_sc); /* integer case handled above */ - if (car(arg) == sc->leq_symbol) return(fx_leq_sc); - if (car(arg) == sc->gt_symbol) return(fx_gt_sc); - if (car(arg) == sc->geq_symbol) return(fx_geq_sc); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return(fx_c_sc_direct); - }} - return(fx_c_sc); - - case HOP_SAFE_C_CS: - if (is_unchanged_global(car(arg))) - { - if (car(arg) == sc->cons_symbol) return(fx_cons_cs); - if ((car(arg) == sc->add_symbol) && (is_t_real(cadr(arg)))) return(fx_add_fs); - if ((car(arg) == sc->subtract_symbol) && (is_t_real(cadr(arg)))) return(fx_subtract_fs); - if ((car(arg) == sc->num_eq_symbol) && (cadr(arg) == int_zero)) return(fx_num_eq_0s); - if (car(arg) == sc->multiply_symbol) - { - if (is_t_real(cadr(arg))) return(fx_multiply_fs); - if (is_t_integer(cadr(arg))) return(fx_multiply_is); - }} - return(fx_c_cs); - - case HOP_SAFE_C_S_opSq: - if (fx_matches(car(caddr(arg)), sc->car_symbol)) - { - set_opt2_sym(cdr(arg), cadaddr(arg)); - if (fx_matches(car(arg), sc->hash_table_ref_symbol)) return(fx_hash_table_ref_car); - return(fx_matches(car(arg), sc->add_symbol) ? fx_add_s_car_s : fx_c_s_car_s); - } - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caaddr(arg), s7_p_p_function))) - { - if ((car(arg) == sc->cons_symbol) && (caaddr(arg) == sc->cdr_symbol)) {set_opt2_sym(cdr(arg), cadaddr(arg)); return(fx_cons_s_cdr_s);} - set_opt1_sym(cdr(arg), cadaddr(arg)); - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caaddr(arg))))); - return(fx_c_s_opsq_direct); - } - return(fx_c_s_opsq); - - case HOP_SAFE_C_C_opSq: - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - s7_pointer arg2 = caddr(arg); - if (is_global_and_has_func(car(arg2), s7_p_p_function)) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(car(arg2))))); - set_opt1_sym(cdr(arg), cadr(arg2)); - return(fx_c_c_opsq_direct); - }} - return(fx_c_c_opsq); - - case HOP_SAFE_C_opSq_C: - if (is_unchanged_global(car(arg))) - { - if ((car(arg) == sc->memq_symbol) && - (fx_matches(caadr(arg), sc->car_symbol)) && - (is_proper_quote(sc, caddr(arg))) && - (is_pair(cadaddr(arg)))) - return((s7_list_length(sc, opt2_con(cdr(arg))) == 2) ? fx_memq_car_s_2 : fx_memq_car_s); - - if (car(arg) == sc->is_eq_symbol) - { - if (((fx_matches(caadr(arg), sc->car_symbol)) || (fx_matches(caadr(arg), sc->caar_symbol))) && - (is_proper_quote(sc, caddr(arg)))) - { - set_opt3_sym(cdr(arg), cadadr(arg)); - set_opt2_con(cdr(arg), cadaddr(arg)); - return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_sq : fx_is_eq_caar_sq); - }} - if (((car(arg) == sc->lt_symbol) || (car(arg) == sc->num_eq_symbol)) && - (is_t_integer(caddr(arg))) && - (fx_matches(caadr(arg), sc->length_symbol))) - { - set_opt3_sym(cdr(arg), cadadr(arg)); - set_opt2_con(cdr(arg), caddr(arg)); - return((car(arg) == sc->lt_symbol) ? fx_less_length_i : fx_num_eq_length_i); - }} - set_opt1_sym(cdr(arg), cadadr(arg)); - return(fx_c_opsq_c); - - case HOP_SAFE_C_op_opSqq: - return((fx_matches(car(arg), sc->not_symbol)) ? ((fn_proc(cadr(arg)) == g_is_pair) ? fx_not_is_pair_opsq : fx_not_op_opsqq) : fx_c_op_opsqq); - - case HOP_SAFE_C_opSCq: - if (fx_matches(car(arg), sc->not_symbol)) - { - if (fn_proc(cadr(arg)) == g_is_eq) - { - set_opt2_sym(cdr(arg), cadadr(arg)); - set_opt3_con(cdr(arg), (is_pair(caddadr(arg))) ? cadaddr(cadr(arg)) : caddadr(arg)); - return(fx_not_is_eq_sq); - } - return(fx_not_opscq); - } - return(fx_c_opscq); - - case HOP_SAFE_C_S_opSCq: - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - s7_pointer arg2 = caddr(arg); - if ((is_global_and_has_func(car(arg2), s7_p_pi_function)) && - (is_t_integer(caddr(arg2)))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg2))))); - set_opt3_sym(arg, cadr(arg2)); - set_opt1_con(cdr(arg), caddr(arg2)); - if (car(arg) == sc->num_eq_symbol) - { - if (car(arg2) == sc->add_symbol) return(fx_num_eq_add_s_si); - if (car(arg2) == sc->subtract_symbol) return(fx_num_eq_subtract_s_si); - } - if ((car(arg) == sc->vector_ref_symbol) && (car(arg2) == sc->add_symbol) && (integer(caddr(arg2)) == 1)) - return(fx_vref_p1); - return(fx_c_s_opsiq_direct); - } - if (is_global_and_has_func(car(arg2), s7_p_pp_function)) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg2))))); - set_opt3_sym(arg, cadr(arg2)); - set_opt1_con(cdr(arg), (is_pair(caddr(arg2))) ? cadaddr(arg2) : caddr(arg2)); - return(fx_c_s_opscq_direct); - }} - return(fx_c_s_opscq); - - case HOP_SAFE_C_opSSq: - if (fx_matches(car(arg), sc->not_symbol)) - { - if (fn_proc(cadr(arg)) == g_is_eq) return(fx_not_is_eq_ss); - return(fx_not_opssq); - } - if ((is_global_and_has_func(car(arg), s7_p_p_function)) && - (is_global_and_has_func(caadr(arg), s7_p_pp_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(arg))))); - return(fx_c_opssq_direct); - } - return(fx_c_opssq); - - case HOP_SAFE_C_C_opSSq: - { - s7_pointer s2 = caddr(arg); - if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) - return(fx_c_c_sqr); - } - if ((is_small_real(cadr(arg))) && - (is_global_and_has_func(car(arg), s7_p_dd_function)) && - (is_global_and_has_func(caaddr(arg), s7_d_pd_function))) /* not * currently (this is for clm) */ - { - set_opt3_direct(cdr(arg), s7_d_pd_function(global_value(caaddr(arg)))); - set_opt2_direct(cdr(arg), s7_p_dd_function(global_value(car(arg)))); - set_opt3_sym(arg, cadaddr(arg)); - set_opt1_sym(cdr(arg), caddaddr(arg)); - return(fx_c_nc_opssq_direct); - } - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caaddr(arg), s7_p_pp_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caaddr(arg))))); - set_opt3_sym(arg, cadaddr(arg)); - set_opt1_sym(cdr(arg), caddaddr(arg)); - if ((is_t_real(cadr(arg))) && (car(arg) == caaddr(arg)) && (car(arg) == sc->multiply_symbol)) return(fx_multiply_c_opssq); - return(fx_c_c_opssq_direct); - } - return(fx_c_c_opssq); - - case HOP_SAFE_C_opSq_opSq: - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caadr(arg), s7_p_p_function)) && - (is_global_and_has_func(caaddr(arg), s7_p_p_function))) - { - set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caaddr(arg))))); - if ((caadr(arg) == caaddr(arg)) && ((caadr(arg) == sc->cdr_symbol) || (caadr(arg) == sc->car_symbol))) - { - set_opt1_sym(cdr(arg), cadadr(arg)); - set_opt2_sym(cdr(arg), cadaddr(arg)); /* usable because we know func is cdr|car */ - return((caadr(arg) == sc->cdr_symbol) ? fx_cdr_s_cdr_s : fx_car_s_car_s); - } - set_opt1_sym(cdr(arg), cadaddr(arg)); /* opt2 is taken by second func */ - return(fx_c_opsq_opsq_direct); - } - return(fx_c_opsq_opsq); - - case HOP_SAFE_C_op_S_opSqq: - return((fx_matches(car(arg), sc->not_symbol)) ? fx_not_op_s_opsqq : fx_c_op_s_opsqq); - - case HOP_SAFE_C_op_opSSqq_S: - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caadr(arg), s7_p_p_function)) && - (is_global_and_has_func(car(cadadr(arg)), s7_p_pp_function))) - { - set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(cadr(arg)))))); - return(fx_c_op_opssqq_s_direct); - } - return(fx_c_op_opssqq_s); - - case HOP_SAFE_C_A: - if (fx_matches(car(arg), sc->not_symbol)) - { - if (fx_proc(cdr(arg)) == fx_is_eq_car_sq) - { - set_opt1_sym(cdr(arg), cadadr(cadr(arg))); - set_opt3_con(cdr(arg), cadaddr(cadr(arg))); - return(fx_not_is_eq_car_sq); - } - return(fx_not_a); - } - if (is_global_and_has_func(car(arg), s7_p_p_function)) - { - set_opt3_direct(arg, (s7_pointer)(s7_p_p_function(global_value(car(arg))))); - return(fx_c_a_direct); - } - return(fx_c_a); - - case HOP_SAFE_C_AC: - if (fn_proc(arg) == g_cons) return(fx_cons_ac); - if (fx_matches(car(arg), sc->is_eq_symbol)) return(fx_is_eq_ac); - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - if ((opt3_direct(cdr(arg)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0)) - set_opt3_direct(cdr(arg), string_ref_p_p0); - if (opt3_direct(cdr(arg)) == (s7_pointer)memq_p_pp) - { - if (fn_proc(arg) == g_memq_2) - set_opt3_direct(cdr(arg), (s7_pointer)memq_2_p_pp); - else - if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) - set_opt3_direct(cdr(arg), memq_3_p_pp); - else - if (fn_proc(arg) == g_memq_4) - set_opt3_direct(cdr(arg), memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */ - } - return(fx_c_ac_direct); - } - return(fx_c_ac); - - case HOP_SAFE_C_CA: - return((fn_proc(arg) == g_cons) ? fx_cons_ca : fx_c_ca); - - case HOP_SAFE_C_SA: - if (fn_proc(arg) == g_multiply_2) return(fx_multiply_sa); - if (fn_proc(arg) == g_add_2) return(fx_add_sa); - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return((fn_proc(arg) == g_cons) ? fx_cons_sa : fx_c_sa_direct); - } - return(fx_c_sa); - - case HOP_SAFE_C_AS: - if (fn_proc(arg) == g_add_2) return(fx_add_as); - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return((fn_proc(arg) == g_cons) ? fx_cons_as : fx_c_as_direct); - } - return(fx_c_as); - - case HOP_SAFE_C_AA: /* (* wr (float-vector-ref rl 0 j)) (* wr (block-ref (vector-ref rl j) 0)) (- (float-vector-ref rl 0 i) tempr) */ - if (fn_proc(arg) == g_add_2) return(fx_add_aa); - if (fn_proc(arg) == g_subtract_2) return(fx_subtract_aa); - if (fn_proc(arg) == g_multiply_2) return(fx_multiply_aa); - if (fn_proc(arg) == g_number_to_string) return(fx_number_to_string_aa); - if (fn_proc(arg) == g_cons) return(fx_cons_aa); - /* we can get here from gx_annotate which does not call fx_tree, where A=fx_unsafe_s */ - if (fx_proc(cdr(arg)) == fx_unsafe_s) return(fx_c_za); - return(fx_c_aa); - - case HOP_SAFE_C_opAAq: - return((fx_proc(cdadr(arg)) == fx_s) ? fx_c_opsaq : fx_c_opaaq); - - case HOP_SAFE_C_NA: - return((fn_proc(arg) == g_vector) ? fx_vector_na : fx_c_na); - - case HOP_SAFE_C_ALL_CA: - return((fn_proc(arg) == g_simple_inlet) ? fx_inlet_ca : fx_c_all_ca); - - case HOP_SAFE_CLOSURE_S_A: - { - s7_pointer body = car(closure_body(opt1_lambda(arg))); - if (is_pair(body)) - { - if (optimize_op(body) == OP_AND_2A) - { - if ((fx_matches(caadr(body), sc->is_pair_symbol)) && - (cadadr(body) == car(closure_args(opt1_lambda(arg))))) - return(fx_safe_closure_s_and_pair); /* lint arg: (len>1? init), args: (x) body: (and (pair? x) (pair? (cdr x))) */ - return(fx_safe_closure_s_and_2a); - } - if (optimize_op(body) == HOP_SAFE_C_opSq_C) - { - if ((fn_proc(body) == g_lint_let_ref) && - (cadadr(body) == car(closure_args(opt1_lambda(arg))))) - { - set_opt2_sym(cdr(arg), cadaddr(body)); - return(fx_lint_let_ref_s); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */ - }}} - return((fx_proc(closure_body(opt1_lambda(arg))) == fx_sqr_t) ? fx_safe_closure_s_sqr : fx_safe_closure_s_a); - } - - case HOP_SAFE_CLOSURE_S_TO_SC: - { - s7_pointer body = car(closure_body(opt1_lambda(arg))); - if (fn_proc(body) == g_vector_ref_2) return(fx_safe_closure_s_to_vref); - if ((is_t_integer(caddr(body))) && (integer(caddr(body)) == 1)) - { - if (car(body) == sc->subtract_symbol) return(fx_safe_closure_s_to_sub1); - if (car(body) == sc->add_symbol) return(fx_safe_closure_s_to_add1); - } - return(fx_safe_closure_s_to_sc); - } - - case HOP_SAFE_CLOSURE_A_TO_SC: - return((fn_proc(car(closure_body(opt1_lambda(arg)))) == g_vector_ref_2) ? fx_safe_closure_a_to_vref : fx_safe_closure_a_to_sc); - - case HOP_SAFE_CLOSURE_A_A: - if (fx_proc(closure_body(opt1_lambda(arg))) == fx_and_2a) - return(fx_safe_closure_a_and_2a); - return((fx_proc(closure_body(opt1_lambda(arg))) == fx_sqr_t) ? fx_safe_closure_a_sqr : fx_safe_closure_a_a); - - case HOP_SAFE_CLOSURE_3S_A: - if (fx_proc(closure_body(opt1_lambda(arg))) == fx_vref_vref_tu_v) return(fx_vref_vref_3_no_let); - return(fx_function[optimize_op(arg)]); - - case OP_IMPLICIT_S7_STARLET_REF_S: - if (opt3_int(arg) == SL_PRINT_LENGTH) return(fx_implicit_s7_starlet_print_length); - if (opt3_int(arg) == SL_SAFETY) return(fx_implicit_s7_starlet_safety); - return(fx_implicit_s7_starlet_ref_s); - - case HOP_C: - if ((is_unchanged_global(car(arg))) && (car(arg) == sc->curlet_symbol)) return(fx_curlet); - /* fall through */ - - default: - /* if ((!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], display(arg)); */ - return(fx_function[optimize_op(arg)]); - }} /* is_optimized */ - - if ((car(arg) == sc->quote_symbol) && - (is_global(sc->quote_symbol))) - { - check_quote(sc, arg); - return(fx_q); - } - return(NULL); -} - -#if S7_DEBUGGING -#define with_fx(P, F) with_fx_1(sc, P, F) -static bool with_fx_1(s7_scheme *sc, s7_pointer p, s7_function f) /* sc needed for set_opt2 under debugger = set_opt2_1(sc,...) */ -#else -static bool with_fx(s7_pointer p, s7_function f) -#endif -{ - set_fx_direct(p, f); - return(true); -} - -static bool o_var_ok(s7_pointer p, s7_pointer var1, s7_pointer var2, s7_pointer var3) {return((p != var1) && (p != var2) && (p != var3));} - -static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool unused_more_vars) -{ - s7_pointer p = car(tree); -#if 0 - if ((s7_tree_memq(sc, var1, p)) || ((var2) && (s7_tree_memq(sc, var2, p))) || ((var3) && (s7_tree_memq(sc, var3, p)))) - fprintf(stderr, "%s[%d] %s %s %s %d %d: %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", - has_fx(tree), unused_more_vars, display(p)); -#endif - if (is_symbol(p)) - { - if ((fx_proc(tree) == fx_s) || (fx_proc(tree) == fx_o)) - { - if (p == var1) return(with_fx(tree, fx_T)); - if (p == var2) return(with_fx(tree, fx_U)); - if (p == var3) return(with_fx(tree, fx_V)); - } - return(false); - } - if ((is_pair(p)) && (is_pair(cdr(p)))) - { - if (cadr(p) == var1) - { - if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o)) return(with_fx(tree, fx_c_T)); /* fx_c_T_direct got no hits */ - if ((fx_proc(tree) == fx_car_s) || (fx_proc(tree) == fx_car_o)) return(with_fx(tree, fx_car_T)); - if ((fx_proc(tree) == fx_cdr_s) || (fx_proc(tree) == fx_cdr_o)) return(with_fx(tree, fx_cdr_T)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_T)); - if (fx_proc(tree) == fx_iterate_o) return(with_fx(tree, fx_iterate_T)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_T1)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_T1)); - if (fx_proc(tree) == fx_c_sca) return(with_fx(tree, fx_c_Tca)); - if ((fx_proc(tree) == fx_num_eq_si) || (fx_proc(tree) == fx_num_eq_s0) || (fx_proc(tree) == fx_num_eq_oi)) return(with_fx(tree, fx_num_eq_Ti)); - /* if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, fx_cons_Ts)); */ /* can be fooled -- there is no fx_cons_us etc -- need fx_cons_os */ - /* if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_Ts)); */ /* this also can be fooled? */ - if ((fx_proc(tree) == fx_c_scs_direct) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_TcU_direct)); - if ((fx_proc(tree) == fx_hash_table_ref_ss) && (var3 == caddr(p))) return(with_fx(tree, fx_hash_table_ref_TV)); - if ((fx_proc(tree) == fx_geq_ss) && (var2 == caddr(p))) return(with_fx(tree, fx_geq_TU)); - } - else - if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_U1)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_U1)); - if ((fx_proc(tree) == fx_car_s) || (fx_proc(tree) == fx_car_o)) return(with_fx(tree, fx_car_U)); - if ((fx_proc(tree) == fx_cdr_s) || (fx_proc(tree) == fx_cdr_o)) return(with_fx(tree, fx_cdr_U)); - } - else - if (cadr(p) == var3) - { - if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o)) return(with_fx(tree, fx_c_V)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_V1)); - } - else - if (is_pair(cddr(p))) - { - if (caddr(p) == var1) - { - if ((fx_proc(tree) == fx_num_eq_ts) || (fx_proc(tree) == fx_num_eq_to)) return(with_fx(tree, fx_num_eq_tT)); - if ((fx_proc(tree) == fx_gt_ts) || (fx_proc(tree) == fx_gt_to)) return(with_fx(tree, fx_gt_tT)); - if (fx_proc(tree) == fx_lt_ts) return(with_fx(tree, fx_lt_tT)); - if ((fx_proc(tree) == fx_geq_ts) || (fx_proc(tree) == fx_geq_to)) return(with_fx(tree, fx_geq_tT)); - } - else - if (caddr(p) == var2) - { - if (fx_proc(tree) == fx_c_ts) return(with_fx(tree, fx_c_tU)); - if (fx_proc(tree) == fx_cons_ts) return(with_fx(tree, fx_cons_tU)); - if (fx_proc(tree) == fx_c_ts_direct) return(with_fx(tree, fx_c_tU_direct)); - if (fx_proc(tree) == fx_lt_ts) return(with_fx(tree, fx_lt_tU)); - if (fx_proc(tree) == fx_num_eq_us) return(with_fx(tree, fx_num_eq_uU)); - if (fx_proc(tree) == fx_num_eq_vs) return(with_fx(tree, fx_num_eq_vU)); - } - else - if ((fx_proc(tree) == fx_add_sqr_s) && (cadadr(p) == var1)) return(with_fx(tree, fx_add_sqr_T)); - }} -#if 0 - if ((s7_tree_memq(sc, var1, p)) || ((var2) && (s7_tree_memq(sc, var2, p))) || ((var3) && (s7_tree_memq(sc, var3, p)))) - fprintf(stderr, "%s[%d] %s %s %s %d %d: %s %s\n", __func__, __LINE__, display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", - has_fx(tree), unused_more_vars, display(p), op_names[optimize_op(p)]); -#endif - return(false); -} - -static void fx_tree_outer(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars) -{ - if ((!is_pair(tree)) || - ((is_symbol(car(tree))) && (is_definer_or_binder(car(tree)))) || - (is_syntax(car(tree)))) - return; - if ((!has_fx(tree)) || - (!fx_tree_out(sc, tree, var1, var2, var3, more_vars))) - fx_tree_outer(sc, car(tree), var1, var2, var3, more_vars); - fx_tree_outer(sc, cdr(tree), var1, var2, var3, more_vars); -} - -static s7_b_7p_t s7_b_7p_function(s7_pointer f); - -static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars) -{ - s7_pointer p = car(tree); -#if 0 - /* if ((s7_tree_memq(sc, var1, p)) || ((var2) && (s7_tree_memq(sc, var2, p))) || ((var3) && (s7_tree_memq(sc, var3, p)))) */ - fprintf(stderr, "fx_tree_in %s %s %s %s: %s, treed: %d\n", op_names[optimize_op(p)], - display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", display_80(p), is_fx_treed(tree)); -#endif - if (is_symbol(p)) - { - if (fx_proc(tree) == fx_s) - { - if (p == var1) return(with_fx(tree, fx_t)); - if (p == var2) return(with_fx(tree, fx_u)); - if (p == var3) return(with_fx(tree, fx_v)); - if (is_global(p)) return(with_fx(tree, fx_g)); - if (!more_vars) return(with_fx(tree, fx_o)); - } - return(false); - } - if ((!is_pair(p)) || (is_fx_treed(tree)) || (!has_fx(tree))) return(false); - set_fx_treed(tree); - switch (optimize_op(p)) - { - case HOP_SAFE_C_S: - if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_t)); - if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, (opt2_direct(cdr(p)) == (s7_pointer)cddr_p_p) ? fx_cddr_t : fx_c_t_direct)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_t)); - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_t)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_t)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_t)); - if (fx_proc(tree) == fx_not_s) return(with_fx(tree, fx_not_t)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_t)); - if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_t)); - if (fx_proc(tree) == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_t)); - if (fx_proc(tree) == fx_is_eof_s) return(with_fx(tree, fx_is_eof_t)); - if (fx_proc(tree) == fx_is_string_s) return(with_fx(tree, fx_is_string_t)); - if (fx_proc(tree) == fx_is_vector_s) return(with_fx(tree, fx_is_vector_t)); - if (fx_proc(tree) == fx_is_integer_s) return(with_fx(tree, fx_is_integer_t)); - if (fx_proc(tree) == fx_is_procedure_s) return(with_fx(tree, fx_is_procedure_t)); - if (fx_proc(tree) == fx_is_type_s) return(with_fx(tree, fx_is_type_t)); - if (fx_proc(tree) == fx_length_s) return(with_fx(tree, fx_length_t)); - if (fx_proc(tree) == fx_real_part_s) return(with_fx(tree, fx_real_part_t)); - if (fx_proc(tree) == fx_imag_part_s) return(with_fx(tree, fx_imag_part_t)); - return(false); - } - if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_c_s) - { - if (is_global_and_has_func(car(p), s7_p_p_function)) - { - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(car(p))))); - return(with_fx(tree, (car(p) == sc->cddr_symbol) ? fx_cddr_u : - ((car(p) == sc->is_positive_symbol) ? fx_is_positive_u : - ((car(p) == sc->is_zero_symbol) ? fx_is_zero_u : fx_c_u_direct)))); - } - return(with_fx(tree, fx_c_u)); - } - if (fx_proc(tree) == fx_c_s_direct) - return(with_fx(tree, (car(p) == sc->cddr_symbol) ? fx_cddr_u : - ((car(p) == sc->is_positive_symbol) ? fx_is_positive_u : - ((car(p) == sc->is_zero_symbol) ? fx_is_zero_u : fx_c_u_direct)))); - - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_u)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_u)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_u)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_u)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_u)); - if (fx_proc(tree) == fx_is_type_s) return(with_fx(tree, fx_is_type_u)); - if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_u)); - if (fx_proc(tree) == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_u)); - if (fx_proc(tree) == fx_is_eof_s) return(with_fx(tree, fx_is_eof_u)); - return(false); - } - if (cadr(p) == var3) - { - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_v)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_v)); - if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_v)); - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_v)); - if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_v_direct)); - return(false); - } - if (!more_vars) - { - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_o)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_o)); - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_o)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_o)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_o)); - if (fx_proc(tree) == fx_iterate_s) return(with_fx(tree, fx_iterate_o)); - if (fx_proc(tree) == fx_not_s) return(with_fx(tree, fx_not_o)); - if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_o_direct)); - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_o)); - } - break; - - case HOP_SAFE_C_SC: - if (cadr(p) == var1) - { - if ((fx_proc(tree) == fx_char_eq_sc) || (fn_proc(p) == g_char_equal_2)) return(with_fx(tree, fx_char_eq_tc)); - if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_tc)); - if (fx_proc(tree) == fx_add_sf) return(with_fx(tree, fx_add_tf)); - if (fn_proc(p) == g_less_xf) return(with_fx(tree, fx_lt_tf)); - if (fn_proc(p) == g_less_x0) return(with_fx(tree, fx_lt_t0)); - if (fn_proc(p) == g_less_xi) - return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti))); - if (fn_proc(p) == g_geq_xf) return(with_fx(tree, fx_geq_tf)); - if (fn_proc(p) == g_geq_xi) return(with_fx(tree, (integer(caddr(p)) == 0) ? fx_geq_t0 : fx_geq_ti)); - if (fn_proc(p) == g_leq_xi) return(with_fx(tree, fx_leq_ti)); - if (fn_proc(p) == g_greater_xi) return(with_fx(tree, fx_gt_ti)); - if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_ti)); - if (fx_proc(tree) == fx_gt_si) return(with_fx(tree, fx_gt_ti)); - - if (fx_proc(tree) == fx_c_sc_direct) /* p_pp cases */ - { - if ((opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) && (is_t_integer(caddr(p)))) - return(with_fx(tree, fx_vector_ref_tc)); - if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(p))) && (integer(caddr(p)) == 0)) - set_opt3_direct(cdr(p), string_ref_p_p0); - return(with_fx(tree, fx_c_tc_direct)); - } - if (fx_proc(tree) == fx_c_si_direct) /* p_pi cases */ - { - if (opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pi) - return(with_fx(tree, fx_vector_ref_tc)); - if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pi) && (integer(caddr(p)) == 0)) - set_opt3_direct(cdr(p), string_ref_p_p0); - return(with_fx(tree, (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pi) ? fx_c_ti_remainder : fx_c_ti_direct)); - } - - if (fx_proc(tree) == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_tc)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_t1)); - if (fx_proc(tree) == fx_add_si) return(with_fx(tree, fx_add_ti)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_t1)); - if (fx_proc(tree) == fx_subtract_si) return(with_fx(tree, fx_subtract_ti)); - if (fx_proc(tree) == fx_subtract_sf) return(with_fx(tree, fx_subtract_tf)); - if (fx_proc(tree) == fx_multiply_sf) return(with_fx(tree, fx_multiply_tf)); - if (fx_proc(tree) == fx_lt_si) /* is this ever hit? */ - return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti))); - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ti)); - if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_t0)); - if (fx_proc(tree) == fx_memq_sc) return(with_fx(tree, fx_memq_tc)); - return(false); - } - if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_uc)); - if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_u0)); - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ui)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_u1)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_u1)); - if (fx_proc(tree) == fx_subtract_si) return(with_fx(tree, fx_subtract_ui)); - if (fx_proc(tree) == fx_multiply_si) return(with_fx(tree, fx_multiply_ui)); - if (fx_proc(tree) == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_uc)); - if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_ui)); - if (fx_proc(tree) == fx_gt_si) return(with_fx(tree, fx_gt_ui)); - return(false); - } - if (cadr(p) == var3) - { - if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_v0)); - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_vi)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_v1)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_v1)); - if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_vi)); - if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_vc)); - return(false); - } - if (!more_vars) - { - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_oi)); - if ((fx_proc(tree) == fx_c_sc) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_c_oc)); - } - break; - - case HOP_SAFE_C_CS: - if (caddr(p) == var1) - { - if ((car(p) == sc->cons_symbol) && (is_unchanged_global(sc->cons_symbol))) return(with_fx(tree, fx_cons_ct)); - if (fx_proc(tree) == fx_c_cs) - { - if (is_global_and_has_func(car(p), s7_p_pp_function)) - { - if (fn_proc(p) == g_tree_set_memq_1) - set_opt3_direct(cdr(p), (s7_pointer)tree_set_memq_direct); - else set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_fx_direct(tree, fx_c_ct_direct); - } - else set_fx_direct(tree, fx_c_ct); - return(true); - }} - if ((caddr(p) == var2) && (fx_proc(tree) == fx_c_cs)) return(with_fx(tree, fx_c_cu)); - break; - - case HOP_SAFE_C_SS: - if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_c_tu : fx_c_ts)); - if (fx_proc(tree) == fx_c_ss_direct) return(with_fx(tree, (caddr(p) == var2) ? fx_c_tu_direct : fx_c_ts_direct)); - if (fx_proc(tree) == fx_add_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_add_tu : fx_add_ts)); - if (fx_proc(tree) == fx_subtract_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_subtract_tu : fx_subtract_ts)); - if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_cons_tu : fx_cons_ts)); - if (caddr(p) == var2) - { - if (fx_proc(tree) == fx_gt_ss) return(with_fx(tree, fx_gt_tu)); - if (fx_proc(tree) == fx_lt_ss) return(with_fx(tree, fx_lt_tu)); - if (fx_proc(tree) == fx_leq_ss) return(with_fx(tree, fx_leq_tu)); - if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, fx_geq_tu)); - if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_tu)); - if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_tu)); - if (fx_proc(tree) == fx_memq_ss) return(with_fx(tree, fx_memq_tu)); - } - if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_ts)); - if (fx_proc(tree) == fx_num_eq_ss) - { - if (caddr(p) == var3) return(with_fx(tree, fx_num_eq_tv)); - if (is_global(caddr(p))) return(with_fx(tree, fx_num_eq_tg)); - if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_num_eq_to)); - return(with_fx(tree, fx_num_eq_ts)); - } - if (fx_proc(tree) == fx_geq_ss) - { - if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_geq_to)); - return(with_fx(tree, fx_geq_ts)); - } - if (fx_proc(tree) == fx_leq_ss) return(with_fx(tree, fx_leq_ts)); - if (fx_proc(tree) == fx_lt_ss) return(with_fx(tree, fx_lt_ts)); - if (fx_proc(tree) == fx_lt_sg) return(with_fx(tree, fx_lt_tg)); - if (fx_proc(tree) == fx_gt_ss) - { - if (is_global(caddr(p))) return(with_fx(tree, fx_gt_tg)); - if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_gt_to)); - return(with_fx(tree, fx_gt_ts)); - } - if (fx_proc(tree) == fx_sqr_s) return(with_fx(tree, fx_sqr_t)); - if (fx_proc(tree) == fx_is_eq_ss) - { - if (caddr(p) == var2) return(with_fx(tree, fx_is_eq_tu)); - if ((!more_vars) && (caddr(p) != var3) && (caddr(p) != var1)) return(with_fx(tree, fx_is_eq_to)); - return(with_fx(tree, fx_is_eq_ts)); - } - if (fx_proc(tree) == fx_vref_ss) - { - if (caddr(p) == var2) return(with_fx(tree, fx_vref_tu)); - return(with_fx(tree, fx_vref_ts)); - }} - if (caddr(p) == var1) - { - if (fx_proc(tree) == fx_c_ss) return(with_fx(tree, fx_c_st)); - if (fx_proc(tree) == fx_c_ss_direct) {return(with_fx(tree, (is_global(cadr(p))) ? fx_c_gt_direct : fx_c_st_direct));} - if (fx_proc(tree) == fx_hash_table_ref_ss) return(with_fx(tree, fx_hash_table_ref_st)); - if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, fx_cons_st)); - if (fx_proc(tree) == fx_vref_ss) - { - if (is_global(cadr(p))) return(with_fx(tree, fx_vref_gt)); - if ((!more_vars) && (cadr(p) != var2) && (cadr(p) != var3)) return(with_fx(tree, fx_vref_ot)); - return(with_fx(tree, fx_vref_st)); - } - if ((fx_proc(tree) == fx_gt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_gt_ut)); - if ((fx_proc(tree) == fx_lt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_lt_ut)); - if ((fx_proc(tree) == fx_geq_ss)) - { - if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_geq_ot)); - return(with_fx(tree, fx_geq_st)); - }} - if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_num_eq_ut : fx_num_eq_us)); - if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, fx_geq_us)); - if (fx_proc(tree) == fx_add_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_add_ut : ((caddr(p) == var3) ? fx_add_uv : fx_add_us))); - if (fx_proc(tree) == fx_subtract_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_subtract_ut : fx_subtract_us)); - if (caddr(p) == var3) return(with_fx(tree, fx_c_uv)); - } - if (cadr(p) == var3) - { - if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_vs)); - if ((fx_proc(tree) == fx_add_ss) && (caddr(p) == var2)) return(with_fx(tree, fx_add_vu)); - if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) ? fx_geq_vo : fx_geq_vs)); - } - break; - - case HOP_SAFE_C_AS: - if (caddr(p) == var1) return(with_fx(tree, fx_c_at)); - break; - - case HOP_SAFE_C_SA: - if (cadr(p) == var1) - { - if ((fx_proc(cddr(p)) == fx_c_opsq_c) && - (cadadr(caddr(p)) == var1) && - (is_t_integer(caddaddr(p))) && - (integer(caddaddr(p)) == 1) && - (car(p) == sc->string_ref_symbol) && - (caaddr(p) == sc->subtract_symbol) && -#if (!WITH_PURE_S7) - ((caadr(caddr(p)) == sc->string_length_symbol) || (caadr(caddr(p)) == sc->length_symbol))) -#else - (caadr(caddr(p)) == sc->length_symbol)) -#endif - return(with_fx(tree, fx_string_ref_t_last)); - return(with_fx(tree, fx_c_ta)); - } - if (cadr(p) == var2) return(with_fx(tree, (fx_proc(tree) == fx_c_sa_direct) ? fx_c_ua_direct : fx_c_ua)); - break; - - case HOP_SAFE_C_SCS: - if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_scs) return(with_fx(tree, fx_c_tcs)); - if (fx_proc(tree) == fx_c_scs_direct) return(with_fx(tree, (cadddr(p) == var2) ? fx_c_tcu_direct : fx_c_tcs_direct)); - } - break; - - case HOP_SAFE_C_SSC: - if ((cadr(p) == var1) && (caddr(p) == var2)) return(with_fx(tree, fx_c_tuc)); - break; - - case HOP_SAFE_C_CSS: - if ((caddr(p) == var1) && (cadddr(p) == var3)) return(with_fx(tree, fx_c_ctv)); - break; - - case HOP_SAFE_C_SSS: - if ((cadr(p) == var1) && ((caddr(p) == var2) && ((fx_proc(tree) == fx_c_sss) || (fx_proc(tree) == fx_c_sss_direct)))) - return(with_fx(tree, (cadddr(p) == var3) ? ((fx_proc(tree) == fx_c_sss_direct) ? fx_c_tuv_direct : fx_c_tuv) : fx_c_tus)); - if (caddr(p) == var1) - { - if (car(p) == sc->vector_set_symbol) - { - if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3)) && (o_var_ok(cadddr(p), var1, var2, var3))) return(with_fx(tree, fx_vset_oto)); - return(with_fx(tree, fx_vset_sts)); - } - return(with_fx(tree, fx_c_sts)); - } - break; - - case HOP_SAFE_C_SSA: - if (cadr(p) == var1) return(with_fx(tree, fx_c_tsa)); /* tua is hit but not called much */ - if (caddr(p) == var1) return(with_fx(tree, fx_c_sta)); - break; - - case HOP_SAFE_C_opSq: - if (cadadr(p) == var1) - { - if (fx_proc(tree) == fx_is_pair_car_s) return(with_fx(tree, fx_is_pair_car_t)); - if (fx_proc(tree) == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_t)); - if (fx_proc(tree) == fx_is_pair_cadr_s) return(with_fx(tree, fx_is_pair_cadr_t)); - if (fx_proc(tree) == fx_is_symbol_cadr_s) return(with_fx(tree, fx_is_symbol_cadr_t)); - if (fx_proc(tree) == fx_is_pair_cddr_s) return(with_fx(tree, fx_is_pair_cddr_t)); - if (fx_proc(tree) == fx_is_null_cdr_s) return(with_fx(tree, fx_is_null_cdr_t)); - if (fx_proc(tree) == fx_is_null_cadr_s) return(with_fx(tree, fx_is_null_cadr_t)); - if (fx_proc(tree) == fx_is_null_cddr_s) return(with_fx(tree, fx_is_null_cddr_t)); - if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_t)); - if (fx_proc(tree) == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_t)); - if (fx_proc(tree) == fx_not_is_symbol_s) return(with_fx(tree, fx_not_is_symbol_t)); - if (fx_proc(tree) == fx_is_type_car_s) - return(with_fx(tree, (car(p) == sc->is_symbol_symbol) ? fx_is_symbol_car_t : fx_is_type_car_t)); - if (fx_proc(tree) == fx_c_opsq) - { - set_opt1_sym(cdr(p), cadadr(p)); - if ((is_global_and_has_func(car(p), s7_p_p_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function))) - { - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - return(with_fx(tree, fx_c_optq_direct)); - } - return(with_fx(tree, fx_c_optq)); - } - if (fx_proc(tree) == fx_c_car_s) return(with_fx(tree, fx_c_car_t)); - if (fx_proc(tree) == fx_c_cdr_s) return(with_fx(tree, fx_c_cdr_t)); - if (fx_proc(tree) == fx_is_type_opsq) return(with_fx(tree, fx_is_type_optq)); - if (fx_proc(tree) == fx_not_opsq) - { - set_opt1_sym(cdr(p), cadadr(p)); - return(with_fx(tree, (caadr(p) == sc->car_symbol) ? fx_not_car_t : fx_not_optq)); - }} - if (cadadr(p) == var2) - { - if (fx_proc(tree) == fx_c_car_s) return(with_fx(tree, fx_c_car_u)); - if (fx_proc(tree) == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_u)); - if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_u)); - if (fx_proc(tree) == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_u)); - } - if (cadadr(p) == var3) - { - if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_v)); - } - break; - - case HOP_SAFE_C_opSq_S: - if (cadadr(p) == var1) - { - if (fx_proc(tree) == fx_c_opsq_s) - { - if ((is_global_and_has_func(car(p), s7_p_pp_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function))) - { - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - return(with_fx(tree, fx_c_optq_s_direct)); - } - return(with_fx(tree, fx_c_optq_s)); - } - if (fx_proc(tree) == fx_c_opsq_s_direct) return(with_fx(tree, fx_c_optq_s_direct)); - if (fx_proc(tree) == fx_cons_car_s_s) - { - set_opt1_sym(cdr(p), var1); - return(with_fx(tree, (caddr(p) == var3) ? fx_cons_car_t_v : fx_cons_car_t_s)); - }} - if (cadadr(p) == var2) - { - if ((fx_proc(tree) == fx_c_opsq_s) && (caddr(p) == var1)) - { - if ((is_global_and_has_func(car(p), s7_p_pp_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function))) /* (memq (car sequence) items) lint */ - { - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - return(with_fx(tree, (car(p) == sc->cons_symbol) ? - ((caadr(p) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); - } - return(with_fx(tree, fx_c_opuq_t)); - } - if (((fx_proc(tree) == fx_c_opsq_s_direct) || (fx_proc(tree) == fx_cons_car_s_s)) && - (caddr(p) == var1)) - return(with_fx(tree, (car(p) == sc->cons_symbol) ? - ((caadr(p) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); - } - break; - - case HOP_SAFE_C_S_opSq: - if (cadr(p) == var1) - { - if (cadaddr(p) == var2) - { - if (fx_proc(tree) == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_u)); - if (fx_proc(tree) == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opuq_direct)); - } - if (cadaddr(p) == var3) - { - if (fx_proc(tree) == fx_add_s_car_s) return(with_fx(tree, fx_add_t_car_v)); - if (fx_proc(tree) == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_v)); /* ideally eq_p_pp not g_is_eq */ - } - if (fx_proc(tree) == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opsq_direct)); - } - if (cadr(p) == var2) - { - if ((fx_proc(tree) == fx_add_s_car_s) && (cadaddr(p) == var1)) return(with_fx(tree, fx_add_u_car_t)); - if ((fx_proc(tree) == fx_c_s_opsq_direct) && (cadaddr(p) == var3)) return(with_fx(tree, fx_c_u_opvq_direct)); - } - if ((cadaddr(p) == var1) && (fx_proc(tree) == fx_c_s_car_s)) return(with_fx(tree, fx_c_s_car_t)); - break; - - case HOP_SAFE_C_opSq_opSq: - if ((fx_proc(tree) == fx_c_opsq_opsq_direct) && (cadadr(p) == var1) && (cadadr(p) == cadaddr(p))) - { - set_opt1_sym(cdr(p), cadadr(p)); - return(with_fx(tree, fx_c_optq_optq_direct)); /* opuq got few hits */ - } - if (((fx_proc(tree) == fx_c_opsq_opsq_direct) || (fx_proc(tree) == fx_car_s_car_s)) && - ((caadr(p) == sc->car_symbol) && (caadr(p) == caaddr(p)))) - { - set_opt1_sym(cdr(p), cadadr(p)); - set_opt2_sym(cdr(p), cadaddr(p)); - return(with_fx(tree, ((cadadr(p) == var1) && (cadaddr(p) == var2)) ? - ((opt3_direct(p) == (s7_pointer)is_eq_p_pp) ? fx_is_eq_car_car_tu : fx_car_t_car_u) : fx_car_s_car_s)); - } - break; - - case HOP_SAFE_C_opSq_C: - if (cadadr(p) == var1) - { - if (fx_proc(tree) == fx_is_eq_car_sq) return(with_fx(tree, fx_is_eq_car_tq)); - if ((fx_proc(tree) == fx_c_opsq_c) || (fx_proc(tree) == fx_c_optq_c)) - { - if (fn_proc(p) != g_lint_let_ref) /* don't step on opt3_sym */ - { - if ((is_global_and_has_func(car(p), s7_p_pp_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function))) - { - if (fn_proc(p) == g_memq_2) - set_opt3_direct(p, (s7_pointer)memq_2_p_pp); - else set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - set_fx_direct(tree, fx_c_optq_c_direct); - return(true); - } - if ((is_t_integer(caddr(p))) && - (is_global_and_has_func(caadr(p), s7_i_7p_function)) && - (is_global_and_has_func(car(p), s7_p_ii_function))) - { - set_opt3_direct(p, (s7_pointer)(s7_p_ii_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_i_7p_function(global_value(caadr(p))))); - set_fx_direct(tree, fx_c_optq_i_direct); - } - else set_fx_direct(tree, fx_c_optq_c); - } - return(true); - }} - break; - - case HOP_SAFE_C_opSSq: - if (fx_proc(tree) == fx_c_opssq) - { - if (caddadr(p) == var1) return(with_fx(tree, fx_c_opstq)); - if ((cadadr(p) == var1) && (caddadr(p) == var2)) return(with_fx(tree, fx_c_optuq)); - } - if (fx_proc(tree) == fx_c_opssq_direct) - { - if ((cadadr(p) == var1) && (caddadr(p) == var2)) return(with_fx(tree, fx_c_optuq_direct)); - if (caddadr(p) == var1) - { - if ((opt2_direct(cdr(p)) == (s7_pointer)is_zero_p_p) && (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pp) && - (!more_vars) && (o_var_ok(cadadr(p), var1, var2, var3))) - return(with_fx(tree, fx_is_zero_remainder_o)); - return(with_fx(tree, fx_c_opstq_direct)); - }} - if ((cadadr(p) == var2) && (fx_proc(tree) == fx_not_opssq) && (caddadr(p) == var1)) - { - set_fx_direct(tree, (fn_proc(cadr(p)) == g_less_2) ? fx_not_lt_ut : fx_not_oputq); - return(true); - } - break; - - case HOP_SAFE_C_opSCq: - if (cadadr(p) == var1) - { - if ((fn_proc(p) == g_is_zero) && (fn_proc(cadr(p)) == g_remainder) && - (is_t_integer(caddadr(p))) && (integer(caddadr(p)) > 1)) - return(with_fx(tree, fx_is_zero_remainder_ti)); - return(with_fx(tree, fx_c_optcq)); /* there currently isn't any fx_c_opscq_direct */ - } - break; - - case HOP_SAFE_C_opSSq_C: - if ((fx_proc(tree) == fx_c_opssq_c) && (caddadr(p) == var1)) - { - if (is_global_and_has_func(car(p), s7_p_pp_function)) - { - if ((car(p) == sc->is_eq_symbol) && (!is_unspecified(caddr(p))) && (caadr(p) == sc->vector_ref_symbol) && - (!more_vars) && (o_var_ok(cadadr(p), var1, var2, var3))) - return(with_fx(tree, fx_is_eq_vref_opotq_c)); - set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - return(with_fx(tree, fx_c_opstq_c_direct)); - } - return(with_fx(tree, fx_c_opstq_c)); - } - break; - - case HOP_SAFE_C_S_opSCq: - if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_s_opscq_direct) return(with_fx(tree, (cadaddr(p) == var2) ? fx_c_t_opucq_direct : fx_c_t_opscq_direct)); - if ((fx_proc(tree) == fx_c_s_opsiq_direct) && (!more_vars) && (o_var_ok(cadaddr(p), var1, var2, var3))) return(with_fx(tree, fx_c_t_opoiq_direct)); - } - else - if ((cadr(p) == var2) && (cadaddr(p) == var1)) - { - if (fx_proc(tree) == fx_c_s_opsiq_direct) return(with_fx(tree, fx_c_u_optiq_direct)); - if (fx_proc(tree) == fx_c_s_opscq) return(with_fx(tree, fx_c_u_optcq)); - } - break; - - case HOP_SAFE_C_opSq_CS: - if ((cadadr(p) == var1) && (fx_proc(tree) == fx_c_opsq_cs) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_optq_cu)); - break; - - case HOP_SAFE_C_opSq_opSSq: - if ((fx_proc(tree) == fx_c_opsq_opssq) && (cadaddr(p) == var1) && (caddaddr(p) == var2) && - (is_global_and_has_func(car(p), s7_p_pp_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function)) && - (is_global_and_has_func(caaddr(p), s7_p_pp_function))) - { - set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(caaddr(p))))); - set_opt1_sym(cdr(p), var2); /* caddaddr(p) */ - - set_opt2_sym(cddr(p), var1); - if ((car(p) == sc->num_eq_symbol) && (caadr(p) == sc->car_symbol) && (cadadr(p) == var3)) - { - if (caaddr(p) == sc->add_symbol) return(with_fx(tree, fx_num_eq_car_v_add_tu)); - if (caaddr(p) == sc->subtract_symbol) return(with_fx(tree, fx_num_eq_car_v_subtract_tu)); - } - return(with_fx(tree, fx_c_opsq_optuq_direct)); - } - break; - - case HOP_SAFE_C_opSSq_S: - if (fx_proc(tree) == fx_vref_vref_ss_s) - { - if ((caddr(p) == var1) && (is_global(cadadr(p)))) - { - if ((!more_vars) && (o_var_ok(caddadr(p), var1, var2, var3))) return(with_fx(tree, fx_vref_vref_go_t)); - return(with_fx(tree, fx_vref_vref_gs_t)); - } - if ((cadadr(p) == var1) && (caddadr(p) == var2) && (caddr(p) == var3)) return(with_fx(tree, fx_vref_vref_tu_v)); - } - if ((fx_proc(tree) == fx_gt_add_s) && (cadadr(p) == var1) && (caddadr(p) == var2)) - return(with_fx(tree, fx_gt_add_tu_s)); - if ((fx_proc(tree) == fx_add_sub_s) && (cadadr(p) == var1) && (caddadr(p) == var2)) - return(with_fx(tree, fx_add_sub_tu_s)); - break; - - case HOP_SAFE_C_S_opSSq: - if (caddaddr(p) == var1) - { - if ((fn_proc(p) == g_vector_ref_2) && (is_global(cadr(p)) && (is_global(cadaddr(p))))) - { - set_opt3_pair(p, cdaddr(p)); - return(with_fx(tree, fx_vref_g_vref_gt)); - } - if (fx_proc(tree) == fx_c_s_opssq_direct) return(with_fx(tree, fx_c_s_opstq_direct)); - } - if ((fx_proc(tree) == fx_c_s_opssq_direct) && (cadr(p) == var1) && (caddaddr(p) == var2)) return(with_fx(tree, fx_c_t_opsuq_direct)); - break; - - case HOP_SAFE_C_op_opSq_Sq: - if ((car(p) == sc->not_symbol) && (is_global(sc->not_symbol)) && (var1 == cadr(cadadr(p)))) - return(with_fx(tree, fx_not_op_optq_sq)); - break; - - case HOP_SAFE_C_AC: - if (((fx_proc(tree) == fx_c_ac) || (fx_proc(tree) == fx_c_ac_direct)) && (fn_proc(p) == g_num_eq_xi) && (caddr(p) == int_zero) && - (fx_proc(cdr(p)) == fx_c_opuq_t_direct) && (caadr(p) == sc->remainder_symbol) && (fn_proc(cadadr(p)) == g_car)) - { - set_opt3_sym(p, cadr(cadadr(p))); - set_opt1_sym(cdr(p), caddadr(p)); - return(with_fx(tree, fx_is_zero_remainder_car)); - } - break; - - case HOP_SAFE_CLOSURE_S_A: - if ((cadr(p) == var1) && (fx_proc(tree) == fx_safe_closure_s_a)) return(with_fx(tree, fx_safe_closure_t_a)); - break; - - case OP_IF_S_A_A: - if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_if_o_a_a)); - break; - - case OP_AND_3A: - if ((fx_proc(tree) == fx_and_3a) && - (is_pair(cadr(p))) && - (is_pair(cdadr(p))) && (cadadr(p) == var1) && /* so "s" below is "t" */ - (((fx_proc(cdr(p)) == fx_is_pair_t) && (fx_proc(cddr(p)) == fx_is_pair_cdr_t)) || - ((fx_proc(cdr(p)) == fx_is_pair_s) && (fx_proc(cddr(p)) == fx_is_pair_cdr_s)))) - { - set_opt1_sym(cdr(p), cadadr(p)); - if ((fx_proc(cdddr(p)) == fx_is_null_cddr_t) || (fx_proc(cdddr(p)) == fx_is_null_cddr_s)) - return(with_fx(tree, fx_len2_t)); - if ((fx_proc(cdddr(p)) == fx_is_pair_cddr_t) || (fx_proc(cdddr(p)) == fx_is_pair_cddr_s)) - return(with_fx(tree, fx_len3_t)); - } - break; - } -#if 0 - if ((var3) && ((s7_tree_memq(sc, var1, car(tree))) || ((var2) && (s7_tree_memq(sc, var2, car(tree)))) || ((var3) && (s7_tree_memq(sc, var3, car(tree)))))) - fprintf(stderr, "fx_tree_in %s %s %s: %s %s\n", - display(var1), (var2) ? display(var2) : "", (var3) ? display(var3) : "", display_80(car(tree)), op_names[optimize_op(car(tree))]); -#endif - return(false); -} - -static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars) -{ - /* if (is_pair(tree)) fprintf(stderr, "fx_tree %s %d %d\n", display(tree), has_fx(tree), is_syntax(car(tree))); */ - if (!is_pair(tree)) return; - if ((is_symbol(car(tree))) && - (is_definer_or_binder(car(tree)))) - { - if ((car(tree) == sc->let_symbol) && (is_pair(cdr(tree))) && (is_pair(cadr(tree))) && - (is_null(cdadr(tree))) && (is_pair(caadr(tree)))) /* (let (a) ...) */ - fx_tree(sc, cddr(tree), caaadr(tree), NULL, NULL, more_vars); - return; - } - if (is_syntax(car(tree))) return; /* someday let #_when/#_if etc through -- the symbol 'if, for example, is not syntax */ - - if ((!has_fx(tree)) || - (!fx_tree_in(sc, tree, var1, var2, var3, more_vars))) - fx_tree(sc, car(tree), var1, var2, var3, more_vars); - fx_tree(sc, cdr(tree), var1, var2, var3, more_vars); -} - -/* -------------------------------------------------------------------------------- */ -static opt_funcs_t *alloc_semipermanent_opt_func(s7_scheme *sc) -{ - if (sc->alloc_opt_func_k == ALLOC_FUNCTION_SIZE) - { - sc->alloc_opt_func_cells = (opt_funcs_t *)Malloc(ALLOC_FUNCTION_SIZE * sizeof(opt_funcs_t)); - add_saved_pointer(sc, sc->alloc_opt_func_cells); - sc->alloc_opt_func_k = 0; - } - return(&(sc->alloc_opt_func_cells[sc->alloc_opt_func_k++])); -} - -static void add_opt_func(s7_scheme *sc, s7_pointer f, opt_func_t typ, void *func) -{ - opt_funcs_t *op; -#if S7_DEBUGGING - static const char *o_names[] = {"o_d_v", "o_d_vd", "o_d_vdd", "o_d_vid", "o_d_id", "o_d_7pi", "o_d_7pii", "o_d_7piid", "o_d_7piii", "o_d_7piiid", - "o_d_ip", "o_d_pd", "o_d_7pid", "o_d", "o_d_d", "o_d_dd", "o_d_7dd", "o_d_ddd", "o_d_dddd", - "o_i_i", "o_i_7i", "o_i_ii", "o_i_7ii", "o_i_iii", "o_i_7pi", "o_i_7pii", "o_i_7_piii", "o_d_p", - "o_b_p", "o_b_7p", "o_b_pp", "o_b_7pp", "o_b_pp_unchecked", "o_b_pi", "o_b_ii", "o_b_7ii", "o_b_dd", - "o_p", "o_p_p", "o_p_ii", "o_p_d", "o_p_dd", "o_i_7d", "o_i_7p", "o_d_7d", "o_p_pp", "o_p_ppp", "o_p_pi", "o_p_pi_unchecked", - "o_p_ppi", "o_p_i", "o_p_pii", "o_p_pip", "o_p_pip_unchecked", "o_p_piip", "o_b_i", "o_b_d"}; - if (!is_c_function(f)) - { - fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, display(f)); - if (sc->stop_at_error) abort(); - } - else - if (c_function_opt_data(f)) - for (opt_funcs_t *p = c_function_opt_data(f); p; p = p->next) - { - if (p->typ == typ) - fprintf(stderr, "%s[%d]: %s has a function of type %d (%s)\n", - __func__, __LINE__, display(f), typ, o_names[typ]); - if (p->func == func) - fprintf(stderr, "%s[%d]: %s already has this function as type %d %s (current: %d %s)\n", - __func__, __LINE__, display(f), p->typ, o_names[p->typ], typ, o_names[typ]); - } -#endif - op = alloc_semipermanent_opt_func(sc); - op->typ = typ; - op->func = func; - op->next = c_function_opt_data(f); - c_function_opt_data(f) = op; -} - -static void *opt_func(s7_pointer f, opt_func_t typ) -{ - if (is_c_function(f)) - for (opt_funcs_t *p = c_function_opt_data(f); p; p = p->next) - if (p->typ == typ) - return(p->func); - return(NULL); -} - -/* clm2xen.c */ -void s7_set_d_function(s7_scheme *sc, s7_pointer f, s7_d_t df) {add_opt_func(sc, f, o_d, (void *)df);} -s7_d_t s7_d_function(s7_pointer f) {return((s7_d_t)opt_func(f, o_d));} - -void s7_set_d_d_function(s7_scheme *sc, s7_pointer f, s7_d_d_t df) {add_opt_func(sc, f, o_d_d, (void *)df);} -s7_d_d_t s7_d_d_function(s7_pointer f) {return((s7_d_d_t)opt_func(f, o_d_d));} - -void s7_set_d_dd_function(s7_scheme *sc, s7_pointer f, s7_d_dd_t df) {add_opt_func(sc, f, o_d_dd, (void *)df);} -s7_d_dd_t s7_d_dd_function(s7_pointer f) {return((s7_d_dd_t)opt_func(f, o_d_dd));} - -void s7_set_d_v_function(s7_scheme *sc, s7_pointer f, s7_d_v_t df) {add_opt_func(sc, f, o_d_v, (void *)df);} -s7_d_v_t s7_d_v_function(s7_pointer f) {return((s7_d_v_t)opt_func(f, o_d_v));} - -void s7_set_d_vd_function(s7_scheme *sc, s7_pointer f, s7_d_vd_t df) {add_opt_func(sc, f, o_d_vd, (void *)df);} -s7_d_vd_t s7_d_vd_function(s7_pointer f) {return((s7_d_vd_t)opt_func(f, o_d_vd));} - -void s7_set_d_vdd_function(s7_scheme *sc, s7_pointer f, s7_d_vdd_t df) {add_opt_func(sc, f, o_d_vdd, (void *)df);} -s7_d_vdd_t s7_d_vdd_function(s7_pointer f) {return((s7_d_vdd_t)opt_func(f, o_d_vdd));} - -void s7_set_d_vid_function(s7_scheme *sc, s7_pointer f, s7_d_vid_t df) {add_opt_func(sc, f, o_d_vid, (void *)df);} -s7_d_vid_t s7_d_vid_function(s7_pointer f) {return((s7_d_vid_t)opt_func(f, o_d_vid));} - -void s7_set_d_id_function(s7_scheme *sc, s7_pointer f, s7_d_id_t df) {add_opt_func(sc, f, o_d_id, (void *)df);} -s7_d_id_t s7_d_id_function(s7_pointer f) {return((s7_d_id_t)opt_func(f, o_d_id));} - -void s7_set_d_7pid_function(s7_scheme *sc, s7_pointer f, s7_d_7pid_t df) {add_opt_func(sc, f, o_d_7pid, (void *)df);} -s7_d_7pid_t s7_d_7pid_function(s7_pointer f) {return((s7_d_7pid_t)opt_func(f, o_d_7pid));} - -void s7_set_d_ip_function(s7_scheme *sc, s7_pointer f, s7_d_ip_t df) {add_opt_func(sc, f, o_d_ip, (void *)df);} -s7_d_ip_t s7_d_ip_function(s7_pointer f) {return((s7_d_ip_t)opt_func(f, o_d_ip));} - -void s7_set_d_pd_function(s7_scheme *sc, s7_pointer f, s7_d_pd_t df) {add_opt_func(sc, f, o_d_pd, (void *)df);} -s7_d_pd_t s7_d_pd_function(s7_pointer f) {return((s7_d_pd_t)opt_func(f, o_d_pd));} - -void s7_set_d_p_function(s7_scheme *sc, s7_pointer f, s7_d_p_t df) {add_opt_func(sc, f, o_d_p, (void *)df);} -s7_d_p_t s7_d_p_function(s7_pointer f) {return((s7_d_p_t)opt_func(f, o_d_p));} - -void s7_set_b_p_function(s7_scheme *sc, s7_pointer f, s7_b_p_t df) {add_opt_func(sc, f, o_b_p, (void *)df);} -s7_b_p_t s7_b_p_function(s7_pointer f) {return((s7_b_p_t)opt_func(f, o_b_p));} - -void s7_set_d_7pi_function(s7_scheme *sc, s7_pointer f, s7_d_7pi_t df) {add_opt_func(sc, f, o_d_7pi, (void *)df);} -s7_d_7pi_t s7_d_7pi_function(s7_pointer f) {return((s7_d_7pi_t)opt_func(f, o_d_7pi));} - -static void s7_set_d_7pii_function(s7_scheme *sc, s7_pointer f, s7_d_7pii_t df) {add_opt_func(sc, f, o_d_7pii, (void *)df);} -static s7_d_7pii_t s7_d_7pii_function(s7_pointer f) {return((s7_d_7pii_t)opt_func(f, o_d_7pii));} - -static void s7_set_d_7piii_function(s7_scheme *sc, s7_pointer f, s7_d_7piii_t df) {add_opt_func(sc, f, o_d_7piii, (void *)df);} -static s7_d_7piii_t s7_d_7piii_function(s7_pointer f) {return((s7_d_7piii_t)opt_func(f, o_d_7piii));} - -void s7_set_i_7p_function(s7_scheme *sc, s7_pointer f, s7_i_7p_t df) {add_opt_func(sc, f, o_i_7p, (void *)df);} -s7_i_7p_t s7_i_7p_function(s7_pointer f) {return((s7_i_7p_t)opt_func(f, o_i_7p));} - -/* cload.scm */ -void s7_set_d_ddd_function(s7_scheme *sc, s7_pointer f, s7_d_ddd_t df) {add_opt_func(sc, f, o_d_ddd, (void *)df);} -s7_d_ddd_t s7_d_ddd_function(s7_pointer f) {return((s7_d_ddd_t)opt_func(f, o_d_ddd));} - -void s7_set_d_dddd_function(s7_scheme *sc, s7_pointer f, s7_d_dddd_t df) {add_opt_func(sc, f, o_d_dddd, (void *)df);} -s7_d_dddd_t s7_d_dddd_function(s7_pointer f) {return((s7_d_dddd_t)opt_func(f, o_d_dddd));} - -void s7_set_i_i_function(s7_scheme *sc, s7_pointer f, s7_i_i_t df) {add_opt_func(sc, f, o_i_i, (void *)df);} -s7_i_i_t s7_i_i_function(s7_pointer f) {return((s7_i_i_t)opt_func(f, o_i_i));} - -void s7_set_i_ii_function(s7_scheme *sc, s7_pointer f, s7_i_ii_t df) {add_opt_func(sc, f, o_i_ii, (void *)df);} -s7_i_ii_t s7_i_ii_function(s7_pointer f) {return((s7_i_ii_t)opt_func(f, o_i_ii));} - -void s7_set_i_7d_function(s7_scheme *sc, s7_pointer f, s7_i_7d_t df) {add_opt_func(sc, f, o_i_7d, (void *)df);} -s7_i_7d_t s7_i_7d_function(s7_pointer f) {return((s7_i_7d_t)opt_func(f, o_i_7d));} - -/* s7test.scm */ -void s7_set_p_d_function(s7_scheme *sc, s7_pointer f, s7_p_d_t df) {add_opt_func(sc, f, o_p_d, (void *)df);} -s7_p_d_t s7_p_d_function(s7_pointer f) {return((s7_p_d_t)opt_func(f, o_p_d));} - -static void s7_set_d_7dd_function(s7_scheme *sc, s7_pointer f, s7_d_7dd_t df) {add_opt_func(sc, f, o_d_7dd, (void *)df);} -static s7_d_7dd_t s7_d_7dd_function(s7_pointer f) {return((s7_d_7dd_t)opt_func(f, o_d_7dd));} - -static void s7_set_i_7i_function(s7_scheme *sc, s7_pointer f, s7_i_7i_t df) {add_opt_func(sc, f, o_i_7i, (void *)df);} -static s7_i_7i_t s7_i_7i_function(s7_pointer f) {return((s7_i_7i_t)opt_func(f, o_i_7i));} - -static void s7_set_i_7ii_function(s7_scheme *sc, s7_pointer f, s7_i_7ii_t df) {add_opt_func(sc, f, o_i_7ii, (void *)df);} -static s7_i_7ii_t s7_i_7ii_function(s7_pointer f) {return((s7_i_7ii_t)opt_func(f, o_i_7ii));} - -static void s7_set_i_iii_function(s7_scheme *sc, s7_pointer f, s7_i_iii_t df) {add_opt_func(sc, f, o_i_iii, (void *)df);} -s7_i_iii_t s7_i_iii_function(s7_pointer f) {return((s7_i_iii_t)opt_func(f, o_i_iii));} - -static void s7_set_p_pi_function(s7_scheme *sc, s7_pointer f, s7_p_pi_t df) {add_opt_func(sc, f, o_p_pi, (void *)df);} -static s7_p_pi_t s7_p_pi_function(s7_pointer f) {return((s7_p_pi_t)opt_func(f, o_p_pi));} - -static void s7_set_p_ppi_function(s7_scheme *sc, s7_pointer f, s7_p_ppi_t df) {add_opt_func(sc, f, o_p_ppi, (void *)df);} -static s7_p_ppi_t s7_p_ppi_function(s7_pointer f) {return((s7_p_ppi_t)opt_func(f, o_p_ppi));} - -static void s7_set_i_7pi_function(s7_scheme *sc, s7_pointer f, s7_i_7pi_t df) {add_opt_func(sc, f, o_i_7pi, (void *)df);} -static s7_i_7pi_t s7_i_7pi_function(s7_pointer f) {return((s7_i_7pi_t)opt_func(f, o_i_7pi));} - -static void s7_set_i_7pii_function(s7_scheme *sc, s7_pointer f, s7_i_7pii_t df) {add_opt_func(sc, f, o_i_7pii, (void *)df);} -static s7_i_7pii_t s7_i_7pii_function(s7_pointer f) {return((s7_i_7pii_t)opt_func(f, o_i_7pii));} - -static void s7_set_i_7piii_function(s7_scheme *sc, s7_pointer f, s7_i_7piii_t df) {add_opt_func(sc, f, o_i_7piii, (void *)df);} -static s7_i_7piii_t s7_i_7piii_function(s7_pointer f) {return((s7_i_7piii_t)opt_func(f, o_i_7piii));} - -static void s7_set_b_d_function(s7_scheme *sc, s7_pointer f, s7_b_d_t df) {add_opt_func(sc, f, o_b_d, (void *)df);} -static s7_b_d_t s7_b_d_function(s7_pointer f) {return((s7_b_d_t)opt_func(f, o_b_d));} - -static void s7_set_b_i_function(s7_scheme *sc, s7_pointer f, s7_b_i_t df) {add_opt_func(sc, f, o_b_i, (void *)df);} -static s7_b_i_t s7_b_i_function(s7_pointer f) {return((s7_b_i_t)opt_func(f, o_b_i));} - -static void s7_set_b_7p_function(s7_scheme *sc, s7_pointer f, s7_b_7p_t df) {add_opt_func(sc, f, o_b_7p, (void *)df);} -static s7_b_7p_t s7_b_7p_function(s7_pointer f) {return((s7_b_7p_t)opt_func(f, o_b_7p));} - -static void s7_set_b_pp_function(s7_scheme *sc, s7_pointer f, s7_b_pp_t df) {add_opt_func(sc, f, o_b_pp, (void *)df);} -static s7_b_pp_t s7_b_pp_function(s7_pointer f) {return((s7_b_pp_t)opt_func(f, o_b_pp));} - -static void s7_set_b_7pp_function(s7_scheme *sc, s7_pointer f, s7_b_7pp_t df) {add_opt_func(sc, f, o_b_7pp, (void *)df);} -static s7_b_7pp_t s7_b_7pp_function(s7_pointer f) {return((s7_b_7pp_t)opt_func(f, o_b_7pp));} - -static void s7_set_d_7d_function(s7_scheme *sc, s7_pointer f, s7_d_7d_t df) {add_opt_func(sc, f, o_d_7d, (void *)df);} -static s7_d_7d_t s7_d_7d_function(s7_pointer f) {return((s7_d_7d_t)opt_func(f, o_d_7d));} - -static void s7_set_b_pi_function(s7_scheme *sc, s7_pointer f, s7_b_pi_t df) {add_opt_func(sc, f, o_b_pi, (void *)df);} -static s7_b_pi_t s7_b_pi_function(s7_pointer f) {return((s7_b_pi_t)opt_func(f, o_b_pi));} - -static void s7_set_b_ii_function(s7_scheme *sc, s7_pointer f, s7_b_ii_t df) {add_opt_func(sc, f, o_b_ii, (void *)df);} -static s7_b_ii_t s7_b_ii_function(s7_pointer f) {return((s7_b_ii_t)opt_func(f, o_b_ii));} - -static void s7_set_b_7ii_function(s7_scheme *sc, s7_pointer f, s7_b_7ii_t df) {add_opt_func(sc, f, o_b_7ii, (void *)df);} -static s7_b_7ii_t s7_b_7ii_function(s7_pointer f) {return((s7_b_7ii_t)opt_func(f, o_b_7ii));} - -static void s7_set_b_dd_function(s7_scheme *sc, s7_pointer f, s7_b_dd_t df) {add_opt_func(sc, f, o_b_dd, (void *)df);} -static s7_b_dd_t s7_b_dd_function(s7_pointer f) {return((s7_b_dd_t)opt_func(f, o_b_dd));} - -void s7_set_p_p_function(s7_scheme *sc, s7_pointer f, s7_p_p_t df) {add_opt_func(sc, f, o_p_p, (void *)df);} -s7_p_p_t s7_p_p_function(s7_pointer f) {return((s7_p_p_t)opt_func(f, o_p_p));} - -static void s7_set_p_function(s7_scheme *sc, s7_pointer f, s7_p_t df) {add_opt_func(sc, f, o_p, (void *)df);} -static s7_p_t s7_p_function(s7_pointer f) {return((s7_p_t)opt_func(f, o_p));} - -void s7_set_p_pp_function(s7_scheme *sc, s7_pointer f, s7_p_pp_t df) {add_opt_func(sc, f, o_p_pp, (void *)df);} -s7_p_pp_t s7_p_pp_function(s7_pointer f) {return((s7_p_pp_t)opt_func(f, o_p_pp));} - -void s7_set_p_ppp_function(s7_scheme *sc, s7_pointer f, s7_p_ppp_t df) {add_opt_func(sc, f, o_p_ppp, (void *)df);} -s7_p_ppp_t s7_p_ppp_function(s7_pointer f) {return((s7_p_ppp_t)opt_func(f, o_p_ppp));} - -static void s7_set_p_pip_function(s7_scheme *sc, s7_pointer f, s7_p_pip_t df) {add_opt_func(sc, f, o_p_pip, (void *)df);} -static s7_p_pip_t s7_p_pip_function(s7_pointer f) {return((s7_p_pip_t)opt_func(f, o_p_pip));} - -static void s7_set_p_pii_function(s7_scheme *sc, s7_pointer f, s7_p_pii_t df) {add_opt_func(sc, f, o_p_pii, (void *)df);} -static s7_p_pii_t s7_p_pii_function(s7_pointer f) {return((s7_p_pii_t)opt_func(f, o_p_pii));} - -static void s7_set_p_piip_function(s7_scheme *sc, s7_pointer f, s7_p_piip_t df) {add_opt_func(sc, f, o_p_piip, (void *)df);} -static s7_p_piip_t s7_p_piip_function(s7_pointer f) {return((s7_p_piip_t)opt_func(f, o_p_piip));} - -static void s7_set_p_pi_unchecked_function(s7_scheme *sc, s7_pointer f, s7_p_pi_t df) {add_opt_func(sc, f, o_p_pi_unchecked, (void *)df);} -static s7_p_pi_t s7_p_pi_unchecked_function(s7_pointer f) {return((s7_p_pi_t)opt_func(f, o_p_pi_unchecked));} - -static void s7_set_p_pip_unchecked_function(s7_scheme *sc, s7_pointer f, s7_p_pip_t df) {add_opt_func(sc, f, o_p_pip_unchecked, (void *)df);} -static s7_p_pip_t s7_p_pip_unchecked_function(s7_pointer f) {return((s7_p_pip_t)opt_func(f, o_p_pip_unchecked));} - -static void s7_set_b_pp_unchecked_function(s7_scheme *sc, s7_pointer f, s7_b_pp_t df) {add_opt_func(sc, f, o_b_pp_unchecked, (void *)df);} -static s7_b_pp_t s7_b_pp_unchecked_function(s7_pointer f) {return((s7_b_pp_t)opt_func(f, o_b_pp_unchecked));} - -static void s7_set_p_i_function(s7_scheme *sc, s7_pointer f, s7_p_i_t df) {add_opt_func(sc, f, o_p_i, (void *)df);} -static s7_p_i_t s7_p_i_function(s7_pointer f) {return((s7_p_i_t)opt_func(f, o_p_i));} - -static void s7_set_p_ii_function(s7_scheme *sc, s7_pointer f, s7_p_ii_t df) {add_opt_func(sc, f, o_p_ii, (void *)df);} -static s7_p_ii_t s7_p_ii_function(s7_pointer f) {return((s7_p_ii_t)opt_func(f, o_p_ii));} - -static void s7_set_d_7piid_function(s7_scheme *sc, s7_pointer f, s7_d_7piid_t df) {add_opt_func(sc, f, o_d_7piid, (void *)df);} -static s7_d_7piid_t s7_d_7piid_function(s7_pointer f) {return((s7_d_7piid_t)opt_func(f, o_d_7piid));} - -static void s7_set_d_7piiid_function(s7_scheme *sc, s7_pointer f, s7_d_7piiid_t df) {add_opt_func(sc, f, o_d_7piiid, (void *)df);} -static s7_d_7piiid_t s7_d_7piiid_function(s7_pointer f) {return((s7_d_7piiid_t)opt_func(f, o_d_7piiid));} - -static void s7_set_p_dd_function(s7_scheme *sc, s7_pointer f, s7_p_dd_t df) {add_opt_func(sc, f, o_p_dd, (void *)df);} -static s7_p_dd_t s7_p_dd_function(s7_pointer f) {return((s7_p_dd_t)opt_func(f, o_p_dd));} - -static opt_info *alloc_opt_info(s7_scheme *sc) -{ - opt_info *o; - if (sc->pc >= OPTS_SIZE) - sc->pc = OPTS_SIZE - 1; - o = sc->opts[sc->pc++]; - o->v[O_WRAP].fd = NULL; /* see bool_optimize -- this is a kludge */ - return(o); -} - -#define backup_pc(sc) sc->pc-- - -#define OPT_PRINT 0 -#if OPT_PRINT - -#define green_text "\033[32m" -#define blue_text "\033[34m" -#define red_text "\033[31m" -#define uncolor_text "\033[0m" /* yellow=33 */ - -#define return_false(Sc, Expr) return(return_false_1(Sc, Expr, __func__, __LINE__)) -static bool return_false_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line) -{ - if (expr) - fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT, func, line, UNBOLD_TEXT, display_80(expr)); - else fprintf(stderr, " %s%s[%d]%s: false\n", BOLD_TEXT, func, line, UNBOLD_TEXT); - return(false); -} - -#define return_true(Sc, Expr) return(return_true_1(Sc, Expr, __func__, __LINE__)) -static bool return_true_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line) -{ - if (expr) - fprintf(stderr, " %s%s[%d]%s: %s\n", blue_text, func, line, uncolor_text, display_80(expr)); - else fprintf(stderr, " %s%s[%d]%s: true\n", blue_text, func, line, uncolor_text); - return(true); -} - -#define return_success(Sc, P, Expr) return(return_success_1(Sc, P, Expr, __func__, __LINE__)) -static s7_pfunc return_success_1(s7_scheme *sc, s7_pfunc p, s7_pointer expr, const char *func, int32_t line) -{ - fprintf(stderr, " %s%s[%d]%s: %s\n", BOLD_TEXT green_text, func, line, UNBOLD_TEXT uncolor_text, display(expr)); - return(p); -} - -#define return_null(Sc, Expr) return(return_null_1(Sc, Expr, __func__, __LINE__)) -static s7_pfunc return_null_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line) -{ - fprintf(stderr, " %s%s[%d]%s: %s\n %sfailure%s\n", BOLD_TEXT, func, line, UNBOLD_TEXT, display_80(expr), BOLD_TEXT red_text, UNBOLD_TEXT uncolor_text); - return(NULL); -} -#else -#define return_false(Sc, Expr) return(false) -#define return_true(Sc, Expr) return(true) -#define return_success(Sc, P, Expr) return(P) -#define return_null(Sc, Expr) return(NULL) -#endif - -static s7_pointer opt_integer_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (is_symbol(sym)) - { - s7_pointer p = lookup_slot_from(sym, sc->curlet); - if ((is_slot(p)) && - (is_t_integer(slot_value(p)))) - return(p); - } - return(NULL); -} - -static s7_pointer opt_real_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (is_symbol(sym)) - { - s7_pointer p = lookup_slot_from(sym, sc->curlet); - if ((is_slot(p)) && - (is_small_real(slot_value(p)))) - return(p); - } - return(NULL); -} - -static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (is_symbol(sym)) - { - s7_pointer p = lookup_slot_from(sym, sc->curlet); - if ((is_slot(p)) && - (is_t_real(slot_value(p)))) - return(p); - } - return(NULL); -} - -static s7_pointer opt_simple_symbol(s7_scheme *sc, s7_pointer sym) -{ - s7_pointer p = lookup_slot_from(sym, sc->curlet); - if ((is_slot(p)) && - (!has_methods(slot_value(p)))) - return(p); - return(NULL); -} - -static s7_pointer opt_types_match(s7_scheme *sc, s7_pointer check, s7_pointer sym) -{ - s7_pointer checker = s7_symbol_value(sc, check); - s7_pointer slot = lookup_slot_from(sym, sc->curlet); - if (is_slot(slot)) - { - s7_pointer obj = slot_value(slot); - if (s7_apply_function(sc, checker, set_plist_1(sc, obj)) == sc->T) - return(slot); - } - return(NULL); -} - -static s7_pointer opt_bool_any(s7_scheme *sc) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);} -static s7_pointer opt_float_any_nv(s7_scheme *sc) {sc->opts[0]->v[0].fd(sc->opts[0]); return(NULL);} -static s7_pointer opt_int_any_nv(s7_scheme *sc) {sc->opts[0]->v[0].fi(sc->opts[0]); return(NULL);} -static s7_pointer opt_bool_any_nv(s7_scheme *sc) {sc->opts[0]->v[0].fb(sc->opts[0]); return(NULL);} -static s7_pointer opt_cell_any_nv(s7_scheme *sc) {return(sc->opts[0]->v[0].fp(sc->opts[0]));} /* this is faster than returning null */ - -static s7_pointer opt_wrap_float(s7_scheme *sc) {return(make_real(sc, sc->opts[0]->v[0].fd(sc->opts[0])));} -static s7_pointer opt_wrap_int(s7_scheme *sc) {return(make_integer(sc, sc->opts[0]->v[0].fi(sc->opts[0])));} -static s7_pointer opt_wrap_cell(s7_scheme *sc) {return(sc->opts[0]->v[0].fp(sc->opts[0]));} -static s7_pointer opt_wrap_bool(s7_scheme *sc) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);} - -static bool p_to_b(opt_info *o) {return(o->v[O_WRAP].fp(o) != o->sc->F);} -static s7_pointer d_to_p(opt_info *o) {return(make_real(o->sc, o->v[O_WRAP].fd(o)));} -static s7_pointer d_to_p_nr(opt_info *o) {o->v[O_WRAP].fd(o); return(NULL);} -static s7_pointer i_to_p(opt_info *o) {return(make_integer(o->sc, o->v[O_WRAP].fi(o)));} -static s7_pointer i_to_p_nr(opt_info *o) {o->v[O_WRAP].fi(o); return(NULL);} - - -/* -------------------------------- int opts -------------------------------- */ -static bool int_optimize(s7_scheme *sc, s7_pointer expr); -static bool float_optimize(s7_scheme *sc, s7_pointer expr); - -static s7_int opt_i_c(opt_info *o) {return(o->v[1].i);} -static s7_int opt_i_s(opt_info *o) {return(integer(slot_value(o->v[1].p)));} - -static bool opt_int_not_pair(s7_scheme *sc, s7_pointer car_x) -{ - opt_info *opc; - s7_pointer p; - if (is_t_integer(car_x)) - { - opc = alloc_opt_info(sc); - opc->v[1].i = integer(car_x); - opc->v[0].fi = opt_i_c; - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, car_x); - if (!p) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - opc->v[1].p = p; - opc->v[0].fi = opt_i_s; - return_true(sc, car_x); -} - -/* -------- i_i|d|p -------- */ -static s7_int opt_i_i_c(opt_info *o) {return(o->v[2].i_i_f(o->v[1].i));} -static s7_int opt_i_i_s(opt_info *o) {return(o->v[2].i_i_f(integer(slot_value(o->v[1].p))));} -static s7_int opt_i_7i_c(opt_info *o) {return(o->v[2].i_7i_f(o->sc, o->v[1].i));} -static s7_int opt_i_7i_s(opt_info *o) {return(o->v[2].i_7i_f(o->sc, integer(slot_value(o->v[1].p))));} -static s7_int opt_i_7i_s_rand(opt_info *o) {return(random_i_7i(o->sc, integer(slot_value(o->v[1].p))));} -static s7_int opt_i_d_c(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[1].x));} -static s7_int opt_i_d_s(opt_info *o) {return(o->v[2].i_7d_f(o->sc, real(slot_value(o->v[1].p))));} - -static s7_int opt_i_i_f(opt_info *o) {return(o->v[2].i_i_f(o->v[4].fi(o->v[3].o1)));} -static s7_int opt_i_7i_f(opt_info *o) {return(o->v[2].i_7i_f(o->sc, o->v[4].fi(o->v[3].o1)));} -static s7_int opt_i_7d_f(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[4].fd(o->v[3].o1)));} -static s7_int opt_i_7p_f(opt_info *o) {return(o->v[2].i_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_int opt_i_7p_f_cint(opt_info *o) {return(char_to_integer_i_7p(o->sc, o->v[4].fp(o->v[3].o1)));} - -static s7_int opt_i_i_s_abs(opt_info *o) {return(abs_i_i(integer(slot_value(o->v[1].p))));} -static s7_int opt_i_i_f_abs(opt_info *o) {return(abs_i_i(o->v[4].fi(o->v[3].o1)));} - -static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_i_i_t func = s7_i_i_function(s_func); - s7_i_7i_t func7 = NULL; - s7_i_7p_t ipf; - s7_pointer p; - int32_t start = sc->pc; - opc->v[3].o1 = sc->opts[start]; - if (!func) - func7 = s7_i_7i_function(s_func); - if ((func) || (func7)) - { - if (func) - opc->v[2].i_i_f = func; - else opc->v[2].i_7i_f = func7; - if (is_t_integer(cadr(car_x))) - { - if (opc->v[2].i_i_f == subtract_i_i) - { - opc->v[1].i = -integer(cadr(car_x)); - opc->v[0].fi = opt_i_c; - } - else - { - opc->v[1].i = integer(cadr(car_x)); - opc->v[0].fi = (func) ? opt_i_i_c : opt_i_7i_c; - } - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_s_abs : opt_i_i_s) : ((func7 == random_i_7i) ? opt_i_7i_s_rand : opt_i_7i_s); - return_true(sc, car_x); - } - if (int_optimize(sc, cdr(car_x))) - { - opc->v[4].fi = sc->opts[start]->v[0].fi; - opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_f_abs : opt_i_i_f) : opt_i_7i_f; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - if (!is_t_ratio(cadr(car_x))) - { - s7_i_7d_t idf = s7_i_7d_function(s_func); - if (idf) - { - opc->v[2].i_7d_f = idf; - if (is_small_real(cadr(car_x))) - { - opc->v[1].x = s7_number_to_real(sc, cadr(car_x)); - opc->v[0].fi = opt_i_d_c; - return_true(sc, car_x); - } - p = opt_float_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - opc->v[0].fi = opt_i_d_s; - return_true(sc, car_x); - } - if (float_optimize(sc, cdr(car_x))) - { - opc->v[0].fi = opt_i_7d_f; - opc->v[4].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - ipf = s7_i_7p_function(s_func); - if (ipf) - { - opc->v[2].i_7p_f = ipf; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fi = (ipf == char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f; - opc->v[4].fp = sc->opts[start]->v[0].fp; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - return_false(sc, car_x); -} - - -/* -------- i_pi -------- */ - -static s7_int opt_i_7pi_ss(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_int opt_7pi_ss_ivref(opt_info *o) {return(int_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_int opt_7pi_ss_bvref(opt_info *o) {return(byte_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_int opt_i_7pi_sf(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} - -static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer sig; - s7_i_7pi_t pfunc = s7_i_7pi_function(s_func); - if (!pfunc) - return_false(sc, car_x); - sig = c_function_signature(s_func); - if (is_pair(sig)) - { - s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); - int32_t start = sc->pc; - if ((is_symbol(cadr(sig))) && - (is_symbol(arg1)) && - (slot = opt_types_match(sc, cadr(sig), arg1))) - { - s7_pointer p; - opc->v[1].p = slot; - if ((s_func == global_value(sc->int_vector_ref_symbol)) && /* ivref etc */ - ((!is_int_vector(slot_value(slot))) || - (vector_rank(slot_value(slot)) > 1))) - return_false(sc, car_x); - if ((s_func == global_value(sc->byte_vector_ref_symbol)) && /* bvref etc */ - ((!is_byte_vector(slot_value(slot))) || - (vector_rank(slot_value(slot)) > 1))) - return_false(sc, car_x); - - opc->v[3].i_7pi_f = pfunc; - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - opc->v[0].fi = opt_i_7pi_ss; - if ((s_func == global_value(sc->int_vector_ref_symbol)) && - (step_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) - { - opc->v[0].fi = opt_7pi_ss_ivref; - opc->v[3].i_7pi_f = int_vector_ref_i_7pi_direct; - } - else - if ((s_func == global_value(sc->byte_vector_ref_symbol)) && - (step_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) - { - opc->v[0].fi = opt_7pi_ss_bvref; - opc->v[3].i_7pi_f = byte_vector_ref_i_7pi_direct; - } - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fi = opt_i_7pi_sf; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- i_ii -------- */ -static s7_int opt_i_ii_cc(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, o->v[2].i));} -static s7_int opt_i_ii_cs(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, integer(slot_value(o->v[2].p))));} -static s7_int opt_i_ii_cs_mul(opt_info *o) {return(o->v[1].i * integer(slot_value(o->v[2].p)));} -static s7_int opt_i_ii_sc(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));} -static s7_int opt_i_ii_sc_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + o->v[2].i);} /* +1 is not faster */ -static s7_int opt_i_ii_sc_sub(opt_info *o) {return(integer(slot_value(o->v[1].p)) - o->v[2].i);} /* -1 is not faster */ -static s7_int opt_i_ii_ss(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static s7_int opt_i_ii_ss_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p)));} -static s7_pointer opt_p_ii_ss_add(opt_info *o) {return(make_integer(o->sc, integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p))));} -static s7_int opt_i_ii_cf(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_ii_cf_mul(opt_info *o) {return(o->v[1].i * o->v[5].fi(o->v[4].o1));} -static s7_int opt_i_ii_sf(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_ii_sf_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + o->v[5].fi(o->v[4].o1));} -static s7_int opt_i_ii_ff(opt_info *o) {return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));} -static s7_int opt_i_7ii_ff_quo(opt_info *o){return(quotient_i_7ii(o->sc,o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));} -static s7_int opt_i_ii_fc(opt_info *o) {return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));} -static s7_int opt_i_ii_fc_add(opt_info *o) {return(o->v[11].fi(o->v[10].o1) + o->v[2].i);} -static s7_int opt_i_ii_fc_mul(opt_info *o) {return(o->v[11].fi(o->v[10].o1) * o->v[2].i);} -/* returning s7_int so overflow->real is not doable here, so - * (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (* (lognot 4294967297) 4294967297)))) (func) (func) - * will return -12884901890 rather than -18446744086594454000.0, 4294967297 > sqrt(fixmost) - * This affects all the opt arithmetical functions. Unfortunately the gmp version also gets -12884901890! - * We need to make sure none of these are available in the gmp version. - */ -static s7_int opt_i_7ii_fc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[11].fi(o->v[10].o1), o->v[2].i));} -static s7_int opt_i_ii_fco(opt_info *o) {return(o->v[3].i_ii_f(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));} -static s7_int opt_i_ii_fco_ivref_add(opt_info *o){return(int_vector_ref_i_7pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))) + o->v[5].i);} /* tref */ -static s7_int opt_i_7ii_fco(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));} - -static bool i_ii_fc_combinable(s7_scheme *sc, opt_info *opc, s7_i_ii_t func) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fi == opt_i_7pi_ss) || (o1->v[0].fi == opt_7pi_ss_ivref)) - { - opc->v[5].i = opc->v[2].i; /* move v2.i ("c" in fc = arg2) out of the symbols' way */ - opc->v[4].i_7pi_f = o1->v[3].i_7pi_f; - opc->v[1].p = o1->v[1].p; - opc->v[2].p = o1->v[2].p; - if (func) - opc->v[0].fi = ((opc->v[3].i_ii_f == add_i_ii) && (opc->v[4].i_7pi_f == int_vector_ref_i_7pi_direct)) ? opt_i_ii_fco_ivref_add : opt_i_ii_fco; - else opc->v[0].fi = opt_i_7ii_fco; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static s7_int opt_i_7ii_cc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[2].i));} -static s7_int opt_i_7ii_cs(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, integer(slot_value(o->v[2].p))));} -static s7_int opt_i_7ii_sc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));} -static s7_int opt_i_7ii_ss(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static s7_int opt_i_7ii_cf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_7ii_sf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));} - -static s7_int opt_i_7ii_ff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[3].i_7ii_f(o->sc, i1, i2)); -} - -#if WITH_GMP -static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc)));} -static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(o->v[1].i * next_random(o->sc)) - o->v[2].i);} -#else -static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc->default_random_state)));} -static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(o->v[1].i * next_random(o->sc->default_random_state)) - o->v[2].i);} -#endif - -static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_i_ii_t ifunc = s7_i_ii_function(s_func); - s7_i_7ii_t ifunc7 = NULL; - s7_pointer sig; - - if (!ifunc) - { - ifunc7 = s7_i_7ii_function(s_func); - if (!ifunc7) - return_false(sc, car_x); - } - sig = c_function_signature(s_func); - if (is_pair(sig)) - { - s7_pointer arg1 = cadr(car_x); - s7_pointer arg2 = caddr(car_x); - int32_t start = sc->pc; - s7_pointer p; - if (ifunc) - opc->v[3].i_ii_f = ifunc; - else opc->v[3].i_7ii_f = ifunc7; - - if (is_t_integer(arg1)) - { - opc->v[1].i = integer(arg1); - if (is_t_integer(arg2)) - { - if (opc->v[3].i_ii_f == add_i_ii) - { - opc->v[1].i = integer(arg1) + integer(arg2); /* no overflow check for sc_add case above */ - opc->v[0].fi = opt_i_c; - } - else - { - opc->v[2].i = integer(arg2); - opc->v[0].fi = (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc; - } - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - if (ifunc) - opc->v[0].fi = (opc->v[3].i_ii_f == multiply_i_ii) ? opt_i_ii_cs_mul : opt_i_ii_cs; - else opc->v[0].fi = opt_i_7ii_cs; - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - if (ifunc) - { - opc->v[0].fi = opt_i_ii_cf; /* sc->opts[start]->v[0].fi -> opt_i_7i_c -> same_opt->v[2].i_7i_f = random_i_7i tmap */ - if ((ifunc == add_i_ii) && (opc == sc->opts[sc->pc - 2]) && - (sc->opts[start]->v[0].fi == opt_i_7i_c) && - (sc->opts[start]->v[2].i_7i_f == random_i_7i)) - { - opc->v[0].fi = opt_add_i_random_i; - opc->v[2].i = sc->opts[start]->v[1].i; - backup_pc(sc); - } - else if (ifunc == multiply_i_ii) opc->v[0].fi = opt_i_ii_cf_mul; - } - else opc->v[0].fi = opt_i_7ii_cf; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 not integer */ - p = opt_integer_symbol(sc, arg1); - if (p) - { - opc->v[1].p = p; - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - if (ifunc) - { - if (opc->v[3].i_ii_f == add_i_ii) - opc->v[0].fi = opt_i_ii_sc_add; - else opc->v[0].fi = (opc->v[3].i_ii_f == subtract_i_ii) ? opt_i_ii_sc_sub : opt_i_ii_sc; /* add1/sub1 are not faster */ - } - else opc->v[0].fi = opt_i_7ii_sc; - if ((car(car_x) == sc->modulo_symbol) && - (integer(arg2) > 1)) - opc->v[3].i_ii_f = modulo_i_ii_unchecked; - else - { - if (car(car_x) == sc->ash_symbol) - { - if (opc->v[2].i < 0) - { - opc->v[3].i_ii_f = (opc->v[2].i == -1) ? rsh_i_i2_direct : rsh_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - } - else - if (opc->v[2].i < S7_INT_BITS) - { - opc->v[3].i_ii_f = lsh_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - }} - else - if (opc->v[2].i > 0) - { - /* these assume vunion is a union, not a struct; i_7ii_f otherwise might be leftover from a previous use */ - if (opc->v[3].i_7ii_f == quotient_i_7ii) - { - opc->v[3].i_ii_f = quotient_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - } - else - if ((opc->v[2].i > 1) && (opc->v[3].i_7ii_f == remainder_i_7ii)) - { - opc->v[3].i_ii_f = remainder_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - }}} - return_true(sc, car_x); - } - - /* arg2 not integer, arg1 is int symbol */ - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - if (ifunc) - opc->v[0].fi = (opc->v[3].i_ii_f == add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss; - else opc->v[0].fi = opt_i_7ii_ss; - return_true(sc, car_x); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - if (ifunc) - opc->v[0].fi = (opc->v[3].i_ii_f == add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf; - else opc->v[0].fi = opt_i_7ii_sf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 not int symbol */ - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - if (!i_ii_fc_combinable(sc, opc, ifunc)) - { - if (ifunc) - { - if (opc->v[3].i_ii_f == add_i_ii) {opc->v[0].fi = opt_i_ii_fc_add; return_true(sc, car_x);} - if (opc->v[3].i_ii_f == multiply_i_ii) {opc->v[0].fi = opt_i_ii_fc_mul; return_true(sc, car_x);} - opc->v[0].fi = opt_i_ii_fc; - - if ((opc->v[3].i_ii_f == subtract_i_ii) && (opc == sc->opts[sc->pc - 2]) && - (sc->opts[start]->v[0].fi == opt_i_7i_c) && - (sc->opts[start]->v[2].i_7i_f == random_i_7i)) - { - opc->v[0].fi = opt_subtract_random_i_i; - opc->v[1].i = sc->opts[start]->v[1].i; - backup_pc(sc); - }} - else opc->v[0].fi = opt_i_7ii_fc; - if (opc->v[2].i > 0) - { - if (opc->v[3].i_7ii_f == quotient_i_7ii) - { - opc->v[3].i_ii_f = quotient_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_fc; - } - else - if ((opc->v[2].i > 1) && (opc->v[3].i_7ii_f == remainder_i_7ii)) - { - opc->v[3].i_ii_f = remainder_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_fc; - }}} - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 not integer or symbol, arg2 not integer */ - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[0].fi = (ifunc) ? opt_i_ii_ff : ((opc->v[3].i_7ii_f == quotient_i_7ii) ? opt_i_7ii_ff_quo : opt_i_7ii_ff); - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- i_iii -------- */ -static s7_int opt_i_iii_fff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - s7_int i3 = o->v[5].fi(o->v[4].o1); - return(o->v[3].i_iii_f(i1, i2, i3)); -} - -static bool i_iii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - s7_i_iii_t ifunc = s7_i_iii_function(s_func); - if (!ifunc) - return_false(sc, car_x); - opc->v[10].o1 = sc->opts[start]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[3].i_iii_f = ifunc; - opc->v[0].fi = opt_i_iii_fff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - }}} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- i_7pii -------- */ -static s7_int opt_i_7pii_ssf(opt_info *o) {return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_7pii_ssf_vset(opt_info *o) {return(int_vector_set_i_7pii_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1)));} -static s7_int opt_i_7pii_ssc(opt_info *o) {return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].i));} -static s7_int opt_i_7pii_sss(opt_info *o) {return(o->v[4].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p))));} -static s7_int opt_i_7pii_sif(opt_info *o) {return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), o->v[12].i, o->v[9].fi(o->v[8].o1)));} - -static s7_int opt_i_pii_sss_ivref_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - return(int_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p))))); -} - -static s7_int opt_i_7pii_sff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), i1, i2)); -} - -/* -------- i_7piii -------- */ -static s7_int opt_i_7piii_sssf(opt_info *o) -{ - return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fi(o->v[10].o1))); -} - -static s7_int opt_i_piii_sssf_ivset_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - s7_int val = o->v[11].fi(o->v[10].o1); - int_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))) = val; - return(val); -} - -static s7_int opt_i_7piii_sssc(opt_info *o) -{ - return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[4].i)); -} - -static s7_int opt_i_7piii_ssss(opt_info *o) -{ - return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), integer(slot_value(o->v[4].p)))); -} - -static s7_int opt_i_7piii_sfff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - s7_int i3 = o->v[6].fi(o->v[4].o1); - return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), i1, i2, i3)); -} - -static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) -{ - /* opc->v[5] is the called function (int-vector-set! etc) */ - s7_pointer slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (is_t_integer(car(valp))) - { - opc->v[0].fi = opt_i_7piii_sssc; - opc->v[4].i = integer(car(valp)); - return_true(sc, NULL); - } - slot = opt_integer_symbol(sc, car(valp)); - if (slot) - { - opc->v[4].p = slot; - opc->v[0].fi = opt_i_7piii_ssss; - return_true(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, valp)) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[0].fi = opt_i_7piii_sssf; - if ((opc->v[5].i_7piii_f == int_vector_set_i_7piii) && - (step_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fi = opt_i_piii_sssf_ivset_unchecked; - return_true(sc, NULL); - }} - return_false(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, valp)) - { - opc->v[0].fi = opt_i_7piii_sfff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[6].fi = opc->v[4].o1->v[0].fi; /* v[5] is in use */ - return_true(sc, NULL); - }}} - return_false(sc, indexp1); -} - -static bool opt_int_vector_set(s7_scheme *sc, int32_t otype, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp) -{ - s7_pointer settee = lookup_slot_from(v, sc->curlet); - if ((is_slot(settee)) && - (!is_immutable(slot_value(settee)))) - { - s7_pointer slot, vect = slot_value(settee); - bool int_case = (is_int_vector(vect)); - opc->v[1].p = settee; - if ((int_case) || (is_byte_vector(vect))) - { - if ((otype >= 0) && (otype != ((int_case) ? 1 : 0))) - return_false(sc, indexp1); - if ((!indexp2) && - (vector_rank(vect) == 1)) - { - opc->v[3].i_7pii_f = (int_case) ? int_vector_set_i_7pii : byte_vector_set_i_7pii; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - int32_t start = sc->pc; - opc->v[2].p = slot; - if (step_end_fits(opc->v[2].p, vector_length(vect))) - opc->v[3].i_7pii_f = (int_case) ? int_vector_set_i_7pii_direct : byte_vector_set_i_7pii_direct; - if ((is_pair(valp)) && - (is_null(cdr(valp))) && - (is_t_integer(car(valp)))) - { - opc->v[4].i = integer(car(valp)); - opc->v[0].fi = opt_i_7pii_ssc; - return_true(sc, NULL); - } - if (!int_optimize(sc, valp)) - return_false(sc, NULL); - opc->v[0].fi = (opc->v[3].i_7pii_f == int_vector_set_i_7pii_direct) ? opt_i_7pii_ssf_vset : opt_i_7pii_ssf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - return_true(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, valp)) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - if (opc->v[11].fi == opt_i_c) /* (int-vector-set! v 0 (floor (sqrt i))) */ - { - opc->v[0].fi = opt_i_7pii_sif; - opc->v[12].i = opc->v[10].o1->v[1].i; - } - else opc->v[0].fi = opt_i_7pii_sff; - return_true(sc, NULL); - }} - return_false(sc, NULL); - } - if ((indexp2) && - (vector_rank(vect) == 2)) - { - opc->v[5].i_7piii_f = (int_case) ? int_vector_set_i_7piii : byte_vector_set_i_7piii; - return(opt_i_7piii_args(sc, opc, indexp1, indexp2, valp)); - }}} - return_false(sc, v); -} - -static bool is_target_or_its_alias(s7_pointer symbol, s7_pointer symfunc, s7_pointer target) -{ - return((symbol == target) || (symfunc == initial_value(target))); -} - -static bool i_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer sig; - s7_i_7pii_t pfunc = s7_i_7pii_function(s_func); - if (!pfunc) - return_false(sc, car_x); - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_symbol(cadr(car_x)))) - { - s7_pointer slot, fname = car(car_x); - - if ((is_target_or_its_alias(fname, s_func, sc->int_vector_set_symbol)) || - (is_target_or_its_alias(fname, s_func, sc->byte_vector_set_symbol))) - return(opt_int_vector_set(sc, (fname == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), NULL, cdddr(car_x))); - - slot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (slot) - { - s7_pointer arg2, p; - int32_t start = sc->pc; - opc->v[1].p = slot; - - if (((is_target_or_its_alias(fname, s_func, sc->int_vector_ref_symbol)) || - (is_target_or_its_alias(fname, s_func, sc->byte_vector_ref_symbol))) && - (vector_rank(slot_value(slot)) != 2)) - return_false(sc, car_x); - - arg2 = caddr(car_x); - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - p = opt_integer_symbol(sc, cadddr(car_x)); - if (p) - { - opc->v[3].p = p; - opc->v[4].i_7pii_f = pfunc; - opc->v[0].fi = opt_i_7pii_sss; - if ((pfunc == int_vector_ref_i_7pii) && - (step_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; - return_true(sc, car_x); - } - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[3].i_7pii_f = pfunc; - opc->v[0].fi = opt_i_7pii_ssf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - return_true(sc, car_x); - } - return_false(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[3].i_7pii_f = pfunc; - opc->v[0].fi = opt_i_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -static bool i_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_i_7piii_t f = s7_i_7piii_function(s_func); - if ((f) && - (is_symbol(cadr(car_x)))) - { - s7_pointer settee; - if ((is_target_or_its_alias(car(car_x), s_func, sc->int_vector_set_symbol)) || - (is_target_or_its_alias(car(car_x), s_func, sc->byte_vector_set_symbol))) - return(opt_int_vector_set(sc, (car(car_x) == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x))); - - settee = lookup_slot_from(cadr(car_x), sc->curlet); - if (is_slot(settee)) - { - s7_pointer vect = slot_value(settee); - if ((is_int_vector(vect)) && (vector_rank(vect) == 3)) - { - opc->v[5].i_7piii_f = f; - opc->v[1].p = settee; - return(opt_i_7piii_args(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x))); - }}} - return_false(sc, car_x); -} - -/* -------- i_add|multiply_any -------- */ -static s7_int opt_i_add_any_f(opt_info *o) -{ - s7_int sum = 0; - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 2].o1; - sum += o1->v[0].fi(o1); - } - return(sum); -} - -static s7_int opt_i_add2(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - return(sum + o->v[7].fi(o->v[3].o1)); -} - -static s7_int opt_i_mul2(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - return(sum * o->v[7].fi(o->v[3].o1)); -} - -static s7_int opt_i_add3(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - sum += o->v[7].fi(o->v[3].o1); - return(sum + o->v[8].fi(o->v[4].o1)); -} - -static s7_int opt_i_mul3(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - sum *= o->v[7].fi(o->v[3].o1); - return(sum * o->v[8].fi(o->v[4].o1)); -} - -static s7_int opt_i_add4(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - sum += o->v[7].fi(o->v[3].o1); - sum += o->v[8].fi(o->v[4].o1); - return(sum + o->v[9].fi(o->v[5].o1)); -} - -static s7_int opt_i_mul4(opt_info *o) -{ - s7_int sum = o->v[6].fi(o->v[2].o1); - sum *= o->v[7].fi(o->v[3].o1); - sum *= o->v[8].fi(o->v[4].o1); - return(sum * o->v[9].fi(o->v[5].o1)); -} - -static s7_int opt_i_multiply_any_f(opt_info *o) -{ - s7_int sum = 1; - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 2].o1; - sum *= o1->v[0].fi(o1); - } - return(sum); -} - -static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x) -{ - s7_pointer p, head = car(car_x); - int32_t cur_len, start = sc->pc; - for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); p = cdr(p), cur_len++) - { - opc->v[cur_len + 2].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, p)) - break; - } - if (is_null(p)) - { - opc->v[1].i = cur_len; - if (cur_len <= 4) - for (int32_t i = 0; i < cur_len; i++) - opc->v[i + 6].fi = opc->v[i + 2].o1->v[0].fi; - if (cur_len == 2) - opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2; - else - if (cur_len == 3) - opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3; - else - if (cur_len == 4) - opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4; - else opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add_any_f : opt_i_multiply_any_f; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); -} - - -/* -------- set_i_i -------- */ -static s7_int opt_set_i_i_f(opt_info *o) -{ - s7_int x = o->v[3].fi(o->v[2].o1); - slot_set_value(o->v[1].p, make_integer(o->sc, x)); - return(x); -} - -static s7_int opt_set_i_i_fm(opt_info *o) /* called in increment: (set! sum (+ sum (...))) where are all ints */ -{ - s7_int x = o->v[3].fi(o->v[2].o1); - integer(slot_value(o->v[1].p)) = x; - return(x); -} - -static s7_int opt_set_i_i_fo(opt_info *o) -{ - s7_int x = integer(slot_value(o->v[3].p)) + o->v[2].i; - slot_set_value(o->v[1].p, make_integer(o->sc, x)); - return(x); -} - -static bool set_i_i_f_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fi == opt_i_ii_sc_add) - { - /* opc->v[4].i_ii_f = o1->v[3].i_ii_f; */ - opc->v[3].p = o1->v[1].p; - opc->v[2].i = o1->v[2].i; - opc->v[0].fi = opt_set_i_i_fo; - backup_pc(sc); - return_true(sc, NULL); /* ii_sc v[1].p is a slot */ - }} - return_false(sc, NULL); -} - -static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - if ((car(car_x) == sc->set_symbol) && - (len == 3)) - { - opt_info *opc = alloc_opt_info(sc); - if (is_symbol(cadr(car_x))) /* (set! i 3) */ - { - s7_pointer settee; - if (is_immutable(cadr(car_x))) - return_false(sc, car_x); - settee = lookup_slot_from(cadr(car_x), sc->curlet); - if ((is_slot(settee)) && - (is_t_integer(slot_value(settee))) && - (!is_immutable(settee)) && - ((!slot_has_setter(settee)) || - ((is_c_function(slot_setter(settee))) && - ((slot_setter(settee) == initial_value(sc->is_integer_symbol)) || - (c_function_call(slot_setter(settee)) == b_is_integer_setter))))) - /* opt set! won't change type, and it is an integer now (and we might not hit opt_cell_set) */ - { - opt_info *o1 = sc->opts[sc->pc]; - opc->v[1].p = settee; - if (int_optimize(sc, cddr(car_x))) - { - if (set_i_i_f_combinable(sc, opc)) - return_true(sc, car_x); - opc->v[0].fi = (is_mutable_integer(slot_value(opc->v[1].p))) ? opt_set_i_i_fm : opt_set_i_i_f; - opc->v[2].o1 = o1; - opc->v[3].fi = o1->v[0].fi; - return_true(sc, car_x); /* or OO_I? */ - }}} - else - if ((is_pair(cadr(car_x))) && /* if is_pair(settee) get setter */ - (is_symbol(caadr(car_x))) && - (is_pair(cdadr(car_x)))) - { - if (is_null(cddadr(car_x))) - return(opt_int_vector_set(sc, -1, opc, caadr(car_x), cdadr(car_x), NULL, cddr(car_x))); - if (is_null(cdddr(cadr(car_x)))) - return(opt_int_vector_set(sc, -1, opc, caadr(car_x), cdadr(car_x), cddadr(car_x), cddr(car_x))); - }} - return_false(sc, car_x); -} - -static bool i_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len) -{ - s7_pointer obj = slot_value(s_slot); - if ((is_int_vector(obj)) || (is_byte_vector(obj))) - { - bool int_case = is_int_vector(obj); - s7_pointer slot; - - if ((len == 2) && - (vector_rank(obj) == 1)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[0].fi = opt_i_7pi_ss; - opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - opc->v[2].p = slot; - if (step_end_fits(opc->v[2].p, vector_length(obj))) - opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi_direct : byte_vector_ref_i_7pi_direct; - /* not opc->v[0].fi = opt_7pi_ss_ivref -- this causes a huge slowdown in dup.scm?? */ - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[0].fi = opt_i_7pi_sf; - opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - } - if ((len == 3) && - (vector_rank(obj) == 2)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (!slot) - return_false(sc, car_x); - opc->v[4].i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - opc->v[3].p = slot; - opc->v[0].fi = opt_i_7pii_sss; - if ((int_case) && - (step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[3].i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - opc->v[0].fi = opt_i_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - - -/* ------------------------------------- float opts ------------------------------------------- */ -static s7_double opt_d_c(opt_info *o) {return(o->v[1].x);} -static s7_double opt_d_s(opt_info *o) {return(real(slot_value(o->v[1].p)));} - -static s7_double opt_D_s(opt_info *o) -{ - s7_pointer x = slot_value(o->v[1].p); - return((is_t_integer(x)) ? (s7_double)(integer(x)) : s7_number_to_real(o->sc, x)); -} - -static bool opt_float_not_pair(s7_scheme *sc, s7_pointer car_x) -{ - s7_pointer p; - if (is_small_real(car_x)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].x = s7_number_to_real(sc, car_x); - opc->v[0].fd = opt_d_c; - return_true(sc, car_x); - } - p = opt_real_symbol(sc, car_x); - if (p) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = p; - opc->v[0].fd = (is_t_real(slot_value(p))) ? opt_d_s : opt_D_s; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- d -------- */ -static s7_double opt_d_f(opt_info *o) {return(o->v[1].d_f());} - -static bool d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func) /* (f): (mus-srate) */ -{ - s7_d_t func = s7_d_function(s_func); - if (!func) - return_false(sc, NULL); - opc->v[0].fd = opt_d_f; - opc->v[1].d_f = func; - return_true(sc, NULL); -} - -/* -------- d_d -------- */ -static s7_double opt_d_d_c(opt_info *o) {return(o->v[3].d_d_f(o->v[1].x));} -static s7_double opt_d_d_s(opt_info *o) {return(o->v[3].d_d_f(real(slot_value(o->v[1].p))));} -static s7_double opt_d_d_s_abs(opt_info *o) {return(abs_d_d(real(slot_value(o->v[1].p))));} -static s7_double opt_d_7d_c(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[1].x));} -static s7_double opt_d_7d_s(opt_info *o) {return(o->v[3].d_7d_f(o->sc, real(slot_value(o->v[1].p))));} -static s7_double opt_d_d_f(opt_info *o) {return(o->v[3].d_d_f(o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_d_f_abs(opt_info *o) {return(abs_d_d(o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_d_f_sin(opt_info *o) {return(sin_d_d(o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_d_f_cos(opt_info *o) {return(cos_d_d(o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_7d_f(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_7d_f_divide(opt_info *o) {return(divide_d_7d(o->sc, o->v[5].fd(o->v[4].o1)));} - -static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o); -static s7_double opt_abs_d_ss_fvref(opt_info *o) -{ - opt_info *o1 = o->v[4].o1; - return(abs_d_d(float_vector(slot_value(o1->v[1].p), integer(slot_value(o1->v[2].p))))); -} - -static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7d_t func7 = NULL; - int32_t start = sc->pc; - s7_d_d_t func = s7_d_d_function(s_func); - if (!func) func7 = s7_d_7d_function(s_func); - if ((func) || (func7)) - { - s7_pointer p; - if (func) - opc->v[3].d_d_f = func; - else opc->v[3].d_7d_f = func7; - if (is_small_real(cadr(car_x))) - { - if ((!is_t_real(cadr(car_x))) && /* (random 1) != (random 1.0) */ - ((car(car_x) == sc->random_symbol) || - (car(car_x) == sc->sin_symbol) || (car(car_x) == sc->cos_symbol))) - return_false(sc, car_x); - opc->v[1].x = s7_number_to_real(sc, cadr(car_x)); - opc->v[0].fd = (func) ? opt_d_d_c : opt_d_7d_c; - return_true(sc, car_x); - } - p = opt_float_symbol(sc, cadr(car_x)); - if ((p) && - (!has_methods(slot_value(p)))) - { - opc->v[1].p = p; - opc->v[0].fd = (func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) : opt_d_7d_s; - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[0].fd = (func) ? ((func == abs_d_d) ? opt_d_d_f_abs : ((func == sin_d_d) ? opt_d_d_f_sin : - ((func == cos_d_d) ? opt_d_d_f_cos : opt_d_d_f))) : - ((func7 == divide_d_7d) ? opt_d_7d_f_divide : opt_d_7d_f); - opc->v[5].fd = opc->v[4].o1->v[0].fd; - if ((func == abs_d_d) && (opc->v[5].fd == opt_d_7pi_ss_fvref_direct)) - opc->v[0].fd = opt_abs_d_ss_fvref; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - return_false(sc, car_x); -} - -/* -------- d_v -------- */ -static s7_double opt_d_v(opt_info *o) {return(o->v[3].d_v_f(o->v[5].obj));} - -static bool d_v_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer sig; - s7_d_v_t flt_func = s7_d_v_function(s_func); - if (!flt_func) - return_false(sc, car_x); - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_symbol(cadr(sig))) && - (is_symbol(cadr(car_x)))) /* look for (oscil g) */ - { - s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (slot) - { - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - opc->v[3].d_v_f = flt_func; - opc->v[0].fd = opt_d_v; - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - -/* -------- d_p -------- */ -static s7_double opt_d_p_s(opt_info *o) {return(o->v[3].d_p_f(slot_value(o->v[1].p)));} -static s7_double opt_d_p_f(opt_info *o) {return(o->v[3].d_p_f(o->v[5].fp(o->v[4].o1)));} - -static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - s7_d_p_t dpf = s7_d_p_function(s_func); /* mostly clm gens */ - if (!dpf) - return_false(sc, car_x); - opc->v[3].d_p_f = dpf; - if (is_symbol(cadr(car_x))) - { - s7_pointer slot = opt_simple_symbol(sc, cadr(car_x)); - if (!slot) - return_false(sc, car_x); - opc->v[1].p = slot; - opc->v[0].fd = opt_d_p_s; - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fd = opt_d_p_f; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- d_7pi -------- */ - -static s7_double opt_d_7pi_sc(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));} -static s7_double opt_d_7pi_ss(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_double opt_d_7pi_sf(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1)));} -static s7_double opt_d_7pi_ss_fvref(opt_info *o) {return(float_vector_ref_d_7pi(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o) {return(float_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} - -static s7_double opt_d_7pi_ff(opt_info *o) -{ - s7_pointer seq = o->v[5].fp(o->v[4].o1); - return(o->v[3].d_7pi_f(o->sc, seq, o->v[9].fi(o->v[8].o1))); -} - -static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - /* float-vector-ref is checked for a 1D float-vector arg, but other callers should do type checking */ - int32_t start = sc->pc; - s7_d_7pi_t ifunc = s7_d_7pi_function(s_func); /* ifunc: float_vector_ref_d_7pi, s_func: global_value(sc->float_vector_ref_symbol) */ - if (!ifunc) - return_false(sc, car_x); - opc->v[3].d_7pi_f = ifunc; - if (is_symbol(cadr(car_x))) /* (float-vector-ref v i) */ - { - s7_pointer arg2, p, obj; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if (!is_slot(opc->v[1].p)) - return_false(sc, car_x); - - obj = slot_value(opc->v[1].p); - if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) && - ((!is_float_vector(obj)) || /* if it's float-vector-ref, make sure obj is a float-vector */ - (vector_rank(obj) > 1))) - return_false(sc, car_x); /* but if it's e.g. (block-ref...), go on */ - - arg2 = caddr(car_x); - if (!is_pair(arg2)) - { - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - opc->v[0].fd = opt_d_7pi_sc; - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, arg2); - if (!p) - return_false(sc, car_x); - opc->v[2].p = p; - opc->v[0].fd = opt_d_7pi_ss; - if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) - opc->v[0].fd = (step_end_fits(opc->v[2].p, vector_length(obj))) ? opt_d_7pi_ss_fvref_direct : opt_d_7pi_ss_fvref; - return_true(sc, car_x); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_7pi_sf; - opc->v[10].o1 = sc->opts[start]; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) && - ((!is_float_vector(cadr(car_x))) || - (vector_rank(cadr(car_x)) > 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */ - return_false(sc, car_x); - - if (cell_optimize(sc, cdr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_7pi_ff; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - opc->v[8].o1 = o2; - opc->v[9].fi = o2->v[0].fi; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- d_ip -------- */ -static s7_double opt_d_ip_ss(opt_info *o) {return(o->v[3].d_ip_f(integer(slot_value(o->v[1].p)), slot_value(o->v[2].p)));} - -static bool d_ip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_ip_t pfunc = s7_d_ip_function(s_func); - if ((pfunc) && - (is_symbol(caddr(car_x)))) - { - s7_pointer p = opt_integer_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[3].d_ip_f = pfunc; - opc->v[1].p = p; - opc->v[2].p = lookup_slot_from(caddr(car_x), sc->curlet); - if (is_slot(opc->v[2].p)) /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */ - { - opc->v[0].fd = opt_d_ip_ss; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -/* -------- d_pd -------- */ -static s7_double opt_d_pd_sf(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), o->v[11].fd(o->v[10].o1)));} -static s7_double opt_d_pd_ss(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), real(slot_value(o->v[2].p))));} - -static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - if (is_symbol(cadr(car_x))) - { - s7_d_pd_t func = s7_d_pd_function(s_func); - if (func) - { - s7_pointer p, arg2 = caddr(car_x); - int32_t start = sc->pc; - opc->v[3].d_pd_f = func; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if (!is_slot(opc->v[1].p)) - return_false(sc, car_x); - p = opt_float_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - opc->v[0].fd = opt_d_pd_ss; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_pd_sf; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- d_vd -------- */ -static s7_double opt_d_vd_c(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].x));} -static s7_double opt_d_vd_s(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p))));} -static s7_double opt_d_vd_f(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[9].fd(o->v[8].o1)));} -static s7_double opt_d_vd_o(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));} -static s7_double opt_d_vd_o1_mul(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p)) * o->v[11].fd(o->v[10].o1)));} -static s7_double opt_d_vd_o1(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))));} -static s7_double opt_d_vd_o2(opt_info *o) {return(o->v[4].d_vd_f(o->v[6].obj, o->v[5].d_vd_f(o->v[2].obj, real(slot_value(o->v[3].p)))));} -static s7_double opt_d_vd_o3(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(o->v[6].x, real(slot_value(o->v[2].p)))));} -static s7_double opt_d_vd_ff(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].d_vd_f(o->v[4].obj, o->v[11].fd(o->v[10].o1))));} - -static s7_double opt_d_dd_cs(opt_info *o); -static s7_double opt_d_dd_sf_mul(opt_info *o); -static s7_double opt_d_dd_sf_add(opt_info *o); -static s7_double opt_d_dd_sf(opt_info *o); - -static bool d_vd_f_combinable(s7_scheme *sc, int32_t start) -{ - opt_info *opc = sc->opts[start - 1], *o1 = sc->opts[start]; - if (o1->v[0].fd == opt_d_v) - { - opc->v[2].p = o1->v[1].p; - opc->v[6].obj = o1->v[5].obj; - opc->v[4].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = opt_d_vd_o; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_vd_s) - { - opc->v[6].obj = opc->v[5].obj; - opc->v[4].d_vd_f = opc->v[3].d_vd_f; /* room for symbols */ - opc->v[2].obj = o1->v[5].obj; - opc->v[5].d_vd_f = o1->v[3].d_vd_f; - opc->v[3].p = o1->v[2].p; - opc->v[7].p = o1->v[1].p; - opc->v[0].fd = opt_d_vd_o2; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_dd_cs) - { - opc->v[4].d_dd_f = o1->v[3].d_dd_f; - opc->v[6].x = o1->v[2].x; - opc->v[2].p = o1->v[1].p; - opc->v[0].fd = opt_d_vd_o3; - backup_pc(sc); - return_true(sc, NULL); - } - if ((o1->v[0].fd == opt_d_dd_sf_mul) || (o1->v[0].fd == opt_d_dd_sf) || (o1->v[0].fd == opt_d_dd_sf_add)) - { - opc->v[2].p = o1->v[1].p; - opc->v[4].d_dd_f = o1->v[3].d_dd_f; - opc->v[0].fd = (o1->v[0].fd == opt_d_dd_sf_mul) ? opt_d_vd_o1_mul : opt_d_vd_o1; - opc->v[11].fd = o1->v[5].fd; - opc->v[10].o1 = o1->v[4].o1; - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_vd_f) - { - opc->v[2].d_vd_f = o1->v[3].d_vd_f; - opc->v[4].obj = o1->v[5].obj; - opc->v[6].p = o1->v[1].p; - opc->v[0].fd = opt_d_vd_ff; - opc->v[11].fd = o1->v[9].fd; - opc->v[10].o1 = o1->v[8].o1; - return_true(sc, NULL); - } - return_false(sc, NULL); -} - -static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer sig; - s7_d_vd_t vfunc; - if (!is_symbol(cadr(car_x))) - return_false(sc, car_x); - vfunc = s7_d_vd_function(s_func); - if (!vfunc) - return_false(sc, car_x); - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_symbol(cadr(sig)))) - { - s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (slot) - { - s7_pointer arg2 = caddr(car_x); - int32_t start = sc->pc; - opc->v[3].d_vd_f = vfunc; - if (!is_pair(arg2)) - { - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - if (is_small_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[0].fd = opt_d_vd_c; - return_true(sc, car_x); - } - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); - if (is_slot(opc->v[2].p)) - { - if (is_t_real(slot_value(opc->v[2].p))) - { - opc->v[0].fd = opt_d_vd_s; - return_true(sc, car_x); - } - if (!float_optimize(sc, cddr(car_x))) - return_false(sc, car_x); - if (d_vd_f_combinable(sc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_vd_f; - opc->v[8].o1 = sc->opts[start]; - opc->v[9].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - }} - else /* is pair arg2 */ - { - if (float_optimize(sc, cddr(car_x))) - { - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - if (d_vd_f_combinable(sc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_vd_f; - opc->v[8].o1 = sc->opts[start]; - opc->v[9].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }}} - return_false(sc, car_x); -} - -/* -------- d_id -------- */ -static s7_double opt_d_id_sf(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_id_sc(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[2].x));} -static s7_double opt_d_id_sfo1(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_v_f(o->v[2].obj)));} -static s7_double opt_d_id_sfo(opt_info *o) {return(o->v[4].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[3].p)))));} -static s7_double opt_d_id_cf(opt_info *o) {return(o->v[3].d_id_f(o->v[1].i, o->v[5].fd(o->v[4].o1)));} - -static s7_double opt_d_id_ff(opt_info *o) -{ - s7_int x1 = o->v[9].fi(o->v[8].o1); - return(o->v[3].d_id_f(x1, o->v[11].fd(o->v[10].o1))); -} - -static bool d_id_sf_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fd == opt_d_vd_s) - { - opc->v[4].d_id_f = opc->v[3].d_id_f; - opc->v[2].p = o1->v[1].p; - opc->v[6].obj = o1->v[5].obj; - opc->v[5].d_vd_f = o1->v[3].d_vd_f; - opc->v[3].p = o1->v[2].p; - opc->v[0].fd = opt_d_id_sfo; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_v) - { - opc->v[6].p = o1->v[1].p; - opc->v[2].obj = o1->v[5].obj; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = opt_d_id_sfo1; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool d_id_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer p; - int32_t start = sc->pc; - s7_d_id_t flt_func = s7_d_id_function(s_func); - if (!flt_func) - return_false(sc, car_x); - opc->v[3].d_id_f = flt_func; - p = opt_integer_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - if (is_t_real(caddr(car_x))) - { - opc->v[0].fd = opt_d_id_sc; - opc->v[2].x = real(caddr(car_x)); - return_true(sc, car_x); - } - if (float_optimize(sc, cddr(car_x))) - { - if (d_id_sf_combinable(sc, opc)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_id_sf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - if (is_t_integer(cadr(car_x))) - { - if (float_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_id_cf; - opc->v[1].i = integer(cadr(car_x)); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[0].fd = opt_d_id_ff; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - return_false(sc, car_x); -} - -/* -------- d_dd -------- */ - -static s7_double opt_d_dd_cc(opt_info *o) {return(o->v[3].d_dd_f(o->v[1].x, o->v[2].x));} -static s7_double opt_d_dd_cs(opt_info *o) {return(o->v[3].d_dd_f(o->v[2].x, real(slot_value(o->v[1].p))));} -static s7_double opt_d_dd_sc(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));} -static s7_double opt_d_dd_sc_sub(opt_info *o) {return(real(slot_value(o->v[1].p)) - o->v[2].x);} -static s7_double opt_d_dd_ss(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));} -static s7_double opt_d_dd_ss_add(opt_info *o) {return(real(slot_value(o->v[1].p)) + real(slot_value(o->v[2].p)));} -static s7_double opt_d_dd_ss_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * real(slot_value(o->v[2].p)));} - -static s7_double opt_d_dd_cf(opt_info *o) {return(o->v[3].d_dd_f(o->v[1].x, o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_dd_1f_subtract(opt_info *o) {return(1.0 - o->v[5].fd(o->v[4].o1));} -static s7_double opt_d_dd_fc(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x));} - -#if WITH_GMP -static s7_double opt_subtract_random_f_f(opt_info *o) {return(o->v[1].x * next_random(o->sc) - o->v[2].x);} -#else -static s7_double opt_subtract_random_f_f(opt_info *o) {return(o->v[1].x * next_random(o->sc->default_random_state) - o->v[2].x);} -#endif - -static s7_double opt_d_dd_fc_add(opt_info *o) {return(o->v[5].fd(o->v[4].o1) + o->v[2].x);} -static s7_double opt_d_dd_fc_fvref_add(opt_info *o) {return(o->v[2].x + float_vector(slot_value(o->v[4].o1->v[1].p), integer(slot_value(o->v[4].o1->v[2].p))));} -static s7_double opt_d_dd_fc_subtract(opt_info *o) {return(o->v[5].fd(o->v[4].o1) - o->v[2].x);} -static s7_double opt_d_dd_sf(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_dd_sf_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1));} -static s7_double opt_d_dd_sf_add(opt_info *o) {return(real(slot_value(o->v[1].p)) + o->v[5].fd(o->v[4].o1));} -static s7_double opt_d_dd_sf_sub(opt_info *o) {return(real(slot_value(o->v[1].p)) - o->v[5].fd(o->v[4].o1));} - -static s7_double opt_d_7dd_cc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[2].x));} -static s7_double opt_d_7dd_cs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[2].x, real(slot_value(o->v[1].p))));} -static s7_double opt_d_7dd_sc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[2].x));} -static s7_double opt_d_7dd_ss(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));} -static s7_double opt_d_7dd_cf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[5].fd(o->v[4].o1)));} -static s7_double opt_d_7dd_fc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), o->v[2].x));} -static s7_double opt_d_7dd_sf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));} - -static s7_double opt_d_7pii_scs(opt_info *o); -static s7_double opt_d_dd_sf_mul_fvref(opt_info *o) -{ - opt_info *o1 = o->v[4].o1; - return(real(slot_value(o->v[1].p)) * float_vector_ref_d_7pii(o1->sc, slot_value(o1->v[1].p), o1->v[2].i, integer(slot_value(o1->v[3].p)))); -} - -static s7_double opt_d_dd_sfo(opt_info *o) -{ - return(o->v[4].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))))); -} - -static s7_double opt_d_7dd_sfo(opt_info *o) -{ - return(o->v[4].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))))); -} - -static bool d_dd_sf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fd == opt_d_7pi_ss) || (o1->v[0].fd == opt_d_7pi_ss_fvref) || (o1->v[0].fd == opt_d_7pi_ss_fvref_direct)) - { - if (func) - { - opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ - opc->v[0].fd = opt_d_dd_sfo; - } - else - { - opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; /* need room for 3 symbols */ - opc->v[0].fd = opt_d_7dd_sfo; - } - opc->v[2].p = o1->v[1].p; - opc->v[3].p = o1->v[2].p; - opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static s7_double opt_d_dd_fs(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));} -static s7_double opt_d_dd_fs_mul(opt_info *o) {return(o->v[5].fd(o->v[4].o1) * real(slot_value(o->v[1].p)));} -static s7_double opt_d_dd_fs_add(opt_info *o) {return(o->v[5].fd(o->v[4].o1) + real(slot_value(o->v[1].p)));} -static s7_double opt_d_dd_fs_sub(opt_info *o) {return(o->v[5].fd(o->v[4].o1) - real(slot_value(o->v[1].p)));} -static s7_double opt_d_7dd_fs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));} - -static s7_double opt_d_dd_fs_add_fvref(opt_info *o) -{ - opt_info *o1 = o->v[4].o1; - return(real(slot_value(o->v[1].p)) + float_vector_ref_d_7pii(o1->sc, slot_value(o1->v[1].p), o1->v[2].i, integer(slot_value(o1->v[3].p)))); -} - -static s7_double opt_d_dd_fso(opt_info *o) -{ - return(o->v[4].d_dd_f(o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p)))); -} - -static s7_double opt_d_7dd_fso(opt_info *o) -{ - return(o->v[4].d_7dd_f(o->sc, o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p)))); -} - -static bool d_dd_fs_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fd == opt_d_7pi_ss) || (o1->v[0].fd == opt_d_7pi_ss_fvref) || (o1->v[0].fd == opt_d_7pi_ss_fvref_direct)) - { - if (func) - { - opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ - opc->v[0].fd = opt_d_dd_fso; - } - else - { - opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; - opc->v[0].fd = opt_d_7dd_fso; - } - opc->v[2].p = o1->v[1].p; - opc->v[3].p = o1->v[2].p; - opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static s7_double opt_d_dd_ff(opt_info *o) -{ - s7_double x1 = o->v[9].fd(o->v[8].o1); - return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_dd_ff_mul(opt_info *o) -{ - s7_double x1 = o->v[9].fd(o->v[8].o1); - return(x1 * o->v[11].fd(o->v[10].o1)); -} - -static s7_double opt_d_dd_ff_square(opt_info *o) -{ - s7_double x1 = o->v[9].fd(o->v[8].o1); - return(x1 * x1); -} - -static s7_double opt_d_dd_ff_add(opt_info *o) -{ - s7_double x1 = o->v[5].fd(o->v[4].o1); - return(x1 + o->v[11].fd(o->v[10].o1)); -} - -static s7_double opt_d_dd_ff_add_mul(opt_info *o) -{ - s7_double x1 = o->v[5].fd(o->v[4].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - return(x1 + (x2 * o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_dd_ff_add_fv_ref(opt_info *o) -{ - s7_double x1 = o->v[5].fd(o->v[4].o1); - return(x1 + float_vector_ref_d_7pi(o->sc, slot_value(o->v[6].p), o->v[9].fi(o->v[8].o1))); -} - -static s7_double opt_d_dd_ff_sub(opt_info *o) -{ - s7_double x1 = o->v[5].fd(o->v[4].o1); - return(x1 - o->v[11].fd(o->v[10].o1)); -} - -static s7_double opt_d_7dd_ff(opt_info *o) -{ - s7_double x1 = o->v[9].fd(o->v[8].o1); - return(o->v[3].d_7dd_f(o->sc, x1, o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_dd_ff_o1(opt_info *o) -{ - s7_double x1 = o->v[2].d_v_f(o->v[1].obj); - return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_dd_ff_mul1(opt_info *o) {return(o->v[2].d_v_f(o->v[1].obj) * o->v[11].fd(o->v[10].o1));} - -static s7_double opt_d_dd_ff_o2(opt_info *o) -{ - s7_double x1 = o->v[4].d_v_f(o->v[1].obj); - return(o->v[3].d_dd_f(x1, o->v[5].d_v_f(o->v[2].obj))); -} - -static s7_double opt_d_dd_ff_mul2(opt_info *o) {return(o->v[4].d_v_f(o->v[1].obj) * o->v[5].d_v_f(o->v[2].obj));} - -static s7_double opt_d_dd_ff_o3(opt_info *o) -{ - s7_double x1 = o->v[5].d_v_f(o->v[1].obj); - return(o->v[4].d_dd_f(x1, o->v[6].d_vd_f(o->v[2].obj, real(slot_value(o->v[3].p))))); -} - -static s7_double opt_d_dd_fff(opt_info *o) -{ - s7_double x1 = o->v[3+4].d_dd_f(o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))), real(slot_value(o->v[3+1].p))); /* dd_fso */ - s7_double x2 = o->v[8+4].d_dd_f(o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))), real(slot_value(o->v[8+1].p))); /* dd_fso */ - return(o->v[3].d_dd_f(x1, x2)); -} - -static s7_double opt_d_mm_fff(opt_info *o) -{ - s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))) * real(slot_value(o->v[3+1].p)); - s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))) * real(slot_value(o->v[8+1].p)); - return(o->v[3].d_dd_f(x1, x2)); -} - -static s7_double opt_d_dd_fff_rev(opt_info *o) /* faster with o->sc? */ -{ - s7_double x1 = o->v[3+4].d_dd_f(real(slot_value(o->v[3+1].p)), o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p)))); - s7_double x2 = o->v[8+4].d_dd_f(real(slot_value(o->v[8+1].p)), o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p)))); - return(o->v[3].d_dd_f(x1, x2)); -} - -static s7_double opt_d_dd_ff_o4(opt_info *o) -{ - s7_double x1 = o->v[2].d_v_f(o->v[1].obj); - return(o->v[3].d_dd_f(x1, o->v[7].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)))); -} - -static s7_double opt_d_dd_ff_mul4(opt_info *o) {return(o->v[2].d_v_f(o->v[1].obj) * o->v[7].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));} - -static s7_double opt_d_7pii_sss(opt_info *o); -static s7_double opt_d_dd_ff_mul_sss(opt_info *o) -{ - opt_info *o1 = o->v[8].o1; - s7_pointer v = slot_value(o1->v[1].p); - s7_int i1 = integer(slot_value(o1->v[2].p)); - s7_int i2 = integer(slot_value(o1->v[3].p)); - s7_double x1 = float_vector_ref_d_7pii(o1->sc, v, i1, i2); - o1 = o->v[10].o1; - v = slot_value(o1->v[1].p); - i1 = integer(slot_value(o1->v[2].p)); /* in (* (A i j) (B j k)) we could reuse i2->i1 (flipping args below) */ - i2 = integer(slot_value(o1->v[3].p)); - return(x1 * float_vector_ref_d_7pii(o1->sc, v, i1, i2)); -} - -static bool finish_dd_fso(opt_info *opc, opt_info *o1, opt_info *o2) -{ - opc->v[3+1].p = o1->v[1].p; - opc->v[3+2].p = o1->v[2].p; - opc->v[3+3].p = o1->v[3].p; - opc->v[3+4].d_dd_f = o1->v[4].d_dd_f; - opc->v[3+5].d_7pi_f = o1->v[5].d_7pi_f; - opc->v[8+1].p = o2->v[1].p; - opc->v[8+2].p = o2->v[2].p; - opc->v[8+3].p = o2->v[3].p; - opc->v[8+4].d_dd_f = o2->v[4].d_dd_f; - opc->v[8+5].d_7pi_f = o2->v[5].d_7pi_f; - return(true); -} - -static s7_double opt_d_7dd_ff_div_add(opt_info *o) -{ - opt_info *o2 = o->v[10].o1; - s7_double x1 = o->v[9].fd(o->v[8].o1); - s7_double x2 = o2->v[5].fd(o2->v[4].o1); - x2 += float_vector_ref_d_7pi(o2->sc, slot_value(o2->v[6].p), o2->v[9].fi(o2->v[8].o1)); - return(divide_d_7dd(o->sc, x1, x2)); -} - -static bool d_dd_ff_combinable(s7_scheme *sc, opt_info *opc, int32_t start) -{ - opt_info *o1 = opc->v[8].o1, *o2 = opc->v[10].o1; - if (o1->v[0].fd == opt_d_v) - { - /* opc->v[3] is in use */ - if ((o2->v[0].fd == opt_d_v) && - (sc->pc == start + 2)) - { - opc->v[1].obj = o1->v[5].obj; - opc->v[6].p = o1->v[1].p; - opc->v[4].d_v_f = o1->v[3].d_v_f; - opc->v[2].obj = o2->v[5].obj; - opc->v[7].p = o2->v[1].p; - opc->v[5].d_v_f = o2->v[3].d_v_f; - opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul2 : opt_d_dd_ff_o2; - sc->pc -= 2; - return_true(sc, NULL); - } - if ((o2->v[0].fd == opt_d_vd_s) && - (sc->pc == start + 2)) - { - opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* make room for symbols */ - opc->v[1].obj = o1->v[5].obj; - opc->v[7].p = o1->v[1].p; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[2].obj = o2->v[5].obj; - opc->v[8].p = o2->v[1].p; - opc->v[6].d_vd_f = o2->v[3].d_vd_f; - opc->v[3].p = o2->v[2].p; - opc->v[0].fd = opt_d_dd_ff_o3; - sc->pc -= 2; - return_true(sc, NULL); - } - if ((o2->v[0].fd == opt_d_vd_o) && - (sc->pc == start + 2)) - { - opc->v[1].obj = o1->v[5].obj; - opc->v[8].p = o1->v[1].p; - opc->v[2].d_v_f = o1->v[3].d_v_f; - opc->v[7].d_vd_f = o2->v[3].d_vd_f; - opc->v[4].d_v_f = o2->v[4].d_v_f; - opc->v[5].obj = o2->v[5].obj; - opc->v[9].p = o2->v[1].p; - opc->v[6].obj = o2->v[6].obj; - opc->v[10].p = o2->v[2].p; - opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul4 : opt_d_dd_ff_o4; - sc->pc -= 2; - return_true(sc, NULL); - } - opc->v[1].obj = o1->v[5].obj; - opc->v[4].p = o1->v[1].p; - opc->v[2].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul1 : opt_d_dd_ff_o1; - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_dd_fso) - { - if (o2->v[0].fd == opt_d_dd_fso) - { - if ((o1->v[4].d_dd_f == multiply_d_dd) && - (o2->v[4].d_dd_f == multiply_d_dd) && - (o1->v[5].d_7pi_f == float_vector_ref_d_7pi) && - (o2->v[5].d_7pi_f == float_vector_ref_d_7pi)) - opc->v[0].fd = opt_d_mm_fff; /* a placeholder (never called) */ - else opc->v[0].fd = opt_d_dd_fff; - return(finish_dd_fso(opc, o1, o2)); - }} - if (o1->v[0].fd == opt_d_dd_sfo) - { - if (o2->v[0].fd == opt_d_dd_sfo) - { - if ((o1->v[4].d_dd_f == multiply_d_dd) && - (o2->v[4].d_dd_f == multiply_d_dd) && - (o1->v[5].d_7pi_f == float_vector_ref_d_7pi) && - (o2->v[5].d_7pi_f == float_vector_ref_d_7pi)) - opc->v[0].fd = opt_d_mm_fff; /* multiply is commutative */ - else opc->v[0].fd = opt_d_dd_fff_rev; - return(finish_dd_fso(opc, o1, o2)); - }} - return_false(sc, NULL); -} - -static s7_double opt_d_dd_cfo(opt_info *o) {return(o->v[3].d_dd_f(o->v[2].x, o->v[4].d_v_f(o->v[1].obj)));} -static s7_double opt_d_7dd_cfo(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[2].x, o->v[4].d_v_f(o->v[1].obj)));} -static s7_double opt_d_dd_cfo1(opt_info *o) {return(o->v[3].d_dd_f(o->v[4].x, o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[2].p)))));} -static s7_double opt_d_7dd_cfo1(opt_info *o){return(o->v[3].d_7dd_f(o->sc, o->v[4].x, o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[2].p)))));} - -static bool d_dd_call_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fd == opt_d_v) - { - opc->v[2].x = opc->v[1].x; - opc->v[6].p = o1->v[1].p; - opc->v[1].obj = o1->v[5].obj; - opc->v[4].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fd == opt_d_vd_s) - { - opc->v[4].x = opc->v[1].x; - opc->v[1].p = o1->v[1].p; - opc->v[6].obj = o1->v[5].obj; - opc->v[2].p = o1->v[2].p; - opc->v[5].d_vd_f = o1->v[3].d_vd_f; - opc->v[0].fd = (func) ? opt_d_dd_cfo1 : opt_d_7dd_cfo1; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); - int32_t start = sc->pc; - opt_info *o1; - s7_d_7dd_t func7 = NULL; - s7_d_dd_t func = s7_d_dd_function(s_func); - if (!func) - { - func7 = s7_d_7dd_function(s_func); - if (!func7) return_false(sc, car_x); - } - if (func) - opc->v[3].d_dd_f = func; - else opc->v[3].d_7dd_f = func7; - - /* arg1 = real constant */ - if (is_small_real(arg1)) - { - if (is_small_real(arg2)) - { - if ((!is_t_real(arg1)) && (!is_t_real(arg2))) - return_false(sc, car_x); - opc->v[1].x = s7_number_to_real(sc, arg1); - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[0].fd = (func) ? opt_d_dd_cc : opt_d_7dd_cc; - return_true(sc, car_x); - } - slot = opt_float_symbol(sc, arg2); - if (slot) - { - opc->v[1].p = slot; - opc->v[2].x = s7_number_to_real(sc, arg1); /* move arg1? */ - opc->v[0].fd = (func) ? opt_d_dd_cs : opt_d_7dd_cs; - return_true(sc, car_x); - } - if (float_optimize(sc, cddr(car_x))) - { - opc->v[1].x = s7_number_to_real(sc, arg1); - if (d_dd_call_combinable(sc, opc, func)) - return_true(sc, car_x); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - opc->v[0].fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf; - if ((opc->v[1].x == 1.0) && (func == subtract_d_dd)) opc->v[0].fd = opt_d_dd_1f_subtract; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 = float symbol */ - slot = opt_float_symbol(sc, arg1); - if (slot) - { - opc->v[1].p = slot; - if (is_small_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - if (func) - opc->v[0].fd = (func == subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc; - else opc->v[0].fd = opt_d_7dd_sc; - return_true(sc, car_x); - } - slot = opt_float_symbol(sc, arg2); - if (slot) - { - opc->v[2].p = slot; - if (func) - { - if (func == multiply_d_dd) - opc->v[0].fd = opt_d_dd_ss_mul; - else opc->v[0].fd = (func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss; - } - else opc->v[0].fd = opt_d_7dd_ss; - return_true(sc, car_x); - } - if (float_optimize(sc, cddr(car_x))) - { - if (d_dd_sf_combinable(sc, opc, func)) - return_true(sc, car_x); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - if (func) - { - opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_sf_mul : - ((func == add_d_dd) ? opt_d_dd_sf_add : - ((func == subtract_d_dd) ? opt_d_dd_sf_sub : opt_d_dd_sf)); - if ((func == multiply_d_dd) && (opc->v[5].fd == opt_d_7pii_scs)) - opc->v[0].fd = opt_d_dd_sf_mul_fvref; - } - else opc->v[0].fd = opt_d_7dd_sf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - return_false(sc, car_x); - } - - /* arg1 = float expr or non-float */ - o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - int32_t start2 = sc->pc; - if (is_small_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - if (func) - { - if (func == add_d_dd) - { - opc->v[0].fd = (opc->v[5].fd == opt_d_7pi_ss_fvref_direct) ? opt_d_dd_fc_fvref_add : opt_d_dd_fc_add; - return_true(sc, car_x); - } - if (func == subtract_d_dd) - { - opc->v[0].fd = opt_d_dd_fc_subtract; - /* if o1->v[0].fd = opt_d_7d_c and its o->v[3].d_7d_f = random_d_7d it's (- (random f1) f2) */ - if ((opc == sc->opts[sc->pc - 2]) && - (sc->opts[start]->v[0].fd == opt_d_7d_c) && - (sc->opts[start]->v[3].d_7d_f == random_d_7d)) - { - opc->v[0].fd = opt_subtract_random_f_f; - opc->v[1].x = sc->opts[start]->v[1].x; /* random arg */ - backup_pc(sc); - }} - else opc->v[0].fd = opt_d_dd_fc; - } - else opc->v[0].fd = opt_d_7dd_fc; - return_true(sc, car_x); - } - slot = opt_float_symbol(sc, arg2); - if (slot) - { - opc->v[1].p = slot; - if (d_dd_fs_combinable(sc, opc, func)) - return_true(sc, car_x); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - if (func) - { - opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_fs_mul : - ((func == add_d_dd) ? opt_d_dd_fs_add : - ((func == subtract_d_dd) ? opt_d_dd_fs_sub : opt_d_dd_fs)); - if ((func == add_d_dd) && (opc->v[5].fd == opt_d_7pii_scs)) - opc->v[0].fd = opt_d_dd_fs_add_fvref; - } - else opc->v[0].fd = opt_d_7dd_fs; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opt_info *o2; - opc->v[8].o1 = o1; - opc->v[9].fd = o1->v[0].fd; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - if (func) - { - if (d_dd_ff_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_dd_ff; - if (func == multiply_d_dd) - { - if (arg1 == arg2) - opc->v[0].fd = opt_d_dd_ff_square; - else - if ((opc->v[9].fd == opt_d_7pii_sss) && (opc->v[11].fd == opt_d_7pii_sss) && - (o1->v[4].d_7pii_f == float_vector_ref_d_7pii)) /* currently redundant */ - opc->v[0].fd = opt_d_dd_ff_mul_sss; - else opc->v[0].fd = opt_d_dd_ff_mul; - return_true(sc, car_x); - } - o2 = sc->opts[start2]; /* this is opc->v[10].o1 */ - if (func == add_d_dd) - { - if (o2->v[0].fd == opt_d_dd_ff_mul) - { - opc->v[0].fd = opt_d_dd_ff_add_mul; - opc->v[4].o1 = o1; /* add first arg */ - opc->v[5].fd = o1->v[0].fd; - opc->v[8].o1 = o2->v[8].o1; /* mul first arg */ - opc->v[9].fd = o2->v[9].fd; - opc->v[10].o1 = o2->v[10].o1; /* mul second arg */ - opc->v[11].fd = o2->v[11].fd; - return_true(sc, car_x); - } - if ((o2->v[0].fd == opt_d_7pi_sf) && - (o2->v[3].d_7pi_f == float_vector_ref_d_7pi)) - { - opc->v[0].fd = opt_d_dd_ff_add_fv_ref; - opc->v[6].p = o2->v[1].p; - opc->v[8].o1 = o2->v[10].o1; /* sc->opts[start2 + 1]; */ - opc->v[9].fi = o2->v[11].fi; /* sc->opts[start2 + 1]->v[0].fi; */ - } - else - { - opc->v[0].fd = opt_d_dd_ff_add; - opc->v[10].o1 = o2; - opc->v[11].fd = o2->v[0].fd; - } - opc->v[4].o1 = o1; /* sc->opts[start]; */ - opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ - return_true(sc, car_x); - } - if (func == subtract_d_dd) - { - opc->v[0].fd = opt_d_dd_ff_sub; - opc->v[4].o1 = o1; /* sc->opts[start]; */ - opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ - opc->v[10].o1 = o2; - opc->v[11].fd = o2->v[0].fd; - return_true(sc, car_x); - }} - else - { - opc->v[0].fd = opt_d_7dd_ff; - if ((opc->v[11].fd == opt_d_dd_ff_add_fv_ref) && - (opc->v[3].d_7dd_f == divide_d_7dd)) - opc->v[0].fd = opt_d_7dd_ff_div_add; - } - return_true(sc, car_x); - }} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- d_ddd -------- */ -static s7_double opt_d_ddd_sss(opt_info *o) {return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p)), real(slot_value(o->v[3].p))));} -static s7_double opt_d_ddd_ssf(opt_info *o) {return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));} - -static s7_double opt_d_ddd_sff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), x1, x2)); -} - -static s7_double opt_d_ddd_fff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - s7_double x3 = o->v[6].fd(o->v[5].o1); - return(o->v[4].d_ddd_f(x1, x2, x3)); -} - -static s7_double opt_d_ddd_fff1(opt_info *o) -{ - s7_double x1 = o->v[1].d_v_f(o->v[2].obj); - s7_double x2 = o->v[3].d_v_f(o->v[4].obj); - s7_double x3 = o->v[5].d_v_f(o->v[6].obj); - return(o->v[7].d_ddd_f(x1, x2, x3)); -} - -static s7_double opt_d_ddd_fff2(opt_info *o) -{ - s7_double x1 = o->v[1].d_v_f(o->v[2].obj); - s7_double x2 = o->v[9].fd(o->v[12].o1); - s7_double x3 = o->v[6].fd(o->v[5].o1); - return(o->v[7].d_ddd_f(x1, x2, x3)); -} - -static s7_double opt_d_ddd_fff_mul(opt_info *o) -{ - s7_double x1 = opt_D_s(o->v[10].o1); - s7_double x2 = opt_D_s(o->v[8].o1); - s7_double x3 = opt_d_s(o->v[5].o1); - return(multiply_d_ddd(x1, x2, x3)); -} - -static bool d_ddd_fff_combinable(s7_scheme *sc, opt_info *opc, int32_t start) -{ - opt_info *o1; - if (sc->opts[start]->v[0].fd != opt_d_v) - return_false(sc, NULL); - opc->v[12].o1 = opc->v[8].o1; - opc->v[7].d_ddd_f = opc->v[4].d_ddd_f; - o1 = sc->opts[start]; - opc->v[1].d_v_f = o1->v[3].d_v_f; - opc->v[2].obj = o1->v[5].obj; - opc->v[8].p = o1->v[1].p; - if ((sc->opts[start + 1]->v[0].fd == opt_d_v) && - (sc->opts[start + 2]->v[0].fd == opt_d_v)) - { - opc->v[0].fd = opt_d_ddd_fff1; - o1 = sc->opts[start + 1]; - opc->v[3].d_v_f = o1->v[3].d_v_f; - opc->v[4].obj = o1->v[5].obj; - opc->v[9].p = o1->v[1].p; - o1 = sc->opts[start + 2]; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[6].obj = o1->v[5].obj; - opc->v[10].p = o1->v[1].p; - sc->pc -= 3; - return_true(sc, NULL); - } - opc->v[0].fd = opt_d_ddd_fff2; - opc->v[9].fd = opc->v[12].o1->v[0].fd; - opc->v[6].fd = opc->v[5].o1->v[0].fd; - return_true(sc, NULL); -} - -static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); - s7_d_ddd_t f = s7_d_ddd_function(s_func); - if (!f) - return_false(sc, car_x); - opc->v[4].d_ddd_f = f; - slot = opt_float_symbol(sc, arg1); - opc->v[10].o1 = sc->opts[start]; - if (slot) - { - opc->v[1].p = slot; - slot = opt_float_symbol(sc, arg2); - if (slot) - { - s7_pointer arg3 = cadddr(car_x); - opc->v[2].p = slot; - slot = opt_float_symbol(sc, arg3); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_ddd_sss; - return_true(sc, car_x); - } - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[0].fd = opt_d_ddd_ssf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - if (float_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[0].fd = opt_d_ddd_sff; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - } - if (float_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[5].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - if (d_ddd_fff_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_ddd_fff; /* tfft: (* xout xin iw) (+ (* xout xin iw) (* yout yin ih) (* zout zin id)) */ - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[6].fd = opc->v[5].o1->v[0].fd; - if ((f = multiply_d_ddd) && (opc->v[11].fd == opt_D_s) && (opc->v[9].fd == opt_D_s) && (opc->v[6].fd == opt_d_s)) - opc->v[0].fd = opt_d_ddd_fff_mul; - return_true(sc, car_x); - }}} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- d_7pid -------- */ -static s7_double opt_d_7pid_ssf(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))); -} - -static s7_pointer opt_d_7pid_ssf_nr(opt_info *o) -{ - o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)); - return(NULL); -} - -static s7_double opt_d_7pid_sss(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), real(slot_value(o->v[3].p)))); -} - -static s7_double opt_d_7pid_ssc(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[3].x)); -} - -static s7_double opt_d_7pid_sff(opt_info *o) -{ - s7_int pos = o->v[11].fi(o->v[10].o1); - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), pos, o->v[9].fd(o->v[8].o1))); -} - -static s7_double opt_d_7pid_sff_fvset(opt_info *o) -{ - s7_int pos = o->v[11].fi(o->v[10].o1); - return(float_vector_set_d_7pid(o->sc, slot_value(o->v[1].p), pos, o->v[9].fd(o->v[8].o1))); -} - -static s7_double opt_d_7pid_sso(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].d_v_f(o->v[3].obj))); -} - -static s7_double opt_d_7pid_ss_ss(opt_info *o) -{ - return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), - integer(slot_value(o->v[2].p)), - o->v[3].d_7pi_f(o->sc, slot_value(o->v[5].p), integer(slot_value(o->v[6].p))))); -} - -static s7_double opt_d_7pid_ssfo(opt_info *o) -{ - s7_pointer fv = slot_value(o->v[1].p); - return(o->v[4].d_7pid_f(o->sc, fv, integer(slot_value(o->v[2].p)), - o->v[6].d_dd_f(o->v[5].d_7pi_f(o->sc, fv, integer(slot_value(o->v[3].p))), real(slot_value(o->v[8].p))))); -} - -static s7_double opt_d_7pid_ssfo_fv(opt_info *o) -{ - s7_double *els = float_vector_floats(slot_value(o->v[1].p)); - s7_double val = o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))], real(slot_value(o->v[8].p))); - els[integer(slot_value(o->v[2].p))] = val; - return(val); -} - -static s7_pointer opt_d_7pid_ssfo_fv_nr(opt_info *o) /* these next are variations on (float-vector-set! s (float-vector-ref s...)) */ -{ - s7_double *els = float_vector_floats(slot_value(o->v[1].p)); - els[integer(slot_value(o->v[2].p))] = o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))], real(slot_value(o->v[8].p))); - return(NULL); -} - -static s7_pointer opt_d_7pid_ssfo_fv_add_nr(opt_info *o) -{ - s7_double *els = float_vector_floats(slot_value(o->v[1].p)); - els[integer(slot_value(o->v[2].p))] = els[integer(slot_value(o->v[3].p))] + real(slot_value(o->v[8].p)); - return(NULL); -} - -static s7_pointer opt_d_7pid_ssfo_fv_sub_nr(opt_info *o) -{ - s7_double *els = float_vector_floats(slot_value(o->v[1].p)); - els[integer(slot_value(o->v[2].p))] = els[integer(slot_value(o->v[3].p))] - real(slot_value(o->v[8].p)); - return(NULL); -} - -static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fd == opt_d_v) - { - opc->v[6].p = o1->v[1].p; - opc->v[3].obj = o1->v[5].obj; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = opt_d_7pid_sso; - backup_pc(sc); - return_true(sc, NULL); - } - if ((o1->v[0].fd == opt_d_7pi_ss) || (o1->v[0].fd == opt_d_7pi_ss_fvref) || (o1->v[0].fd == opt_d_7pi_ss_fvref_direct)) - { - opc->v[3].d_7pi_f = o1->v[3].d_7pi_f; - opc->v[5].p = o1->v[1].p; - opc->v[6].p = o1->v[2].p; - opc->v[0].fd = opt_d_7pid_ss_ss; - backup_pc(sc); - return_true(sc, NULL); - } - if ((o1->v[0].fd == opt_d_dd_fso) && - (opc->v[1].p == o1->v[2].p)) - { - /* opc: pid_ssf: o->v[4].d_7pid_f(slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fd(o1)) - * o1: d_dd_fso: o->v[4].d_dd_f(o->v[5].d_7pi_f(slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p)))) - */ - opc->v[6].d_dd_f = o1->v[4].d_dd_f; - opc->v[5].d_7pi_f = o1->v[5].d_7pi_f; - opc->v[3].p = o1->v[3].p; - opc->v[8].p = o1->v[1].p; - opc->v[0].fd = opt_d_7pid_ssfo; - if ((opc->v[5].d_7pi_f == float_vector_ref_d_7pi) && - ((opc->v[4].d_7pid_f == float_vector_set_d_7pid_direct) || (opc->v[4].d_7pid_f == float_vector_set_d_7pid))) - opc->v[0].fd = opt_d_7pid_ssfo_fv; /* actually if either is *_d, we need to check the indices */ - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer indexp3, s7_pointer valp); -static bool d_7pid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7pid_t f = s7_d_7pid_function(s_func); - if ((f) && - (is_symbol(cadr(car_x)))) - { - s7_pointer slot, head = car(car_x); - int32_t start = sc->pc; - opc->v[4].d_7pid_f = f; - - if (is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) - return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), NULL, NULL, cdddr(car_x))); - - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - opc->v[10].o1 = sc->opts[start]; - if (is_slot(opc->v[1].p)) - { - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_float_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_7pid_sss; - return_true(sc, car_x); - } - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[11].fd = sc->opts[start]->v[0].fd; - if (d_7pid_ssf_combinable(sc, opc)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_7pid_ssf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[0].fd = opt_d_7pid_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- d_7pii -------- */ -/* currently this can only be float_vector_ref_d_7pii (d_7pii is not exported at this time) */ - -static s7_double opt_d_7pii_sss(opt_info *o) -{ /* o->v[4].d_7pii_f */ - return(float_vector_ref_d_7pii(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)))); -} - -static s7_double opt_d_7pii_sss_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - return(float_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p))))); -} - -static s7_double opt_d_7pii_scs(opt_info *o) -{ - return(float_vector_ref_d_7pii(o->sc, slot_value(o->v[1].p), o->v[2].i, integer(slot_value(o->v[3].p)))); -} - -static s7_double opt_d_7pii_sff(opt_info *o) -{ - return(float_vector_ref_d_7pii(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1))); -} - -static bool d_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7pii_t ifunc = s7_d_7pii_function(s_func); - if ((ifunc == float_vector_ref_d_7pii) && - (is_symbol(cadr(car_x)))) - { - s7_pointer slot; - int32_t start = sc->pc; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if ((!is_slot(opc->v[1].p)) || - (!is_float_vector(slot_value(opc->v[1].p))) || - (vector_rank(slot_value(opc->v[1].p)) != 2)) - return_false(sc, car_x); - - opc->v[4].d_7pii_f = ifunc; /* currently pointless */ - slot = opt_integer_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[2].p = slot; - opc->v[0].fd = opt_d_7pii_sss; - if ((step_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fd = opt_d_7pii_sss_unchecked; - return_true(sc, car_x); - } - if (is_t_integer(caddr(car_x))) - { - opc->v[2].i = integer(caddr(car_x)); - opc->v[0].fd = opt_d_7pii_scs; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[start]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[0].fd = opt_d_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - } - return_false(sc, car_x); -} - -/* -------- d_7piid -------- */ -/* currently only float_vector_set */ - -static s7_double opt_d_7piid_sssf(opt_info *o) -{ /* o->v[5].d_7piid_f and below */ - return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[9].fd(o->v[8].o1))); -} - -static s7_double opt_d_7piid_sssc(opt_info *o) -{ - return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[4].x)); -} - -static s7_double opt_d_7piid_scsf(opt_info *o) -{ - return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), o->v[2].i, integer(slot_value(o->v[3].p)), o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_7piid_sfff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), i1, i2, o->v[4].fd(o->v[3].o1))); -} - -static s7_double opt_d_7piid_sssf_unchecked(opt_info *o) /* this could be subsumed by the call above if we were using o->v[5] or o->v[0].fd */ -{ - s7_int i1 = integer(slot_value(o->v[2].p)), i2 = integer(slot_value(o->v[3].p)); - s7_pointer vect = slot_value(o->v[1].p); - s7_double val = o->v[9].fd(o->v[8].o1); - float_vector(vect, (i1 * (vector_offset(vect, 0)) + i2)) = val; - return(val); -} - -static bool d_7piid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7piid_t f = s7_d_7piid_function(s_func); - if ((f) && - (is_symbol(cadr(car_x)))) - { - opc->v[4].d_7piid_f = f; - if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_set_symbol)) - return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), NULL, cddddr(car_x))); - } - return_false(sc, car_x); -} - -/* -------- d_7piii -------- */ -static s7_double opt_d_7piii_ssss(opt_info *o) -{ - return(float_vector_ref_d_7piii(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), - integer(slot_value(o->v[3].p)), integer(slot_value(o->v[5].p)))); -} - -static s7_double opt_d_7piii_ssss_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - s7_int i1 = integer(slot_value(o->v[2].p)) * vector_offset(v, 0); - s7_int i2 = integer(slot_value(o->v[3].p)) * vector_offset(v, 1); /* offsets accumulate */ - return(float_vector(v, (i1 + i2 + integer(slot_value(o->v[5].p))))); -} - -static bool d_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7piii_t ifunc = s7_d_7piii_function(s_func); - if ((ifunc == float_vector_ref_d_7piii) && - (is_symbol(cadr(car_x)))) - { - s7_pointer slot; - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if ((!is_slot(opc->v[1].p)) || - (!is_float_vector(slot_value(opc->v[1].p))) || - (vector_rank(slot_value(opc->v[1].p)) != 3)) - return_false(sc, car_x); - - opc->v[4].d_7piii_f = ifunc; /* currently ignored */ - slot = opt_integer_symbol(sc, car(cddddr(car_x))); - if (slot) - { - opc->v[5].p = slot; - slot = opt_integer_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - s7_pointer vect = slot_value(opc->v[1].p); - opc->v[2].p = slot; - opc->v[0].fd = opt_d_7piii_ssss; - if ((step_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(vect, 1))) && - (step_end_fits(opc->v[5].p, vector_dimension(vect, 2)))) - opc->v[0].fd = opt_d_7piii_ssss_unchecked; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - -/* -------- d_7piiid -------- */ -static s7_double opt_d_7piiid_ssssf(opt_info *o) -{ - return(float_vector_set_d_7piiid(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), - integer(slot_value(o->v[3].p)), integer(slot_value(o->v[5].p)), o->v[11].fd(o->v[10].o1))); -} - -static s7_double opt_d_7piiid_ssssf_unchecked(opt_info *o) -{ - s7_pointer vect = slot_value(o->v[1].p); - s7_int i1 = integer(slot_value(o->v[2].p)) * vector_offset(vect, 0); - s7_int i2 = integer(slot_value(o->v[3].p)) * vector_offset(vect, 1); - s7_int i3 = integer(slot_value(o->v[5].p)); - s7_double val = o->v[11].fd(o->v[10].o1); - float_vector(vect, (i1 + i2 + i3)) = val; - return(val); -} - -static bool d_7piiid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_7piiid_t f = s7_d_7piiid_function(s_func); - if ((f == float_vector_set_d_7piiid) && - (is_symbol(cadr(car_x)))) - { - opc->v[4].d_7piiid_f = f; - if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_set_symbol)) - return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x), cdr(cddddr(car_x)))); - } - return(false); -} - -static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer indexp3, s7_pointer valp) -{ - s7_pointer settee = lookup_slot_from(v, sc->curlet); - if ((is_slot(settee)) && - (!is_immutable(slot_value(settee)))) - { - s7_pointer slot, vect = slot_value(settee); - int32_t start = sc->pc; - opc->v[1].p = settee; - if (!is_float_vector(vect)) - return_false(sc, NULL); - opc->v[10].o1 = sc->opts[start]; - if ((!indexp2) && - (vector_rank(vect) == 1)) - { - opc->v[4].d_7pid_f = float_vector_set_d_7pid; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (step_end_fits(opc->v[2].p, vector_length(vect))) - opc->v[4].d_7pid_f = float_vector_set_d_7pid_direct; - slot = opt_float_symbol(sc, car(valp)); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_7pid_sss; - return_true(sc, NULL); - } - if (is_small_real(car(valp))) - { - opc->v[3].x = s7_real(car(valp)); - opc->v[0].fd = opt_d_7pid_ssc; - return_true(sc, NULL); - } - if (float_optimize(sc, valp)) - { - opc->v[11].fd = sc->opts[start]->v[0].fd; - if (d_7pid_ssf_combinable(sc, opc)) - return_true(sc, NULL); - opc->v[0].fd = opt_d_7pid_ssf; - return_true(sc, NULL); - } - pc_fallback(sc, start); - } - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = (opc->v[4].d_7pid_f == float_vector_set_d_7pid) ? opt_d_7pid_sff_fvset : opt_d_7pid_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - return_true(sc, NULL); - }} - return_false(sc, NULL); - } - if ((indexp2) && (!indexp3) && - (vector_rank(vect) == 2)) - { - opc->v[5].d_7piid_f = float_vector_set_d_7piid; - /* could check for step_end/end-ok here for both indices, but the d_7pii* functions currently assume fv_d_7piid - * perhaps set a different fd? so opc->v[0].fd = fvset_unchecked_d_7piid or whatever - */ - slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - if (is_t_integer(car(indexp1))) - { - if (!float_optimize(sc, valp)) - return_false(sc, NULL); - opc->v[0].fd = opt_d_7piid_scsf; - opc->v[2].i = integer(car(indexp1)); - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, NULL); - } - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (is_small_real(car(valp))) - { - opc->v[0].fd = opt_d_7piid_sssc; - opc->v[4].x = s7_real(car(valp)); - return_true(sc, NULL); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = opt_d_7piid_sssf; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - - if ((step_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(vect, 1)))) - opc->v[0].fd = opt_d_7piid_sssf_unchecked; - return_true(sc, NULL); - } - pc_fallback(sc, start); - }} - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[3].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = opt_d_7piid_sfff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[4].fd = opc->v[3].o1->v[0].fd; - return_true(sc, NULL); - }}} - return_false(sc, NULL); - } - if ((indexp3) && - (vector_rank(vect) == 3)) - { - opc->v[4].d_7piiid_f = float_vector_set_d_7piiid; - slot = opt_integer_symbol(sc, car(indexp3)); - if (slot) - { - opc->v[5].p = slot; - slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = opt_d_7piiid_ssssf; - opc->v[11].fd = sc->opts[start]->v[0].fd; - if ((step_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(vect, 1))) && - (step_end_fits(opc->v[5].p, vector_dimension(vect, 2)))) - opc->v[0].fd = opt_d_7piiid_ssssf_unchecked; - return_true(sc, NULL); - }}}}}} - return_false(sc, NULL); -} - - -/* -------- d_vid -------- */ -static s7_double opt_d_vid_ssf(opt_info *o) {return(o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));} - -static inline s7_double opt_fmv(opt_info *o) -{ - /* d_vid_ssf -> d_dd_ff_o1 -> d_vd_o1 -> d_dd_ff_o3, this is a placeholder */ - opt_info *o1 = o->v[12].o1; - opt_info *o2 = o->v[13].o1; - opt_info *o3 = o->v[14].o1; - s7_double amp_env = o1->v[2].d_v_f(o1->v[1].obj); - s7_double vib = real(slot_value(o2->v[2].p)); - s7_double index_env = o3->v[5].d_v_f(o3->v[1].obj); - return(o->v[4].d_vid_f(o->v[5].obj, - integer(slot_value(o->v[2].p)), - amp_env * o2->v[3].d_vd_f(o2->v[5].obj, - vib + (index_env * o3->v[6].d_vd_f(o3->v[2].obj, vib))))); -} - -static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - if ((is_symbol(cadr(car_x))) && - (is_symbol(caddr(car_x)))) - { - s7_pointer sig; - s7_d_vid_t flt = s7_d_vid_function(s_func); - if (!flt) - return_false(sc, car_x); - opc->v[4].d_vid_f = flt; - sig = c_function_signature(s_func); - if (is_pair(sig)) - { - int32_t start = sc->pc; - s7_pointer vslot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (vslot) - { - s7_pointer slot; - opc->v[0].fd = opt_d_vid_ssf; - opc->v[1].p = vslot; - opc->v[10].o1 = sc->opts[start]; - slot = opt_integer_symbol(sc, caddr(car_x)); - if ((slot) && - (float_optimize(sc, cdddr(car_x)))) - { - opt_info *o2; - opc->v[2].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(vslot)); - opc->v[11].fd = opc->v[10].o1->v[0].fd; - o2 = sc->opts[start]; - if (o2->v[0].fd == opt_d_dd_ff_mul1) - { - opt_info *o3 = sc->opts[start + 2]; - if (o3->v[0].fd == opt_d_vd_o1) - { - opt_info *o1 = sc->opts[start + 4]; - if ((o1->v[0].fd == opt_d_dd_ff_o3) && - (o1->v[4].d_dd_f == multiply_d_dd) && - (o3->v[4].d_dd_f == add_d_dd)) - { - opc->v[0].fd = opt_fmv; /* a placeholder -- see below */ - opc->v[12].o1 = o2; - opc->v[13].o1 = o3; - opc->v[14].o1 = o1; - }}} - return_true(sc, car_x); - }} - pc_fallback(sc, start); - }} - return_false(sc, car_x); -} - -/* -------- d_vdd -------- */ -static s7_double opt_d_vdd_ff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - return(o->v[4].d_vdd_f(o->v[5].obj, x1, x2)); -} - -static bool d_vdd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_vdd_t flt = s7_d_vdd_function(s_func); - if (flt) - { - s7_pointer sig = c_function_signature(s_func); - opc->v[4].d_vdd_f = flt; - if (is_pair(sig)) - { - s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (slot) - { - int32_t start = sc->pc; - opc->v[10].o1 = sc->opts[start]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - opc->v[0].fd = opt_d_vdd_ff; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - }}} - return_false(sc, car_x); -} - - -/* -------- d_dddd -------- */ -static s7_double opt_d_dddd_ffff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - s7_double x3 = o->v[5].fd(o->v[4].o1); - s7_double x4 = o->v[3].fd(o->v[2].o1); - return(o->v[1].d_dddd_f(x1, x2, x3, x4)); -} - -static bool d_dddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_d_dddd_t f = s7_d_dddd_function(s_func); - if (!f) - return_false(sc, car_x); - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[2].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddddr(car_x))) - { - opc->v[1].d_dddd_f = f; - opc->v[0].fd = opt_d_dddd_ffff; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[5].fd = opc->v[4].o1->v[0].fd; - opc->v[3].fd = opc->v[2].o1->v[0].fd; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - -/* -------- d_add|multiply|subtract_any ------- */ -static s7_double opt_d_add_any_f(opt_info *o) -{ - s7_double sum = 0.0; - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 2].o1; - sum += o1->v[0].fd(o1); - } - return(sum); -} - -static s7_double opt_d_multiply_any_f(opt_info *o) -{ - s7_double sum = 1.0; - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 2].o1; - sum *= o1->v[0].fd(o1); - } - return(sum); -} - -static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x) -{ - s7_pointer head = car(car_x); - int32_t start = sc->pc; - if ((head == sc->add_symbol) || - (head == sc->multiply_symbol)) - { - s7_pointer p; - int32_t cur_len; - for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); p = cdr(p), cur_len++) - { - opc->v[cur_len + 2].o1 = sc->opts[sc->pc]; - if (!float_optimize(sc, p)) - break; - } - if (is_null(p)) - { - opc->v[1].i = cur_len; - opc->v[0].fd = (head == sc->add_symbol) ? opt_d_add_any_f : opt_d_multiply_any_f; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - return_false(sc, car_x); -} - - -/* -------- d_syntax -------- */ -static s7_double opt_set_d_d_f(opt_info *o) -{ - s7_double x = o->v[3].fd(o->v[2].o1); - slot_set_value(o->v[1].p, make_real(o->sc, x)); - return(x); -} - -static s7_double opt_set_d_d_fm(opt_info *o) -{ - s7_double x = o->v[3].fd(o->v[2].o1); - real(slot_value(o->v[1].p)) = x; - return(x); -} - -static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - if ((len == 3) && - (car(car_x) == sc->set_symbol)) - { - opt_info *opc = alloc_opt_info(sc); - if (is_symbol(cadr(car_x))) - { - s7_pointer settee; - if (is_immutable(cadr(car_x))) - return_false(sc, car_x); - settee = lookup_slot_from(cadr(car_x), sc->curlet); - if ((is_slot(settee)) && - (is_t_real(slot_value(settee))) && - (!is_immutable(settee)) && - ((!slot_has_setter(settee)) || - ((is_c_function(slot_setter(settee))) && - ((slot_setter(settee) == initial_value(sc->is_float_symbol)) || - (c_function_call(slot_setter(settee)) == b_is_float_setter))))) - { - opt_info *o1 = sc->opts[sc->pc]; - opc->v[1].p = settee; - if ((!is_t_integer(caddr(car_x))) && - (float_optimize(sc, cddr(car_x)))) - { - opc->v[0].fd = (is_mutable_number(slot_value(opc->v[1].p))) ? opt_set_d_d_fm : opt_set_d_d_f; - opc->v[2].o1 = o1; - opc->v[3].fd = o1->v[0].fd; - return_true(sc, car_x); - }}} - else /* if is_pair(settee) get setter */ - if ((is_pair(cadr(car_x))) && - (is_symbol(caadr(car_x))) && - (is_pair(cdadr(car_x)))) - { - if (is_null(cddadr(car_x))) - return(opt_float_vector_set(sc, opc, caadr(car_x), cdadr(car_x), NULL, NULL, cddr(car_x))); - if (is_null(cdddr(cadr(car_x)))) - return(opt_float_vector_set(sc, opc, caadr(car_x), cdadr(car_x), cddadr(car_x), NULL, cddr(car_x))); - }} - return_false(sc, car_x); -} - -static bool d_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len) -{ - s7_pointer slot, obj = slot_value(s_slot); - if (is_float_vector(obj)) - { - /* implicit float-vector-ref */ - if ((len == 2) && - (vector_rank(obj) == 1)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[3].d_7pi_f = float_vector_ref_d_7pi; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - if (step_end_fits(opc->v[2].p, vector_length(obj))) - opc->v[0].fd = opt_d_7pi_ss_fvref_direct; - else opc->v[0].fd = opt_d_7pi_ss_fvref; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[0].fd = opt_d_7pi_sf; - return_true(sc, car_x); - } - if ((len == 3) && - (vector_rank(obj) == 2)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[4].d_7pii_f = float_vector_ref_d_7pii; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_7pii_sss; - if ((step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fd = opt_d_7pii_sss_unchecked; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }}} - if ((len == 4) && - (vector_rank(obj) == 3)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[4].d_7piii_f = float_vector_ref_d_7piii; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[5].p = slot; - opc->v[0].fd = opt_d_7piii_ssss; - if ((step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1))) && - (step_end_fits(opc->v[5].p, vector_dimension(obj, 2)))) - opc->v[0].fd = opt_d_7piii_ssss_unchecked; - return_true(sc, car_x); - }}}}} - if ((is_c_object(obj)) && - (len == 2)) - { - s7_pointer getf = c_object_getf(sc, obj); - if (is_c_function(getf)) /* default is #f */ - { - s7_d_7pi_t func = s7_d_7pi_function(getf); - if (func) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[4].obj = (void *)c_object_value(obj); - opc->v[3].d_7pi_f = func; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[0].fd = opt_d_7pi_ss; - opc->v[2].p = slot; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[0].fd = opt_d_7pi_sf; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - - -/* -------------------------------- bool opts -------------------------------- */ -static bool opt_b_s(opt_info *o) {return(slot_value(o->v[1].p) != o->sc->F);} - -static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x) -{ - s7_pointer p; - if (!is_symbol(car_x)) - return_false(sc, car_x); /* i.e. use cell_optimize */ - p = opt_simple_symbol(sc, car_x); - if ((p) && - (is_boolean(slot_value(p)))) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = p; - opc->v[0].fb = opt_b_s; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- b_idp -------- */ -static bool opt_b_i_s(opt_info *o) {return(o->v[2].b_i_f(integer(slot_value(o->v[1].p))));} -static bool opt_b_i_f(opt_info *o) {return(o->v[2].b_i_f(o->v[11].fi(o->v[10].o1)));} -static bool opt_b_d_s(opt_info *o) {return(o->v[2].b_d_f(real(slot_value(o->v[1].p))));} -static bool opt_b_d_f(opt_info *o) {return(o->v[2].b_d_f(o->v[11].fd(o->v[10].o1)));} -static bool opt_b_p_s(opt_info *o) {return(o->v[2].b_p_f(slot_value(o->v[1].p)));} -static bool opt_b_p_f(opt_info *o) {return(o->v[2].b_p_f(o->v[4].fp(o->v[3].o1)));} -static bool opt_b_7p_s(opt_info *o) {return(o->v[2].b_7p_f(o->sc, slot_value(o->v[1].p)));} -static bool opt_b_7p_s_not(opt_info *o) {return(slot_value(o->v[1].p) == o->sc->F);} -static bool opt_b_7p_f(opt_info *o) {return(o->v[2].b_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));} -static bool opt_b_d_s_is_positive(opt_info *o) {return(real(slot_value(o->v[1].p)) > 0.0);} -static bool opt_b_p_s_is_integer(opt_info *o) {return(s7_is_integer(slot_value(o->v[1].p)));} -static bool opt_b_p_s_is_pair(opt_info *o) {return(is_pair(slot_value(o->v[1].p)));} -static bool opt_b_p_f_is_string(opt_info *o) {return(s7_is_string(o->v[4].fp(o->v[3].o1)));} -static bool opt_b_7p_s_iter_at_end(opt_info *o) {return(iterator_is_at_end(slot_value(o->v[1].p)));} -static bool opt_b_7p_f_not(opt_info *o) {return((o->v[4].fp(o->v[3].o1)) == o->sc->F);} - -static bool opt_zero_mod(opt_info *o) -{ - s7_int x = integer(slot_value(o->v[1].p)); - return((x % o->v[2].i) == 0); -} - -static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg_type) -{ - s7_b_p_t bpf = NULL; - s7_b_7p_t bpf7 = NULL; - opt_info *opc = alloc_opt_info(sc); - int32_t cur_index = sc->pc; - - if (arg_type == sc->is_integer_symbol) - { - s7_b_i_t bif = s7_b_i_function(s_func); - if (bif) - { - opc->v[2].b_i_f = bif; - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - opc->v[0].fb = opt_b_i_s; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((car(car_x) == sc->is_zero_symbol) && - (o1->v[0].fi == opt_i_ii_sc) && - (o1->v[3].i_ii_f == modulo_i_ii_unchecked)) - { - opc->v[0].fb = opt_zero_mod; - opc->v[1].p = o1->v[1].p; - opc->v[2].i = o1->v[2].i; - backup_pc(sc); - return_true(sc, car_x); - } - opc->v[0].fb = opt_b_i_f; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - return_true(sc, car_x); - }}} - else - if (arg_type == sc->is_float_symbol) - { - s7_b_d_t bdf = s7_b_d_function(s_func); - if (bdf) - { - opc->v[2].b_d_f = bdf; - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - opc->v[0].fb = (bdf == is_positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[0].fb = opt_b_d_f; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, car_x); - }}} - pc_fallback(sc, cur_index); - - bpf = s7_b_p_function(s_func); - if (!bpf) bpf7 = s7_b_7p_function(s_func); - if ((bpf) || (bpf7)) - { - if (bpf) - opc->v[2].b_p_f = bpf; - else opc->v[2].b_7p_f = bpf7; - if (is_symbol(cadr(car_x))) - { - s7_pointer p = opt_simple_symbol(sc, cadr(car_x)); - if (!p) return_false(sc, car_x); - opc->v[1].p = p; - opc->v[0].fb = (bpf) ? ((bpf == s7_is_integer) ? opt_b_p_s_is_integer : ((bpf == s7_is_pair) ? opt_b_p_s_is_pair : opt_b_p_s)) : - (((bpf7 == iterator_is_at_end_b_7p) && (is_iterator(slot_value(p)))) ? opt_b_7p_s_iter_at_end : - ((bpf7 == not_b_7p) ? opt_b_7p_s_not : opt_b_7p_s)); - return_true(sc, car_x); - } - opc->v[3].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fb = (bpf) ? ((bpf == s7_is_string) ? opt_b_p_f_is_string : opt_b_p_f) : (bpf7 == not_b_7p) ? opt_b_7p_f_not : opt_b_7p_f; - opc->v[4].fp = opc->v[3].o1->v[0].fp; - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - - -/* -------- b_pp -------- */ -static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) -{ - s7_pointer slot, arg = car(argp); - if (is_pair(arg)) - { - if (is_symbol(car(arg))) - { - if ((is_global(car(arg))) || - ((is_slot(global_slot(car(arg)))) && - (lookup_slot_from(car(arg), sc->curlet) == global_slot(car(arg))))) - { - s7_pointer a_func = global_value(car(arg)); - if (is_c_function(a_func)) - { - s7_pointer sig = c_function_signature(a_func); - if (is_pair(sig)) - { - if ((car(sig) == sc->is_integer_symbol) || - ((is_pair(car(sig))) && (direct_memq(sc->is_integer_symbol, car(sig))))) - return(sc->is_integer_symbol); - if ((car(sig) == sc->is_float_symbol) || - ((is_pair(car(sig))) && (direct_memq(sc->is_float_symbol, car(sig))))) - return(sc->is_float_symbol); - if ((car(sig) == sc->is_real_symbol) || - (car(sig) == sc->is_number_symbol)) - { - int32_t start = sc->pc; - if (int_optimize(sc, argp)) - { - pc_fallback(sc, start); - return(sc->is_integer_symbol); - } - if (float_optimize(sc, argp)) - { - pc_fallback(sc, start); - return(sc->is_float_symbol); - } - pc_fallback(sc, start); - } - return(car(sig)); /* we want the function's return type in this context */ - } - return(sc->T); - } - if ((car(arg) == sc->quote_symbol) && - (is_pair(cdr(arg)))) - return(s7_type_of(sc, cadr(arg))); - } - slot = lookup_slot_from(car(arg), sc->curlet); - if ((is_slot(slot)) && - (is_sequence(slot_value(slot)))) - { - s7_pointer sig = s7_signature(sc, slot_value(slot)); - if (is_pair(sig)) - return(car(sig)); - }} - return(sc->T); - } - if (is_symbol(arg)) - { - slot = opt_simple_symbol(sc, arg); - if (!slot) return(sc->T); -#if WITH_GMP - if (is_big_number(slot_value(slot))) - return(sc->T); - if ((is_t_integer(slot_value(slot))) && - (integer(slot_value(slot)) > QUOTIENT_INT_LIMIT)) - return(sc->T); - if ((is_t_real(slot_value(slot))) && - (real(slot_value(slot)) > QUOTIENT_FLOAT_LIMIT)) - return(sc->T); -#endif - return(s7_type_of(sc, slot_value(slot))); - } - return(s7_type_of(sc, arg)); -} - -static bool opt_b_pp_ff(opt_info *o) -{ - s7_pointer p1 = o->v[9].fp(o->v[8].o1); - return(o->v[3].b_pp_f(p1, o->v[11].fp(o->v[10].o1))); -} - -static bool opt_b_7pp_ff(opt_info *o) -{ - s7_pointer p1 = o->v[9].fp(o->v[8].o1); - return(o->v[3].b_7pp_f(o->sc, p1, o->v[11].fp(o->v[10].o1))); -} - -static bool opt_b_pp_sf(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));} -static bool opt_b_pp_fs(opt_info *o) {return(o->v[3].b_pp_f(o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));} -static bool opt_b_pp_ss(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_pp_sc(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[2].p));} -static bool opt_b_pp_sfo(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));} -static bool opt_b_7pp_sf(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));} -static bool opt_b_7pp_fs(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));} -static bool opt_b_7pp_ss(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_7pp_ss_lt(opt_info *o) {return(lt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_7pp_ss_gt(opt_info *o) {return(gt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_7pp_ss_char_lt(opt_info *o) {return(char_lt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static bool opt_b_7pp_sc(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));} -static bool opt_b_7pp_sfo(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));} -static bool opt_is_equal_sfo(opt_info *o) {return(s7_is_equal(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));} -static bool opt_is_equivalent_sfo(opt_info *o) {return(is_equivalent_1(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p)), NULL));} -static bool opt_b_pp_sf_char_eq(opt_info *o) {return(slot_value(o->v[1].p) == o->v[11].fp(o->v[10].o1));} /* lt above checks for char args */ -static bool opt_b_pp_ff_char_eq(opt_info *o) {return(o->v[9].fp(o->v[8].o1) == o->v[11].fp(o->v[10].o1));} - -static bool opt_car_equal_sf(opt_info *o) -{ - s7_pointer p = slot_value(o->v[2].p); - return(s7_is_equal(o->sc, slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p)))); -} - -static bool opt_car_equivalent_sf(opt_info *o) -{ - s7_pointer p = slot_value(o->v[2].p); - return(is_equivalent_1(o->sc, slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p)), NULL)); -} - -static bool opt_b_7pp_car_sf(opt_info *o) -{ - s7_pointer p = slot_value(o->v[2].p); - return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p)))); -} - -static s7_pointer opt_p_substring_uncopied_ssf(opt_info *o) /* "inline" here rather than copying below is much slower? */ -{ - return(substring_uncopied_p_pii(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[6].fi(o->v[5].o1))); -} - -static bool opt_substring_equal_sf(opt_info *o) {return(scheme_strings_are_equal(slot_value(o->v[1].p), opt_p_substring_uncopied_ssf(o->v[10].o1)));} - -static s7_pointer opt_p_p_s(opt_info *o); - -static bool b_pp_sf_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fp == opt_p_p_s) - { - opc->v[2].p = o1->v[1].p; - opc->v[4].p_p_f = o1->v[2].p_p_f; - if (bpf_case) - opc->v[0].fb = opt_b_pp_sfo; - else - if (opc->v[4].p_p_f == car_p_p) - opc->v[0].fb = ((opc->v[3].b_7pp_f == s7_is_equal) ? opt_car_equal_sf : - ((opc->v[3].b_7pp_f == s7_is_equivalent) ? opt_car_equivalent_sf : opt_b_7pp_car_sf)); - else opc->v[0].fb = ((opc->v[3].b_7pp_f == s7_is_equal) ? opt_is_equal_sfo : - ((opc->v[3].b_7pp_f == s7_is_equivalent) ? opt_is_equivalent_sfo : opt_b_7pp_sfo)); - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool opt_b_pp_ffo(opt_info *o) -{ - s7_pointer b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)); - return(o->v[3].b_pp_f(b1, o->v[5].p_p_f(o->sc, slot_value(o->v[2].p)))); -} - -static bool opt_b_pp_ffo_is_eq(opt_info *o) -{ - s7_pointer b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)); - s7_pointer b2 = o->v[5].p_p_f(o->sc, slot_value(o->v[2].p)); - return((b1 == b2) || ((is_unspecified(b1)) && (is_unspecified(b2)))); -} - -static bool opt_b_7pp_ffo(opt_info *o) -{ - s7_pointer b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)); - return(o->v[3].b_7pp_f(o->sc, b1, o->v[5].p_p_f(o->sc, slot_value(o->v[2].p)))); -} - -static bool opt_b_cadr_cadr(opt_info *o) -{ - s7_pointer p1 = slot_value(o->v[1].p); - s7_pointer p2 = slot_value(o->v[2].p); - p1 = ((is_pair(p1)) && (is_pair(cdr(p1)))) ? cadr(p1) : g_cadr(o->sc, set_plist_1(o->sc, p1)); - p2 = ((is_pair(p2)) && (is_pair(cdr(p2)))) ? cadr(p2) : g_cadr(o->sc, set_plist_1(o->sc, p2)); - return(o->v[3].b_7pp_f(o->sc, p1, p2)); -} - -static bool b_pp_ff_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case) -{ - if ((sc->pc > 2) && - (opc == sc->opts[sc->pc - 3])) - { - opt_info *o1 = sc->opts[sc->pc - 2], *o2 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fp == opt_p_p_s) && (o2->v[0].fp == opt_p_p_s)) - { - opc->v[1].p = o1->v[1].p; - opc->v[4].p_p_f = o1->v[2].p_p_f; - opc->v[2].p = o2->v[1].p; - opc->v[5].p_p_f = o2->v[2].p_p_f; - opc->v[0].fb = (bpf_case) ? ((opc->v[3].b_pp_f == s7_is_eq) ? opt_b_pp_ffo_is_eq : opt_b_pp_ffo) : - (((opc->v[4].p_p_f == cadr_p_p) && (opc->v[5].p_p_f == cadr_p_p)) ? opt_b_cadr_cadr : opt_b_7pp_ffo); - sc->pc -= 2; - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static void check_b_types(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, bool (*fb)(opt_info *o)) -{ - if (s7_b_pp_unchecked_function(s_func)) - { - s7_pointer call_sig = c_function_signature(s_func); - s7_pointer arg1_type = opt_arg_type(sc, cdr(car_x)); - s7_pointer arg2_type = opt_arg_type(sc, cddr(car_x)); - if ((cadr(call_sig) == arg1_type) && /* not car(arg1_type) here: (string>? (string) (read-line)) */ - (caddr(call_sig) == arg2_type)) - { - opc->v[0].fb = fb; - opc->v[3].b_pp_f = s7_b_pp_unchecked_function(s_func); - }} -#if 0 - if ((arg2_type == sc->is_integer_symbol) && s7_b_pi_function(s_func)) - { - /* opc->v[0].fb = opt_b_pi */ - fprintf(stderr, " pi: %s\n", display(car_x)); - } -#endif -} - -static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2, bool bpf_case) -{ - int32_t cur_index = sc->pc; - opt_info *o1; - /* v[3] is set when we get here */ - if ((is_symbol(arg1)) && - (is_symbol(arg2))) - { - opc->v[1].p = opt_simple_symbol(sc, arg1); - opc->v[2].p = opt_simple_symbol(sc, arg2); - if ((opc->v[1].p) && - (opc->v[2].p)) - { - s7_b_7pp_t b7f = (bpf_case) ? NULL : opc->v[3].b_7pp_f; - opc->v[0].fb = (bpf_case) ? opt_b_pp_ss : - ((b7f == lt_b_7pp) ? opt_b_7pp_ss_lt : ((b7f == gt_b_7pp) ? opt_b_7pp_ss_gt : - ((b7f == char_lt_b_7pp) ? opt_b_7pp_ss_char_lt : opt_b_7pp_ss))); - return_true(sc, car_x); - }} - if (is_symbol(arg1)) - { - opc->v[1].p = opt_simple_symbol(sc, arg1); - if (!opc->v[1].p) - return_false(sc, car_x); - if ((!is_symbol(arg2)) && - (!is_pair(arg2))) - { - opc->v[2].p = arg2; - opc->v[0].fb = (bpf_case) ? opt_b_pp_sc : opt_b_7pp_sc; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_sc); - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - if (!b_pp_sf_combinable(sc, opc, bpf_case)) - { - opc->v[10].o1 = sc->opts[cur_index]; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fb = (bpf_case) ? opt_b_pp_sf : opt_b_7pp_sf; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_sf); /* this finds b_pp_unchecked cases */ - if ((opc->v[11].fp == opt_p_substring_uncopied_ssf) && (opc->v[3].b_pp_f == string_eq_b_unchecked)) - opc->v[0].fb = opt_substring_equal_sf; - else if (opc->v[3].b_pp_f == char_eq_b_unchecked) opc->v[0].fb = opt_b_pp_sf_char_eq; - } - return_true(sc, car_x); - } - pc_fallback(sc, cur_index); - } - else - if ((is_symbol(arg2)) && - (is_pair(arg1))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); - if ((!is_slot(opc->v[1].p)) || - (has_methods(slot_value(opc->v[1].p)))) - return_false(sc, car_x); - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fb = (bpf_case) ? opt_b_pp_fs : opt_b_7pp_fs; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_fs); - return_true(sc, car_x); - } - pc_fallback(sc, cur_index); - } - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - if (b_pp_ff_combinable(sc, opc, bpf_case)) - return_true(sc, car_x); - opc->v[0].fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff; - opc->v[8].o1 = o1; - opc->v[9].fp = o1->v[0].fp; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_ff); - if (opc->v[3].b_pp_f == char_eq_b_unchecked) opc->v[0].fb = opt_b_pp_ff_char_eq; - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - -/* -------- b_pi -------- */ -static bool opt_b_pi_fs(opt_info *o) {return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));} -static bool opt_b_pi_fs_num_eq(opt_info *o) {return(num_eq_b_pi(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));} -static bool opt_b_pi_fi(opt_info *o) {return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), o->v[1].i));} -static bool opt_b_pi_ff(opt_info *o) {s7_pointer p1 = o->v[11].fp(o->v[10].o1); return(o->v[2].b_pi_f(o->sc, p1, o->v[9].fi(o->v[8].o1)));} - -static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg2) -{ - s7_b_pi_t bpif = s7_b_pi_function(s_func); /* perhaps add vector-ref/equal? */ - if (bpif) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opt_info *o1 = sc->opts[sc->pc]; - opc->v[2].b_pi_f = bpif; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - if (is_symbol(arg2)) - { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); /* slot checked in opt_arg_type */ - opc->v[0].fb = (bpif == num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; - return_true(sc, car_x); - } - if (is_t_integer(arg2)) - { - opc->v[1].i = integer(arg2); - opc->v[0].fb = opt_b_pi_fi; - return_true(sc, car_x); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fb = opt_b_pi_ff; - opc->v[8].o1 = o1; - opc->v[9].fp = o1->v[0].fp; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - - -/* -------- b_dd -------- */ -static bool opt_b_dd_ss(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));} -static bool opt_b_dd_ss_lt(opt_info *o) {return(real(slot_value(o->v[1].p)) < real(slot_value(o->v[2].p)));} -static bool opt_b_dd_ss_gt(opt_info *o) {return(real(slot_value(o->v[1].p)) > real(slot_value(o->v[2].p)));} - -static bool opt_b_dd_sc(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));} -static bool opt_b_dd_sc_lt(opt_info *o) {return(real(slot_value(o->v[1].p)) < o->v[2].x);} -static bool opt_b_dd_sc_geq(opt_info *o) {return(real(slot_value(o->v[1].p)) >= o->v[2].x);} -static bool opt_b_dd_sc_eq(opt_info *o) {return(real(slot_value(o->v[1].p)) == o->v[2].x);} - -static bool opt_b_dd_sf(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[11].fd(o->v[10].o1)));} -static bool opt_b_dd_fs(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), real(slot_value(o->v[1].p))));} -static bool opt_b_dd_fs_gt(opt_info *o) {return(o->v[11].fd(o->v[10].o1) > real(slot_value(o->v[1].p)));} -static bool opt_b_dd_fc(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), o->v[1].x));} -static bool opt_b_dd_fc_gt(opt_info *o) {return(o->v[11].fd(o->v[10].o1) > o->v[1].x);} - -static bool opt_b_dd_ff(opt_info *o) -{ - s7_double x1 = o->v[11].fd(o->v[10].o1); - s7_double x2 = o->v[9].fd(o->v[8].o1); - return(o->v[3].b_dd_f(x1, x2)); -} - -static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2) -{ - s7_b_dd_t bif = s7_b_dd_function(s_func); - int32_t cur_index = sc->pc; - if (!bif) - return_false(sc, car_x); - opc->v[3].b_dd_f = bif; - if (is_symbol(arg1)) - { - opc->v[1].p = lookup_slot_from(arg1, sc->curlet); - if (is_symbol(arg2)) - { - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); - opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_ss_lt : ((bif == gt_b_dd) ? opt_b_dd_ss_gt : opt_b_dd_ss); - return_true(sc, car_x); - } - if (is_t_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_sc_lt : ((bif == geq_b_dd) ? opt_b_dd_sc_geq : ((bif == num_eq_b_dd) ? opt_b_dd_sc_eq : opt_b_dd_sc)); - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[0].fb = opt_b_dd_sf; - return_true(sc, car_x); - }} - pc_fallback(sc, cur_index); - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - if (is_symbol(arg2)) - { - opc->v[1].p = lookup_slot_from(arg2, sc->curlet); - opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; - return_true(sc, car_x); - } - if (is_small_real(arg2)) - { - opc->v[1].x = s7_number_to_real(sc, arg2); - opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fc_gt : opt_b_dd_fc; - return_true(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[0].fb = opt_b_dd_ff; - return_true(sc, car_x); - }} - pc_fallback(sc, cur_index); - return_false(sc, car_x); -} - - -/* -------- b_ii -------- */ -static bool opt_b_ii_ss(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static bool opt_b_ii_ss_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_ss_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == integer(slot_value(o->v[2].p)));} -static bool opt_b_ii_sc(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));} -static bool opt_b_ii_sc_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < o->v[2].i);} -static bool opt_b_ii_sc_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= o->v[2].i);} -static bool opt_b_ii_sc_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > o->v[2].i);} -static bool opt_b_ii_sc_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= o->v[2].i);} -static bool opt_b_ii_sc_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[2].i);} -static bool opt_b_ii_sc_lt_2(opt_info *o) {return(integer(slot_value(o->v[1].p)) < 2);} -static bool opt_b_ii_sc_lt_1(opt_info *o) {return(integer(slot_value(o->v[1].p)) < 1);} -static bool opt_b_ii_sc_lt_0(opt_info *o) {return(integer(slot_value(o->v[1].p)) < 0);} -static bool opt_b_ii_sc_leq_0(opt_info *o){return(integer(slot_value(o->v[1].p)) <= 0);} -static bool opt_b_ii_sc_gt_0(opt_info *o) {return(integer(slot_value(o->v[1].p)) > 0);} -static bool opt_b_ii_sc_geq_0(opt_info *o){return(integer(slot_value(o->v[1].p)) >= 0);} -static bool opt_b_ii_sc_eq_0(opt_info *o) {return(integer(slot_value(o->v[1].p)) == 0);} -static bool opt_b_ii_sc_eq_1(opt_info *o) {return(integer(slot_value(o->v[1].p)) == 1);} - -static bool opt_b_7ii_ss(opt_info *o) {return(o->v[3].b_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static bool opt_b_7ii_sc(opt_info *o) {return(o->v[3].b_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));} -static bool opt_b_7ii_sc_bit(opt_info *o) {return((integer(slot_value(o->v[1].p)) & ((int64_t)(1LL << o->v[2].i))) != 0);} - -static bool opt_b_ii_ff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[3].b_ii_f(i1, i2)); -} - -static bool opt_b_ii_fs(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));} -static bool opt_b_ii_sf(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[11].fi(o->v[10].o1)));} -static bool opt_b_ii_sf_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[11].fi(o->v[10].o1));} -static bool opt_b_ii_fc(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));} -static bool opt_b_ii_fc_eq(opt_info *o) {return(o->v[11].fi(o->v[10].o1) == o->v[2].i);} - -static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2) -{ - s7_b_ii_t bif = s7_b_ii_function(s_func); - s7_b_7ii_t b7if = NULL; - if (!bif) - { - b7if = s7_b_7ii_function(s_func); - if (!b7if) - return_false(sc, car_x); - } - if (bif) opc->v[3].b_ii_f = bif; else opc->v[3].b_7ii_f = b7if; - if (is_symbol(arg1)) - { - opc->v[1].p = lookup_slot_from(arg1, sc->curlet); - if (is_symbol(arg2)) - { - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); - - opc->v[0].fb = (bif == lt_b_ii) ? opt_b_ii_ss_lt : - ((bif == leq_b_ii) ? opt_b_ii_ss_leq : - ((bif == gt_b_ii) ? opt_b_ii_ss_gt : - ((bif == geq_b_ii) ? opt_b_ii_ss_geq : - ((bif == num_eq_b_ii) ? opt_b_ii_ss_eq : - ((bif) ? opt_b_ii_ss : opt_b_7ii_ss))))); - return_true(sc, car_x); - } - if (is_t_integer(arg2)) - { - s7_int i2 = integer(arg2); - opc->v[2].i = i2; - opc->v[0].fb = (bif == num_eq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_eq_0 : ((i2 == 1) ? opt_b_ii_sc_eq_1 : opt_b_ii_sc_eq)) : - ((bif == lt_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_lt_0 : ((i2 == 1) ? opt_b_ii_sc_lt_1 : ((i2 == 2) ? opt_b_ii_sc_lt_2 : opt_b_ii_sc_lt))) : - ((bif == gt_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_gt_0 : opt_b_ii_sc_gt) : - ((bif == leq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_leq_0 : opt_b_ii_sc_leq) : - ((bif == geq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_geq_0 : opt_b_ii_sc_geq) : - (((b7if == logbit_b_7ii) && (i2 >= 0) && (i2 < S7_INT_BITS)) ? opt_b_7ii_sc_bit : - ((bif) ? opt_b_ii_sc : opt_b_7ii_sc)))))); - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if ((bif) && (int_optimize(sc, cddr(car_x)))) - { - opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - return_true(sc, car_x); - } - return_false(sc, car_x); - } - if (!bif) return_false(sc, car_x); - - if (is_symbol(arg2)) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[2].p = lookup_slot_from(arg2, sc->curlet); - opc->v[0].fb = opt_b_ii_fs; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; - return_true(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[0].fb = opt_b_ii_ff; - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - -/* -------- b_or|and -------- */ -static bool opt_and_bb(opt_info *o) {return((o->v[3].fb(o->v[2].o1)) && (o->v[11].fb(o->v[10].o1)));} - -static bool opt_and_any_b(opt_info *o) -{ - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 3].o1; - if (!o1->v[0].fb(o1)) - return(false); - } - return(true); -} - -static bool opt_or_bb(opt_info *o) {return((o->v[3].fb(o->v[2].o1)) || o->v[11].fb(o->v[10].o1));} - -static bool opt_or_any_b(opt_info *o) -{ - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 3].o1; - if (o1->v[0].fb(o1)) - return(true); - } - return(false); -} - -static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t is_and) -{ - opt_info *opc = alloc_opt_info(sc); - s7_pointer p = cdr(car_x); - if (len == 3) - { - opt_info *o1 = sc->opts[sc->pc]; - if (bool_optimize_nw(sc, cdr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (bool_optimize_nw(sc, cddr(car_x))) - { - opc->v[10].o1 = o2; - opc->v[11].fb = o2->v[0].fb; - opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb; - opc->v[2].o1 = o1; - opc->v[3].fb = o1->v[0].fb; - return_true(sc, car_x); - }} - return_false(sc, car_x); - } - opc->v[1].i = (len - 1); - for (int32_t i = 0; (is_pair(p)) && (i < 12); i++, p = cdr(p)) - { - opc->v[i + 3].o1 = sc->opts[sc->pc]; - if (!bool_optimize_nw(sc, p)) - break; - } - if (!is_null(p)) - return_false(sc, car_x); - opc->v[0].fb = (is_and) ? opt_and_any_b : opt_or_any_b; - return_true(sc, car_x); -} - -static bool opt_b_and(s7_scheme *sc, s7_pointer car_x, int32_t len) {return(opt_b_or_and(sc, car_x, len, true));} -static bool opt_b_or(s7_scheme *sc, s7_pointer car_x, int32_t len) {return(opt_b_or_and(sc, car_x, len, false));} - - -/* ---------------------------------------- cell opts ---------------------------------------- */ -static s7_pointer opt_p_c(opt_info *o) {return(o->v[1].p);} -static s7_pointer opt_p_s(opt_info *o) {return(slot_value(o->v[1].p));} - -static bool opt_cell_not_pair(s7_scheme *sc, s7_pointer car_x) -{ - s7_pointer p; - opt_info *opc; - if (!is_symbol(car_x)) - { - opc = alloc_opt_info(sc); - opc->v[1].p = car_x; - opc->v[0].fp = opt_p_c; - return_true(sc, car_x); - } - p = opt_simple_symbol(sc, car_x); - if (!p) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - opc->v[1].p = p; - opc->v[0].fp = opt_p_s; - return_true(sc, car_x); -} - -/* -------- p -------- */ -#define is_opt_safe(P) ((optimize_op(P) >= OP_SAFE_C_S) && (!is_unknown_op(optimize_op(P)))) - -#define cf_call(Sc, Car_x, S_func, Num) \ - (((is_optimized(Car_x)) && (is_opt_safe(Car_x))) ? fn_proc(Car_x) : c_function_call(c_function_chooser(S_func)(Sc, S_func, Num, Car_x, false))) - -static s7_pointer opt_p_f(opt_info *o) {return(o->v[1].p_f(o->sc));} -static s7_pointer opt_p_call(opt_info *o) {return(o->v[1].call(o->sc, o->sc->nil));} - -static bool p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_p_t func = s7_p_function(s_func); - if (func) - { - opc->v[1].p_f = func; - opc->v[0].fp = opt_p_f; - return_true(sc, car_x); - } - if ((is_safe_procedure(s_func)) && - (c_function_min_args(s_func) == 0)) - { - opc->v[1].call = cf_call(sc, car_x, s_func, 0); - opc->v[0].fp = opt_p_call; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- p_p -------- */ -static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o); -static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o); - -static s7_pointer opt_p_p_c(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[1].p));} -static s7_pointer opt_p_i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_i_f(o->v[1].i)));} -static s7_pointer opt_p_7i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_7i_f(o->sc, o->v[1].i)));} -static s7_pointer opt_p_d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_d_f(o->v[1].x)));} -static s7_pointer opt_p_7d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_7d_f(o->sc, o->v[1].x)));} -static s7_pointer opt_p_p_s(opt_info *o) {return(o->v[2].p_p_f(o->sc, slot_value(o->v[1].p)));} -static s7_pointer opt_p_p_s_abs(opt_info *o) {return(abs_p_p(o->sc, slot_value(o->v[1].p)));} -static s7_pointer opt_p_p_s_cdr(opt_info *o) {s7_pointer p = slot_value(o->v[1].p); return((is_pair(p)) ? cdr(p) : cdr_p_p(o->sc, p));} -static s7_pointer opt_p_p_f(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_pointer opt_p_p_f1(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[3].p_p_f(o->sc, slot_value(o->v[1].p))));} -static s7_pointer opt_p_p_f_exp(opt_info *o) {return(exp_p_p(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_pointer opt_p_7d_c_random(opt_info *o) {return(make_real(o->sc, random_d_7d(o->sc, o->v[1].x)));} -static s7_pointer opt_p_p_s_iterate(opt_info *o) {return(iterate_p_p(o->sc, slot_value(o->v[1].p)));} -static s7_pointer opt_p_p_f_iterate(opt_info *o) {return(iterate_p_p(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_pointer opt_p_p_f_string_to_number(opt_info *o) {return(string_to_number_p_p(o->sc, o->v[4].fp(o->v[3].o1)));} -static s7_pointer opt_p_p_s_iterate_unchecked(opt_info *o) {s7_pointer iter = slot_value(o->v[1].p); return(iterator_next(iter)(o->sc, iter));} -static s7_pointer opt_p_p_fvref(opt_info *o) {return(o->v[2].p_p_f(o->sc, opt_p_pi_ss_fvref_direct(o->v[3].o1)));} /* unwrap to fvref is not faster */ -static s7_pointer opt_p_p_vref(opt_info *o) {return(o->v[2].p_p_f(o->sc, opt_p_pi_ss_vref_direct(o->v[3].o1)));} - -static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fp == opt_p_p_s) - { - opc->v[3].p_p_f = o1->v[2].p_p_f; - opc->v[1].p = o1->v[1].p; - opc->v[0].fp = opt_p_p_f1; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static s7_pointer opt_p_call_f(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[5].fp(o->v[4].o1))));} -static s7_pointer opt_p_call_s(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, slot_value(o->v[1].p))));} -static s7_pointer opt_p_call_c(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[1].p)));} - -static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_p_p_t ppf; - int32_t start = sc->pc; - if (is_t_integer(cadr(car_x))) - { - s7_i_i_t iif = s7_i_i_function(s_func); - s7_i_7i_t i7if; - opc->v[1].i = integer(cadr(car_x)); - if (iif) - { - opc->v[2].i_i_f = iif; - opc->v[0].fp = opt_p_i_c; - return_true(sc, car_x); - } - i7if = s7_i_7i_function(s_func); - if (i7if) - { - opc->v[2].i_7i_f = i7if; - opc->v[0].fp = opt_p_7i_c; - return_true(sc, car_x); - }} - if (is_t_real(cadr(car_x))) - { - s7_d_d_t ddf = s7_d_d_function(s_func); - s7_d_7d_t d7df; - opc->v[1].x = real(cadr(car_x)); - if (ddf) - { - opc->v[2].d_d_f = ddf; - opc->v[0].fp = opt_p_d_c; - return_true(sc, car_x); - } - d7df = s7_d_7d_function(s_func); - if (d7df) - { - opc->v[2].d_7d_f = d7df; - opc->v[0].fp = (d7df == random_d_7d) ? opt_p_7d_c_random : opt_p_7d_c; - return_true(sc, car_x); - }} - ppf = s7_p_p_function(s_func); - if (ppf) - { - opt_info *o1; - opc->v[2].p_p_f = ppf; - if ((ppf == symbol_to_string_p_p) && - (is_optimized(car_x)) && - (fn_proc(car_x) == g_symbol_to_string_uncopied)) - opc->v[2].p_p_f = symbol_to_string_uncopied_p; - - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = opt_simple_symbol(sc, cadr(car_x)); - if (!opc->v[1].p) - return_false(sc, car_x); - opc->v[0].fp = (ppf == abs_p_p) ? opt_p_p_s_abs : ((ppf == cdr_p_p) ? opt_p_p_s_cdr : - ((ppf == iterate_p_p) ? ((is_iterator(slot_value(opc->v[1].p))) ? opt_p_p_s_iterate_unchecked : opt_p_p_s_iterate) : opt_p_p_s)); - return_true(sc, car_x); - } - if (!is_pair(cadr(car_x))) - { - if (opc->v[2].p_p_f == s7_length) - { - opc->v[1].p = s7_length(sc, cadr(car_x)); - opc->v[0].fp = opt_p_c; - } - else - { - opc->v[1].p = cadr(car_x); - opc->v[0].fp = opt_p_p_c; - } - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - if (!p_p_f_combinable(sc, opc)) - { - s7_pointer (*fp)(opt_info *o); - opc->v[0].fp = (ppf == exp_p_p) ? opt_p_p_f_exp : ((ppf == iterate_p_p) ? opt_p_p_f_iterate : - ((ppf == string_to_number_p_p) ? opt_p_p_f_string_to_number : opt_p_p_f)); - if (caadr(car_x) == sc->string_ref_symbol) - { - if (opc->v[2].p_p_f == char_upcase_p_p) - opc->v[2].p_p_f = char_upcase_p_p_unchecked; - else - if (opc->v[2].p_p_f == is_char_whitespace_p_p) - opc->v[2].p_p_f = is_char_whitespace_p_p_unchecked; - } - opc->v[3].o1 = o1; - fp = o1->v[0].fp; - opc->v[4].fp = fp; - if (fp == opt_p_pi_ss_fvref_direct) opc->v[0].fp = opt_p_p_fvref; - else if (fp == opt_p_pi_ss_vref_direct) opc->v[0].fp = opt_p_p_vref; - } - return_true(sc, car_x); - }} - - pc_fallback(sc, start); - if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 1))) - { - opc->v[2].call = cf_call(sc, car_x, s_func, 1); - if (is_symbol(cadr(car_x))) - { - s7_pointer slot = opt_simple_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[1].p = slot; - opc->v[0].fp = opt_p_call_s; - return_true(sc, car_x); - }} - else - { - opt_info *o1; - if (!is_pair(cadr(car_x))) - { - opc->v[1].p = cadr(car_x); - opc->v[0].fp = opt_p_call_c; - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fp = opt_p_call_f; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -/* -------- p_i -------- */ -static s7_pointer opt_p_i_s(opt_info *o) {return(o->v[2].p_i_f(o->sc, integer(slot_value(o->v[1].p))));} /* number_to_string_p_i expanded here doesn't gain much */ -static s7_pointer opt_p_i_f(opt_info *o) {return(o->v[2].p_i_f(o->sc, o->v[4].fi(o->v[3].o1)));} -static s7_pointer opt_p_i_f_intc(opt_info *o) {return(integer_to_char_p_i(o->sc, o->v[4].fi(o->v[3].o1)));} - -static bool p_i_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer p; - s7_p_i_t ifunc = s7_p_i_function(s_func); - if (!ifunc) - return_false(sc, car_x); - p = opt_integer_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - opc->v[2].p_i_f = ifunc; - opc->v[0].fp = opt_p_i_s; - return_true(sc, car_x); - } - if (int_optimize(sc, cdr(car_x))) - { - opc->v[2].p_i_f = ifunc; - opc->v[0].fp = (ifunc == integer_to_char_p_i) ? opt_p_i_f_intc : opt_p_i_f; - opc->v[3].o1 = sc->opts[pstart]; - opc->v[4].fi = sc->opts[pstart]->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_ii -------- */ -static s7_pointer opt_p_ii_ss(opt_info *o) {return(o->v[3].p_ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_ii_fs(opt_info *o) {return(o->v[3].p_ii_f(o->sc, o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_ii_ff_divide(opt_info *o) {return(make_ratio_with_div_check(o->sc, o->sc->divide_symbol, o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));} - -static s7_pointer opt_p_ii_ff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - return(o->v[3].p_ii_f(o->sc, i1, o->v[9].fi(o->v[8].o1))); -} - -static bool p_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer p2; - s7_p_ii_t ifunc = s7_p_ii_function(s_func); - if (!ifunc) - return_false(sc, car_x); - p2 = opt_integer_symbol(sc, caddr(car_x)); - if (p2) - { - s7_pointer p1 = opt_integer_symbol(sc, cadr(car_x)); - if (p1) - { - opc->v[1].p = p1; - opc->v[2].p = p2; - opc->v[3].p_ii_f = ifunc; - opc->v[0].fp = opt_p_ii_ss; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[2].p = p2; - opc->v[3].p_ii_f = ifunc; - opc->v[0].fp = opt_p_ii_fs; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[3].p_ii_f = ifunc; - opc->v[0].fp = (ifunc == divide_p_ii) ? opt_p_ii_ff_divide : opt_p_ii_ff; - return_true(sc, car_x); - }} - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_d -------- */ -static s7_pointer opt_p_d_s(opt_info *o) {return(o->v[2].p_d_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), __func__)));} -static s7_pointer opt_p_d_f(opt_info *o) {return(o->v[2].p_d_f(o->sc, o->v[4].fd(o->v[3].o1)));} -/* static s7_pointer opt_p_d_fvref(opt_info *o) {return(o->v[2].p_d_f(o->sc, float_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p)))));} */ - -static bool p_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer p; - opt_info *o1; - s7_p_d_t ifunc = s7_p_d_function(s_func); - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(car_x)); */ - - if (!ifunc) - return_false(sc, car_x); - p = opt_float_symbol(sc, cadr(car_x)); - if (p) - { - opc->v[1].p = p; - opc->v[2].p_d_f = ifunc; - opc->v[0].fp = opt_p_d_s; - return_true(sc, car_x); - } - if ((is_number(cadr(car_x))) && (!is_t_real(cadr(car_x)))) - return_false(sc, car_x); - o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[2].p_d_f = ifunc; - opc->v[0].fp = opt_p_d_f; - opc->v[3].o1 = o1; - opc->v[4].fd = o1->v[0].fd; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_dd -------- */ -static s7_pointer opt_p_dd_sc(opt_info *o) {return(o->v[3].p_dd_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), __func__), o->v[2].x));} -static s7_pointer opt_p_dd_cs(opt_info *o) {return(o->v[3].p_dd_f(o->sc, o->v[2].x, real_to_double(o->sc, slot_value(o->v[1].p), __func__)));} -static s7_pointer opt_p_dd_cc(opt_info *o) {return(o->v[3].p_dd_f(o->sc, o->v[1].x, o->v[2].x));} - -static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); - s7_p_dd_t ifunc = s7_p_dd_function(s_func); - if (!ifunc) - return_false(sc, car_x); - if (is_t_real(arg2)) - { - if (is_t_real(arg1)) - { - opc->v[1].x = real(arg1); - opc->v[2].x = real(arg2); - opc->v[3].p_dd_f = ifunc; - opc->v[0].fp = opt_p_dd_cc; - return_true(sc, car_x); - } - slot = opt_real_symbol(sc, arg1); - if (slot) - { - opc->v[2].x = real(arg2); - opc->v[1].p = slot; - opc->v[3].p_dd_f = ifunc; - opc->v[0].fp = opt_p_dd_sc; - return_true(sc, car_x); - }} - if (is_t_real(arg1)) - { - slot = opt_real_symbol(sc, arg2); - if (slot) - { - opc->v[2].x = real(arg1); - opc->v[1].p = slot; - opc->v[3].p_dd_f = ifunc; - opc->v[0].fp = opt_p_dd_cs; - return_true(sc, car_x); - }} - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_pi -------- */ -static s7_pointer opt_p_pi_ss(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_vref(opt_info *o) {return(normal_vector_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o) {return(normal_vector_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o) {return(float_vector_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_ivref_direct(opt_info *o) {return(int_vector_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_ss_lref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));} -static s7_pointer opt_p_pi_sc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));} -static s7_pointer opt_p_pi_sc_lref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), o->v[2].i));} -static s7_pointer opt_p_pi_sf(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} -static s7_pointer opt_p_pi_sf_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} -static s7_pointer opt_p_pi_sf_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} -static s7_pointer opt_p_pi_fc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].i));} - -/* use a unique name for this use of denominator (need to remember that any such integer should be new (i.e. mutable, not a small int) */ -#define do_loop_end(A) denominator(T_Int(A)) -#define set_do_loop_end(A, B) denominator(T_Int(A)) = B - -static void check_unchecked(s7_scheme *sc, s7_pointer obj, s7_pointer slot, opt_info *opc, s7_pointer expr) -{ - switch (type(obj)) /* can't use funcs here (opc->v[3].p_pi_f et al) because there are so many, and copy depends on this choice */ - { - case T_STRING: - if (((!expr) || (car(expr) == sc->string_ref_symbol)) && (do_loop_end(slot_value(slot)) <= string_length(obj))) - opc->v[3].p_pi_f = string_ref_p_pi_direct; - break; - case T_BYTE_VECTOR: - if (((!expr) || (car(expr) == sc->byte_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && - (do_loop_end(slot_value(slot)) <= byte_vector_length(obj))) - opc->v[3].p_pi_f = byte_vector_ref_p_pi_direct; - break; - case T_VECTOR: - if (((!expr) || (car(expr) == sc->vector_ref_symbol)) && (do_loop_end(slot_value(slot)) <= vector_length(obj))) - opc->v[3].p_pi_f = normal_vector_ref_p_pi_direct; - break; - case T_FLOAT_VECTOR: - if (((!expr) || (car(expr) == sc->float_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && - (do_loop_end(slot_value(slot)) <= vector_length(obj))) - opc->v[3].p_pi_f = float_vector_ref_p_pi_direct; - break; - case T_INT_VECTOR: - if (((!expr) || (car(expr) == sc->int_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && - (do_loop_end(slot_value(slot)) <= vector_length(obj))) - opc->v[3].p_pi_f = int_vector_ref_p_pi_direct; - break; - } -} - -static void fixup_p_pi_ss(opt_info *opc) -{ - opc->v[0].fp = (opc->v[3].p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_ss_sref : - ((opc->v[3].p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_ss_sref_direct : - ((opc->v[3].p_pi_f == normal_vector_ref_p_pi_unchecked) ? opt_p_pi_ss_vref : - ((opc->v[3].p_pi_f == float_vector_ref_p_pi_direct) ? opt_p_pi_ss_fvref_direct : - ((opc->v[3].p_pi_f == int_vector_ref_p_pi_direct) ? opt_p_pi_ss_ivref_direct : - ((opc->v[3].p_pi_f == normal_vector_ref_p_pi_direct) ? opt_p_pi_ss_vref_direct : - ((opc->v[3].p_pi_f == list_ref_p_pi_unchecked) ? opt_p_pi_ss_lref : opt_p_pi_ss)))))); -} - -static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer sig, s7_pointer car_x) -{ - s7_pointer obj = NULL, slot1, checker = NULL; - opt_info *o1; - s7_p_pi_t func = s7_p_pi_function(s_func); - if (!func) - return_false(sc, car_x); - /* here we know cadr is a symbol */ - slot1 = opt_simple_symbol(sc, cadr(car_x)); - if (!slot1) - return_false(sc, car_x); - if ((is_any_vector(slot_value(slot1))) && - (vector_rank(slot_value(slot1)) > 1)) - return_false(sc, car_x); - - opc->v[3].p_pi_f = func; - opc->v[1].p = slot1; - - if (is_symbol(cadr(sig))) - checker = cadr(sig); - - if ((s7_p_pi_unchecked_function(s_func)) && - (checker)) - { - obj = slot_value(opc->v[1].p); - if ((is_string(obj)) || - (is_pair(obj)) || - (is_any_vector(obj))) - { - if (((is_string(obj)) && (checker == sc->is_string_symbol)) || - ((is_any_vector(obj)) && (checker == sc->is_vector_symbol)) || - ((is_pair(obj)) && (checker == sc->is_pair_symbol)) || - ((is_byte_vector(obj)) && (checker == sc->is_byte_vector_symbol))) - opc->v[3].p_pi_f = (is_normal_vector(obj)) ? normal_vector_ref_p_pi_unchecked : s7_p_pi_unchecked_function(s_func); - }} - slot1 = opt_integer_symbol(sc, caddr(car_x)); - if (slot1) - { - opc->v[2].p = slot1; - if ((obj) && - (is_step_end(slot1))) - check_unchecked(sc, obj, slot1, opc, car_x); - fixup_p_pi_ss(opc); - return_true(sc, car_x); - } - if (is_t_integer(caddr(car_x))) - { - opc->v[2].i = integer(caddr(car_x)); - opc->v[0].fp = (opc->v[3].p_pi_f == list_ref_p_pi_unchecked) ? opt_p_pi_sc_lref : opt_p_pi_sc; - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = (opc->v[3].p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_sf_sref : - ((opc->v[3].p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_sf_sref_direct : opt_p_pi_sf); - opc->v[4].o1 = o1; - opc->v[5].fi = o1->v[0].fi; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -static s7_pointer opt_p_pi_fco(opt_info *o) {return(o->v[3].p_pi_f(o->sc, o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)), o->v[2].i));} - -static bool p_pi_fc_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if (o1->v[0].fp == opt_p_p_s) - { - opc->v[4].p_p_f = o1->v[2].p_p_f; - opc->v[1].p = o1->v[1].p; - opc->v[0].fp = opt_p_pi_fco; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -/* -------- p_pp -------- */ -static s7_pointer opt_p_pp_ss(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static s7_pointer opt_p_pp_sc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));} -static s7_pointer opt_p_pp_cs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[2].p, slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_sf(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_fs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_fc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].p));} -static s7_pointer opt_p_pp_cc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[1].p, o->v[2].p));} -static s7_pointer opt_p_pp_cc_make_list(opt_info *o) {return(make_list(o->sc, o->v[1].i, o->v[2].p));} -static s7_pointer opt_set_car_pp_ss(opt_info *o) {return(inline_set_car(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static s7_pointer opt_p_pp_ss_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));} -static s7_pointer opt_p_pp_sf_add(opt_info *o) {return(add_p_pp(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_sub(opt_info *o) {return(subtract_p_pp(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_mul(opt_info *o) {return(multiply_p_pp(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_set_car(opt_info *o) {return(inline_set_car(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_set_cdr(opt_info *o) {return(inline_set_cdr(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_sf_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pp_fs_vref(opt_info *o) {return(vector_ref_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_fs_cons(opt_info *o) {return(cons(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_fs_add(opt_info *o) {return(add_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} -static s7_pointer opt_p_pp_fs_sub(opt_info *o) {return(subtract_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));} - -static s7_pointer opt_p_pp_ff(opt_info *o) -{ - s7_scheme *sc = o->sc; - s7_pointer result; - gc_protect_2_via_stack(sc, o->v[11].fp(o->v[10].o1), o->v[9].fp(o->v[8].o1)); /* we do need to protect both */ - result = o->v[3].p_pp_f(sc, stack_protected1(sc), stack_protected2(sc)); - unstack(sc); - return(result); -} - -static s7_pointer opt_p_pp_ff_add_mul_mul_1(opt_info *o, bool add_case) /* (+|- (* s1 f2) (* s3 f4)) */ -{ - opt_info *o1 = o->v[10].o1, *o2 = o->v[8].o1; - s7_pointer f4; - s7_scheme *sc = o->sc; - s7_pointer s1 = slot_value(o1->v[1].p); - s7_pointer s3 = slot_value(o2->v[1].p); - s7_pointer f2 = o1->v[5].fp(o1->v[4].o1); - if ((is_t_real(f2)) && (is_t_real(s1)) && (is_t_real(s3))) - { - s7_double r2 = real(f2); - f4 = o2->v[5].fp(o2->v[4].o1); - if (is_t_real(f4)) - return(make_real(sc, (add_case) ? ((real(s1) * r2) + (real(s3) * real(f4))) : ((real(s1) * r2) - (real(s3) * real(f4))))); - gc_protect_via_stack(sc, f2); - } - else - { - gc_protect_via_stack(sc, f2); - f4 = o2->v[5].fp(o2->v[4].o1); - } - set_stack_protected2(sc, f4); - set_stack_protected2(sc, multiply_p_pp(sc, s3, f4)); - set_stack_protected1(sc, multiply_p_pp(sc, s1, f2)); - s3 = (add_case) ? add_p_pp(sc, stack_protected1(sc), stack_protected2(sc)) : subtract_p_pp(sc, stack_protected1(sc), stack_protected2(sc)); - unstack(sc); - return(s3); -} - -static s7_pointer opt_p_pp_ff_add_mul_mul(opt_info *o) {return(opt_p_pp_ff_add_mul_mul_1(o, true));} -static s7_pointer opt_p_pp_ff_sub_mul_mul(opt_info *o) {return(opt_p_pp_ff_add_mul_mul_1(o, false));} - -static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - s7_pointer slot; - s7_p_pp_t func = s7_p_pp_function(s_func); - if (!func) - return_false(sc, car_x); - - opc->v[3].p_pp_f = func; - if (is_symbol(cadr(car_x))) - { - slot = opt_simple_symbol(sc, cadr(car_x)); - if (!slot) - { - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - if ((is_any_vector(slot_value(slot))) && - (vector_rank(slot_value(slot)) > 1)) - { - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - opc->v[1].p = slot; - - if ((func == hash_table_ref_p_pp) && (is_hash_table(slot_value(slot)))) - opc->v[3].p_pp_f = s7_hash_table_ref; - - if (is_symbol(caddr(car_x))) - { - opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[2].p) - { - opc->v[0].fp = (func == set_car_p_pp) ? opt_set_car_pp_ss : ((opc->v[3].p_pp_f == s7_hash_table_ref) ? opt_p_pp_ss_href : opt_p_pp_ss); - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - if ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x)))) - { - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); - opc->v[0].fp = opt_p_pp_sc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_sf_add : ((func == subtract_p_pp) ? opt_p_pp_sf_sub : ((func == multiply_p_pp) ? opt_p_pp_sf_mul : - ((func == set_car_p_pp) ? opt_p_pp_sf_set_car : ((func == set_cdr_p_pp) ? opt_p_pp_sf_set_cdr : - ((opc->v[3].p_pp_f == s7_hash_table_ref) ? opt_p_pp_sf_href : opt_p_pp_sf))))); - opc->v[4].o1 = sc->opts[pstart]; - opc->v[5].fp = sc->opts[pstart]->v[0].fp; - return_true(sc, car_x); - }} - else - { - opt_info *o1 = sc->opts[sc->pc]; - if ((!is_pair(cadr(car_x))) || - (is_proper_quote(sc, cadr(car_x)))) - { - opc->v[1].p = (!is_pair(cadr(car_x))) ? cadr(car_x) : cadadr(car_x); - if ((!is_symbol(caddr(car_x))) && - ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x))))) - { - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); - if ((opc->v[3].p_pp_f == make_list_p_pp) && - (is_t_integer(opc->v[1].p)) && (integer(opc->v[1].p) >= 0) && (integer(opc->v[1].p) < sc->max_list_length)) - { - opc->v[0].fp = opt_p_pp_cc_make_list; - opc->v[1].i = integer(opc->v[1].p); - } - else opc->v[0].fp = opt_p_pp_cc; - return_true(sc, car_x); - } - if (is_symbol(caddr(car_x))) - { - opc->v[2].p = opc->v[1].p; - opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[1].p) - { - opc->v[0].fp = opt_p_pp_cs; - if (is_pair(slot_value(opc->v[1].p))) - { - if (func == assq_p_pp) opc->v[3].p_pp_f = s7_assq; - else - if (func == memq_p_pp) opc->v[3].p_pp_f = s7_memq; - else - if ((func == member_p_pp) && (is_simple(opc->v[2].p))) opc->v[3].p_pp_f = s7_memq; - else - if (func == assoc_p_pp) - { - if (is_simple(opc->v[2].p)) opc->v[3].p_pp_f = s7_assq; - else if (is_pair(car(slot_value(opc->v[1].p)))) opc->v[3].p_pp_f = assoc_1; - }} - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - }} - if (cell_optimize(sc, cdr(car_x))) - { - if (is_symbol(caddr(car_x))) - { - opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[1].p) - { - opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_fs_add : ((func == subtract_p_pp) ? opt_p_pp_fs_sub : - ((func == vector_ref_p_pp) ? opt_p_pp_fs_vref : ((func == cons_p_pp) ? opt_p_pp_fs_cons : opt_p_pp_fs))); - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - if ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x)))) - { - if (is_t_integer(caddr(car_x))) - { - s7_p_pi_t ifunc = s7_p_pi_function(s_func); - if (ifunc) - { - opc->v[2].i = integer(caddr(car_x)); - opc->v[3].p_pi_f = ifunc; - if (!p_pi_fc_combinable(sc, opc)) - { - opc->v[0].fp = opt_p_pi_fc; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - } - return_true(sc, car_x); - }} - opc->v[2].p = (!is_pair(caddr(car_x))) ? caddr(car_x) : cadaddr(car_x); - opc->v[0].fp = opt_p_pp_fc; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[10].o1 = o1; - opc->v[11].fp = o1->v[0].fp; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - opc->v[0].fp = opt_p_pp_ff; - - if ((opc->v[9].fp == opt_p_pp_sf_mul) && (opc->v[11].fp == opt_p_pp_sf_mul)) - { - if (func == add_p_pp) opc->v[0].fp = opt_p_pp_ff_add_mul_mul; - else if (func == subtract_p_pp) opc->v[0].fp = opt_p_pp_ff_sub_mul_mul; - } - - return_true(sc, car_x); - }}} - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - -/* -------- p_call_pp -------- */ -static s7_pointer opt_p_call_ff(opt_info *o) -{ - s7_pointer po2; - s7_scheme *sc = o->sc; - gc_protect_via_stack(sc, o->v[11].fp(o->v[10].o1)); - po2 = o->v[9].fp(o->v[8].o1); - po2 = o->v[3].call(sc, set_plist_2(sc, stack_protected1(sc), po2)); - unstack(sc); - return(po2); -} - -static s7_pointer opt_p_call_fs(opt_info *o) -{ - s7_pointer po1 = o->v[11].fp(o->v[10].o1); - return(o->v[3].call(o->sc, set_plist_2(o->sc, po1, slot_value(o->v[1].p)))); -} - -static s7_pointer opt_p_call_sf(opt_info *o) -{ - s7_pointer po1 = o->v[11].fp(o->v[10].o1); - return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), po1))); -} - -static s7_pointer opt_p_call_sc(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), o->v[2].p)));} -static s7_pointer opt_p_call_ss(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p))));} - -static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart) -{ - if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 2))) - { - /* if optimized, we want to use the current fn_proc (to take advantage of fixups like substring_temp), - * but those same fixups are incorrect for this context if op_safe_c_c related. - */ - opc->v[3].call = cf_call(sc, car_x, s_func, 2); - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = lookup_slot_from(cadr(car_x), sc->curlet); - if ((is_slot(opc->v[1].p)) && - (!has_methods(slot_value(opc->v[1].p)))) - { - if (is_symbol(caddr(car_x))) - { - opc->v[2].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[2].p) - { - opc->v[0].fp = opt_p_call_ss; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - if (!is_pair(caddr(car_x))) - { - opc->v[2].p = caddr(car_x); - opc->v[0].fp = opt_p_call_sc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[10].o1 = sc->opts[pstart]; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fp = opt_p_call_sf; - return_true(sc, car_x); - }} - else - { - pc_fallback(sc, pstart); - return_false(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[11].fp = opc->v[10].o1->v[0].fp; - if (is_symbol(caddr(car_x))) - { - opc->v[1].p = opt_simple_symbol(sc, caddr(car_x)); - if (opc->v[1].p) - { - opc->v[0].fp = opt_p_call_fs; - return_true(sc, car_x); - } - pc_fallback(sc, pstart); - return_false(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[9].fp = opc->v[8].o1->v[0].fp; - opc->v[0].fp = opt_p_call_ff; - return_true(sc, car_x); - }}} - pc_fallback(sc, pstart); - return_false(sc, car_x); -} - - -/* -------- p_pip --------*/ - -static s7_pointer opt_p_pip_ssf(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pip_ssf_sset(opt_info *o) {return(string_set_p_pip_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pip_ssf_vset(opt_info *o) {return(vector_set_p_pip_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_pip_sss(opt_info *o) {return(o->v[4].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));} -static s7_pointer opt_p_pip_sss_vset(opt_info *o) {return(vector_set_p_pip_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));} -static s7_pointer opt_p_pip_ssc(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p));} -static s7_pointer opt_p_pip_c(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].p_p_f(o->sc, o->v[4].p)));} - -static s7_pointer opt_p_pip_sff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), i1, o->v[9].fp(o->v[8].o1))); -} - -static s7_pointer opt_p_pip_sff_lset(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - return(list_set_p_pip_unchecked(o->sc, slot_value(o->v[1].p), i1, o->v[9].fp(o->v[8].o1))); -} - -static s7_pointer opt_p_pip_sso(opt_info *o) -{ - return(o->v[5].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), - o->v[6].p_pi_f(o->sc, slot_value(o->v[3].p), integer(slot_value(o->v[4].p))))); -} - -static s7_pointer opt_p_pip_ssf1(opt_info *o) -{ - return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p_p_f(o->sc, o->v[6].fp(o->v[5].o1)))); -} - -static bool p_pip_ssf_combinable(s7_scheme *sc, opt_info *opc, int32_t start) -{ - opt_info *o1; - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fp == opt_p_pi_ss) || (o1->v[0].fp == opt_p_pi_ss_sref) || (o1->v[0].fp == opt_p_pi_ss_vref) || - (o1->v[0].fp == opt_p_pi_ss_sref_direct) || (o1->v[0].fp == opt_p_pi_ss_vref_direct) || - (o1->v[0].fp == opt_p_pi_ss_fvref_direct) || (o1->v[0].fp == opt_p_pi_ss_ivref_direct) || - (o1->v[0].fp == opt_p_pi_ss_lref)) - { - opc->v[5].p_pip_f = opc->v[3].p_pip_f; - opc->v[6].p_pi_f = o1->v[3].p_pi_f; - opc->v[3].p = o1->v[1].p; - opc->v[4].p = o1->v[2].p; - opc->v[0].fp = opt_p_pip_sso; - backup_pc(sc); - return_true(sc, NULL); - } - if (o1->v[0].fp == opt_p_p_c) - { - opc->v[5].p_p_f = o1->v[2].p_p_f; - opc->v[4].p = o1->v[1].p; - backup_pc(sc); - opc->v[0].fp = opt_p_pip_c; - return_true(sc, NULL); - }} - o1 = sc->opts[start]; - if (o1->v[0].fp != opt_p_p_f) - return_false(sc, NULL); - opc->v[4].p_p_f = o1->v[2].p_p_f; - opc->v[5].o1 = sc->opts[start + 1]; - opc->v[6].fp = sc->opts[start + 1]->v[0].fp; - opc->v[0].fp = opt_p_pip_ssf1; - return_true(sc, NULL); -} - -static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer obj, slot1, sig, checker = NULL; - s7_p_pip_t func = s7_p_pip_function(s_func); - if (!func) - return_false(sc, car_x); - - sig = c_function_signature(s_func); - if ((is_pair(sig)) && - (is_pair(cdr(sig))) && - (is_symbol(cadr(sig)))) - checker = cadr(sig); - - /* here we know cadr is a symbol */ - slot1 = lookup_slot_from(cadr(car_x), sc->curlet); - if ((!is_slot(slot1)) || - (has_methods(slot_value(slot1))) || - (is_immutable(slot_value(slot1)))) - return_false(sc, car_x); - if ((is_any_vector(slot_value(slot1))) && - (vector_rank(slot_value(slot1)) > 1)) - return_false(sc, car_x); - - opc->v[1].p = slot1; - obj = slot_value(opc->v[1].p); - opc->v[3].p_pip_f = func; - if ((s7_p_pip_unchecked_function(s_func)) && - (checker)) - { - if ((is_normal_vector(obj)) && (checker == sc->is_vector_symbol)) - opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked : vector_set_p_pip_unchecked; - else - if ((is_pair(obj)) && (checker == sc->is_pair_symbol)) /* avoid dumb mismatch in val_type and sig below, #t integer:any? and integer? integer:any? */ - opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); - else - { - s7_pointer val_type = opt_arg_type(sc, cdddr(car_x)); - if ((val_type == cadddr(sig)) && - (((is_string(obj)) && (checker == sc->is_string_symbol)) || - ((is_float_vector(obj)) && (checker == sc->is_float_vector_symbol)) || - ((is_int_vector(obj)) && (checker == sc->is_int_vector_symbol)) || - ((is_byte_vector(obj)) && (checker == sc->is_byte_vector_symbol)))) - opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); - }} - if (is_symbol(caddr(car_x))) - { - int32_t start = sc->pc; - s7_pointer slot2 = opt_integer_symbol(sc, caddr(car_x)); - if (slot2) - { - opc->v[2].p = slot2; - if (is_step_end(slot2)) - switch (type(obj)) - { - case T_VECTOR: - if (do_loop_end(slot_value(slot2)) <= vector_length(obj)) - opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_normal_vector_set_p_pip_direct : normal_vector_set_p_pip_direct; - break; - case T_INT_VECTOR: - if (do_loop_end(slot_value(slot2)) <= vector_length(obj)) - opc->v[3].p_pip_f = int_vector_set_p_pip_direct; - break; - case T_FLOAT_VECTOR: - if (do_loop_end(slot_value(slot2)) <= vector_length(obj)) - opc->v[3].p_pip_f = float_vector_set_p_pip_direct; - break; - case T_STRING: - if (do_loop_end(slot_value(slot2)) <= string_length(obj)) - opc->v[3].p_pip_f = string_set_p_pip_direct; - break; - case T_BYTE_VECTOR: - if (do_loop_end(slot_value(slot2)) <= vector_length(obj)) - opc->v[3].p_pip_f = byte_vector_set_p_pip_direct; - break; - } /* T_PAIR here would require list_length check which sort of defeats the purpose */ - - if (is_symbol(cadddr(car_x))) - { - s7_pointer val_slot = opt_simple_symbol(sc, cadddr(car_x)); - if (val_slot) - { - opc->v[4].p_pip_f = opc->v[3].p_pip_f; - opc->v[3].p = val_slot; - opc->v[0].fp = (opc->v[4].p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_sss_vset : opt_p_pip_sss; - return_true(sc, car_x); - }} - else - if ((!is_pair(cadddr(car_x))) || - (is_proper_quote(sc, cadddr(car_x)))) - { - opc->v[4].p = (is_pair(cadddr(car_x))) ? cadr(cadddr(car_x)) : cadddr(car_x); - opc->v[0].fp = opt_p_pip_ssc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cdddr(car_x))) - { - if (p_pip_ssf_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fp = (opc->v[3].p_pip_f == string_set_p_pip_direct) ? opt_p_pip_ssf_sset : - ((opc->v[3].p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_ssf_vset : opt_p_pip_ssf); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - return_true(sc, car_x); - }}} - else /* not symbol caddr */ - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[0].fp = (opc->v[3].p_pip_f == list_set_p_pip_unchecked) ? opt_p_pip_sff_lset : opt_p_pip_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -/* -------- p_piip -------- */ -static s7_pointer opt_p_piip_sssf(opt_info *o) -{ - return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fp(o->v[10].o1))); -} - -static s7_pointer vector_set_piip_sssf_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - s7_pointer val = o->v[11].fp(o->v[10].o1); - vector_element(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))) = val; - return(val); -} - -static s7_pointer opt_p_piip_sssc(opt_info *o) -{ - return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[4].p)); -} - -static s7_pointer opt_p_piip_sfff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), i1, i2, o->v[3].fp(o->v[4].o1))); /* v[3] because v[5] is already in use */ -} - -static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp, s7_pointer obj) -{ - s7_pointer slot = opt_integer_symbol(sc, car(indexp2)); - if (!slot) - return_false(sc, indexp1); - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if ((is_symbol(car(valp))) || - (is_unquoted_pair(car(valp)))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, valp)) - return_false(sc, indexp1); - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fp = opt_p_piip_sssf; - if ((is_normal_vector(obj)) && - (step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fp = vector_set_piip_sssf_unchecked; - return_true(sc, NULL); - } - opc->v[0].fp = opt_p_piip_sssc; - opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp); - return_true(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, valp)) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[3].fp = opc->v[4].o1->v[0].fp; - opc->v[0].fp = opt_p_piip_sfff; - return_true(sc, NULL); - }}} - return_false(sc, NULL); -} - -static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_p_piip_t func = s7_p_piip_function(s_func); - if ((func) && (s_func == global_value(sc->vector_set_symbol)) && (is_symbol(cadr(car_x)))) - { - s7_pointer obj; - s7_pointer slot1 = lookup_slot_from(cadr(car_x), sc->curlet); - if (!is_slot(slot1)) - return_false(sc, car_x); - obj = slot_value(slot1); - if ((has_methods(obj)) || (is_immutable(obj))) - return_false(sc, car_x); - if ((is_any_vector(obj)) && /* vector_set_p_piip calls vector_setter(obj) */ - (vector_rank(obj) == 2)) - { - opc->v[1].p = slot1; - opc->v[5].p_piip_f = vector_set_p_piip; - return(p_piip_to_sx(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x), obj)); - }} - return_false(sc, car_x); -} - -/* -------- p_pii -------- */ -static s7_pointer opt_p_pii_sss(opt_info *o) -{ - return(o->v[4].p_pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)))); -} - -static s7_pointer opt_p_pii_sff(opt_info *o) -{ - s7_int i1 = o->v[11].fi(o->v[10].o1); - s7_int i2 = o->v[9].fi(o->v[8].o1); - return(o->v[4].p_pii_f(o->sc, slot_value(o->v[1].p), i1, i2)); -} - -static s7_pointer vector_ref_pii_sss_unchecked(opt_info *o) -{ - s7_pointer v = slot_value(o->v[1].p); - return(vector_element(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p))))); -} - -static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_p_pii_t func = s7_p_pii_function(s_func); - if ((func) && - (is_symbol(cadr(car_x)))) - { - s7_pointer obj; - s7_pointer slot1 = lookup_slot_from(cadr(car_x), sc->curlet); - if (!is_slot(slot1)) - return_false(sc, car_x); - obj = slot_value(slot1); - if ((has_methods(obj)) || (is_immutable(obj))) - return_false(sc, car_x); - if ((is_normal_vector(obj)) && - (vector_rank(obj) == 2)) - { - s7_pointer slot, indexp1 = cddr(car_x), indexp2 = cdddr(car_x); - opc->v[1].p = slot1; - opc->v[4].p_pii_f = vector_ref_p_pii; - slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - opc->v[0].fp = opt_p_pii_sss; - /* normal vector rank 2 (see above) */ - if ((step_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fp = vector_ref_pii_sss_unchecked; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[0].fp = opt_p_pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - -/* -------- p_ppi -------- */ -static s7_pointer opt_p_ppi_psf(opt_info *o) {return(o->v[3].p_ppi_f(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} -static s7_pointer opt_p_ppi_psf_cpos(opt_info *o) {return(char_position_p_ppi(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));} - -static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - s7_p_ppi_t ifunc = s7_p_ppi_function(s_func); - if (!ifunc) - return_false(sc, car_x); - opc->v[3].p_ppi_f = ifunc; - if ((is_character(cadr(car_x))) && - (is_symbol(caddr(car_x))) && - (int_optimize(sc, cdddr(car_x)))) - { - s7_pointer slot = opt_simple_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[2].p = cadr(car_x); - opc->v[1].p = slot; - opc->v[0].fp = (ifunc == char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- p_ppp -------- */ -static s7_pointer opt_p_ppp_ssf(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].fp(o->v[4].o1)));} -static s7_pointer opt_p_ppp_hash_table_increment(opt_info *o) {return(fx_hash_table_increment_1(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].p));} -static s7_pointer opt_p_ppp_sfs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)));} -static s7_pointer opt_p_ppp_scs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[4].p, slot_value(o->v[2].p)));} -static s7_pointer opt_p_ppp_scs_eset(opt_info *o) {return(let_set_1(o->sc, slot_value(o->v[1].p), o->v[4].p, slot_value(o->v[2].p)));} -static s7_pointer opt_p_ppp_sss(opt_info *o) {return(o->v[4].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} -static s7_pointer opt_p_ppp_sss_mul(opt_info *o) {return(multiply_p_ppp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} -static s7_pointer opt_p_ppp_sss_hset(opt_info *o) {return(s7_hash_table_set(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));} -static s7_pointer opt_p_ppp_ssc(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[4].p));} -static s7_pointer opt_list_3c(opt_info *o) {s7_scheme *sc = o->sc; return(list_3(sc, o->v[10].p, o->v[8].p, o->v[4].p));} - -static s7_pointer opt_p_ppp_sff(opt_info *o) -{ - s7_pointer res; - s7_scheme *sc = o->sc; - gc_protect_2_via_stack(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1))); - res = o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), stack_protected1(sc), stack_protected2(sc)); - unstack(sc); - return(res); -} - -static s7_pointer opt_p_ppp_fff(opt_info *o) -{ - s7_pointer res; - s7_scheme *sc = o->sc; - gc_protect_2_via_stack(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1))); - res = o->v[3].p_ppp_f(sc, stack_protected1(sc), stack_protected2(sc), o->v[5].fp(o->v[4].o1)); - unstack(sc); - return(res); -} - -static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - s7_pointer arg1 = cadr(car_x); - s7_pointer arg2 = caddr(car_x); - s7_pointer arg3 = cadddr(car_x); - int32_t start = sc->pc; - s7_p_ppp_t func = s7_p_ppp_function(s_func); - if (!func) - return_false(sc, car_x); - opc->v[3].p_ppp_f = func; - if (is_symbol(arg1)) /* dealt with at the top -> p1 */ - { - s7_pointer obj; - opt_info *o1; - s7_pointer slot = lookup_slot_from(arg1, sc->curlet); - if ((!is_slot(slot)) || - (has_methods(slot_value(slot)))) - return_false(sc, car_x); - - obj = slot_value(slot); - if ((is_any_vector(obj)) && - (vector_rank(obj) > 1)) - return_false(sc, car_x); - - if (is_target_or_its_alias(car(car_x), s_func, sc->hash_table_set_symbol)) - { - if ((!is_hash_table(obj)) || (is_immutable(obj))) - return_false(sc, car_x); - } - else - if ((is_target_or_its_alias(car(car_x), s_func, sc->let_set_symbol)) && - ((!is_let(obj)) || (is_immutable(obj)))) - return_false(sc, car_x); - - opc->v[1].p = slot; - - if ((func == hash_table_set_p_ppp) && (is_hash_table(obj))) - opc->v[3].p_ppp_f = s7_hash_table_set; - - if (is_symbol(arg2)) - { - slot = opt_simple_symbol(sc, arg2); - if (slot) - { - opc->v[2].p = slot; - if (is_symbol(arg3)) - { - slot = opt_simple_symbol(sc, arg3); - if (slot) - { - s7_p_ppp_t func1 = opc->v[3].p_ppp_f; - opc->v[4].p_ppp_f = func1; - opc->v[3].p = slot; - opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : ((func1 == s7_hash_table_set) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); - return_true(sc, car_x); - }} - else - if ((!is_pair(arg3)) || - (is_proper_quote(sc, arg3))) - { - opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3; - opc->v[0].fp = opt_p_ppp_ssc; - return_true(sc, car_x); - } - if (optimize_op(car_x) == HOP_HASH_TABLE_INCREMENT) - { - opc->v[0].fp = opt_p_ppp_hash_table_increment; - opc->v[5].p = car_x; - return_true(sc, car_x); - } - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - opc->v[0].fp = opt_p_ppp_ssf; - return_true(sc, car_x); - } - pc_fallback(sc, start); - }} - if ((is_proper_quote(sc, arg2)) && - (is_symbol(arg3))) - { - s7_pointer val_slot = opt_simple_symbol(sc, arg3); - if (val_slot) - { - opc->v[4].p = cadr(arg2); - opc->v[2].p = val_slot; - opc->v[0].fp = opt_p_ppp_scs; - if (opc->v[3].p_ppp_f == let_set) - { - if (is_symbol(cadr(arg2))) /* checked is_let, has_methods and is_immutable above */ - opc->v[0].fp = opt_p_ppp_scs_eset; - else return_false(sc, car_x); - } - return_true(sc, car_x); - }} - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (is_symbol(arg3)) - { - s7_pointer val_slot = opt_simple_symbol(sc, arg3); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_p_ppp_sfs; /* hset case goes through the case below */ - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - }} - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[0].fp = opt_p_ppp_sff; - opc->v[10].o1 = o1; - opc->v[11].fp = o1->v[0].fp; - opc->v[8].o1 = o2; - opc->v[9].fp = o2->v[0].fp; - return_true(sc, car_x); - }}} - else - { - opc->v[10].o1 = sc->opts[start]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[0].fp = opt_p_ppp_fff; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - if ((opc->v[3].p_ppp_f == list_p_ppp) && - (opc->v[5].fp == opt_p_c) && (opc->v[9].fp == opt_p_c) && (opc->v[11].fp == opt_p_c)) - { - opc->v[0].fp = opt_list_3c; - opc->v[4].p = opc->v[4].o1->v[1].p; - opc->v[8].p = opc->v[8].o1->v[1].p; - opc->v[10].p = opc->v[10].o1->v[1].p; - } - return_true(sc, car_x); - }}}} - pc_fallback(sc, start); - return_false(sc, car_x); -} - -/* -------- p_call_ppp -------- */ -static s7_pointer opt_p_call_sss(opt_info *o) -{ - return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)))); -} - -static s7_pointer opt_p_call_css(opt_info *o) -{ - return(o->v[4].call(o->sc, set_plist_3(o->sc, o->v[1].p, slot_value(o->v[2].p), slot_value(o->v[3].p)))); -} - -static s7_pointer opt_p_call_ssf(opt_info *o) -{ - return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[6].fp(o->v[5].o1)))); -} - -static s7_pointer opt_p_call_ppp(opt_info *o) -{ - s7_pointer res; - s7_scheme *sc = o->sc; - gc_protect_2_via_stack(sc, o->v[4].fp(o->v[3].o1), o->v[6].fp(o->v[5].o1)); - res = o->v[11].fp(o->v[10].o1); /* not combinable into next */ - res = o->v[2].call(sc, set_plist_3(sc, stack_protected1(sc), stack_protected2(sc), res)); - unstack(sc); - return(res); -} - -static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) -{ - int32_t start = sc->pc; - if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 3)) && - (s_func != global_value(sc->hash_table_ref_symbol)) && (s_func != global_value(sc->list_ref_symbol))) - { - s7_pointer slot, arg = cadr(car_x); - opt_info *o1 = sc->opts[sc->pc]; - - if (!is_pair(arg)) - { - if (is_symbol(arg)) - { - slot = opt_simple_symbol(sc, arg); - if (slot) - { - opc->v[1].p = slot; - if ((s_func == global_value(sc->vector_ref_symbol)) && - (is_normal_vector(slot_value(slot))) && (vector_rank(slot_value(slot)) != 2)) - return_false(sc, car_x); - } - else return_false(sc, car_x); /* no need for pc_fallback here, I think */ - } - else - { - opc->v[1].p = arg; - if (s_func == global_value(sc->vector_ref_symbol)) - return_false(sc, car_x); - } - arg = caddr(car_x); - if (is_symbol(arg)) - { - slot = opt_simple_symbol(sc, arg); - if (slot) - { - opc->v[2].p = slot; - arg = cadddr(car_x); - if (is_symbol(arg)) - { - slot = opt_simple_symbol(sc, arg); - if (slot) - { - opc->v[3].p = slot; - opc->v[4].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = (is_slot(opc->v[1].p)) ? opt_p_call_sss : opt_p_call_css; - return_true(sc, car_x); - }} - else - if (is_slot(opc->v[1].p)) - { - int32_t start1 = sc->pc; - if ((cf_call(sc, car_x, s_func, 3) == g_substring_uncopied) && /* opc->v[4].call is unsafe -- might not be set */ - (is_t_integer(slot_value(opc->v[2].p))) && - (is_string(slot_value(opc->v[1].p))) && - (int_optimize(sc, cdddr(car_x)))) - { - opc->v[0].fp = opt_p_substring_uncopied_ssf; - opc->v[5].o1 = o1; - opc->v[6].fi = o1->v[0].fi; - return_true(sc, car_x); - } - pc_fallback(sc, start1); - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = opt_p_call_ssf; - opc->v[5].o1 = o1; - opc->v[6].fp = o1->v[0].fp; - return_true(sc, car_x); - }}}}} - if (s_func == global_value(sc->vector_ref_symbol)) - return_false(sc, car_x); - if (cell_optimize(sc, cdr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opt_info *o3 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[2].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = opt_p_call_ppp; - opc->v[3].o1 = o1; - opc->v[4].fp = o1->v[0].fp; - opc->v[5].o1 = o2; - opc->v[6].fp = o2->v[0].fp; - opc->v[10].o1 = o3; - opc->v[11].fp = o3->v[0].fp; - return_true(sc, car_x); - }}}} - pc_fallback(sc, start); - return_false(sc, car_x); -} - - -/* -------- p_call_any -------- */ -#define P_CALL_O1 3 - -static s7_pointer opt_p_call_any(opt_info *o) -{ - s7_scheme *sc = o->sc; - s7_pointer val = safe_list_if_possible(sc, o->v[1].i); - s7_pointer arg = val; - if (in_heap(val)) gc_protect_via_stack(sc, val); - for (s7_int i = 0; i < o->v[1].i; i++, arg = cdr(arg)) - { - opt_info *o1 = o->v[i + P_CALL_O1].o1; - set_car(arg, o1->v[0].fp(o1)); - } - arg = o->v[2].call(sc, val); - if (in_heap(val)) unstack(sc); - else clear_list_in_use(val); - return(arg); -} - -static bool p_call_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t len) -{ - if ((len < (NUM_VUNIONS - P_CALL_O1)) && - (is_safe_procedure(s_func)) && - (c_function_is_aritable(s_func, len - 1))) - { - s7_pointer p = cdr(car_x); /* (vector-set! v k i 2) gets here */ - opc->v[1].i = (len - 1); - for (int32_t pctr = P_CALL_O1; is_pair(p); pctr++, p = cdr(p)) - { - opc->v[pctr].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (is_null(p)) - { - opc->v[0].fp = opt_p_call_any; - opc->v[2].call = cf_call(sc, car_x, s_func, len - 1); - return_true(sc, car_x); - }} - return_false(sc, car_x); -} - - -/* -------- p_fx_any -------- */ - -static s7_pointer opt_p_fx_any(opt_info *o) {return(o->v[1].call(o->sc, o->v[2].p));} - -static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer x) -{ - s7_function f = (has_fx(x)) ? fx_proc(x) : fx_choose(sc, x, sc->curlet, let_symbol_is_safe); - if (!f) - return_false(sc, x); - opc->v[0].fp = opt_p_fx_any; - opc->v[1].call = f; - opc->v[2].p = car(x); - return_true(sc, x); -} - - -/* -------- p_implicit -------- */ - -static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len) -{ - s7_pointer obj = slot_value(s_slot); - opt_info *opc; - int32_t start; - - if ((!is_sequence(obj)) || (len < 2)) - return_false(sc, car_x); - - opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - start = sc->pc; - if (len == 2) - { - switch (type(obj)) - { - case T_PAIR: opc->v[3].p_pi_f = list_ref_p_pi_unchecked; break; - case T_HASH_TABLE: opc->v[3].p_pp_f = s7_hash_table_ref; break; - case T_LET: opc->v[3].p_pp_f = let_ref; break; - case T_STRING: opc->v[3].p_pi_f = string_ref_p_pi_unchecked; break; - case T_C_OBJECT: return_false(sc, car_x); /* no pi_ref because ref assumes pp */ - - case T_VECTOR: - if (vector_rank(obj) != 1) - return_false(sc, car_x); - opc->v[3].p_pi_f = normal_vector_ref_p_pi_unchecked; - break; - - case T_BYTE_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - if (vector_rank(obj) != 1) - return_false(sc, car_x); - opc->v[3].p_pi_f = vector_ref_p_pi_unchecked; - break; - - default: - return_false(sc, car_x); - } - /* now v3.p_pi|pp.f is set */ - if (is_symbol(cadr(car_x))) - { - s7_pointer slot = lookup_slot_from(cadr(car_x), sc->curlet); - if (is_slot(slot)) - { - opc->v[2].p = slot; - if ((!is_hash_table(obj)) && /* these because opt_int below */ - (!is_let(obj))) - { - if (!is_t_integer(slot_value(slot))) - return_false(sc, car_x); /* I think this reflects that a non-int index is an error for list-ref et al */ - opc->v[0].fp = opt_p_pi_ss; - if (is_step_end(opc->v[2].p)) - check_unchecked(sc, obj, opc->v[2].p, opc, NULL); - fixup_p_pi_ss(opc); - return_true(sc, car_x); - } - opc->v[0].fp = opt_p_pp_ss; - return_true(sc, car_x); - }} - else - { - if ((!is_hash_table(obj)) && - (!is_let(obj))) - { - opt_info *o1; - if (is_t_integer(cadr(car_x))) - { - opc->v[2].i = integer(cadr(car_x)); - opc->v[0].fp = opt_p_pi_sc; - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[0].fp = opt_p_pi_sf; - opc->v[4].o1 = o1; - opc->v[5].fi = o1->v[0].fi; - return_true(sc, car_x); - } - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fp = opt_p_pp_sf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - return_true(sc, car_x); - }}} /* len==2 */ - else - { /* len > 2 */ - if ((is_normal_vector(obj)) && (len == 3) && (vector_rank(obj) == 2)) - { - s7_pointer slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - opc->v[4].p_pii_f = vector_ref_p_pii; - opc->v[0].fp = opt_p_pii_sss; - if ((step_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (step_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fp = vector_ref_pii_sss_unchecked; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_p_pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - /* opc->v[1].p set above */ - opc->v[4].p_pii_f = vector_ref_p_pii_direct; - return_true(sc, car_x); - }} - pc_fallback(sc, start); - } - - #define P_IMPLICIT_CALL_O1 4 - if (len < (NUM_VUNIONS - P_IMPLICIT_CALL_O1)) /* mimic p_call_any_ok */ - { - s7_pointer p = car_x; - opc->v[1].i = len; - for (int32_t pctr = (P_IMPLICIT_CALL_O1 - 1); is_pair(p); pctr++, p = cdr(p)) - { - opc->v[pctr].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (is_null(p)) - { - /* here we know the vector rank/type, probably can handle the new value type, and maybe indices/dimensions, - * so at least forgo the vec type/rank + immutable checks, the *_set cases are from p_call_any_ok called in cell_optimize, - * but this is called very rarely mainly because hi-rank implicit refs are rare, and check_type_uncertainty is unhappy - * if there are multiple sets of a var. - * hash-tables, lets, lists, and vectors with extra (implicit) args can't be handled because we have no way to tell - * what the implicit call will do, and in the opt_* context, everything must be "safe" (i.e. no defines or - * hidden multiple-values, etc). - */ - if ((!is_any_vector(obj)) || (vector_rank(obj) != (len - 1))) return_false(sc, car_x); - opc->v[0].fp = opt_p_call_any; - switch (type(obj)) /* string can't happen here (no multidimensional strings), for pair/hash/let see above */ - { - case T_INT_VECTOR: opc->v[2].call = g_int_vector_ref; break; - case T_BYTE_VECTOR: opc->v[2].call = g_byte_vector_ref; break; - case T_FLOAT_VECTOR: opc->v[2].call = g_float_vector_ref; break; - case T_VECTOR: opc->v[2].call = g_vector_ref; break; - default: return_false(sc, car_x); - } - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -/* -------- cell_quote -------- */ -static bool opt_cell_quote(s7_scheme *sc, s7_pointer car_x) -{ - opt_info *opc; - if (!is_null(cddr(car_x))) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - opc->v[1].p = cadr(car_x); - opc->v[0].fp = opt_p_c; - return_true(sc, car_x); -} - -/* -------- cell_set -------- */ -static s7_pointer opt_set_p_p_f(opt_info *o) -{ - s7_pointer x = o->v[4].fp(o->v[3].o1); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_p_f_with_setter(opt_info *o) -{ - s7_pointer x = o->v[4].fp(o->v[3].o1); - call_c_function_setter(o->sc, slot_setter(o->v[1].p), slot_symbol(o->v[1].p), x); - slot_set_value(o->v[1].p, x); /* symbol_increment?? */ - return(x); -} - -static s7_pointer opt_set_p_i_s(opt_info *o) -{ - s7_pointer val = slot_value(o->v[2].p); - if (is_mutable_integer(val)) - val = make_integer(o->sc, integer(val)); - slot_set_value(o->v[1].p, val); - return(val); -} - -static s7_pointer opt_set_p_i_f(opt_info *o) -{ - s7_pointer x = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_d_s(opt_info *o) -{ - s7_pointer val = slot_value(o->v[2].p); - if (is_mutable_number(val)) - val = make_real(o->sc, real(val)); - slot_set_value(o->v[1].p, val); - return(val); -} - -static s7_pointer opt_set_p_d_f(opt_info *o) -{ - s7_pointer x = make_real(o->sc, o->v[5].fd(o->v[4].o1)); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_d_f_sf_add(opt_info *o) -{ - s7_pointer x = make_real(o->sc, opt_d_dd_sf_add(o->v[4].o1)); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_d_f_mm_add(opt_info *o) -{ - s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[4].p), integer(slot_value(o->v[5].p))) * real(slot_value(o->v[3].p)); - s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[10].p), integer(slot_value(o->v[11].p))) * real(slot_value(o->v[9].p)); - slot_set_value(o->v[1].p, make_real(o->sc, x1 + x2)); - return(slot_value(o->v[1].p)); -} - -static s7_pointer opt_set_p_d_f_mm_subtract(opt_info *o) -{ - s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[4].p), integer(slot_value(o->v[5].p))) * real(slot_value(o->v[3].p)); - s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[10].p), integer(slot_value(o->v[11].p))) * real(slot_value(o->v[9].p)); - slot_set_value(o->v[1].p, make_real(o->sc, x1 - x2)); - return(slot_value(o->v[1].p)); -} - -static s7_pointer opt_set_p_c(opt_info *o) -{ - slot_set_value(o->v[1].p, o->v[2].p); - return(o->v[2].p); -} - -static s7_pointer opt_set_p_i_fo(opt_info *o) -{ - s7_int i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p))); - s7_pointer x = make_integer(o->sc, i); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_i_fo_add(opt_info *o) -{ - s7_int i = integer(slot_value(o->v[2].p)) + integer(slot_value(o->v[3].p)); - s7_pointer x = make_integer(o->sc, i); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_i_fo1(opt_info *o) -{ - s7_int i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), o->v[3].i); - s7_pointer x = make_integer(o->sc, i); - slot_set_value(o->v[1].p, x); - return(x); -} - -static s7_pointer opt_set_p_i_fo1_add(opt_info *o) -{ - s7_int i = integer(slot_value(o->v[2].p)) + o->v[3].i; - s7_pointer x = make_integer(o->sc, i); - slot_set_value(o->v[1].p, x); - return(x); -} - -static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 1) && - (opc == sc->opts[sc->pc - 2])) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((o1->v[0].fi == opt_i_ii_ss) || - (o1->v[0].fi == opt_i_ii_ss_add)) - { - opc->v[4].i_ii_f = o1->v[3].i_ii_f; - opc->v[2].p = o1->v[1].p; - opc->v[3].p = o1->v[2].p; - opc->v[0].fp = (o1->v[0].fi == opt_i_ii_ss_add) ? opt_set_p_i_fo_add : opt_set_p_i_fo; - backup_pc(sc); - return_true(sc, NULL); - } - if ((o1->v[0].fi == opt_i_ii_sc) || (o1->v[0].fi == opt_i_ii_sc_add) || (o1->v[0].fi == opt_i_ii_sc_sub)) - { - opc->v[4].i_ii_f = o1->v[3].i_ii_f; - opc->v[2].p = o1->v[1].p; - opc->v[3].i = o1->v[2].i; - opc->v[0].fp = (o1->v[0].fi == opt_i_ii_sc_add) ? opt_set_p_i_fo1_add : opt_set_p_i_fo1; - backup_pc(sc); - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool set_p_d_f_combinable(s7_scheme *sc, opt_info *opc) -{ - if ((sc->pc > 3) && - (opc == sc->opts[sc->pc - 4])) - { - opt_info *o1 = sc->opts[sc->pc - 3]; - if ((o1->v[0].fd == opt_d_mm_fff) && - ((o1->v[3].d_dd_f == add_d_dd) || (o1->v[3].d_dd_f == subtract_d_dd))) - { - opc->v[0].fp = (o1->v[3].d_dd_f == add_d_dd) ? opt_set_p_d_f_mm_add : opt_set_p_d_f_mm_subtract; - o1 = sc->opts[sc->pc - 2]; - opc->v[3].p = o1->v[1].p; - opc->v[4].p = o1->v[2].p; - opc->v[5].p = o1->v[3].p; - o1 = sc->opts[sc->pc - 1]; - opc->v[9].p = o1->v[1].p; - opc->v[10].p = o1->v[2].p; - opc->v[11].p = o1->v[3].p; - sc->pc -= 3; - return_true(sc, NULL); - }} - return_false(sc, NULL); -} - -static bool is_some_number(s7_scheme *sc, const s7_pointer tp) -{ - return((tp == sc->is_integer_symbol) || - (tp == sc->is_float_symbol) || - (tp == sc->is_real_symbol) || - (tp == sc->is_complex_symbol) || - (tp == sc->is_number_symbol) || - (tp == sc->is_byte_symbol) || - (tp == sc->is_rational_symbol)); -} - -static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer car_x, opt_info *opc, int32_t start_pc) -{ - s7_pointer code = sc->code; - /* if we're optimizing do, sc->code is (sometimes) ((vars...) (end...) car_x) where car_x is the do body, but it can also be for-each etc */ - - /* maybe the type uncertainty is not a problem */ - if ((is_pair(code)) && /* t101-aux-14: (vector-set! !v! 0 (do ((x (list 1 2 3) (cdr x)) (j -1)) ((null? x) j) (set! j (car x)))) */ - (is_pair(car(code))) && - (is_pair(cdr(code))) && /* weird that code sometimes has nothing to do with car_x -- tree_memq below for reality check */ - (is_pair(cadr(code)))) - { - s7_int counts; - if ((!has_low_count(code)) && /* only set below */ - (s7_tree_memq(sc, car_x, code))) - { - if (is_pair(caar(code))) - { - counts = tree_count(sc, target, car(code), 0) + - tree_count(sc, target, caadr(code), 0) + - tree_count(sc, target, cddr(code), 0); - for (s7_pointer p = car(code); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((is_proper_list_2(sc, var)) && - (car(var) == target)) - counts--; - }} - else counts = tree_count(sc, target, code, 0); - } - else counts = 2; - /* can be from lambda: (lambda (n)...): ((n) (set! sum (+ sum n))) etc */ - if (counts <= 2) - { - set_has_low_count(code); - pc_fallback(sc, start_pc); - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_set_p_p_f; - opc->v[3].o1 = sc->opts[start_pc]; - opc->v[4].fp = sc->opts[start_pc]->v[0].fp; - return_true(sc, car_x); - }}} - return_false(sc, car_x); -} - -static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_syntax) */ -{ - opt_info *opc = alloc_opt_info(sc); - s7_pointer target = cadr(car_x); - if (is_symbol(target)) - { - s7_pointer settee; - if ((is_constant_symbol(sc, target)) || - ((is_slot(global_slot(target))) && (slot_has_setter(global_slot(target))))) - return_false(sc, car_x); - - settee = lookup_slot_from(target, sc->curlet); - if ((is_slot(settee)) && - (!is_immutable(settee)) && - (!is_syntax(slot_value(settee)))) - { - int32_t start_pc = sc->pc; - s7_pointer stype = s7_type_of(sc, slot_value(settee)); - s7_pointer atype; - opc->v[1].p = settee; - if (slot_has_setter(settee)) - { - if ((is_c_function(slot_setter(settee))) && - (is_bool_function(slot_setter(settee))) && - (stype == opt_arg_type(sc, cddr(car_x))) && - (cell_optimize(sc, cddr(car_x)))) - { - opc->v[1].p = settee; - opc->v[0].fp = opt_set_p_p_f_with_setter; - opc->v[3].o1 = sc->opts[start_pc]; - opc->v[4].fp = sc->opts[start_pc]->v[0].fp; - return_true(sc, car_x); - } - return_false(sc, car_x); - } - - if (stype == sc->is_integer_symbol) - { - if (is_symbol(caddr(car_x))) - { - s7_pointer val_slot = opt_integer_symbol(sc, caddr(car_x)); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_set_p_i_s; - return_true(sc, car_x); - }} - else - { - opc->v[5].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cddr(car_x))) - return(check_type_uncertainty(sc, target, car_x, opc, start_pc)); - if (!set_p_i_f_combinable(sc, opc)) - { - opc->v[0].fp = opt_set_p_i_f; - opc->v[6].fi = opc->v[5].o1->v[0].fi; - } - return_true(sc, car_x); - }} - if (stype == sc->is_float_symbol) - { - if (is_t_real(caddr(car_x))) - { - opc->v[2].p = caddr(car_x); - opc->v[0].fp = opt_set_p_c; - return_true(sc, car_x); - } - if (is_symbol(caddr(car_x))) - { - s7_pointer val_slot = opt_float_symbol(sc, caddr(car_x)); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_set_p_d_s; - return_true(sc, car_x); - }} - else - { - if ((is_pair(caddr(car_x))) && - (float_optimize(sc, cddr(car_x)))) - { - if (!set_p_d_f_combinable(sc, opc)) - { - opc->v[4].o1 = sc->opts[start_pc]; - opc->v[5].fd = sc->opts[start_pc]->v[0].fd; - opc->v[0].fp = (opc->v[5].fd == opt_d_dd_sf_add) ? opt_set_p_d_f_sf_add : opt_set_p_d_f; - } - return_true(sc, car_x); - } - return(check_type_uncertainty(sc, target, car_x, opc, start_pc)); - }} - - atype = opt_arg_type(sc, cddr(car_x)); - if ((is_some_number(sc, atype)) && - (!is_some_number(sc, stype))) - return_false(sc, car_x); - if (cell_optimize(sc, cddr(car_x))) - { - if ((stype != atype) && - (is_symbol(stype)) && - (((t_sequence_p[symbol_type(stype)]) && - (stype != sc->is_null_symbol) && - (stype != sc->is_pair_symbol)) || /* compatible with is_proper_list! */ - (stype == sc->is_iterator_symbol))) - return_false(sc, car_x); - opc->v[0].fp = opt_set_p_p_f; - opc->v[3].o1 = sc->opts[start_pc]; - opc->v[4].fp = sc->opts[start_pc]->v[0].fp; - return_true(sc, car_x); - }} - return_false(sc, car_x); - } - if ((is_pair(target)) && - (is_symbol(car(target))) && - (is_pair(cdr(target))) && - ((is_null(cddr(target))) || (is_null(cdddr(target))) || (is_null(cddddr(target))))) - { - s7_pointer obj, index, s_slot = lookup_slot_from(car(target), sc->curlet); - if (!is_slot(s_slot)) - return_false(sc, car_x); - - obj = slot_value(s_slot); - opc->v[1].p = s_slot; - if (!is_mutable_sequence(obj)) - return_false(sc, car_x); - - index = cadr(target); - switch (type(obj)) - { - case T_STRING: - { - s7_pointer val_type; - if (is_pair(cddr(target))) return_false(sc, car_x); - val_type = opt_arg_type(sc, cddr(car_x)); - if (val_type != sc->is_char_symbol) - return_false(sc, car_x); - opc->v[3].p_pip_f = string_set_p_pip_unchecked; - } - break; - - case T_VECTOR: - /* is_t_integer below to handle the index */ - if (is_null(cddr(target))) - { - if (vector_rank(obj) != 1) return_false(sc, car_x); - opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked : vector_set_p_pip_unchecked; - } - else - { - if (vector_rank(obj) != 2) - return_false(sc, car_x); - opc->v[5].p_piip_f = (is_typed_vector(obj)) ? typed_vector_set_p_piip_direct : vector_set_p_piip_direct; - return(p_piip_to_sx(sc, opc, cdr(target), cddr(target), cddr(car_x), obj)); - } - break; - - case T_FLOAT_VECTOR: - if (opt_float_vector_set(sc, opc, car(target), cdr(target), - (is_null(cddr(target))) ? NULL : cddr(target), - ((!is_pair(cddr(target))) || (is_null(cdddr(target)))) ? NULL : cdddr(target), - cddr(car_x))) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return_true(sc, car_x); - } - return_false(sc, car_x); - - case T_BYTE_VECTOR: - case T_INT_VECTOR: - if (opt_int_vector_set(sc, -1, opc, car(target), cdr(target), (is_null(cddr(target))) ? NULL : cddr(target), cddr(car_x))) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - return_true(sc, car_x); - } - return_false(sc, car_x); - - case T_C_OBJECT: - if ((is_null(cddr(target))) && - (is_c_function(c_object_setf(sc, obj)))) - { - /* d_7pid_ok assumes cadr is the target, not car etc */ - s7_d_7pid_t func = s7_d_7pid_function(c_object_setf(sc, obj)); - if (func) - { - s7_pointer slot = opt_integer_symbol(sc, cadr(target)); - opc->v[4].d_7pid_f = func; - opc->v[10].o1 = sc->opts[sc->pc]; - if (slot) - { - if (float_optimize(sc, cddr(car_x))) - { - opc->v[O_WRAP].fd = opt_d_7pid_ssf; - opc->v[0].fp = d_to_p; /* cell_optimize, so need to return s7_pointer */ - opc->v[2].p = slot; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, car_x); - }} - else - if (int_optimize(sc, cdr(target))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[O_WRAP].fd = opt_d_7pid_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[0].fp = d_to_p; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); - - case T_PAIR: - if (is_pair(cddr(target))) return_false(sc, car_x); - opc->v[3].p_pip_f = list_set_p_pip_unchecked; - - /* an experiment -- is this ever hit in normal code? */ - { - s7_pointer val = caddr(car_x); - if ((is_pair(val)) && (car(val) == sc->add_symbol) && (is_t_integer(caddr(val))) && (is_null(cdddr(val))) && (is_symbol(cadr(target))) && - (car(target) == (caadr(val))) && (is_pair(cdadr(val))) && (is_null(cddadr(val))) && (cadr(target) == cadadr(val))) - { - s7_pointer slot = opt_simple_symbol(sc, index); - if ((slot) && (is_t_integer(slot_value(slot)))) - { - opc->v[2].p = slot; - opc->v[3].p = caddr(val); - opc->v[0].fp = list_increment_p_pip_unchecked; - return_true(sc, car_x); - }}} - break; - - case T_HASH_TABLE: - if (is_pair(cddr(target))) return_false(sc, car_x); - opc->v[3].p_ppp_f = s7_hash_table_set; - break; - - case T_LET: - /* here we know the let is a covered mutable let -- ?? not true if s7-optimize called explicitly */ - if ((is_pair(cddr(target))) || (is_openlet(obj))) - return_false(sc, car_x); - if ((is_symbol_and_keyword(cadr(target))) || - ((is_quoted_symbol(cadr(target))))) - opc->v[3].p_ppp_f = let_set_1; - else opc->v[3].p_ppp_f = let_set_p_ppp_2; - break; - - default: - return_false(sc, car_x); - } - if (is_symbol(index)) - { - int32_t start = sc->pc; - s7_pointer slot = opt_simple_symbol(sc, index); - if (slot) - { - opc->v[2].p = slot; - if ((is_t_integer(slot_value(slot))) && - (is_step_end(opc->v[2].p))) - { - if (is_string(obj)) - { - if (do_loop_end(slot_value(opc->v[2].p)) <= string_length(obj)) - opc->v[3].p_pip_f = string_set_p_pip_direct; - } - else - if (is_byte_vector(obj)) - { - if (do_loop_end(slot_value(opc->v[2].p)) <= byte_vector_length(obj)) - opc->v[3].p_pip_f = byte_vector_set_p_pip_direct; - } - else - if (is_any_vector(obj)) /* true for all 3 vectors */ - { - if ((is_any_vector(obj)) && - (do_loop_end(slot_value(opc->v[2].p)) <= vector_length(obj))) - { - if ((is_normal_vector(obj)) && (is_typed_vector(obj))) - opc->v[3].p_pip_f = typed_normal_vector_set_p_pip_direct; - else opc->v[3].p_pip_f = normal_vector_set_p_pip_direct; - }}} - if (is_symbol(caddr(car_x))) - { - s7_pointer val_slot = opt_simple_symbol(sc, caddr(car_x)); - if (val_slot) - { - s7_p_ppp_t func1; - if ((is_string(obj)) || - (is_any_vector(obj)) || - (is_pair(obj))) - { - opc->v[4].p_pip_f = opc->v[3].p_pip_f; - opc->v[3].p = val_slot; - opc->v[0].fp = opt_p_pip_sss; - return_true(sc, car_x); - } - func1 = opc->v[3].p_ppp_f; - opc->v[4].p_ppp_f = func1; - opc->v[3].p = val_slot; - opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : ((func1 == s7_hash_table_set) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); - return_true(sc, car_x); - }} - else - if ((!is_pair(caddr(car_x))) || - (is_proper_quote(sc, caddr(car_x)))) - { - if (!is_pair(caddr(car_x))) - opc->v[4].p = caddr(car_x); - else opc->v[4].p = cadaddr(car_x); - if ((is_string(obj)) || - (is_any_vector(obj)) || - (is_pair(obj))) - { - opc->v[0].fp = opt_p_pip_ssc; - return_true(sc, car_x); - } - opc->v[0].fp = opt_p_ppp_ssc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - if ((is_string(obj)) || - (is_any_vector(obj)) || - (is_pair(obj))) - { - if (p_pip_ssf_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fp = opt_p_pip_ssf; - return_true(sc, car_x); - } - opc->v[0].fp = opt_p_ppp_ssf; - return_true(sc, car_x); - }}} - else /* index not a symbol */ - { - opt_info *o1; - if ((is_string(obj)) || - (is_pair(obj)) || - (is_any_vector(obj))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(target))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_p_pip_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - return_true(sc, car_x); - }} - return_false(sc, car_x); - } - if ((is_proper_quote(sc, cadr(target))) && - (is_symbol(caddr(car_x)))) - { - s7_pointer val_slot = opt_simple_symbol(sc, caddr(car_x)); - if (val_slot) - { - opc->v[4].p = cadadr(target); - opc->v[2].p = val_slot; - opc->v[0].fp = (opc->v[3].p_ppp_f == let_set_1) ? opt_p_ppp_scs_eset : opt_p_ppp_scs; - return_true(sc, car_x); - }} - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(target))) - { - opt_info *o2; - if (is_symbol(caddr(car_x))) - { - s7_pointer val_slot = opt_simple_symbol(sc, caddr(car_x)); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_p_ppp_sfs; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - }} - o2 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_p_ppp_sff; - opc->v[10].o1 = o1; - opc->v[11].fp = o1->v[0].fp; - opc->v[8].o1 = o2; - opc->v[9].fp = o2->v[0].fp; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - - -/* -------- cell_begin -------- */ -static s7_pointer opt_begin_p(opt_info *o) -{ - opt_info *o1; - s7_int i, len = o->v[1].i; /* len = 1 if 2 exprs, etc */ - for (i = 0; i < len; i++) - { - o1 = o->v[i + 2].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + 2].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_begin_p_1(opt_info *o) -{ - o->v[3].fp(o->v[2].o1); - return(o->v[5].fp(o->v[4].o1)); -} - -static void oo_idp_nr_fixup(opt_info *start) -{ - if (start->v[0].fp == d_to_p) - { - start->v[0].fp = d_to_p_nr; - if (start->v[O_WRAP].fd == opt_d_7pid_ssf) - start->v[0].fp = opt_d_7pid_ssf_nr; - else - if (start->v[O_WRAP].fd == opt_d_7pid_ssfo_fv) - { - start->v[0].fp = opt_d_7pid_ssfo_fv_nr; - if (start->v[6].d_dd_f == add_d_dd) - start->v[0].fp = opt_d_7pid_ssfo_fv_add_nr; - else - if (start->v[6].d_dd_f == subtract_d_dd) - start->v[0].fp = opt_d_7pid_ssfo_fv_sub_nr; - }} - else - if (start->v[0].fp == i_to_p) - start->v[0].fp = i_to_p_nr; -} - -static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - int32_t i; - opt_info *opc; - s7_pointer p; - if (len > (NUM_VUNIONS - 3)) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - for (i = 2, p = cdr(car_x); is_pair(p); i++, p = cdr(p)) - { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - return_false(sc, car_x); - if (is_pair(cdr(p))) - oo_idp_nr_fixup(start); - opc->v[i].o1 = start; - } - opc->v[1].i = len - 2; - if (len == 3) - { - opc->v[0].fp = opt_begin_p_1; - opc->v[4].o1 = opc->v[3].o1; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - opc->v[3].fp = opc->v[2].o1->v[0].fp; - } - else opc->v[0].fp = opt_begin_p; - return_true(sc, car_x); -} - -/* -------- cell_when|unless -------- */ -static s7_pointer opt_when_p_2(opt_info *o) -{ - if (o->v[4].fb(o->v[3].o1)) - { - o->v[6].fp(o->v[5].o1); - return(o->v[8].fp(o->v[7].o1)); - } - return(o->sc->unspecified); -} - -static s7_pointer opt_when_p(opt_info *o) -{ - if (o->v[4].fb(o->v[3].o1)) - { - s7_int i, len = o->v[1].i - 1; - opt_info *o1; - for (i = 0; i < len; i++) - { - o1 = o->v[i + 5].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + 5].o1; - return(o1->v[0].fp(o1)); - } - return(o->sc->unspecified); -} - -static s7_pointer opt_when_p_1(opt_info *o) -{ - opt_info *o1; - if (!o->v[4].fb(o->v[3].o1)) - return(o->sc->unspecified); - o1 = o->v[5].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_unless_p(opt_info *o) -{ - opt_info *o1; - s7_int i, len; - if (o->v[4].fb(o->v[3].o1)) - return(o->sc->unspecified); - len = o->v[1].i - 1; - for (i = 0; i < len; i++) - { - o1 = o->v[i + 5].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + 5].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_unless_p_1(opt_info *o) -{ - opt_info *o1; - if (o->v[4].fb(o->v[3].o1)) - return(o->sc->unspecified); - o1 = o->v[5].o1; - return(o1->v[0].fp(o1)); -} - -static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - s7_pointer p; - int32_t k; - opt_info *opc; - if (len > (NUM_VUNIONS - 6)) - return_false(sc, car_x); - opc = alloc_opt_info(sc); - opc->v[3].o1 = sc->opts[sc->pc]; - if (!bool_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - for (k = 5, p = cddr(car_x); is_pair(p); k++, p = cdr(p)) - { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - return_false(sc, car_x); - if (is_pair(cdr(p))) - oo_idp_nr_fixup(start); - opc->v[k].o1 = start; - } - opc->v[4].fb = opc->v[3].o1->v[0].fb; - opc->v[1].i = len - 2; - if (car(car_x) == sc->when_symbol) - { - if (len == 3) - opc->v[0].fp = opt_when_p_1; - else - if (len == 4) - { - opc->v[0].fp = opt_when_p_2; - opc->v[7].o1 = opc->v[6].o1; - opc->v[8].fp = opc->v[7].o1->v[0].fp; - opc->v[6].fp = opc->v[5].o1->v[0].fp; - } - else opc->v[0].fp = opt_when_p; - } - else opc->v[0].fp = (len == 3) ? opt_unless_p_1 : opt_unless_p; - return_true(sc, car_x); -} - -/* -------- cell_cond -------- */ - -#define COND_O1 3 -#define COND_CLAUSE_O1 5 - -static s7_pointer cond_value(opt_info *o) -{ - opt_info *o1; - s7_int i, len = o->v[1].i - 1; - for (i = 0; i < len; i++) - { - o1 = o->v[i + COND_CLAUSE_O1].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + COND_CLAUSE_O1].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_cond(opt_info *top) -{ - s7_int len = top->v[2].i; - for (s7_int clause = 0; clause < len; clause++) - { - opt_info *o1 = top->v[clause + COND_O1].o1; - opt_info *o2 = o1->v[4].o1; - if (o2->v[0].fb(o2)) - { - s7_pointer res = cond_value(o1); - return(res); - }} - return(top->sc->unspecified); -} - -static s7_pointer opt_cond_1(opt_info *o) {return((o->v[5].fb(o->v[4].o1)) ? cond_value(o->v[6].o1) : o->sc->unspecified);} /* cond as when */ -static s7_pointer opt_cond_1b(opt_info *o) {return((o->v[4].o1->v[O_WRAP].fp(o->v[4].o1) != o->sc->F) ? cond_value(o->v[6].o1) : o->sc->unspecified);} - -static s7_pointer opt_cond_2(opt_info *o) /* 2 branches, results 1 expr, else */ -{ - opt_info *o1 = (o->v[5].fb(o->v[4].o1)) ? o->v[6].o1 : o->v[7].o1; - s7_pointer res = o1->v[0].fp(o1); - return(res); -} - -static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x) -{ - /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */ - s7_pointer last_clause = NULL; - int32_t branches = 0, max_blen = 0; - opt_info *top = alloc_opt_info(sc); - int32_t start_pc = sc->pc; - for (s7_pointer p = cdr(car_x); is_pair(p); p = cdr(p), branches++) - { - opt_info *opc; - s7_pointer clause = car(p), cp; - int32_t blen; - if ((branches >= (NUM_VUNIONS - COND_O1)) || - (!is_pair(clause)) || - (!is_pair(cdr(clause))) || /* leave the test->result case for later */ - (cadr(clause) == sc->feed_to_symbol)) - return_false(sc, clause); - - last_clause = clause; - top->v[branches + COND_O1].o1 = sc->opts[sc->pc]; - opc = alloc_opt_info(sc); - opc->v[4].o1 = sc->opts[sc->pc]; - if (!bool_optimize(sc, clause)) - return_false(sc, clause); - - for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp)) - { - if (blen >= NUM_VUNIONS - COND_CLAUSE_O1) - return_false(sc, cp); - opc->v[blen + COND_CLAUSE_O1].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cp)) - return_false(sc, cp); - } - if (!is_null(cp)) - return_false(sc, cp); - opc->v[1].i = blen; - if (max_blen < blen) max_blen = blen; - opc->v[0].fp = opt_cond; /* a placeholder */ - } - if (branches == 1) - { - opt_info *o1 = sc->opts[start_pc + 1]; - top->v[0].fp = (o1->v[0].fb == p_to_b) ? opt_cond_1b : opt_cond_1; - top->v[4].o1 = o1; - top->v[5].fb = o1->v[0].fb; - top->v[6].o1 = sc->opts[start_pc]; - return_true(sc, car_x); - } - if (branches == 2) - { - if ((max_blen == 1) && - ((car(last_clause) == sc->else_symbol) || (car(last_clause) == sc->T))) - { - opt_info *o1; - top->v[6].o1 = top->v[COND_O1].o1->v[COND_CLAUSE_O1].o1; - top->v[7].o1 = top->v[COND_O1 + 1].o1->v[COND_CLAUSE_O1].o1; - - o1 = sc->opts[start_pc + 1]; - top->v[4].o1 = o1; - top->v[5].fb = o1->v[0].fb; - top->v[0].fp = opt_cond_2; - return_true(sc, car_x); - }} - top->v[2].i = branches; - top->v[0].fp = opt_cond; - return_true(sc, car_x); -} - -/* -------- cell_and|or -------- */ -static s7_pointer opt_and_pp(opt_info *o) {return((o->v[11].fp(o->v[10].o1) == o->sc->F) ? o->sc->F : o->v[9].fp(o->v[8].o1));} - -static s7_pointer opt_and_any_p(opt_info *o) -{ - s7_pointer val = o->sc->T; /* (and) -> #t */ - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 3].o1; - val = o1->v[0].fp(o1); - if (val == o->sc->F) - return(o->sc->F); - } - return(val); -} - -static s7_pointer opt_or_pp(opt_info *o) -{ - s7_pointer val = o->v[11].fp(o->v[10].o1); - return((val != o->sc->F) ? val : o->v[9].fp(o->v[8].o1)); -} - -static s7_pointer opt_or_any_p(opt_info *o) -{ - for (s7_int i = 0; i < o->v[1].i; i++) - { - opt_info *o1 = o->v[i + 3].o1; - s7_pointer val = o1->v[0].fp(o1); - if (val != o->sc->F) - return(val); - } - return(o->sc->F); -} - -static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - opt_info *opc = alloc_opt_info(sc); - if (len == 3) - { - opc->v[0].fp = ((car(car_x) == sc->or_symbol) ? opt_or_pp : opt_and_pp); - opc->v[10].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[8].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cddr(car_x))) - return_false(sc, car_x); - opc->v[9].fp = opc->v[8].o1->v[0].fp; - return_true(sc, car_x); - } - if ((len > 1) && (len < (NUM_VUNIONS - 4))) - { - s7_pointer p = cdr(car_x); - opc->v[1].i = (len - 1); - opc->v[0].fp = ((car(car_x) == sc->or_symbol) ? opt_or_any_p : opt_and_any_p); - for (int32_t i = 3; is_pair(p); i++, p = cdr(p)) - { - opc->v[i].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - return_false(sc, car_x); - } - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- cell_if -------- */ -static s7_pointer opt_if_bp(opt_info *o) {return((o->v[3].fb(o->v[2].o1)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);} -static s7_pointer opt_if_b7p(opt_info *o) {return((opt_b_7p_f(o->v[2].o1)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);} /* expanded not faster */ -static s7_pointer opt_if_nbp(opt_info *o) {return((o->v[5].fb(o->v[4].o1)) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));} -static s7_pointer opt_if_bp_and(opt_info *o) {return((opt_and_bb(o->v[2].o1)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);} - -static s7_pointer opt_if_bp_pb(opt_info *o) /* p_to_b at outer, p_to_b expanded and moved to o[3] */ -{ - return((o->v[3].fp(o->v[2].o1) != o->sc->F) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified); -} - -static s7_pointer opt_if_bp_ii_fc(opt_info *o) -{ - return((o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified); -} - -static s7_pointer opt_if_nbp_s(opt_info *o) -{ - return((o->v[2].b_p_f(slot_value(o->v[3].p))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_sc(opt_info *o) /* b_pp_sc */ -{ - return((o->v[3].b_pp_f(slot_value(o->v[2].p), o->v[4].p)) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_7sc(opt_info *o) /* b_7pp_sc */ -{ - return((o->v[3].b_7pp_f(o->sc, slot_value(o->v[2].p), o->v[4].p)) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_ss(opt_info *o) /* b_ii_ss */ -{ - return((o->v[3].b_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[4].p)))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_num_eq_ii_ss(opt_info *o) /* b_ii_ss */ -{ - return((integer(slot_value(o->v[2].p)) == integer(slot_value(o->v[4].p))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_fs(opt_info *o) /* b_pi_fs */ -{ - return((o->v[2].b_pi_f(o->sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p)))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_sf(opt_info *o) /* b_pp_sf */ -{ - return((o->v[2].b_pp_f(slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_nbp_7sf(opt_info *o) /* b_7pp_sf */ -{ - return((o->v[2].b_7pp_f(o->sc, slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1)); -} - -static s7_pointer opt_if_bpp(opt_info *o) {return((o->v[5].fb(o->v[4].o1)) ? o->v[9].fp(o->v[8].o1) : o->v[11].fp(o->v[10].o1));} -static s7_pointer opt_if_bpp_bit(opt_info *o) {return((opt_b_7ii_sc_bit(o->v[4].o1)) ? o->v[9].fp(o->v[8].o1) : o->v[11].fp(o->v[10].o1));} - -static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - opt_info *opc = alloc_opt_info(sc); - opt_info *bop = sc->opts[sc->pc]; - if (len == 3) - { - if ((is_proper_list_2(sc, cadr(car_x))) && /* (not arg) */ - (caadr(car_x) == sc->not_symbol)) - { - if (bool_optimize(sc, cdadr(car_x))) - { - opt_info *top = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[10].o1 = top; - opc->v[11].fp = top->v[0].fp; - if (bop->v[0].fb == opt_b_p_s) - { - opc->v[2].b_p_f = bop->v[2].b_p_f; - opc->v[3].p = bop->v[1].p; - opc->v[0].fp = opt_if_nbp_s; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_pi_fs) || (bop->v[0].fb == opt_b_pi_fs_num_eq)) - { - opc->v[2].b_pi_f = bop->v[2].b_pi_f; - opc->v[3].p = bop->v[1].p; - opc->v[4].o1 = bop->v[10].o1; - opc->v[5].fp = bop->v[11].fp; - opc->v[0].fp = opt_if_nbp_fs; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_pp_sf) || - (bop->v[0].fb == opt_b_7pp_sf)) - { - opc->v[4].o1 = bop->v[10].o1; - opc->v[5].fp = bop->v[11].fp; - if (bop->v[0].fb == opt_b_pp_sf) - { - opc->v[2].b_pp_f = bop->v[3].b_pp_f; - opc->v[0].fp = opt_if_nbp_sf; - } - else - { - opc->v[2].b_7pp_f = bop->v[3].b_7pp_f; - opc->v[0].fp = opt_if_nbp_7sf; - } - opc->v[3].p = bop->v[1].p; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_pp_sc) || - (bop->v[0].fb == opt_b_7pp_sc)) - { - if (bop->v[0].fb == opt_b_pp_sc) - { - opc->v[3].b_pp_f = bop->v[3].b_pp_f; - opc->v[0].fp = opt_if_nbp_sc; - } - else - { - opc->v[3].b_7pp_f = bop->v[3].b_7pp_f; - opc->v[0].fp = opt_if_nbp_7sc; - } - opc->v[2].p = bop->v[1].p; - opc->v[4].p = bop->v[2].p; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_ii_ss) || (bop->v[0].fb == opt_b_ii_ss_eq) || - (bop->v[0].fb == opt_b_ii_ss_lt) || (bop->v[0].fb == opt_b_ii_ss_gt) || - (bop->v[0].fb == opt_b_ii_ss_leq) || (bop->v[0].fb == opt_b_ii_ss_geq)) - { - opc->v[3].b_ii_f = bop->v[3].b_ii_f; - opc->v[2].p = bop->v[1].p; - opc->v[4].p = bop->v[2].p; - opc->v[0].fp = (opc->v[3].b_ii_f == num_eq_b_ii) ? opt_if_num_eq_ii_ss : opt_if_nbp_ss; - return_true(sc, car_x); - } - opc->v[4].o1 = bop; - opc->v[5].fb = bop->v[0].fb; - opc->v[0].fp = opt_if_nbp; - return_true(sc, car_x); - }}} - else - if (bool_optimize(sc, cdr(car_x))) - { - opt_info *top = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[2].o1 = bop; - opc->v[4].o1 = top; - opc->v[5].fp = top->v[0].fp; - if (bop->v[0].fb == p_to_b) - { - opc->v[0].fp = opt_if_bp_pb; - opc->v[3].fp = bop->v[O_WRAP].fp; - return_true(sc, car_x); - } - if (bop->v[0].fb == opt_b_ii_fc) - { - opc->v[2].i = bop->v[2].i; - opc->v[3].b_ii_f = bop->v[3].b_ii_f; - opc->v[11].fi = bop->v[11].fi; - opc->v[10].o1 = bop->v[10].o1; - opc->v[0].fp = opt_if_bp_ii_fc; - return_true(sc, car_x); - } - opc->v[0].fp = (bop->v[0].fb == opt_b_7p_f) ? opt_if_b7p : ((bop->v[0].fb == opt_and_bb) ? opt_if_bp_and : opt_if_bp); - opc->v[3].fb = bop->v[0].fb; - return_true(sc, car_x); - }} - return_false(sc, car_x); - } - if (len == 4) - { - if (bool_optimize(sc, cdr(car_x))) - { - opt_info *top = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opt_info *o3 = sc->opts[sc->pc]; - opc->v[0].fp = (bop->v[0].fb == opt_b_7ii_sc_bit) ? opt_if_bpp_bit : opt_if_bpp; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].o1 = bop; - opc->v[5].fb = bop->v[0].fb; - opc->v[8].o1 = top; - opc->v[9].fp = top->v[0].fp; - opc->v[10].o1 = o3; - opc->v[11].fp = o3->v[0].fp; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); -} - -/* -------- cell_case -------- */ -#define CASE_O1 3 -#define CASE_SEL 2 -#define CASE_CLAUSE_O1 4 -#define CASE_CLAUSE_KEYS 2 - -static s7_pointer case_value(opt_info *o) -{ - opt_info *o1; - int32_t i, len = o->v[1].i - 1; /* int32_t here and below seems to be faster than s7_int (tleft.scm) */ - for (i = 0; i < len; i++) - { - o1 = o->v[i + CASE_CLAUSE_O1].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + CASE_CLAUSE_O1].o1; - return(o1->v[0].fp(o1)); -} - -static s7_pointer opt_case(opt_info *o) -{ - opt_info *o1 = o->v[CASE_SEL].o1; - int32_t lim = o->v[1].i; - s7_scheme *sc = o->sc; - s7_pointer selector = o1->v[0].fp(o1); - - if (is_simple(selector)) - { - for (int32_t ctr = CASE_O1; ctr < lim; ctr++) - { - s7_pointer z; - o1 = o->v[ctr].o1; - for (z = o1->v[CASE_CLAUSE_KEYS].p; is_pair(z); z = cdr(z)) - if (selector == car(z)) - return(case_value(o1)); - if (z == sc->else_symbol) - return(case_value(o1)); - }} - else - for (int32_t ctr = CASE_O1; ctr < lim; ctr++) - { - s7_pointer z; - o1 = o->v[ctr].o1; - for (z = o1->v[CASE_CLAUSE_KEYS].p; is_pair(z); z = cdr(z)) - if (s7_is_eqv(sc, selector, car(z))) - return(case_value(o1)); - if (z == sc->else_symbol) - return(case_value(o1)); - } - return(sc->unspecified); -} - -static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x) -{ - /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */ - s7_pointer p; - int32_t ctr; - opt_info *top = alloc_opt_info(sc); - top->v[CASE_SEL].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cdr(car_x))) /* selector */ - return_false(sc, car_x); - for (ctr = CASE_O1, p = cddr(car_x); (is_pair(p)) && (ctr < NUM_VUNIONS); ctr++, p = cdr(p)) - { - opt_info *opc; - s7_pointer clause = car(p), cp; - int32_t blen; - if ((!is_pair(clause)) || - ((!is_pair(car(clause))) && (car(clause) != sc->else_symbol)) || - (!is_pair(cdr(clause))) || - (cadr(clause) == sc->feed_to_symbol)) - return_false(sc, clause); - - opc = alloc_opt_info(sc); - top->v[ctr].o1 = opc; - if (car(clause) == sc->else_symbol) - { - if (!is_null(cdr(p))) - return_false(sc, clause); - opc->v[CASE_CLAUSE_KEYS].p = sc->else_symbol; - } - else - { - if (!s7_is_proper_list(sc, car(clause))) - return_false(sc, clause); - opc->v[CASE_CLAUSE_KEYS].p = car(clause); - } - - for (blen = 0, cp = cdr(clause); (is_pair(cp)) && (blen < (NUM_VUNIONS - CASE_CLAUSE_O1)); blen++, cp = cdr(cp)) - { - opc->v[blen + CASE_CLAUSE_O1].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cp)) - return_false(sc, cp); - } - if (!is_null(cp)) - return_false(sc, cp); - opc->v[1].i = blen; - opc->v[0].fp = opt_case; /* just a placeholder I hope */ - } - if (!is_null(p)) - return_false(sc, p); - top->v[1].i = ctr; - top->v[0].fp = opt_case; - return_true(sc, car_x); -} - -/* -------- cell_let_temporarily -------- */ - -#define LET_TEMP_O1 5 - -static s7_pointer opt_let_temporarily(opt_info *o) -{ - opt_info *o1 = o->v[4].o1; - s7_int i, len; - s7_pointer result; - s7_scheme *sc = o->sc; - - if (is_immutable_slot(o->v[1].p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, slot_symbol(o->v[1].p))); - - o->v[3].p = slot_value(o->v[1].p); /* save and protect old value */ - gc_protect_via_stack(sc, o->v[3].p); - slot_set_value(o->v[1].p, o1->v[0].fp(o1)); /* set new value */ - len = o->v[2].i - 1; - for (i = 0; i < len; i++) - { - o1 = o->v[i + LET_TEMP_O1].o1; - o1->v[0].fp(o1); - } - o1 = o->v[i + LET_TEMP_O1].o1; - result = o1->v[0].fp(o1); - slot_set_value(o->v[1].p, o->v[3].p); /* restore old */ - unstack(sc); - return(result); -} - -static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - s7_pointer vars; - if (len <= 2) - return_false(sc, car_x); - - vars = cadr(car_x); - if ((len < (NUM_VUNIONS - LET_TEMP_O1)) && - (is_proper_list_1(sc, vars)) && /* just one var for now */ - (is_proper_list_2(sc, car(vars))) && /* and var is (sym val) */ - (is_symbol(caar(vars))) && - (!is_immutable(caar(vars))) && - (!is_syntactic_symbol(caar(vars)))) - { - int32_t i; - s7_pointer p; - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = lookup_slot_from(caaadr(car_x), sc->curlet); - if (!is_slot(opc->v[1].p)) - return_false(sc, car_x); - - opc->v[4].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cdaadr(car_x))) - return_false(sc, car_x); - - for (i = LET_TEMP_O1, p = cddr(car_x); is_pair(p); i++, p = cdr(p)) - { - opc->v[i].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - return_false(sc, car_x); - } - opc->v[2].i = len - 2; - opc->v[0].fp = opt_let_temporarily; - return_true(sc, car_x); - } - return_false(sc, car_x); -} - -/* -------- cell_do -------- */ - -#define do_curlet(o) o->v[2].p -#define do_body_length(o) o->v[3].i -#define do_result_length(o) o->v[4].i -#define do_any_inits(o) o->v[7].o1 -#define do_any_body(o) o->v[10].o1 -#define do_any_results(o) o->v[11].o1 -#define do_any_test(o) o->v[12].o1 -#define do_any_steps(o) o->v[13].o1 - -static void let_set_has_pending_value(s7_pointer lt) -{ - for (s7_pointer vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp)) - slot_set_pending_value(vp, eof_object); /* gc needs a legit value here */ -} - -static void let_clear_has_pending_value(s7_pointer lt) -{ - for (s7_pointer vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp)) - slot_clear_has_pending_value(vp); -} - -typedef s7_pointer (*opt_info_fp)(opt_info *o); - -static s7_pointer opt_do_any(opt_info *o) -{ - opt_info *o1; - opt_info *ostart = do_any_test(o); - opt_info *body = do_any_body(o); - opt_info *inits = do_any_inits(o); - opt_info *steps = do_any_steps(o); - opt_info *results = do_any_results(o); - int32_t i, k, len = do_body_length(o); /* len=6 tlist, 6|7 tbig, 0 tvect */ - s7_pointer vp, result; - s7_scheme *sc = o->sc; - opt_info *os[NUM_VUNIONS]; - opt_info_fp fp[NUM_VUNIONS]; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - sc->curlet = T_Let(do_curlet(o)); - /* init */ - for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp)) - { - o1 = inits->v[k].o1; - slot_set_value(vp, o1->v[0].fp(o1)); - } - let_set_has_pending_value(sc->curlet); - for (i = 0; i < len; i++) - { - os[i] = body->v[i].o1; - fp[i] = os[i]->v[0].fp; - } - while (true) - { - /* end */ - if (ostart->v[0].fb(ostart)) - break; - /* body */ - if (len == 6) /* here and in opt_do_n we need a better way to unroll these loops */ - {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]);} - else - if (len == 7) - {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]);} - else for (i = 0; i < len; i++) fp[i](os[i]); - /* step (let not let*) */ - for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp)) - if (has_stepper(vp)) - { - o1 = steps->v[k].o1; - slot_simply_set_pending_value(vp, o1->v[0].fp(o1)); - } - for (vp = let_slots(sc->curlet); tis_slot(vp); vp = next_slot(vp)) - if (has_stepper(vp)) - slot_set_value(vp, slot_pending_value(vp)); - } - /* result */ - result = sc->T; - for (i = 0; i < do_result_length(o); i++) - { - o1 = results->v[i].o1; - result = o1->v[0].fp(o1); - } - let_clear_has_pending_value(sc->curlet); - unstack(sc); - set_curlet(sc, old_e); - return(result); -} - -static s7_pointer opt_do_step_1(opt_info *o) -{ - /* 1 stepper (multi inits perhaps), 1 body, 1 rtn */ - opt_info *o1; - opt_info *ostart = do_any_test(o); - opt_info *ostep = o->v[9].o1; - opt_info *inits = do_any_inits(o); - opt_info *body = do_any_body(o); - int32_t k; - s7_pointer vp, result, stepper = NULL; - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - sc->curlet = T_Let(do_curlet(o)); - for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp)) - { - o1 = inits->v[k].o1; - slot_set_value(vp, o1->v[0].fp(o1)); - if (has_stepper(vp)) stepper = vp; - } - while (!(ostart->v[0].fb(ostart))) - { - body->v[0].fp(body); - slot_set_value(stepper, ostep->v[0].fp(ostep)); - } - o1 = do_any_results(o); - result = o1->v[0].fp(o1); - unstack(sc); - set_curlet(sc, old_e); - return(result); -} - -static s7_pointer opt_do_step_i(opt_info *o) -{ - /* 1 stepper (multi inits perhaps), 1 body, 1 rtn */ - opt_info *o1; - opt_info *ostart = do_any_test(o); - opt_info *ostep = o->v[9].o1; - opt_info *inits = do_any_inits(o); - opt_info *body = do_any_body(o); - int32_t k; - s7_pointer vp, result, stepper = NULL, si; - s7_scheme *sc = o->sc; - s7_int end, incr; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - sc->curlet = T_Let(do_curlet(o)); - for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp)) - { - o1 = inits->v[k].o1; - slot_set_value(vp, o1->v[0].fp(o1)); - if (has_stepper(vp)) stepper = vp; - } - end = integer(slot_value(ostart->v[2].p)); - incr = ostep->v[2].i; - si = make_mutable_integer(sc, integer(slot_value(ostart->v[1].p))); - if (stepper) slot_set_value(stepper, si); - while (integer(si) != end) - { - body->v[0].fp(body); - integer(si) += incr; - } - clear_mutable_integer(si); - o1 = do_any_results(o); - result = o1->v[0].fp(o1); - unstack(sc); - set_curlet(sc, old_e); - return(result); -} - -#define do_no_vars_test(o) o->v[6].o1 -#define do_no_vars_body(o) o->v[7].o1 - -static s7_pointer opt_do_no_vars(opt_info *o) -{ - /* no vars, no return, o->v[2].p=let, o->v[3].i=body length, o->v[4].i=return length=0, o->v[6]=end test */ - opt_info *ostart = do_no_vars_test(o); - int32_t len = do_body_length(o); - s7_scheme *sc = o->sc; - bool (*fb)(opt_info *o) = ostart->v[0].fb; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - if (len == 0) /* titer */ - while (!(fb(ostart))); - else - { - opt_info *body = do_no_vars_body(o); - while (!(fb(ostart))) /* tshoot, tfft */ - for (int32_t i = 0; i < len; i++) - { - opt_info *o1 = body->v[i].o1; - o1->v[0].fp(o1); - }} - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -#define do_stepper_init(o) o->v[11].o1 - -static s7_pointer opt_do_1(opt_info *o) -{ - /* 1 var, 1 expr, no return */ - opt_info *o1 = do_stepper_init(o); - opt_info *ostart = do_any_test(o); - opt_info *ostep = o->v[9].o1; - opt_info *body = do_any_body(o); - s7_pointer vp = let_slots(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - slot_set_value(vp, o1->v[0].fp(o1)); - if ((o->v[8].i == 1) && - (is_t_integer(slot_value(vp)))) - { - if ((ostep->v[0].fp == opt_p_ii_ss_add) || /* tmap */ - (ostep->v[0].fp == i_to_p)) - { - s7_pointer step_val = make_mutable_integer(sc, integer(slot_value(vp))); - slot_set_value(vp, step_val); - if (ostep->v[0].fp == opt_p_ii_ss_add) - while (!ostart->v[0].fb(ostart)) - { - body->v[0].fp(body); - integer(step_val) = opt_i_ii_ss_add(ostep); - } - else - while (!ostart->v[0].fb(ostart)) - { - body->v[0].fp(body); - integer(step_val) = ostep->v[O_WRAP].fi(ostep); - } - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); - } - o->v[8].i = 2; - } - while (!(ostart->v[0].fb(ostart))) /* s7test tref */ - { - body->v[0].fp(body); - slot_set_value(vp, ostep->v[0].fp(ostep)); - } - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -#define do_n_body(o) o->v[7].o1 - -static s7_pointer opt_do_n(opt_info *o) -{ - /* 1 var, no return */ - opt_info *o1 = do_stepper_init(o); - opt_info *ostart = do_any_test(o); - opt_info *ostep = o->v[9].o1; - opt_info *body = do_n_body(o); - int32_t len = do_body_length(o); - s7_pointer vp = let_slots(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - slot_set_value(vp, o1->v[0].fp(o1)); - if (len == 2) /* tmac tshoot */ - { - opt_info *e1 = body->v[0].o1, *e2 = body->v[1].o1; - while (!(ostart->v[0].fb(ostart))) - { - e1->v[0].fp(e1); - e2->v[0].fp(e2); - slot_set_value(vp, ostep->v[0].fp(ostep)); - }} - else - { - opt_info *os[NUM_VUNIONS]; - opt_info_fp fp[NUM_VUNIONS]; - for (int32_t i = 0; i < len; i++) - { - os[i] = body->v[i].o1; - fp[i] = os[i]->v[0].fp; - } - if (len == 7) - while (!ostart->v[0].fb(ostart)) /* tfft teq */ - { - fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]); - slot_set_value(vp, ostep->v[0].fp(ostep)); - } - else - while (!ostart->v[0].fb(ostart)) /* tfft teq */ - { - for (int32_t i = 0; i < len; i++) fp[i](os[i]); - slot_set_value(vp, ostep->v[0].fp(ostep)); - }} - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -static s7_pointer opt_do_times(opt_info *o) -{ - /* 1 var, no return */ - opt_info *o1 = do_stepper_init(o); - opt_info *body = do_n_body(o); - int32_t len = do_body_length(o); - s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : o->v[6].i; - s7_pointer vp = let_dox1_value(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - integer(vp) = integer(o1->v[0].fp(o1)); - if (len == 2) /* tmac tmisc */ - { - opt_info *e1 = body->v[0].o1, *e2 = body->v[1].o1; - while (integer(vp) < end) - { - e1->v[0].fp(e1); - e2->v[0].fp(e2); - integer(vp)++; - }} - else - while (integer(vp) < end) /* tbig sg */ - { - for (int32_t i = 0; i < len; i++) - { - o1 = body->v[i].o1; - o1->v[0].fp(o1); - } - integer(vp)++; - } - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -static s7_pointer opt_do_list_simple(opt_info *o) -{ - opt_info *o1 = do_stepper_init(o); - s7_pointer vp = let_slots(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer (*fp)(opt_info *o); - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - slot_set_value(vp, o1->v[0].fp(o1)); - o1 = do_any_body(o); - fp = o1->v[0].fp; - if (fp == opt_if_bp) - while (is_pair(slot_value(vp))) - { - if (o1->v[3].fb(o1->v[2].o1)) - o1->v[5].fp(o1->v[4].o1); - slot_set_value(vp, cdr(slot_value(vp))); - } - else - while (!is_null(slot_value(vp))) - { - fp(o1); - slot_set_value(vp, cdr(slot_value(vp))); - } - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -static s7_pointer opt_do_very_simple(opt_info *o) -{ - /* like simple but step can be direct, v[2].p is a let, v[3].i=end? */ - opt_info *o1 = do_stepper_init(o); - s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : o->v[3].i; - s7_pointer vp = let_dox1_value(do_curlet(o)); - s7_pointer (*f)(opt_info *o); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - integer(vp) = integer(o1->v[0].fp(o1)); - o1 = do_any_body(o); - f = o1->v[0].fp; - if (f == opt_p_pip_ssf) /* tref.scm */ - { - opt_info *o2 = o1; - o1 = o2->v[4].o1; - if (o2->v[3].p_pip_f == normal_vector_set_p_pip_direct) - { - s7_pointer v = slot_value(o2->v[1].p); - while (integer(vp) < end) - { - normal_vector_set_p_pip_direct(o2->sc, v, integer(slot_value(o2->v[2].p)), o1->v[0].fp(o1)); - integer(vp)++; - }} - else - while (integer(vp) < end) - { - o2->v[3].p_pip_f(o2->sc, slot_value(o2->v[1].p), integer(slot_value(o2->v[2].p)), o1->v[0].fp(o1)); - integer(vp)++; - }} - else - { - if (f == opt_p_pip_sso) - { /* vector-set from vector-ref (i.e. copy), but treating vector-* as generic */ - if (((let_dox_slot1(do_curlet(o)) == o1->v[2].p) && (o1->v[2].p == o1->v[4].p)) && - (((o1->v[5].p_pip_f == float_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == float_vector_ref_p_pi_direct)) || - ((o1->v[5].p_pip_f == int_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == int_vector_ref_p_pi_direct)) || - ((o1->v[5].p_pip_f == string_set_p_pip_direct) && (o1->v[6].p_pi_f == string_ref_p_pi_direct)) || - ((o1->v[5].p_pip_f == byte_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == byte_vector_ref_p_pi_direct)))) - { - copy_to_same_type(sc, slot_value(o1->v[1].p), slot_value(o1->v[3].p), integer(vp), end, integer(vp)); - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); - } - while (integer(vp) < end) - { - o1->v[5].p_pip_f(o1->sc, slot_value(o1->v[1].p), integer(slot_value(o1->v[2].p)), - o1->v[6].p_pi_f(o1->sc, slot_value(o1->v[3].p), integer(slot_value(o1->v[4].p)))); - integer(vp)++; - }} - else - if ((f == opt_set_p_i_f) && /* tvect.scm */ - (is_t_integer(slot_value(o1->v[1].p))) && - (o1->v[1].p != let_dox_slot1(do_curlet(o)))) - { - opt_info *o2 = o1->v[5].o1; /* set_p_i_f: x = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); */ - s7_int (*fi)(opt_info *o) = o2->v[0].fi; - s7_pointer ival = make_mutable_integer(sc, integer(slot_value(o1->v[1].p))); - slot_set_value(o1->v[1].p, ival); - while (integer(vp) < end) - { - integer(ival) = fi(o2); - integer(vp)++; - } - slot_set_value(o1->v[1].p, make_integer(sc, integer(slot_value(o1->v[1].p)))); - } - else - if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */ - (o1->v[4].d_7pid_f == float_vector_set_d_7pid_direct)) - { - s7_pointer ind = o1->v[2].p; - opt_info *o2 = do_any_body(o1); - s7_double (*fd)(opt_info *o) = o2->v[0].fd; - s7_pointer fv = slot_value(o1->v[1].p); - while (integer(vp) < end) - { - float_vector_set_d_7pid_direct(sc, fv, integer(slot_value(ind)), fd(o2)); - /* weird! els[integer(slot_value(ind))] = fd(o2) is much slower according to callgrind? */ - integer(vp)++; - }} - else - while (integer(vp) < end) {f(o1); integer(vp)++;}} - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -#define do_prepack_end(o) o->v[1].i -#define do_prepack_stepper(o) o->v[6].p - -static s7_pointer opt_do_prepackaged(opt_info *o) -{ - opt_info *o1 = do_stepper_init(o); - s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : o->v[3].i; - s7_pointer vp = let_dox1_value(do_curlet(o)); - s7_scheme *sc = o->sc; - s7_pointer old_e = sc->curlet; - s7_gc_protect_via_stack(sc, old_e); - set_curlet(sc, do_curlet(o)); - integer(vp) = integer(o1->v[0].fp(o1)); - - do_prepack_stepper(o) = vp; - do_prepack_end(o) = end; - o->v[7].fp(o); /* call opt_do_i|dpnr below */ - - unstack(sc); - set_curlet(sc, old_e); - return(sc->T); -} - -static s7_pointer opt_do_dpnr(opt_info *o) -{ - opt_info *o1 = do_any_body(o); - s7_pointer vp = do_prepack_stepper(o); - s7_int end = do_prepack_end(o); - s7_double (*f)(opt_info *o) = o1->v[O_WRAP].fd; - while (integer(vp) < end) {f(o1); integer(vp)++;} - return(NULL); -} - -static s7_pointer opt_do_ipnr(opt_info *o) -{ - opt_info *o1 = do_any_body(o); - s7_pointer vp = do_prepack_stepper(o); - s7_int end = do_prepack_end(o); - s7_int (*f)(opt_info *o) = o1->v[O_WRAP].fi; - while (integer(vp) < end) {f(o1); integer(vp)++;} - return(NULL); -} - -static bool stop_is_safe(s7_scheme *sc, s7_pointer stop, s7_pointer body) -{ - /* this could be folded into the cell_optimize traveral */ - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (caar(p) == sc->set_symbol) && - (is_pair(cdar(p))) && - (cadar(p) == stop)) - return(!s7_tree_memq(sc, stop, cdr(p))); - return(true); -} - -static bool tree_has_setters(s7_scheme *sc, s7_pointer tree) -{ - clear_symbol_list(sc); - add_symbol_to_list(sc, sc->set_symbol); - add_symbol_to_list(sc, sc->vector_set_symbol); - add_symbol_to_list(sc, sc->list_set_symbol); - add_symbol_to_list(sc, sc->let_set_symbol); - add_symbol_to_list(sc, sc->hash_table_set_symbol); - add_symbol_to_list(sc, sc->set_car_symbol); - add_symbol_to_list(sc, sc->set_cdr_symbol); - return(tree_set_memq(sc, tree)); -} - -static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, bool *has_set); - -static bool do_passes_safety_check(s7_scheme *sc, s7_pointer body, s7_pointer stepper, bool *has_set) -{ - if (!is_pair(body)) return(true); - if (!is_safety_checked(body)) - { - set_safety_checked(body); - if (!(do_is_safe(sc, body, stepper, sc->nil, has_set))) - set_unsafe_do(body); - } - return(!is_unsafe_do(body)); -} - -#define SIZE_O NUM_VUNIONS - -static bool all_integers(s7_scheme *sc, s7_pointer expr) -{ - if ((is_symbol(car(expr))) && (is_all_integer(car(expr)))) - { - s7_pointer p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!((is_t_integer(car(p))) || - ((is_symbol(car(p))) && (is_t_integer(slot_value(lookup_slot_from(car(p), sc->curlet))))) || - ((is_pair(car(p))) && (all_integers(sc, car(p)))))) - break; - return(is_null(p)); - } - return(false); -} - -static bool all_floats(s7_scheme *sc, s7_pointer expr) -{ - if ((is_symbol(car(expr))) && (is_all_float(car(expr)))) - { - s7_pointer p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!((is_t_real(car(p))) || - ((is_symbol(car(p))) && (is_t_real(slot_value(lookup_slot_from(car(p), sc->curlet))))) || - ((is_pair(car(p))) && (all_floats(sc, car(p)))))) - break; - return(is_null(p)); - } - return(false); -} - -static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - opt_info *opc; - s7_pointer p, end, let = NULL, old_e = sc->curlet, stop, ind, ind_step; - int32_t i, k, var_len, body_len = len - 3, body_index, step_len, rtn_len, step_pc, init_pc, end_test_pc; - bool has_set = false; - opt_info *init_o[SIZE_O], *step_o[SIZE_O], *body_o[SIZE_O], *return_o[SIZE_O]; - - if (len < 3) - return_false(sc, car_x); - - if (!s7_is_proper_list(sc, cadr(car_x))) - return_false(sc, car_x); - var_len = proper_list_length(cadr(car_x)); - step_len = var_len; - if (body_len > SIZE_O) - return_false(sc, car_x); - end = caddr(car_x); - if (!is_pair(end)) - return_false(sc, car_x); - - opc = alloc_opt_info(sc); - let = inline_make_let(sc, sc->curlet); - push_stack(sc, OP_GC_PROTECT, old_e, let); - - /* the vars have to be added to the let before evaluating the inits - * else symbol_id can be > let_id (see "(test (do ((i (do ((i (do ((i 0 (+ i 1)))...") - */ - clear_symbol_list(sc); - for (p = cadr(car_x); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((is_pair(var)) && - (is_symbol(car(var))) && - (is_pair(cdr(var)))) - { - s7_pointer sym = car(var); - if (is_constant_symbol(sc, sym)) - return_false(sc, car_x); - if (symbol_is_in_list(sc, sym)) - syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, var); - add_symbol_to_list(sc, sym); - add_slot(sc, let, sym, sc->undefined); - } - else return_false(sc, car_x); - } - if (tis_slot(let_slots(let))) - let_set_slots(let, reverse_slots(sc, let_slots(let))); - - /* inits */ - { - s7_pointer slot; - init_pc = sc->pc; - for (k = 0, p = cadr(car_x), slot = let_slots(let); (is_pair(p)) && (k < SIZE_O); k++, p = cdr(p), slot = next_slot(slot)) - { - s7_pointer var = car(p); - init_o[k] = sc->opts[sc->pc]; - if (!cell_optimize(sc, cdr(var))) /* opt init in outer let */ - return_false(sc, car_x); - if (is_pair(cddr(var))) - { - set_has_stepper(slot); - if (!is_null(cdddr(var))) - return_false(sc, car_x); - } - else - { - step_len--; - if (!is_null(cddr(var))) - return_false(sc, car_x); - } - /* we can't use slot_set_value(slot, init_o[k]->v[0].fp(init_o[k])) to get the init value here: it might involve side-effects, - * and in some contexts might access variables that aren't set up yet. So, we kludge around... - */ - if (is_symbol(cadr(var))) - slot_set_value(slot, slot_value(lookup_slot_from(cadr(var), sc->curlet))); - else - if (!is_pair(cadr(var))) - slot_set_value(slot, cadr(var)); - else - if (is_proper_quote(sc, cadr(var))) - slot_set_value(slot, cadadr(var)); - else - { - s7_pointer sf = lookup_checked(sc, caadr(var)); - if (is_c_function(sf)) - { - s7_pointer sig = c_function_signature(sf); - if (is_pair(sig)) - { - if ((car(sig) == sc->is_integer_symbol) || - ((is_pair(car(sig))) && - (direct_memq(sc->is_integer_symbol, car(sig)))) || - (all_integers(sc, cadr(var)))) - slot_set_value(slot, int_zero); - else - if ((car(sig) == sc->is_float_symbol) || - ((is_pair(car(sig))) && - (direct_memq(sc->is_float_symbol, car(sig)))) || - (all_floats(sc, cadr(var)))) - slot_set_value(slot, real_zero); - /* need for stepper too -- how does it know (+ x 0.1) is float? try (i 0 (floor (+ i 1))) etc */ - }}}} - set_curlet(sc, let); - for (p = cadr(car_x); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if (is_pair(cddr(var))) - { - s7_pointer init_type = opt_arg_type(sc, cdr(var)); - if (((init_type == sc->is_integer_symbol) || - (init_type == sc->is_float_symbol)) && - (opt_arg_type(sc, cddr(var)) != init_type)) - { - unstack(sc); /* not pop_stack! */ - set_curlet(sc, old_e); - return_false(sc, car_x); - }}}} - - /* end test */ - end_test_pc = sc->pc; - if (!bool_optimize_nw(sc, end)) - { - unstack(sc); /* not pop_stack! */ - set_curlet(sc, old_e); - return_false(sc, car_x); - } - - stop = car(end); - if ((is_proper_list_3(sc, stop)) && - ((car(stop) == sc->num_eq_symbol) || (car(stop) == sc->geq_symbol) || (car(stop) == sc->gt_symbol)) && - (is_symbol(cadr(stop))) && - ((is_t_integer(caddr(stop))) || (is_symbol(caddr(stop))))) - { - s7_pointer stop_slot = (is_symbol(caddr(stop))) ? opt_integer_symbol(sc, caddr(stop)) : sc->nil; - if (stop_slot) - { - s7_int lim = (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : integer(caddr(stop)); - bool set_stop = false; - s7_pointer slot; - - if (car(stop) == sc->gt_symbol) lim++; - for (p = cadr(car_x), slot = let_slots(let); is_pair(p); p = cdr(p), slot = next_slot(slot)) - { - /* this could be put off until it is needed (ref/set), but this code is not called much - * another choice: go from init downto 0: init is lim - */ - if (slot_symbol(slot) == cadr(stop)) - set_stop = true; /* don't overrule this decision below */ - if (has_stepper(slot)) - { - s7_pointer var = car(p), step = caddr(var); - if ((is_t_integer(slot_value(slot))) && - (is_pair(step)) && - (is_pair(cdr(step))) && - (car(var) == cadr(stop)) && - (car(var) == cadr(step)) && - ((car(stop) != sc->num_eq_symbol) || /* else > protects at least the top */ - ((caddr(step) == int_one) && (car(step) == sc->add_symbol)))) - { - set_step_end(slot); - slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); - set_do_loop_end(slot_value(slot), lim); - }}} - - if (!set_stop) - { - s7_pointer slot2 = opt_integer_symbol(sc, cadr(stop)); - if ((slot2) && - (stop_is_safe(sc, cadr(stop), cddr(car_x)))) - { - set_step_end(slot2); - set_do_loop_end(slot_value(slot2), lim); - }}}} - - /* body */ - body_index = sc->pc; - for (k = 0, i = 3, p = cdddr(car_x); i < len; k++, i++, p = cdr(p)) - { - opt_info *start = sc->opts[sc->pc]; - body_o[k] = start; - if (i < 5) opc->v[i + 7].o1 = start; - if (!cell_optimize(sc, p)) - break; - oo_idp_nr_fixup(start); - } - if (!is_null(p)) - { - unstack(sc); - set_curlet(sc, old_e); - return_false(sc, car_x); - } - - /* we faked up sc->curlet above, so s7_optimize_1 (float_optimize) isn't safe here - * this means if clm nested loops get here, they aren't fully optimized -- fallback into dox would be better - */ - /* steps */ - step_pc = sc->pc; - for (k = 0, p = cadr(car_x); is_pair(p); k++, p = cdr(p)) - { - s7_pointer var = car(p); - step_o[k] = sc->opts[sc->pc]; - if ((is_pair(cddr(var))) && - (!cell_optimize(sc, cddr(var)))) - break; - } - if (!is_null(p)) - { - unstack(sc); - set_curlet(sc, old_e); - return_false(sc, car_x); - } - - /* result */ - if (!is_list(cdr(end))) - { - unstack(sc); - set_curlet(sc, old_e); - return_false(sc, car_x); - } - for (rtn_len = 0, p = cdr(end); (is_pair(p)) && (rtn_len < SIZE_O); p = cdr(p), rtn_len++) - { - return_o[rtn_len] = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (!is_null(p)) - { - unstack(sc); - set_curlet(sc, old_e); - return_false(sc, car_x); - } - - do_curlet(opc) = let; - do_body_length(opc) = len - 3; - do_result_length(opc) = rtn_len; - opc->v[9].o1 = sc->opts[step_pc]; - set_curlet(sc, old_e); - - if ((var_len == 0) && (rtn_len == 0)) - { - opt_info *body; - do_no_vars_test(opc) = sc->opts[end_test_pc]; - opc->v[0].fp = opt_do_no_vars; - if (body_len > 0) - { - body = alloc_opt_info(sc); - for (k = 0; k < body_len; k++) - body->v[k].o1 = body_o[k]; - do_no_vars_body(opc) = body; - } - return(true); - } - opc->v[8].i = 0; - if (body_len == 1) - { - s7_pointer expr = cadddr(car_x); - if ((is_pair(expr)) && - ((is_c_function(car(expr))) || - (is_safe_setter(car(expr))) || - ((car(expr) == sc->set_symbol) && - (cadr(expr) != caaadr(car_x))) || /* caadr: (stepper init ...) */ - ((car(expr) == sc->vector_set_symbol) && - (is_null(cddddr(expr))) && - (is_code_constant(sc, cadddr(expr)))))) - opc->v[8].i = 1; - } - if ((var_len != 1) || (step_len != 1) || (rtn_len != 0)) - { - opt_info *inits; - - opc->v[0].fp = ((step_len == 1) && (body_len == 1) && (rtn_len == 1)) ? opt_do_step_1 : opt_do_any; - /* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) tmat */ - - do_any_test(opc) = sc->opts[end_test_pc]; - - if ((opc->v[0].fp == opt_do_step_1) && - (opc->v[9].o1->v[0].fp == i_to_p) && - (opc->v[9].o1->v[O_WRAP].fi == opt_i_ii_sc_add) && - (do_any_test(opc)->v[0].fb == opt_b_ii_ss_eq)) - opc->v[0].fp = opt_do_step_i; - - inits = alloc_opt_info(sc); - for (k = 0; k < var_len; k++) - inits->v[k].o1 = init_o[k]; - do_any_inits(opc) = inits; - - if (opc->v[0].fp == opt_do_any) - { - opt_info *result, *step; - opt_info *body = alloc_opt_info(sc); - - for (k = 0; k < body_len; k++) - body->v[k].o1 = body_o[k]; - do_any_body(opc) = body; - - result = alloc_opt_info(sc); - for (k = 0; k < rtn_len; k++) - result->v[k].o1 = return_o[k]; - do_any_results(opc) = result; - - step = alloc_opt_info(sc); - for (k = 0; k < var_len; k++) - step->v[k].o1 = step_o[k]; - do_any_steps(opc) = step; - } - else - { - do_any_body(opc) = sc->opts[body_index]; - do_any_results(opc) = return_o[0]; - } - return(true); - } - - opc->v[0].fp = (body_len == 1) ? opt_do_1 : opt_do_n; - p = caadr(car_x); - ind = car(p); - ind_step = caddr(p); - end = caaddr(car_x); - - if (body_len == 1) /* opt_do_1 */ - do_any_body(opc) = sc->opts[body_index]; - else - { - opt_info *body = alloc_opt_info(sc); - for (k = 0; k < body_len; k++) - body->v[k].o1 = body_o[k]; - do_n_body(opc) = body; - } - do_stepper_init(opc) = sc->opts[init_pc]; - do_any_test(opc) = sc->opts[end_test_pc]; - do_any_steps(opc) = sc->opts[step_pc]; - - if ((is_pair(end)) && /* (= i len|100) */ - (cadr(end) == ind) && - (is_pair(ind_step))) /* (+ i 1) */ - { - /* we can't use step_end_ok here yet (not set except for op_dox?) */ - - if (((car(end) == sc->num_eq_symbol) || (car(end) == sc->geq_symbol)) && - ((is_symbol(caddr(end))) || (is_t_integer(caddr(end)))) && - (is_null(cdddr(end))) && - (car(ind_step) == sc->add_symbol) && - (cadr(ind_step) == ind) && - (caddr(ind_step) == int_one) && - (is_null(cdddr(ind_step))) && - (do_passes_safety_check(sc, cdddr(car_x), ind, &has_set))) - { - s7_pointer slot = let_slots(let); - let_set_dox_slot1(let, slot); - let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? lookup_slot_from(caddr(end), sc->curlet) : sc->undefined); - slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); - opc->v[4].i = body_index; - if (body_len == 1) /* opt_do_1 */ - { - opt_info *o1 = sc->opts[body_index]; - opc->v[0].fp = opt_do_very_simple; - if (is_t_integer(caddr(end))) - opc->v[3].i = integer(caddr(end)); - if (o1->v[0].fp == d_to_p_nr) /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */ - { - opc->v[0].fp = opt_do_prepackaged; - opc->v[7].fp = opt_do_dpnr; - } - else - if (o1->v[0].fp == i_to_p_nr) - { - opc->v[0].fp = opt_do_prepackaged; - opc->v[7].fp = opt_do_ipnr; - }} - else - { - opc->v[0].fp = opt_do_times; - if (is_t_integer(caddr(end))) - opc->v[6].i = integer(caddr(end)); - }} - else - if ((car(end) == sc->is_null_symbol) && - (is_null(cddr(end))) && - (car(ind_step) == sc->cdr_symbol) && - (cadr(ind_step) == ind) && - (is_null(cddr(ind_step))) && - (body_len == 1) && - (do_passes_safety_check(sc, cdddr(car_x), ind, &has_set))) - opc->v[0].fp = opt_do_list_simple; - } - return(true); -} - -static bool p_syntax(s7_scheme *sc, s7_pointer car_x, int32_t len) -{ - s7_pointer func = lookup_global(sc, car(car_x)); - opcode_t op; - if (!is_syntax(func)) {clear_syntactic(car_x); return(false);} - /* I think this is the only case where we don't precede syntax_opcode with syntactic_symbol checks */ - op = syntax_opcode(func); - switch (op) - { - case OP_QUOTE: if ((is_pair(cdr(car_x))) && (is_null(cddr(car_x)))) return(opt_cell_quote(sc, car_x)); break; - case OP_SET: if (len == 3) return(opt_cell_set(sc, car_x)); break; - case OP_BEGIN: if (len > 1) return(opt_cell_begin(sc, car_x, len)); break; - case OP_WHEN: - case OP_UNLESS: if (len > 2) return(opt_cell_when(sc, car_x, len)); break; - case OP_COND: if (len > 1) return(opt_cell_cond(sc, car_x)); break; - case OP_CASE: if (len > 2) return(opt_cell_case(sc, car_x)); break; - case OP_AND: - case OP_OR: return(opt_cell_and(sc, car_x, len)); - case OP_IF: return(opt_cell_if(sc, car_x, len)); - case OP_DO: return(opt_cell_do(sc, car_x, len)); - case OP_LET_TEMPORARILY: return(opt_cell_let_temporarily(sc, car_x, len)); - default: - /* for lambda et al we'd return the new closure, but if unsafe? - * let(*) -> make the let -> body (let=99% of cases), could we use do (i.e. do+no steppers+no end!) or let-temp? - * with-let -> establish car(args)=let, then body - * macroexpand -> return the expansion - * define et al -> define + return value - * map and for-each are not syntax, also call-with*(=exit) - * also let-temp for vars>1 - */ - break; - } - return_false(sc, car_x); -} - - -/* -------------------------------------------------------------------------------- */ -static bool float_optimize_1(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer car_x = car(expr), head, s_func, s_slot = NULL; - s7_int len; - if (WITH_GMP) return(false); - if (!is_pair(car_x)) /* wrap constants/symbols */ - return(opt_float_not_pair(sc, car_x)); - - head = car(car_x); - len = s7_list_length(sc, car_x); - if (is_symbol(head)) - { - if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) - return(d_syntax_ok(sc, car_x, len)); - - s_slot = lookup_slot_from(head, sc->curlet); - if (!is_slot(s_slot)) return_false(sc, car_x); - s_func = slot_value(s_slot); - } - else - if (is_c_function(head)) - s_func = head; - else return_false(sc, car_x); - - if (is_c_function(s_func)) - { - opt_info *opc = alloc_opt_info(sc); - switch (len) - { - case 1: - if (d_ok(sc, opc, s_func)) - return(true); - break; - - case 2: /* (f v) or (f d): (env e) or (abs x) */ - if ((d_d_ok(sc, opc, s_func, car_x)) || - (d_v_ok(sc, opc, s_func, car_x)) || - (d_p_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 3: - if ((d_dd_ok(sc, opc, s_func, car_x)) || - (d_id_ok(sc, opc, s_func, car_x)) || - (d_vd_ok(sc, opc, s_func, car_x)) || - (d_pd_ok(sc, opc, s_func, car_x)) || - (d_ip_ok(sc, opc, s_func, car_x)) || - (d_7pi_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 4: - if ((d_ddd_ok(sc, opc, s_func, car_x)) || - (d_7pid_ok(sc, opc, s_func, car_x)) || - (d_vid_ok(sc, opc, s_func, car_x)) || - (d_vdd_ok(sc, opc, s_func, car_x)) || - (d_7pii_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 5: - if ((d_dddd_ok(sc, opc, s_func, car_x)) || - (d_7piid_ok(sc, opc, s_func, car_x)) || - (d_7piii_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 6: - if (d_7piiid_ok(sc, opc, s_func, car_x)) - return(true); - /* break; */ - - default: - if (d_add_any_ok(sc, opc, car_x)) - return(true); - break; - }} - else - { - if ((is_macro(s_func)) && (!no_cell_opt(expr))) - { - s7_pointer body = closure_body(s_func); - if ((is_null(cdr(body))) && (is_pair(car(body))) && - ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol))) - { - s7_pointer result = s7_macroexpand(sc, s_func, cdar(expr)); - if (result == sc->F) return_false(sc, car_x); - return(float_optimize(sc, set_plist_1(sc, result))); - }} - if (!s_slot) return_false(sc, car_x); - return(d_implicit_ok(sc, s_slot, car_x, len)); - } - return_false(sc, car_x); -} - -static bool float_optimize(s7_scheme *sc, s7_pointer expr) {return((float_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} - -static bool int_optimize_1(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer car_x = car(expr), head, s_func, s_slot = NULL; - s7_int len; - if (WITH_GMP) return(false); - if (!is_pair(car_x)) /* wrap constants/symbols */ - return(opt_int_not_pair(sc, car_x)); - - head = car(car_x); - len = s7_list_length(sc, car_x); - if (is_symbol(head)) - { - if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) - return(i_syntax_ok(sc, car_x, len)); - s_slot = lookup_slot_from(head, sc->curlet); - if (!is_slot(s_slot)) return_false(sc, car_x); - s_func = slot_value(s_slot); - } - else - if (is_c_function(head)) - s_func = head; - else return_false(sc, car_x); - - if (is_c_function(s_func)) - { - opt_info *opc = alloc_opt_info(sc); - switch (len) - { - case 2: - if (i_idp_ok(sc, opc, s_func, car_x)) - return(true); - break; - - case 3: - if ((i_ii_ok(sc, opc, s_func, car_x)) || - (i_7pi_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 4: - if ((i_iii_ok(sc, opc, s_func, car_x)) || - (i_7pii_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 5: - { - int32_t pstart = sc->pc; - if (i_7piii_ok(sc, opc, s_func, car_x)) - return(true); - pc_fallback(sc, pstart); - } - /* break; */ - - default: - if (((head == sc->add_symbol) || - (head == sc->multiply_symbol)) && - (i_add_any_ok(sc, opc, car_x))) - return(true); - break; - }} - else - { - if ((is_macro(s_func)) && (!no_cell_opt(expr))) - { - s7_pointer body = closure_body(s_func); - if ((is_null(cdr(body))) && (is_pair(car(body))) && - ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol))) - { - s7_pointer result = s7_macroexpand(sc, s_func, cdar(expr)); - if (result == sc->F) return_false(sc, car_x); - return(int_optimize(sc, set_plist_1(sc, result))); - }} - if (!s_slot) return_false(sc, car_x); - return(i_implicit_ok(sc, s_slot, car_x, len)); - } - return_false(sc, car_x); -} - -static bool int_optimize(s7_scheme *sc, s7_pointer expr) {return((int_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} - -static bool cell_optimize_1(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer car_x = car(expr), head, s_func, s_slot = NULL; - s7_int len; - if (WITH_GMP) return(false); - if (!is_pair(car_x)) /* wrap constants/symbols */ - return(opt_cell_not_pair(sc, car_x)); - - head = car(car_x); - len = s7_list_length(sc, car_x); - if (is_symbol(head)) - { - if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) /* this can be wrong! */ - return(p_syntax(sc, car_x, len)); - - s_slot = lookup_slot_from(head, sc->curlet); - if (!is_slot(s_slot)) return_false(sc, car_x); - s_func = slot_value(s_slot); - } - else - if (is_c_function(head)) - s_func = head; - else return_false(sc, car_x); - - if (is_c_function(s_func)) - { - s7_pointer sig = c_function_signature(s_func); - opt_info *opc = alloc_opt_info(sc); - int32_t pstart = sc->pc; - - switch (len) - { - case 1: - if (p_ok(sc, opc, s_func, car_x)) - return(true); - break; - - case 2: - if ((p_i_ok(sc, opc, s_func, car_x, sc->pc)) || - (p_d_ok(sc, opc, s_func, car_x, sc->pc)) || - (p_p_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 3: - if (is_symbol(cadr(car_x))) - { - if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_pair(cddr(sig))) && (caddr(sig) == sc->is_integer_symbol)) - { - if (p_pi_ok(sc, opc, s_func, sig, car_x)) - return(true); - - if ((car(sig) == sc->is_float_symbol) || - (car(sig) == sc->is_real_symbol)) - { - s7_d_7pi_t f = s7_d_7pi_function(s_func); - if (f) - { - sc->pc = pstart - 1; - if (float_optimize(sc, expr)) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return(true); - }}} - pc_fallback(sc, pstart); - }} - { - s7_i_ii_t ifunc = s7_i_ii_function(s_func); - sc->pc = pstart - 1; - if ((ifunc) && - (int_optimize(sc, expr))) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - if (opc->v[O_WRAP].fi == opt_i_ii_ss_add) - opc->v[0].fp = opt_p_ii_ss_add; - return(true); - }} - pc_fallback(sc, pstart); - - if ((p_ii_ok(sc, opc, s_func, car_x, pstart)) || - (p_dd_ok(sc, opc, s_func, car_x, pstart)) || - (p_pp_ok(sc, opc, s_func, car_x, pstart)) || - (p_call_pp_ok(sc, opc, s_func, car_x, pstart))) - return(true); - break; - - case 4: - if (is_symbol(cadr(car_x))) - { - if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_pair(cddr(sig))) && - (caddr(sig) == sc->is_integer_symbol)) - { - if (p_pii_ok(sc, opc, s_func, car_x)) - return(true); - if (p_pip_ok(sc, opc, s_func, car_x)) - return(true); - - if (((car(sig) == sc->is_float_symbol) || - (car(sig) == sc->is_real_symbol)) && - (s7_d_7pid_function(s_func)) && - (d_7pid_ok(sc, opc, s_func, car_x))) - { - /* if d_7pid is ok, we need d_to_p for cell_optimize */ - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return(true); - } - - sc->pc = pstart - 1; - if ((car(sig) == sc->is_integer_symbol) && - (s7_i_7pii_function(s_func)) && - (i_7pii_ok(sc, alloc_opt_info(sc), s_func, car_x))) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - return(true); - } - pc_fallback(sc, pstart); - }} - if ((p_ppi_ok(sc, opc, s_func, car_x)) || - (p_ppp_ok(sc, opc, s_func, car_x)) || - (p_call_ppp_ok(sc, opc, s_func, car_x))) - return(true); - break; - - case 5: - if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) && - (d_7piid_ok(sc, opc, s_func, car_x))) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; /* as above, if d_7piid is ok, we need d_to_p for cell_optimize */ - return(true); - } - if ((is_target_or_its_alias(head, s_func, sc->float_vector_ref_symbol)) && - (d_7piii_ok(sc, opc, s_func, car_x))) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return(true); - } - if (i_7piii_ok(sc, opc, s_func, car_x)) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - return(true); - } - if (is_target_or_its_alias(head, s_func, sc->int_vector_set_symbol)) - return_false(sc, car_x); - if (p_piip_ok(sc, opc, s_func, car_x)) - return(true); - pc_fallback(sc, pstart); - if (s_func == global_value(sc->vector_ref_symbol)) - { - s7_pointer obj; - if (!is_symbol(cadr(car_x))) return_false(sc, car_x); - obj = lookup_unexamined(sc, cadr(car_x)); /* was lookup_from (to avoid the unbound variable check) */ - if ((!obj) || (!is_any_vector(obj)) || (vector_rank(obj) != 3)) - return_false(sc, car_x); - } - if (p_call_any_ok(sc, opc, s_func, car_x, len)) - return(true); - break; - - case 6: - if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) && - (d_7piiid_ok(sc, opc, s_func, car_x))) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return(true); - } - - default: /* >3D vector-set etc */ - if (p_call_any_ok(sc, opc, s_func, car_x, len)) - return(true); - break; - }} - else - { - if (is_closure(s_func)) - { - opt_info *opc = alloc_opt_info(sc); - if (p_fx_any_ok(sc, opc, expr)) - return(true); - } - if (is_macro(s_func)) - return_false(sc, car_x); /* macroexpand+cell_optimize here restarts the optimize process */ - if (!s_slot) return_false(sc, car_x); -#if OPT_PRINT - { - bool res = p_implicit_ok(sc, s_slot, car_x, len); - if (!res) fprintf(stderr, " %sno p_implicit for %s%s\n", BOLD_TEXT red_text, display(car_x), UNBOLD_TEXT uncolor_text); - return(res); - } -#else - return(p_implicit_ok(sc, s_slot, car_x, len)); -#endif - } - return_false(sc, car_x); -} - -static bool cell_optimize(s7_scheme *sc, s7_pointer expr) {return((cell_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} - -static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer car_x = car(expr), head, s_func = NULL; - s7_int len; - if (!is_pair(car_x)) /* wrap constants/symbols */ - return(opt_bool_not_pair(sc, car_x)); - - head = car(car_x); - len = s7_list_length(sc, car_x); - if (is_symbol(head)) - { - if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) - { - if (head == sc->and_symbol) - return(opt_b_and(sc, car_x, len)); - if (head == sc->or_symbol) - return(opt_b_or(sc, car_x, len)); - return_false(sc, car_x); - } - s_func = lookup_unexamined(sc, head); - } - else - if (is_c_function(head)) - s_func = head; - else return_false(sc, car_x); - - if (!s_func) return_false(sc, car_x); - if (is_c_function(s_func)) - { - if ((is_symbol(head)) && (symbol_id(head) != 0)) /* (float-vector? (block)) -- both safe c_funcs, but this is a method invocation */ - return_false(sc, car_x); - switch (len) - { - case 2: - return(b_idp_ok(sc, s_func, car_x, opt_arg_type(sc, cdr(car_x)))); - - case 3: - { - s7_pointer arg1 = cadr(car_x), arg2 = caddr(car_x); - s7_pointer sig1 = opt_arg_type(sc, cdr(car_x)); - s7_pointer sig2 = opt_arg_type(sc, cddr(car_x)); - opt_info *opc = alloc_opt_info(sc); - int32_t cur_index = sc->pc; - s7_b_7pp_t bpf7 = NULL; - s7_b_pp_t bpf; - - if (sig2 == sc->is_integer_symbol) - { - if ((sig1 == sc->is_integer_symbol) && - (b_ii_ok(sc, opc, s_func, car_x, arg1, arg2))) - return(true); - pc_fallback(sc, cur_index); - if (b_pi_ok(sc, opc, s_func, car_x, arg2)) - return(true); - pc_fallback(sc, cur_index); - } - - if ((sig1 == sc->is_float_symbol) && - (sig2 == sc->is_float_symbol) && - (b_dd_ok(sc, opc, s_func, car_x, arg1, arg2))) - return(true); - pc_fallback(sc, cur_index); - - bpf = s7_b_pp_function(s_func); - if (!bpf) bpf7 = s7_b_7pp_function(s_func); - if ((bpf) || (bpf7)) - { - if (bpf) - opc->v[3].b_pp_f = bpf; - else opc->v[3].b_7pp_f = bpf7; - return(b_pp_ok(sc, opc, s_func, car_x, arg1, arg2, bpf)); - }} - break; - - default: - break; - }} - return_false(sc, car_x); -} - -static bool bool_optimize_nw(s7_scheme *sc, s7_pointer expr) {return((bool_optimize_nw_1(sc, expr)) && (sc->pc < OPTS_SIZE));} - -static bool bool_optimize(s7_scheme *sc, s7_pointer expr) -{ - int32_t start = sc->pc; - opt_info *wrapper; - if (WITH_GMP) return(false); - if (bool_optimize_nw(sc, expr)) - return(true); - pc_fallback(sc, start); - wrapper = sc->opts[start]; - if (!cell_optimize(sc, expr)) - return_false(sc, NULL); - if (wrapper->v[O_WRAP].fp) /* (when (+ i 1) ...) */ - return_false(sc, NULL); - wrapper->v[O_WRAP].fp = wrapper->v[0].fp; - wrapper->v[0].fb = p_to_b; - return(true); -} - -static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr) -{ - sc->pc = 0; - if ((bool_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) - return_success(sc, opt_bool_any, expr); - return_null(sc, expr); -} - -/* snd-sig.c experiment */ -static s7_double opt_float_any(s7_scheme *sc) {return(sc->opts[0]->v[0].fd(sc->opts[0]));} - -s7_float_function s7_float_optimize(s7_scheme *sc, s7_pointer expr) -{ - sc->pc = 0; - if ((float_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) - return(opt_float_any); - return(NULL); -} - -static s7_pfunc s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nv) -{ - if (WITH_GMP) return(NULL); - if ((!is_pair(expr)) || (no_cell_opt(expr)) || (sc->debug != 0)) - return(NULL); - sc->pc = 0; - if (!no_int_opt(expr)) - { - if (int_optimize(sc, expr)) - return((nv) ? opt_int_any_nv : opt_wrap_int); - pc_fallback(sc, 0); - set_no_int_opt(expr); - } - if (!no_float_opt(expr)) - { - if (float_optimize(sc, expr)) - return_success(sc, (nv) ? opt_float_any_nv : opt_wrap_float, expr); - pc_fallback(sc, 0); - set_no_float_opt(expr); - } - if (!no_bool_opt(expr)) - { - if (bool_optimize_nw(sc, expr)) - return_success(sc, (nv) ? opt_bool_any_nv : opt_wrap_bool, expr); - pc_fallback(sc, 0); - set_no_bool_opt(expr); - } - if (cell_optimize(sc, expr)) - return_success(sc, (nv) ? opt_cell_any_nv : opt_wrap_cell, expr); - set_no_cell_opt(expr); /* checked above */ - return_null(sc, expr); -} - -s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, false));} -s7_pfunc s7_optimize_nv(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, true));} - -static s7_pointer g_optimize(s7_scheme *sc, s7_pointer args) -{ - s7_pfunc f; - s7_pointer code = car(args), result = sc->undefined; - gc_protect_via_stack(sc, code); - f = s7_optimize(sc, code); - if (f) result = f(sc); - if (((opcode_t)sc->stack_end[-1]) == OP_GC_PROTECT) unstack(sc); /* was unstack(sc) */ - return(result); -} - -static s7_pfunc s7_cell_optimize(s7_scheme *sc, s7_pointer expr, bool nv) -{ - sc->pc = 0; - if ((cell_optimize(sc, expr)) && (sc->pc < OPTS_SIZE)) - return((nv) ? opt_cell_any_nv : opt_wrap_cell); - return_null(sc, expr); -} - - -/* ---------------- bool funcs (an experiment) ---------------- */ -static void fx_curlet_tree(s7_scheme *sc, s7_pointer code) -{ - s7_pointer slot1 = let_slots(sc->curlet), slot3 = NULL, outer_e; - bool more_vars; - s7_pointer slot2 = next_slot(slot1); - if (tis_slot(slot2)) slot3 = next_slot(slot2); - - more_vars = (tis_slot(slot3)) && (tis_slot(next_slot(slot3))); - fx_tree(sc, code, - slot_symbol(slot1), - (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, - (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, - more_vars); - - outer_e = let_outlet(sc->curlet); - if ((!more_vars) && - (is_let(outer_e)) && - (!is_funclet(outer_e)) && - (tis_slot(let_slots(outer_e))) && - (slot_symbol(let_slots(outer_e)) != slot_symbol(slot1))) - { - slot1 = let_slots(outer_e); - slot2 = next_slot(slot1); - slot3 = (tis_slot(slot2)) ? next_slot(slot2) : NULL; - fx_tree_outer(sc, code, - slot_symbol(slot1), - (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, - (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, - (tis_slot(slot3)) && (tis_slot(next_slot(slot3)))); - } -} - -static void fx_curlet_tree_in(s7_scheme *sc, s7_pointer code) -{ - s7_pointer slot1 = let_slots(sc->curlet), slot3 = NULL; - s7_pointer slot2 = next_slot(slot1); - if (tis_slot(slot2)) slot3 = next_slot(slot2); - fx_tree_in(sc, code, - slot_symbol(slot1), - (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, - (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, - (tis_slot(slot3)) && (tis_slot(next_slot(slot3)))); -} - -typedef bool (*s7_bfunc)(s7_scheme *sc, s7_pointer expr); - -static bool fb_lt_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = lookup(sc, cadr(expr)); - s7_pointer y = lookup(sc, opt2_sym(cdr(expr))); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) < integer(y)) : lt_b_7pp(sc, x, y)); -} - -static bool fb_lt_ts(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = t_lookup(sc, cadr(expr), expr); - s7_pointer y = lookup(sc, opt2_sym(cdr(expr))); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) < integer(y)) : lt_b_7pp(sc, x, y)); -} - -static bool fb_num_eq_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = lookup(sc, cadr(expr)); - s7_pointer y = lookup(sc, opt2_sym(cdr(expr))); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y)); -} - -static bool fb_num_eq_s0(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = lookup(sc, cadr(expr)); - return((is_t_integer(x)) ? (integer(x) == 0) : num_eq_b_7pp(sc, x, int_zero)); -} - -static bool fb_num_eq_s0f(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = lookup(sc, cadr(expr)); - return((is_t_real(x)) ? (real(x) == 0.0) : num_eq_b_7pp(sc, x, real_zero)); -} - -static bool fb_gt_tu(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = t_lookup(sc, cadr(expr), expr), y = u_lookup(sc, opt2_sym(cdr(expr)), expr); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) > integer(y)) : gt_b_7pp(sc, x, y)); -} - -static bool fb_gt_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = s_lookup(sc, cadr(expr), expr); - s7_pointer y = s_lookup(sc, opt2_sym(cdr(expr)), expr); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) > integer(y)) : gt_b_7pp(sc, x, y)); -} - -static bool fb_geq_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = s_lookup(sc, cadr(expr), expr); - s7_pointer y = s_lookup(sc, opt2_sym(cdr(expr)), expr); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) >= integer(y)) : geq_b_7pp(sc, x, y)); -} - -static bool fb_leq_ss(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = s_lookup(sc, cadr(expr), expr); - s7_pointer y = s_lookup(sc, opt2_sym(cdr(expr)), expr); - return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) <= integer(y)) : leq_b_7pp(sc, x, y)); -} - -static bool fb_leq_ti(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = t_lookup(sc, cadr(expr), expr); - if (is_t_integer(x)) return(integer(x) <= integer(opt2_con(cdr(expr)))); - return(g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(expr))))); -} - -static bool fb_leq_ui(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer x = u_lookup(sc, cadr(expr), expr); - if (is_t_integer(x)) return(integer(x) <= integer(opt2_con(cdr(expr)))); - return(g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(expr))))); -} - -static s7_pointer fx_to_fb(s7_scheme *sc, s7_function fx) /* eventually parallel arrays? */ -{ - if (fx == fx_num_eq_ss) return((s7_pointer)fb_num_eq_ss); - if (fx == fx_lt_ss) return((s7_pointer)fb_lt_ss); - if (fx == fx_lt_ts) return((s7_pointer)fb_lt_ts); - if (fx == fx_gt_ss) return((s7_pointer)fb_gt_ss); - if (fx == fx_leq_ss) return((s7_pointer)fb_leq_ss); - if (fx == fx_leq_ti) return((s7_pointer)fb_leq_ti); - if (fx == fx_leq_ui) return((s7_pointer)fb_leq_ui); - if (fx == fx_geq_ss) return((s7_pointer)fb_geq_ss); - if (fx == fx_gt_tu) return((s7_pointer)fb_gt_tu); - if (fx == fx_num_eq_s0) return((s7_pointer)fb_num_eq_s0); - if (fx == fx_num_eq_s0f) return((s7_pointer)fb_num_eq_s0f); - return(NULL); -} - -static void fb_annotate(s7_scheme *sc, s7_pointer form, s7_pointer fx_expr, opcode_t op) -{ - s7_pointer bfunc; - if ((is_fx_treeable(cdr(form))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(form)); /* and not already treed? just the one expr? */ - bfunc = fx_to_fb(sc, fx_proc(fx_expr)); - if (bfunc) - { - set_opt3_any(cdr(form), bfunc); - pair_set_syntax_op(form, op); - } -#if 0 - /* fb_annotate additions? [these currently require new "B" ops] */ - else - { - fprintf(stderr, "fx: %s %s\n", ((is_pair(fx_expr)) && (is_pair(car(fx_expr)))) ? op_names[optimize_op(car(fx_expr))] : "", display_80(fx_expr)); - if (caar(fx_expr) == sc->num_eq_symbol) abort(); - /* [fx_leq_ti] fx_lt_t0 fx_gt_ti fx_num_eq_u0 */ - } -#endif -} - -/* when_b cond? do end-test? num_eq_vs|us */ - - -/* ---------------------------------------- for-each ---------------------------------------- */ -static Inline s7_pointer inline_make_counter(s7_scheme *sc, s7_pointer iter) /* all calls are hit about the same: lg/sg */ -{ - s7_pointer x; - new_cell(sc, x, T_COUNTER); - counter_set_result(x, sc->nil); - counter_set_list(x, iter); /* iterator -- here it's always either an iterator or a pair */ - counter_set_capture(x, 0); /* will be capture_let_counter */ - counter_set_let(x, sc->nil); /* will be the saved let */ - counter_set_slots(x, sc->nil); /* local let slots before body is evalled */ - stack_set_has_counters(sc->stack); - return(x); -} - -static s7_pointer make_iterators(s7_scheme *sc, s7_pointer caller, s7_pointer args) -{ - s7_pointer p = cdr(args); - sc->temp3 = args; - sc->z = sc->nil; /* don't use sc->args here -- it needs GC protection until we get the iterators */ - for (s7_int i = 2; is_pair(p); p = cdr(p), i++) - { - s7_pointer iter = car(p); - if (!is_iterator(iter)) - { - if (!is_mappable(iter)) - wrong_type_error_nr(sc, caller, i, iter, a_sequence_string); - iter = s7_make_iterator(sc, iter); - } - sc->z = cons(sc, iter, sc->z); - } - sc->temp3 = sc->unused; - return(proper_list_reverse_in_place(sc, sc->z)); -} - -static s7_pointer seq_init(s7_scheme *sc, s7_pointer seq) -{ - if (is_float_vector(seq)) return(real_zero); - if (is_string(seq)) return(chars[65]); - if ((is_int_vector(seq)) || (is_byte_vector(seq))) return(int_zero); - return(sc->F); -} - -#define MUTLIM 32 /* was 1000 */ - -static s7_pointer clear_for_each(s7_scheme *sc) -{ - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - return(sc->unspecified); -} - -static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* one sequence arg */ -{ - s7_pointer body = closure_body(f); - if (!no_cell_opt(body)) /* if at top level we often get an unoptimized (not safe) function here that can be cell_optimized below */ - { - s7_pfunc func = NULL; - s7_pointer old_e = sc->curlet, pars = closure_args(f), val, slot, res = NULL; - - val = seq_init(sc, seq); - sc->curlet = inline_make_let_with_slot(sc, closure_let(f), (is_pair(car(pars))) ? caar(pars) : car(pars), val); - slot = let_slots(sc->curlet); - - if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_optimize_nv(sc, body); - else - if (is_null(cddr(body))) /* 3 sometimes works */ - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); /* was list_1 via cons 8-Apr-21, true=nr */ - }} - - if (func) - { - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq); - sc->map_call_ctr++; - if (is_pair(seq)) - { - for (s7_pointer x = seq, y = x; is_pair(x); ) - { - slot_set_value(slot, car(x)); - func(sc); - x = cdr(x); - if (is_pair(x)) - { - slot_set_value(slot, car(x)); - func(sc); - x = cdr(x); - y = cdr(y); - if (x == y) break; - }} - res = sc->unspecified; - } - else - if (is_float_vector(seq)) - { - s7_double *vals = float_vector_floats(seq); - s7_int i, len = vector_length(seq); - if ((len > MUTLIM) && - (!tree_has_setters(sc, body))) - { - s7_pointer sv = s7_make_mutable_real(sc, 0.0); - slot_set_value(slot, sv); - if (func == opt_float_any_nv) - { - opt_info *o = sc->opts[0]; - s7_double (*fd)(opt_info *o) = o->v[0].fd; - for (i = 0; i < len; i++) {real(sv) = vals[i]; fd(o);}} - else - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if (fp == opt_unless_p_1) - for (i = 0; i < len; i++) {real(sv) = vals[i]; if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1);} - else for (i = 0; i < len; i++) {real(sv) = vals[i]; fp(o);} - } - else for (i = 0; i < len; i++) {real(sv) = vals[i]; func(sc);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, make_real(sc, vals[i])); func(sc);} - res = sc->unspecified; - } - else - if (is_int_vector(seq)) - { - s7_int *vals = int_vector_ints(seq); - s7_int i, len = vector_length(seq); - if ((len > MUTLIM) && - (!tree_has_setters(sc, body))) - { - s7_pointer sv = make_mutable_integer(sc, 0); - slot_set_value(slot, sv); - /* since there are no setters, the inner step is also mutable if there is one. - * func=opt_cell_any_nv, sc->opts[0]->v[0].fp(sc->opts[0]) fp=opt_do_1 -> mutable version - */ - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - for (i = 0; i < len; i++) {integer(sv) = vals[i]; fi(o);}} - else for (i = 0; i < len; i++) {integer(sv) = vals[i]; func(sc);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, make_integer(sc, vals[i])); func(sc);} - res = sc->unspecified; - } - else - if (is_normal_vector(seq)) - { - s7_pointer *vals = vector_elements(seq); - s7_int i, len = vector_length(seq); - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - for (i = 0; i < len; i++) {slot_set_value(slot, vals[i]); fp(o);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, vals[i]); func(sc);} - res = sc->unspecified; - } - else - if (is_string(seq)) - { - const char *str = string_value(seq); - s7_int len = string_length(seq); - for (s7_int i = 0; i < len; i++) {slot_set_value(slot, chars[(uint8_t)(str[i])]); func(sc);} - res = sc->unspecified; - } - else - if (is_byte_vector(seq)) - { - const uint8_t *vals = (const uint8_t *)byte_vector_bytes(seq); - s7_int i, len = vector_length(seq); - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - for (i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); fi(o);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); func(sc);} - res = sc->unspecified; - } - if (res) - return(clear_for_each(sc)); - if (!is_iterator(seq)) - { - if (!is_mappable(seq)) - wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); - sc->z = s7_make_iterator(sc, seq); - seq = sc->z; - set_stack_protected2_with(sc, seq, OP_MAP_UNWIND); /* GC protect new iterator */ - } - else sc->z = T_Ext(seq); - /* push_stack_no_let(sc, OP_GC_PROTECT, seq, f); */ - sc->z = sc->unused; - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - while (true) - { - slot_set_value(slot, s7_iterate(sc, seq)); - if (iterator_is_at_end(seq)) return(clear_for_each(sc)); - fp(o); - }} - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - while (true) - { - slot_set_value(slot, s7_iterate(sc, seq)); - if (iterator_is_at_end(seq)) return(clear_for_each(sc)); - fi(o); - }} - while (true) - { - slot_set_value(slot, s7_iterate(sc, seq)); - if (iterator_is_at_end(seq)) return(clear_for_each(sc)); - func(sc); - }} /* we never get here -- the while loops above exit via return # */ - else /* not func -- unneeded "else" but otherwise confusing code */ - { - set_no_cell_opt(body); - set_curlet(sc, old_e); - }} - if ((!is_closure_star(f)) && /* for simplicity in op_for_each_2 (otherwise we need to check for default arg) */ - (is_null(cdr(body))) && - (is_pair(seq))) - { - s7_pointer c = inline_make_counter(sc, seq); - counter_set_result(c, seq); - push_stack(sc, OP_FOR_EACH_2, c, f); - return(sc->unspecified); - } - - if (!is_iterator(seq)) - { - if (!is_mappable(seq)) - wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); - sc->z = s7_make_iterator(sc, seq); - } - else sc->z = seq; - push_stack(sc, OP_FOR_EACH_1, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->unspecified); -} - -static void map_or_for_each_closure_pair_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) -{ - for (s7_pointer fast1 = seq1, slow1 = seq1, fast2 = seq2, slow2 = seq2; (is_pair(fast1)) && (is_pair(fast2)); - fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2)) - { - slot_set_value(slot1, car(fast1)); - slot_set_value(slot2, car(fast2)); - if (for_each_case) - func(sc); - else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); /* see map_closure_2 below -- stack_protected3 is our temp */ - } - if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) - { - fast1 = cdr(fast1); - if (fast1 == slow1) break; - fast2 = cdr(fast2); - if (fast2 == slow2) break; - slot_set_value(slot1, car(fast1)); - slot_set_value(slot2, car(fast2)); - if (for_each_case) - func(sc); - else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); - }}} -} - -static void map_or_for_each_closure_vector_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) -{ - s7_int len = vector_length(seq1); - if (len > vector_length(seq2)) len = vector_length(seq2); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot1, vector_getter(seq1)(sc, seq1, i)); - slot_set_value(slot2, vector_getter(seq2)(sc, seq2, i)); - if (for_each_case) - func(sc); - else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); - }} -} - -static void map_or_for_each_closure_string_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) -{ - s7_int len = string_length(seq1); - const char *s1 = string_value(seq1), *s2 = string_value(seq2); - if (len > string_length(seq2)) len = string_length(seq2); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot1, chars[(uint8_t)(s1[i])]); - slot_set_value(slot2, chars[(uint8_t)(s2[i])]); - if (for_each_case) - func(sc); - else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); - }} -} - -static s7_pointer g_for_each_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1, s7_pointer seq2) -{ - s7_pointer body = closure_body(f); - if (!no_cell_opt(body)) - { - s7_pfunc func = NULL; - s7_pointer olde = sc->curlet, pars = closure_args(f), slot1, slot2; - s7_pointer val1 = seq_init(sc, seq1); - s7_pointer val2 = seq_init(sc, seq2); - sc->curlet = make_let_with_two_slots(sc, closure_let(f), - (is_pair(car(pars))) ? caar(pars) : car(pars), val1, - (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val2); - slot1 = let_slots(sc->curlet); - slot2 = next_slot(slot1); - - if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_optimize_nv(sc, body); - else - if (is_null(cddr(body))) - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); - }} - - if (func) - { - s7_pointer res = NULL; - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq1); - sc->map_call_ctr++; - if ((is_pair(seq1)) && (is_pair(seq2))) - { - map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, true); - set_curlet(sc, olde); - res = sc->unspecified; - } - else - if ((is_any_vector(seq1)) && (is_any_vector(seq2))) - { - map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, true); - set_curlet(sc, olde); - res = sc->unspecified; - } - else - if ((is_string(seq1)) && (is_string(seq2))) - { - map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, true); - set_curlet(sc, olde); - res = sc->unspecified; - } - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - set_curlet(sc, olde); - if (res) return(res); - set_no_cell_opt(body); - } - else /* not func */ - { - set_no_cell_opt(body); - set_curlet(sc, olde); - }} - - if (!is_iterator(seq1)) - { - if (!is_mappable(seq1)) - wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq1, a_sequence_string); - sc->z = s7_make_iterator(sc, seq1); - } - else sc->z = seq1; - if (!is_iterator(seq2)) - { - if (!is_mappable(seq2)) - wrong_type_error_nr(sc, sc->for_each_symbol, 3, seq2, a_sequence_string); - sc->z = list_2(sc, sc->z, s7_make_iterator(sc, seq2)); - } - else sc->z = list_2(sc, sc->z, seq2); - push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, sc->z, make_list(sc, 2, sc->nil)), f); - sc->z = sc->unused; - return(sc->unspecified); -} - -static inline bool for_each_arg_is_null(s7_scheme *sc, s7_pointer args) -{ - s7_pointer p = args; - bool got_nil = false; - for (s7_int i = 2; is_pair(p); p = cdr(p), i++) - { - s7_pointer obj = car(p); - if (!is_mappable(obj)) - { - if (is_null(obj)) - got_nil = true; - else wrong_type_error_nr(sc, sc->for_each_symbol, i, obj, a_sequence_string); - }} - return(got_nil); -} - -static s7_pointer g_for_each(s7_scheme *sc, s7_pointer args) -{ - #define H_for_each "(for-each proc object . objects) applies proc to each element of the objects traversed in parallel. \ -Each object can be a list, string, vector, hash-table, or any other sequence." - #define Q_for_each s7_make_circular_signature(sc, 2, 3, sc->is_unspecified_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol) - - s7_pointer f = car(args); - s7_int len = proper_list_length(cdr(args)); - bool arity_ok = false; - - /* try the normal case first */ - sc->value = f; - if (is_closure(f)) /* not lambda* that might get confused about arg names */ - { - if ((len == 1) && - (is_pair(closure_args(f))) && - (is_null(cdr(closure_args(f))))) - arity_ok = true; - } - else - if (is_c_object(f)) /* see note in g_map; s7_is_aritable can clobber sc->args=plist=args */ - args = copy_proper_list(sc, args); - else - if (!is_applicable(f)) - return(method_or_bust(sc, f, sc->for_each_symbol, args, something_applicable_string, 1)); - - if ((!arity_ok) && - (!s7_is_aritable(sc, f, len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "for-each ~A: ~A argument~P?", 27), f, wrap_integer(sc, len), wrap_integer(sc, len))); - - if (for_each_arg_is_null(sc, cdr(args))) return(sc->unspecified); - - /* if function is safe c func, do the for-each locally */ - if (is_safe_c_function(f)) - { - s7_function func; - s7_pointer iters; - - s7_p_p_t fp = s7_p_p_function(f); - if ((fp) && (len == 1)) - { - if (is_pair(cadr(args))) - { - for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) - { - fp(sc, car(fast)); - if (is_pair(cdr(fast))) - { - fast = cdr(fast); - if (fast == slow) break; - fp(sc, car(fast)); - }} - return(sc->unspecified); - } - if (is_any_vector(cadr(args))) - { - s7_pointer v = cadr(args); - s7_int vlen = vector_length(v); - if (is_float_vector(v)) - { - s7_pointer rl = s7_make_mutable_real(sc, 0.0); - sc->temp7 = rl; - for (s7_int i = 0; i < vlen; i++) - { - real(rl) = float_vector(v, i); - fp(sc, rl); - }} - else - if (is_int_vector(v)) - { - s7_pointer iv = make_mutable_integer(sc, 0); - sc->temp7 = iv; - for (s7_int i = 0; i < vlen; i++) - { - integer(iv) = int_vector(v, i); - fp(sc, iv); - }} - else - for (s7_int i = 0; i < vlen; i++) - fp(sc, vector_getter(v)(sc, v, i)); /* LOOP_4 here gains almost nothing */ - return(sc->unspecified); - } - if (is_string(cadr(args))) - { - s7_pointer str = cadr(args); - const char *s = string_value(str); - s7_int slen = string_length(str); - for (s7_int i = 0; i < slen; i++) fp(sc, chars[(uint8_t)(s[i])]); - return(sc->unspecified); - }} - func = c_function_call(f); /* presumably this is either display/write, or method call? */ - sc->z = make_iterators(sc, sc->for_each_symbol, args); - sc->z = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); - push_stack_no_let(sc, OP_GC_PROTECT, sc->args, sc->z); /* temporary GC protection */ - if (len == 1) - { - s7_pointer x = caar(sc->z), y = cdr(sc->z); - sc->z = sc->unused; - while (true) - { - set_car(y, s7_iterate(sc, x)); - if (iterator_is_at_end(x)) - { - /* not pop_stack here since that can clobber sc->code et al, and if this for-each call is - * being treated as safe, fn_proc(for-each) assumes everywhere that sc->code is left alone. - */ - unstack(sc); /* free_cell(sc, x); */ /* 16-Jan-19 */ - return(sc->unspecified); - } - func(sc, y); - }} - iters = sc->z; - sc->z = sc->unused; - while (true) - { - for (s7_pointer x = car(iters), y = cdr(iters); is_pair(x); x = cdr(x), y = cdr(y)) - { - set_car(y, s7_iterate(sc, car(x))); - if (iterator_is_at_end(car(x))) - { - unstack(sc); - return(sc->unspecified); - }} - func(sc, cdr(iters)); - }} - - /* if closure call is straightforward, use OP_FOR_EACH_1 */ - if ((len == 1) && - (((is_closure(f)) && - (closure_arity_to_int(sc, f) == 1) && - (!is_constant_symbol(sc, car(closure_args(f))))) || - ((is_closure_star(f)) && - (closure_star_arity_to_int(sc, f) == 1) && - (!is_constant_symbol(sc, (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : car(closure_args(f))))))) - return(g_for_each_closure(sc, f, cadr(args))); - - push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, make_iterators(sc, sc->for_each_symbol, args), make_list(sc, len, sc->nil)), f); - sc->z = sc->unused; - return(sc->unspecified); -} - -static bool op_for_each(s7_scheme *sc) -{ - s7_pointer iterators = car(sc->args); - s7_pointer saved_args = cdr(sc->args); - for (s7_pointer x = saved_args, y = iterators; is_pair(x); x = cdr(x), y = cdr(y)) - { - set_car(x, s7_iterate(sc, car(y))); - if (iterator_is_at_end(car(y))) - { - sc->value = sc->unspecified; - free_cell(sc, sc->args); - return(true); - }} - push_stack_direct(sc, OP_FOR_EACH); - sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, saved_args) : saved_args; - return(false); -} - -/* for-each et al remake the local let, but that's only needed if the local let is exported, - * and that can only happen through make-closure in various guises and curlet. - * owlet captures, but it would require a deliberate error to use it in this context. - * c_objects call object_set_let but that requires a prior curlet or sublet. So we have - * sc->capture_let_counter that is incremented every time an environment is captured, then - * here we save that ctr, call body, on rerun check ctr, if it has not changed we are safe and - * can reuse let. But that reuse assumes no new slots were added (by define etc), because - * update_let* only update the symbol_id's they expect, and that can happen even in op_for_each_2. - */ - -static Inline bool inline_op_for_each_1(s7_scheme *sc) /* called once in eval, case fb gc iter */ -{ - s7_pointer counter = sc->args, code; - s7_pointer p = counter_list(counter); - s7_pointer arg = s7_iterate(sc, p); - if (iterator_is_at_end(p)) - { - sc->value = sc->unspecified; - free_cell(sc, counter); - return(true); - } - code = T_Clo(sc->code); - if (counter_capture(counter) != sc->capture_let_counter) - { - s7_pointer sym = car(closure_args(code)); - sc->curlet = inline_make_let_with_slot(sc, closure_let(code), (is_symbol(sym)) ? sym : car(sym), arg); - counter_set_let(counter, sc->curlet); - counter_set_slots(counter, let_slots(sc->curlet)); - counter_set_capture(counter, sc->capture_let_counter); - } - else - { - let_set_slots(counter_let(counter), counter_slots(counter)); /* this is needed (unless safe_closure but that costs more to check than this set) */ - sc->curlet = update_let_with_slot(sc, counter_let(counter), arg); - } - push_stack(sc, OP_FOR_EACH_1, counter, code); - sc->code = T_Pair(closure_body(code)); - return(false); -} - -static Inline bool inline_op_for_each_2(s7_scheme *sc) /* called once in eval, lg set */ -{ - s7_pointer c = sc->args; - s7_pointer lst = counter_list(c); - if (!is_pair(lst)) /* '(1 2 . 3) as arg? -- counter_list can be anything here */ - { - sc->value = sc->unspecified; - free_cell(sc, c); /* not sc->args = sc->nil; */ - return(true); - } - counter_set_list(c, cdr(lst)); - if (sc->cur_op == OP_FOR_EACH_3) - { - counter_set_result(c, cdr(counter_result(c))); - if (counter_result(c) == counter_list(c)) - { - sc->value = sc->unspecified; - free_cell(sc, c); /* not sc->args = sc->nil; */ - return(true); - } - push_stack_direct(sc, OP_FOR_EACH_2); - } - else push_stack_direct(sc, OP_FOR_EACH_3); - if (counter_capture(c) != sc->capture_let_counter) - { - sc->curlet = inline_make_let_with_slot(sc, closure_let(sc->code), car(closure_args(sc->code)), car(lst)); - counter_set_let(c, sc->curlet); - counter_set_slots(c, let_slots(sc->curlet)); - counter_set_capture(c, sc->capture_let_counter); - } - else - { - let_set_slots(counter_let(c), counter_slots(c)); - sc->curlet = update_let_with_slot(sc, counter_let(c), car(lst)); - } - sc->code = car(closure_body(sc->code)); - return(false); -} - - -/* ---------------------------------------- map ---------------------------------------- */ - -static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* one sequence argument */ -{ - s7_pointer body = closure_body(f); - sc->value = f; - /* fprintf(stderr, "%s[%d]: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); */ - - if (!no_cell_opt(body)) - { - s7_pfunc func = NULL; - s7_pointer old_e = sc->curlet, pars = closure_args(f), slot; - s7_pointer val = seq_init(sc, seq); - sc->curlet = inline_make_let_with_slot(sc, closure_let(f), (is_pair(car(pars))) ? caar(pars) : car(pars), val); - slot = let_slots(sc->curlet); - - if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_cell_optimize(sc, body, false); - else - if (is_null(cddr(body))) - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); /* list_1 8-Apr-21 */ - }} - if (func) - { - s7_pointer z, res = NULL; - /* fprintf(stderr, "%s[%d]: push map unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); */ - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq); - sc->map_call_ctr++; - if (is_pair(seq)) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_pointer fast = seq, slow = seq; is_pair(fast); fast = cdr(fast), slow = cdr(slow)) - { - slot_set_value(slot, car(fast)); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - if (is_pair(cdr(fast))) - { - fast = cdr(fast); - if (fast == slow) break; - slot_set_value(slot, car(fast)); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - }} - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_float_vector(seq)) - { - s7_double *vals = float_vector_floats(seq); - s7_int len = vector_length(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, make_real(sc, vals[i])); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_int_vector(seq)) - { - s7_int *vals = int_vector_ints(seq); - s7_int len = vector_length(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, make_integer(sc, vals[i])); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_normal_vector(seq)) - { - s7_pointer *vals = vector_elements(seq); - s7_int len = vector_length(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, vals[i]); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_string(seq)) - { - s7_int len = string_length(seq); - const char *str = string_value(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, chars[(uint8_t)(str[i])]); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} - if (res) return(res); - } - set_no_cell_opt(body); - set_curlet(sc, old_e); - } - if (is_closure_star(f)) - { - sc->z = make_iterators(sc, sc->map_symbol, set_plist_2(sc, sc->nil, seq)); - push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->nil); - } - if ((is_null(cdr(body))) && - (is_pair(seq))) - { - closure_set_map_list(f, seq); - push_stack(sc, OP_MAP_2, inline_make_counter(sc, seq), f); - return(sc->unspecified); - } - if (!is_iterator(seq)) - { - if (!is_mappable(seq)) - wrong_type_error_nr(sc, sc->map_symbol, 2, seq, a_sequence_string); - sc->z = s7_make_iterator(sc, seq); - } - else sc->z = seq; - push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->nil); -} - -static s7_pointer g_map_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1, s7_pointer seq2) /* two sequences */ -{ - s7_pointer body = closure_body(f); - /* fprintf(stderr, "%s[%d]: %" ld64 " %s %s\n", __func__, __LINE__, sc->map_call_ctr, display(seq1), display(seq2)); */ - if (!no_cell_opt(body)) - { - s7_pfunc func = NULL; - s7_pointer old_e = sc->curlet, pars = closure_args(f), slot1, slot2; - s7_pointer val1 = seq_init(sc, seq1); - s7_pointer val2 = seq_init(sc, seq2); - sc->curlet = make_let_with_two_slots(sc, closure_let(f), - (is_pair(car(pars))) ? caar(pars) : car(pars), val1, - (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val2); - slot1 = let_slots(sc->curlet); - slot2 = next_slot(slot1); - - if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_cell_optimize(sc, body, false); - else - if (is_null(cddr(body))) - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); - }} - if (func) - { - s7_pointer res = NULL; - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq1); - sc->map_call_ctr++; - if ((is_pair(seq1)) && (is_pair(seq2))) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, false); /* builds result on stack_protected3 */ - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if ((is_any_vector(seq1)) && (is_any_vector(seq2))) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, false); - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if ((is_string(seq1)) && (is_string(seq2))) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, false); - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - set_curlet(sc, old_e); - if (res) return(res); - set_no_cell_opt(body); - } - else /* not func */ - { - set_no_cell_opt(body); - set_curlet(sc, old_e); - }} - - if (!is_iterator(seq1)) - { - if (!is_mappable(seq1)) - wrong_type_error_nr(sc, sc->map_symbol, 2, seq1, a_sequence_string); - sc->z = s7_make_iterator(sc, seq1); - } - else sc->z = seq1; - if (!is_iterator(seq2)) - { - if (!is_mappable(seq2)) - wrong_type_error_nr(sc, sc->map_symbol, 3, seq2, a_sequence_string); - sc->z = list_2(sc, sc->z, s7_make_iterator(sc, seq2)); - } - else sc->z = list_2(sc, sc->z, seq2); - - push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->unspecified); -} - -static s7_pointer g_map(s7_scheme *sc, s7_pointer args) -{ - #define H_map "(map proc object . objects) applies proc to a list made up of the next element of each of its arguments, returning \ -a list of the results. Its arguments can be lists, vectors, strings, hash-tables, or any applicable objects." - #define Q_map s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol) - - s7_pointer p, f = car(args); - s7_int len; - bool got_nil = false; - - for (len = 0, p = cdr(args); is_not_null(p); p = cdr(p), len++) - if (!is_mappable(car(p))) - { - if (is_null(car(p))) - got_nil = true; - else wrong_type_error_nr(sc, sc->map_symbol, len + 2, car(p), a_sequence_string); - } - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); - case T_C_RST_NO_REQ_FUNCTION: - /* if function is safe c func, do the map locally */ - if (got_nil) return(sc->nil); - if (is_safe_procedure(f)) - { - s7_pointer val, val1, old_args, iter_list; - s7_function func = c_function_call(f); - if (is_pair(cadr(args))) - { - if (len == 1) - { - s7_p_p_t fp = s7_p_p_function(f); - if (fp) - { - val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); - for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) - { - s7_pointer z = fp(sc, car(fast)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - if (is_pair(cdr(fast))) - { - fast = cdr(fast); - if (fast == slow) break; - z = fp(sc, car(fast)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - }} - unstack(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }} - if ((len == 2) && (is_pair(caddr(args)))) - { - s7_p_pp_t fp = s7_p_pp_function(f); - if (fp) - { - val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); - for (s7_pointer fast1 = cadr(args), slow1 = cadr(args), fast2 = caddr(args), slow2 = caddr(args); - (is_pair(fast1)) && (is_pair(fast2)); - fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2)) - { - s7_pointer z = fp(sc, car(fast1), car(fast2)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) - { - fast1 = cdr(fast1); - if (fast1 == slow1) break; - fast2 = cdr(fast2); - if (fast2 == slow2) break; - z = fp(sc, car(fast1), car(fast2)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - }} - unstack(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }}} - if ((is_string(cadr(args))) && (len == 1)) - { - s7_p_p_t fp = s7_p_p_function(f); - if (fp) - { - s7_pointer str = cadr(args); - const char *s = string_value(str); - val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); - len = string_length(str); - for (s7_int i = 0; i < len; i++) - { - s7_pointer z = fp(sc, chars[(uint8_t)(s[i])]); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - } - unstack(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }} - if ((is_any_vector(cadr(args))) && (len == 1)) - { - s7_p_p_t fp = s7_p_p_function(f); - if (fp) - { - s7_pointer vec = cadr(args); - val = list_1_unchecked(sc, sc->nil); - push_stack_no_let_no_code(sc, OP_GC_PROTECT, val); - len = vector_length(vec); - for (s7_int i = 0; i < len; i++) - { - s7_pointer z = fp(sc, vector_getter(vec)(sc, vec, i)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - } - unstack(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }} - - sc->z = make_iterators(sc, sc->map_symbol, args); - val1 = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); - iter_list = sc->z; - old_args = sc->args; - push_stack_no_let(sc, OP_GC_PROTECT, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */ - sc->z = sc->unused; - while (true) - { - s7_pointer z; - for (s7_pointer x = iter_list, y = cdr(val1); is_pair(x); x = cdr(x), y = cdr(y)) - { - set_car(y, s7_iterate(sc, car(x))); - if (iterator_is_at_end(car(x))) - { - unstack(sc); /* free_cell(sc, car(x)); */ /* 16-Jan-19 iterator in circular list -- see s7test */ - sc->args = T_Pos(old_args); /* can be # */ - return(proper_list_reverse_in_place(sc, car(val))); - }} - z = func(sc, cdr(val1)); /* multiple-values? values is unsafe, but s7_values used externally and claims to be safe? */ /* func = c_function_call(f) */ - if (z != sc->no_value) - set_car(val, cons(sc, z, car(val))); - }} - - else /* not safe procedure */ - if ((f == global_value(sc->values_symbol)) && - (len == 1) && - (!has_methods(cadr(args)))) /* iterator should be ok here -- object_to_list can handle it */ - { - p = object_to_list(sc, cadr(args)); - if (p != cadr(args)) - return(p); - } - break; - - case T_CLOSURE: - case T_CLOSURE_STAR: - { - int32_t fargs = (is_closure(f)) ? closure_arity_to_int(sc, f) : closure_star_arity_to_int(sc, f); - if ((len == 1) && - (fargs == 1) && - (!is_constant_symbol(sc, (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : car(closure_args(f))))) - { - if (got_nil) return(sc->nil); - if (is_closure_star(f)) - return(g_map_closure(sc, f, cadr(args))); - - /* don't go to OP_MAP_2 here! It assumes no recursion */ - sc->z = (!is_iterator(cadr(args))) ? s7_make_iterator(sc, cadr(args)) : cadr(args); - push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - symbol_increment_ctr(car(closure_args(f))); - return(sc->nil); - } - if (((fargs >= 0) && (fargs < len)) || - ((is_closure(f)) && (abs(fargs) > len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); - if (got_nil) return(sc->nil); - } - break; - - case T_C_OBJECT: - /* args if sc->args (plist + c_object) can be clobbered here by s7_is_aritable, so we need to protect it */ - args = copy_proper_list(sc, args); - sc->temp10 = args; - - default: - if (!is_applicable(f)) - return(method_or_bust(sc, f, sc->map_symbol, args, something_applicable_string, 1)); - if ((!is_pair(f)) && - (!s7_is_aritable(sc, f, len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~A argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); - if (got_nil) return(sc->nil); - break; - } - - sc->z = make_iterators(sc, sc->map_symbol, args); - push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - return(sc->nil); -} - -static bool op_map(s7_scheme *sc) -{ - s7_pointer iterators = counter_list(sc->args); - sc->x = sc->nil; /* can't use preset args list here (as in for-each): (map list '(a b c)) */ - for (s7_pointer y = iterators; is_pair(y); y = cdr(y)) - { - s7_pointer x = s7_iterate(sc, car(y)); - if (iterator_is_at_end(car(y))) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(sc->args)); - free_cell(sc, sc->args); /* not sc->args = sc->nil; */ - return(true); - } - sc->x = cons(sc, x, sc->x); - } - sc->x = proper_list_reverse_in_place(sc, sc->x); - push_stack_direct(sc, OP_MAP_GATHER); - sc->args = sc->x; - sc->x = sc->unused; - if (needs_copied_args(sc->code)) - sc->args = copy_proper_list(sc, sc->args); - return(false); -} - -static bool op_map_1(s7_scheme *sc) -{ - s7_pointer args = sc->args, code = sc->code; - s7_pointer p = counter_list(args); - s7_pointer x = s7_iterate(sc, p); - - if (iterator_is_at_end(p)) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(args)); - free_cell(sc, sc->args); /* not sc->args = sc->nil; */ - return(true); - } - push_stack_direct(sc, OP_MAP_GATHER_1); - if (counter_capture(args) != sc->capture_let_counter) - { - sc->curlet = inline_make_let_with_slot(sc, closure_let(code), car(closure_args(code)), x); - counter_set_let(args, sc->curlet); - counter_set_slots(args, let_slots(sc->curlet)); - counter_set_capture(args, sc->capture_let_counter); - } - else - { - /* the counter_slots field saves the original local let slot(s) representing the function - * argument. If the function has internal defines, they get added to the front of the - * slots list, but update_let_with_slot (maybe stupidly) assumes only the one original - * slot exists when it updates its symbol_id from the (possibly changed) let_id. So, - * a subsequent reference to the parameter name causes "unbound variable", or a segfault - * if the check has been optimized away. I think each function call should start with - * the original let slots, so counter_slots saves that pointer, and resets it here. - */ - let_set_slots(counter_let(args), counter_slots(args)); - sc->curlet = update_let_with_slot(sc, counter_let(args), x); - } - sc->code = T_Pair(closure_body(code)); - return(false); -} - -static bool op_map_2(s7_scheme *sc) /* possibly inline lg */ -{ - s7_pointer x, c = sc->args, code = sc->code; - s7_pointer p = counter_list(c); - if (!is_pair(p)) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(c)); - free_cell(sc, sc->args); /* not sc->args = sc->nil; */ - return(true); - } - x = car(p); - counter_set_list(c, cdr(p)); - - if (sc->cur_op == OP_MAP_GATHER_3) - { - closure_set_map_list(code, cdr(closure_map_list(code))); - /* this depends on code (the function) being non-recursive, else closure_setter gets stepped on */ - if (closure_map_list(code) == counter_list(c)) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(c)); - free_cell(sc, c); /* not sc->args = sc->nil; */ - return(true); - } - push_stack_direct(sc, OP_MAP_GATHER_2); - } - else push_stack_direct(sc, OP_MAP_GATHER_3); - - if (counter_capture(c) != sc->capture_let_counter) - { - sc->curlet = inline_make_let_with_slot(sc, closure_let(code), car(closure_args(code)), x); - counter_set_let(c, sc->curlet); - counter_set_slots(c, let_slots(sc->curlet)); - counter_set_capture(c, sc->capture_let_counter); - } - else - { - let_set_slots(counter_let(c), counter_slots(c)); /* needed -- see comment under for-each above */ - sc->curlet = update_let_with_slot(sc, counter_let(c), x); - } - sc->code = car(closure_body(code)); - return(false); -} - -static s7_pointer revappend(s7_scheme *sc, s7_pointer a, s7_pointer b) -{ - /* (map (lambda (x) (if (odd? x) (apply values '(1 2 3)) (values))) (list 1 2 3 4)) is a bad case -- we have to copy the incoming list (in op_map_gather) */ - s7_pointer p = b; - if (is_not_null(a)) - { - a = copy_proper_list(sc, a); - do { - s7_pointer q = cdr(a); - set_cdr(a, p); - p = a; - a = q; - } while (is_pair(a)); - } - return(p); -} - -static Inline void inline_op_map_gather(s7_scheme *sc) /* called thrice in eval, cb lg map */ -{ - if (sc->value != sc->no_value) - { - if (is_multiple_value(sc->value)) - counter_set_result(sc->args, revappend(sc, multiple_value(sc->value), counter_result(sc->args))); - else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args))); - } -} - - -/* -------------------------------- multiple-values -------------------------------- */ -static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) -{ - int64_t top = current_stack_top(sc) - 1; /* stack_end - stack_start if negative, we're in big trouble */ - s7_pointer x; - if (SHOW_EVAL_OPS) - safe_print(fprintf(stderr, "%s[%d]: splice %s %s\n", __func__, __LINE__, - (top > 0) ? op_names[stack_op(sc->stack, top)] : "no stack!", display_80(args))); - if ((S7_DEBUGGING) && ((is_null(args)) || (is_null(cdr(args))))) fprintf(stderr, "%s: %s\n", __func__, display(args)); - - switch (stack_op(sc->stack, top)) - { - /* the normal case -- splice values into caller's args */ - case OP_EVAL_ARGS1: case OP_EVAL_ARGS2: case OP_EVAL_ARGS3: case OP_EVAL_ARGS4: - /* code = args yet to eval in order, args = evalled args reversed. - * it is not safe to simply reverse args and tack the current stacked args onto its (new) end, - * setting stacked args to cdr of reversed-args and returning car because the list (args) - * can be some variable's value in a macro expansion via ,@ and reversing it in place - * (all this to avoid consing), clobbers the variable's value. - */ - sc->w = args; - for (x = args; is_not_null(cdr(x)); x = cdr(x)) - stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top)); - sc->w = sc->unused; - return(car(x)); - - /* in the next set, the main evaluator branches blithely assume no multiple-values, - * and if it happens anyway, we go to a different branch here - */ - case OP_ANY_CLOSURE_NP_2: - stack_element(sc->stack, top) = (s7_pointer)OP_ANY_CLOSURE_NP_MV; - goto FP_MV; - - case OP_ANY_C_NP_2: - stack_element(sc->stack, top) = (s7_pointer)OP_ANY_C_NP_MV; - goto FP_MV; - - case OP_ANY_C_NP_1: case OP_ANY_CLOSURE_NP_1: - stack_element(sc->stack, top) = (s7_pointer)(stack_op(sc->stack, top) + 1); /* replace with mv version */ - - case OP_ANY_C_NP_MV: case OP_ANY_CLOSURE_NP_MV: - FP_MV: - if ((is_immutable(args)) || /* (let () (define (func) (with-output-to-string (lambda () (apply-values (write '(1 2)))))) (func) (func)) */ - (needs_copied_args(args))) - { - clear_needs_copied_args(args); - args = copy_proper_list(sc, args); - } - set_multiple_value(args); - return(args); - - case OP_SAFE_C_SSP_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SSP_MV; - return(args); - - case OP_SAFE_C_SP_1: case OP_SAFE_CONS_SP_1: case OP_SAFE_ADD_SP_1: case OP_SAFE_MULTIPLY_SP_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_SP_MV; - return(args); - - case OP_SAFE_C_PS_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PS_MV; - return(args); - - case OP_SAFE_C_PC_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PC_MV; - return(args); - - case OP_SAFE_C_PA_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PA_MV; - return(args); - - case OP_C_P_1: case OP_SAFE_C_P_1: - stack_element(sc->stack, top) = (s7_pointer)OP_C_P_MV; - return(args); - - case OP_C_AP_1: - stack_element(sc->stack, top) = (s7_pointer)OP_C_AP_MV; - /* sc->value = args; */ /* removed 29-Mar-22 -- seems redundant */ - return(args); - - case OP_SAFE_CLOSURE_P_1: case OP_CLOSURE_P_1: case OP_SAFE_CLOSURE_P_A_1: - case OP_SAFE_CLOSURE_AP_1: case OP_CLOSURE_AP_1: - case OP_SAFE_CLOSURE_PP_1: case OP_CLOSURE_PP_1: - case OP_SAFE_CLOSURE_PA_1: case OP_CLOSURE_PA_1: /* arity is 2, we have 2 args, this has to be an error (see optimize_closure_sym) */ - case OP_ANY_CLOSURE_3P_1: case OP_ANY_CLOSURE_3P_2: case OP_ANY_CLOSURE_3P_3: - case OP_ANY_CLOSURE_4P_1: case OP_ANY_CLOSURE_4P_2: case OP_ANY_CLOSURE_4P_3: case OP_ANY_CLOSURE_4P_4: - if (is_multiple_value(sc->value)) clear_multiple_value(sc->value); - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, too_many_arguments_string, stack_code(sc->stack, top), sc->value)); - - case OP_SAFE_C_PP_1: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PP_3_MV; - return(args); - - case OP_SAFE_C_PP_5: - stack_element(sc->stack, top) = (s7_pointer)OP_SAFE_C_PP_6_MV; - return(args); - - case OP_SAFE_C_3P_1: case OP_SAFE_C_3P_2: case OP_SAFE_C_3P_3: - stack_element(sc->stack, top) = (s7_pointer)(stack_op(sc->stack, top) + 3); - case OP_SAFE_C_3P_1_MV: case OP_SAFE_C_3P_2_MV: case OP_SAFE_C_3P_3_MV: - return(cons(sc, sc->unused, copy_proper_list(sc, args))); - - case OP_EVAL_ARGS5: - /* code = previous arg saved, args = ante-previous args reversed, we'll take value->code->args and reverse in args5 */ - if (is_null(args)) - return(sc->unspecified); - if (is_null(cdr(args))) - return(car(args)); - - stack_args(sc->stack, top) = cons(sc, stack_code(sc->stack, top), stack_args(sc->stack, top)); - for (x = args; is_not_null(cddr(x)); x = cdr(x)) - stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top)); - stack_code(sc->stack, top) = car(x); - return(cadr(x)); - - /* look for errors here rather than glomming up the set! and let code */ - case OP_SET_SAFE: /* symbol is sc->code after pop */ - case OP_SET1: - case OP_SET_FROM_LET_TEMP: /* (set! var (values 1 2 3)) */ - case OP_SET_FROM_SETTER: - syntax_error_with_caller_nr(sc, "set!: can't set ~A to ~S", 24, stack_code(sc->stack, top), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_SET_opSAq_P_1: case OP_SET_opSAAq_P_1: - syntax_error_nr(sc, "too many values to set! ~S", 26, set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LET1: /* (let ((var (values 1 2 3))) ...) */ - { - s7_pointer let_code, vars, sym, p = stack_args(sc->stack, top); - for (let_code = p; is_pair(cdr(let_code)); let_code = cdr(let_code)); - for (vars = caar(let_code); is_pair(cdr(p)); p = cdr(p), vars = cdr(vars)); - sym = caar(vars); - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, sym, set_ulist_1(sc, sc->values_symbol, args)); - /* stack_args: ((((x (values 1 2))) x)) in (let ((x (values 1 2))) x) - * (1 (((x 1) (y (values 1 2))) x)) in (let ((x 1) (y (values 1 2))) x) - */ - } - - case OP_LET_ONE_NEW_1: case OP_LET_ONE_P_NEW_1: - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, - opt2_sym(stack_code(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LET_ONE_OLD_1: case OP_LET_ONE_P_OLD_1: - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, - slot_symbol(let_slots(opt3_let(stack_code(sc->stack, top)))), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LET_STAR1: /* here caar(sc->code) is bound to sc->value */ - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_star_symbol, - caar(stack_code(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LETREC1: /* here sc->args is the slot about to receive a value */ - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_symbol, - slot_symbol(stack_args(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_LETREC_STAR1: - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_star_symbol, - slot_symbol(stack_args(sc->stack, top)), set_ulist_1(sc, sc->values_symbol, args)); - - case OP_AND_P1: - case OP_AND_SAFE_P_REST: /* from OP_AND_SAFE_P1 or P2 */ - for (x = args; is_not_null(cdr(x)); x = cdr(x)) - if (car(x) == sc->F) - return(sc->F); - return(car(x)); - - case OP_OR_P1: - for (x = args; is_not_null(cdr(x)); x = cdr(x)) - if (car(x) != sc->F) - return(car(x)); - return(car(x)); - - case OP_IF1: /* (if (values ...) ...) -- see s7.html at the end of the values writeup for explanation (we're following CL here) */ - case OP_IF_PP: case OP_IF_PPP: case OP_IF_PR: case OP_IF_PRR: - case OP_WHEN_PP: case OP_UNLESS_PP: case OP_WITH_LET1: - case OP_CASE_G_G: case OP_CASE_G_S: case OP_CASE_E_G: case OP_CASE_E_S: case OP_CASE_I_S: - case OP_COND1: case OP_COND1_SIMPLE: - return(car(args)); - - case OP_IF_PN: /* (if|when (not (values...)) ...) as opposed to (if|unless (values...)...) which follows CL and drops trailing values */ - syntax_error_nr(sc, "too many arguments to not: ~S", 29, set_ulist_1(sc, sc->values_symbol, args)); - - case OP_DYNAMIC_UNWIND: case OP_DYNAMIC_UNWIND_PROFILE: - { - s7_pointer old_value = sc->value; - bool mv = is_multiple_value(args); - if (mv) clear_multiple_value(args); - sc->value = cons(sc, sc->values_symbol, args); - dynamic_unwind(sc, stack_code(sc->stack, top), stack_args(sc->stack, top)); /* position (curlet), this applies code to sc->value */ - sc->value = old_value; - if (mv) set_multiple_value(args); - sc->stack_end -= 4; /* either op is possible I think */ - return(splice_in_values(sc, args)); - } - - case OP_BARRIER: - pop_stack(sc); - return(splice_in_values(sc, args)); - - case OP_GC_PROTECT: - sc->stack_end -= 4; - return(splice_in_values(sc, args)); - - case OP_BEGIN_HOOK: case OP_BEGIN_NO_HOOK: case OP_BEGIN_2_UNCHECKED: - case OP_SIMPLE_DO_STEP: case OP_DOX_STEP_O: case OP_DOX_STEP: - /* here we have a values call with nothing to splice into. So flush it... - * otherwise the multiple-values bit gets set in some innocent list and never unset: - * (let ((x '((1 2)))) (eval `(apply apply values x)) x) -> ((values 1 2)) - * other cases: (+ 1 (begin (values 5 6) (values 2 3)) 4) -> 10 -- the (5 6) is dropped - * (let () (values 1 2 3) 4) but (+ (let () (values 1 2))) -> 3 - */ - return(args); - - case OP_DEACTIVATE_GOTO: /* (+ (call-with-exit (lambda (ret) (values 1 2 3)))) */ - call_exit_active(stack_args(sc->stack, top)) = false; - - case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: case OP_CATCH_ALL: /* (+ (catch #t (lambda () (values 3 4)) (lambda args args))) */ - pop_stack(sc); - return(splice_in_values(sc, args)); - - case OP_EXPANSION: - /* we get here if a reader-macro (define-expansion) returns multiple values. - * these need to be read in order into the current reader lists (we'll assume OP_READ_LIST is next in the stack. - * and that it will be expecting the next arg entry in sc->value). - */ - top -= 4; - for (x = args; is_not_null(cdr(x)); x = cdr(x)) - stack_args(sc->stack, top) = cons(sc, car(x), stack_args(sc->stack, top)); - pop_stack(sc); /* need GC protection in loop above, so do this afterwards */ - return(car(x)); /* sc->value from OP_READ_LIST point of view */ - - case OP_EVAL_DONE: - if (stack_op(sc->stack, (top - 4)) == OP_NO_VALUES) - error_nr(sc, sc->error_symbol, - set_elist_1(sc, wrap_string(sc, "function-port should not return multiple-values", 47))); - stack_element(sc->stack, top) = (s7_pointer)OP_SPLICE_VALUES; /* tricky -- continue from eval_done with the current splice */ - stack_args(sc->stack, top) = args; - push_stack_op(sc, OP_EVAL_DONE); - return(args); - - default: - /* fprintf(stderr, "%s[%d]: splice on: %s\n", __func__, __LINE__, op_names[stack_op(sc->stack, top)]); */ - break; - } - - /* let it meander back up the call chain until someone knows where to splice it - * the is_immutable check protects against setting the multiple value bit on (say) sc->hash_table_signature - */ - if (is_immutable(args)) - args = copy_proper_list(sc, args); /* copy needed else (apply values x) where x is a list can leave the mv bit on for x's value */ - if (needs_copied_args(args)) - { - clear_needs_copied_args(args); - args = copy_proper_list(sc, args); - } - set_multiple_value(args); - return(args); -} - - -/* -------------------------------- values -------------------------------- */ -s7_pointer s7_values(s7_scheme *sc, s7_pointer args) -{ - #define H_values "(values obj ...) splices its arguments into whatever list holds it (its 'continuation')" - #define Q_values s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T) - - if (is_null(args)) /* ((lambda () (let ((x 1)) (set! x (boolean? (values)))))) */ - return(sc->no_value); - if (is_null(cdr(args))) - return(car(args)); - set_needs_copied_args(args); - /* copy needed: see s7test (test `(,x ,@y ,x) '(3 a b c 3)) -> (append (list-values x (apply-values y)) x), and apply_values calls s7_values directly */ - return(splice_in_values(sc, args)); -} - -#define g_values s7_values - -static s7_pointer values_p(s7_scheme *sc) {return(sc->no_value);} -static s7_pointer values_p_p(s7_scheme *unused_sc, s7_pointer p) {return(p);} - -static s7_pointer values_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr, bool unused_ops) -{ - if (args > 1) return(sc->values_uncopied); /* splice_in_values */ - return(f); -} - -bool s7_is_multiple_value(s7_pointer obj) {return(is_multiple_value(obj));} - - -/* -------------------------------- list-values -------------------------------- */ -static s7_pointer splice_out_values(s7_scheme *sc, s7_pointer args) -{ - s7_pointer tp; - while (car(args) == sc->no_value) {args = cdr(args); if (is_null(args)) return(sc->nil);} - tp = list_1(sc, car(args)); - sc->temp8 = tp; - for (s7_pointer p = cdr(args), np = tp; is_pair(p); p = cdr(p)) - if (car(p) != sc->no_value) - { - set_cdr(np, list_1(sc, car(p))); - np = cdr(np); - } - sc->temp8 = sc->unused; - return(tp); -} - -static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) -{ - #define H_list_values "(list-values ...) returns its arguments in a list (internal to quasiquote)" - #define Q_list_values s7_make_circular_signature(sc, 1, 2, sc->is_list_symbol, sc->T) - - /* list-values can't be replaced by list(-n) because (list-values (values)) -> () and anything can be # (see s7test) */ - /* but (list-values ) will complain or get into an infinite recursion in copy_tree, so it should not use copy_tree */ - - s7_pointer x; - bool checked = false; - for (x = args; is_pair(x); x = cdr(x)) - if (is_pair(car(x))) - { - if (is_checked(car(x))) - checked = true; - } - else - if (car(x) == sc->no_value) /* unchecked_car|cdr unrolled here is not faster */ - break; - if (is_null(x)) - { - if (!checked) /* (!tree_has_definers(sc, args)) seems to work, reduces copy_tree calls slightly, but costs more than it saves in tgen */ - { - for (s7_pointer p = args; is_pair(p); p = cdr(p)) /* embedded list can be immutable, so we need to copy (sigh) */ - if (is_immutable(p)) - return(copy_proper_list(sc, args)); - return(args); - } - sc->temp5 = args; - check_free_heap_size(sc, 8192); - if (sc->safety > NO_SAFETY) - { - if (!tree_is_cyclic(sc, args)) /* we're copying to clear optimizations I think, and a cyclic list here can't be optimized */ - args = cons_unchecked(sc, /* since list-values is a safe function, args can be immutable, which should not be passed through the copy */ - (is_unquoted_pair(car(args))) ? copy_tree_with_type(sc, car(args)) : car(args), - (is_unquoted_pair(cdr(args))) ? copy_tree_with_type(sc, cdr(args)) : cdr(args)); - } - else args = copy_tree(sc, args); /* not copy_any_list here -- see comment below */ - sc->temp5 = sc->unused; - return(args); - } - /* if a macro expands into a recursive function with a macro argument as its body (or reasonable facsimile thereof), - * and the safety (as in safe_closure) of the body changes from safe to unsafe, then (due to the checked bits - * protecting against cycles in optimize_expression|syntax), the possible safe_closure call will not be fixed, - * the safe_closure's assumption about the saved local let will be violated, and we'll get " unbound" (see tgen.scm). - * clear_all_optimizations assumes its argument has no cycles, and automatically calling copy_tree slows - * everything down intolerably, so if the checked bit is on in a macro expansion, that means we're re-expanding this macro, - * and therefore have to copy the tree. But isn't that only the case if the macro expands into closures? - */ - return(splice_out_values(sc, args)); -} - -static s7_pointer g_simple_list_values(s7_scheme *sc, s7_pointer args) -{ - /* if just (code-)constant/symbol, symbol->pair won't be checked (not optimized/re-expanded code), but might be no-values */ - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - if (car(p) == sc->no_value) - return(splice_out_values(sc, args)); - if (is_immutable(args)) - return(copy_proper_list(sc, args)); - return(args); -} - -static s7_pointer list_values_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr, bool unused_ops) -{ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && (caar(p) != sc->quote_symbol)) - return(f); - return(sc->simple_list_values); -} - - -/* -------------------------------- apply-values -------------------------------- */ -static s7_pointer g_apply_values(s7_scheme *sc, s7_pointer args) -{ - #define H_apply_values "(apply-values var) applies values to var. This is an internal function." - #define Q_apply_values s7_make_signature(sc, 2, sc->T, sc->is_list_symbol) - s7_pointer x; - /* apply-values takes 1 arg: ,@a -> (apply-values a) */ - if (is_null(args)) - return(sc->no_value); - x = car(args); - if (is_null(x)) - return(sc->no_value); - if (!s7_is_proper_list(sc, x)) - apply_list_error_nr(sc, args); - return(g_values(sc, x)); -} - -/* (apply values ...) replaces (unquote_splicing ...) - * (define-macro (hi a) `(+ 1 ,a) == (list '+ 1 a) - * (define-macro (hi a) `(+ 1 ,@a) == (list '+ 1 (apply values a)) - * - * this is not the same as CL's quasiquote; for example: - * [1]> (let ((a 1) (b 2)) `(,a ,@b)) -> '(1 . 2) but in s7 this is an error. - * also in CL the target of ,@ can apparently be a circular list - * one surprising twist: write/display return their first argument directly, so (apply-values (write `(+ x 1))) is the same as (apply-values `(+ x 1)) - */ - - -/* -------------------------------- quasiquote -------------------------------- */ -static bool is_simple_code(s7_scheme *sc, s7_pointer form) -{ - /* if nested with quasiquotes say 20 levels, this is really slow, but to tag intermediate results burns up 2 type bits */ - s7_pointer tmp, slow; - for (tmp = form, slow = form; is_pair(tmp); tmp = cdr(tmp), slow = cdr(slow)) - { - if (is_pair(car(tmp))) - { - if (!is_simple_code(sc, car(tmp))) - return(false); - } - else - if (car(tmp) == sc->unquote_symbol) - return(false); - tmp = cdr(tmp); - if (!is_pair(tmp)) return(is_null(tmp)); - if (tmp == slow) return(false); - if (is_pair(car(tmp))) - { - if (!is_simple_code(sc, car(tmp))) - return(false); - } - else - if (car(tmp) == sc->unquote_symbol) - return(false); - } - return(is_null(tmp)); -} - -/* since the reader expands unquote et al, and the printer does not unexpand them, the standard scheme quine in s7 is: - * ((lambda (x) (list-values x (list-values 'quote x))) '(lambda (x) (list-values x (list-values 'quote x)))) - * but that depends on the "p" in repl... - */ - -static s7_pointer g_quasiquote_1(s7_scheme *sc, s7_pointer form, bool check_cycles) -{ - #define H_quasiquote "(quasiquote arg) is the same as `arg. If arg is a list, it can contain \ -comma (\"unquote\") and comma-atsign (\"apply values\") to pre-evaluate portions of the list. \ -unquoted expressions are evaluated and plugged into the list, apply-values evaluates the expression \ -and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -> (1 2 3 4)." - - if (!is_pair(form)) - { - if (is_normal_symbol(form)) - return(list_2(sc, (is_global(sc->quote_symbol)) ? sc->quote_symbol : initial_value(sc->quote_symbol), form)); - /* things that evaluate to themselves don't need to be quoted */ - return(form); - } - if (car(form) == sc->unquote_symbol) - { - if (!is_pair(cdr(form))) /* (unquote) or (unquote . 1) */ - { - if (is_null(cdr(form))) - syntax_error_nr(sc, "unquote: no argument, ~S", 24, form); - syntax_error_nr(sc, "unquote: stray dot, ~S", 22, form); - } - if (is_not_null(cddr(form))) - syntax_error_nr(sc, "unquote: too many arguments, ~S", 31, form); - return(cadr(form)); - } - - /* it's a list, so return the list with each element handled as above. - * we try to support dotted lists which makes the code much messier. - * if no element of the list is a list or unquote, just return the original quoted - */ - if (((check_cycles) && (tree_is_cyclic(sc, form))) || - (is_simple_code(sc, form))) - /* we can't lookup sc->quote_symbol because this gets called in op_read_quasiquote (at read-time), and sc->curlet can be junk in that context */ - return(list_2(sc, (is_global(sc->quote_symbol)) ? sc->quote_symbol : initial_value(sc->quote_symbol), form)); - - { - s7_int i; - s7_pointer orig, bq, old_scw = sc->w; /* very often, sc->w is in use here */ - bool dotted = false; - s7_int len = s7_list_length(sc, form); - if (len < 0) - { - len = -len; - dotted = true; - } - s7_gc_protect_via_stack(sc, sc->w); - - check_free_heap_size(sc, len + 1); - sc->w = sc->nil; - for (i = 0; i <= len; i++) - sc->w = cons_unchecked(sc, sc->nil, sc->w); - - set_car(sc->w, sc->list_values_symbol); - if (!dotted) - { - for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq)) - if ((is_pair(cdr(orig))) && /* this was is_pair(orig) which seems to be always the case */ - (cadr(orig) == sc->unquote_symbol)) /* `(1 . ,(+ 1 1)) -> '(1 unquote (+ 1 1)) -> '(1 . 2) etc */ - { - if (!is_pair(cddr(orig))) - { - sc->w = old_scw; - unstack(sc); - syntax_error_nr(sc, "unquote: no argument, ~S", 24, form); - } - set_car(bq, g_quasiquote_1(sc, car(orig), false)); - set_cdr(bq, sc->nil); - sc->w = list_3(sc, sc->qq_append_symbol, sc->w, caddr(orig)); /* `(f . ,(string-append "h" "i")) */ - break; - } - else set_car(bq, g_quasiquote_1(sc, car(orig), false)); - } - else /* `(1 2 . 3) */ - { - len--; - for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq)) - set_car(bq, g_quasiquote_1(sc, car(orig), false)); - set_car(bq, g_quasiquote_1(sc, car(orig), false)); - sc->w = list_3(sc, sc->qq_append_symbol, sc->w, g_quasiquote_1(sc, cdr(orig), false)); - /* quasiquote might quote a symbol in cdr(orig), so it's not completely pointless */ - } - bq = sc->w; - sc->w = old_scw; - unstack(sc); - return(bq); - } -} - -static s7_pointer g_quasiquote(s7_scheme *sc, s7_pointer args) -{ - /* this is for explicit quasiquote support, not the backquote stuff in macros - * but it is problematic. g_quasiquote_1 above expands (for example) `(+ ,x) into (list (quote +) x), - * so (multiple-value-bind (quote) quasiquote `(+ ,x)) expands to ((lambda (quote) (list '+ x)) quasiquote) - * which is an infinite loop. Guile says syntax error (because it thinks "quote" can't be a parameter name, I think). - */ - return(g_quasiquote_1(sc, car(args), true)); -} - -static s7_pointer g_qq_append(s7_scheme *sc, s7_pointer args) -{ - #define H_qq_append "[list*]: CL list* (I think) for quasiquote's internal use" - #define Q_qq_append s7_make_circular_signature(sc, 0, 1, sc->T) - s7_pointer a = car(args), b = cadr(args); - s7_pointer p, tp, np; - if (is_null(a)) return(b); - p = cdr(a); - if (is_null(p)) return(cons(sc, car(a), b)); - tp = list_1(sc, car(a)); - s7_gc_protect_via_stack(sc, tp); - for (np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - set_cdr(np, list_1(sc, car(p))); - set_cdr(np, b); - unstack(sc); - return(tp); -} - - -/* -------------------------------- choosers -------------------------------- */ -static s7_pointer make_function_with_class(s7_scheme *sc, s7_pointer cls, const char *name, s7_function f, - int32_t required_args, int32_t optional_args, bool rest_arg) -{ - s7_pointer uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL); - s7_function_set_class(sc, uf, cls); - c_function_signature(uf) = c_function_signature(cls); - return(uf); -} - -static s7_pointer make_unsafe_function_with_class(s7_scheme *sc, s7_pointer cls, const char *name, s7_function f, - int32_t required_args, int32_t optional_args, bool rest_arg) -{ - s7_pointer uf = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, NULL); /* was s7_make_safe_function! 14-Dec-20 */ - s7_function_set_class(sc, uf, cls); - c_function_signature(uf) = c_function_signature(cls); - return(uf); -} - -static s7_pointer set_function_chooser(s7_pointer sym, s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr, bool ops)) -{ - s7_pointer f = global_value(sym); - c_function_chooser(f) = chooser; - return(f); -} - -static void init_choosers(s7_scheme *sc) -{ - s7_pointer f; - - /* + */ - f = set_function_chooser(sc->add_symbol, add_chooser); - sc->add_class = c_function_class(f); - sc->add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false); - sc->add_3 = make_function_with_class(sc, f, "+", g_add_3, 3, 0, false); - sc->add_1x = make_function_with_class(sc, f, "+", g_add_1x, 2, 0, false); - sc->add_x1 = make_function_with_class(sc, f, "+", g_add_x1, 2, 0, false); - sc->add_i_random = make_function_with_class(sc, f, "+", g_add_i_random, 2, 0, false); - sc->add_2_ff = make_function_with_class(sc, f, "+", g_add_2_ff, 2, 0, false); - sc->add_2_ii = make_function_with_class(sc, f, "+", g_add_2_ii, 2, 0, false); - sc->add_2_if = make_function_with_class(sc, f, "+", g_add_2_if, 2, 0, false); - sc->add_2_fi = make_function_with_class(sc, f, "+", g_add_2_fi, 2, 0, false); - sc->add_2_xi = make_function_with_class(sc, f, "+", g_add_2_xi, 2, 0, false); - sc->add_2_ix = make_function_with_class(sc, f, "+", g_add_2_ix, 2, 0, false); - sc->add_2_fx = make_function_with_class(sc, f, "+", g_add_2_fx, 2, 0, false); - sc->add_2_xf = make_function_with_class(sc, f, "+", g_add_2_xf, 2, 0, false); - - /* - */ - f = set_function_chooser(sc->subtract_symbol, subtract_chooser); - sc->subtract_class = c_function_class(f); - sc->subtract_1 = make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false); - sc->subtract_2 = make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false); - sc->subtract_3 = make_function_with_class(sc, f, "-", g_subtract_3, 3, 0, false); - sc->subtract_x1 = make_function_with_class(sc, f, "-", g_subtract_x1, 2, 0, false); - sc->subtract_2f = make_function_with_class(sc, f, "-", g_subtract_2f, 2, 0, false); - sc->subtract_f2 = make_function_with_class(sc, f, "-", g_subtract_f2, 2, 0, false); - - /* * */ - f = set_function_chooser(sc->multiply_symbol, multiply_chooser); - sc->multiply_class = c_function_class(f); - sc->multiply_2 = make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false); - sc->mul_2_ff = make_function_with_class(sc, f, "*", g_mul_2_ff, 2, 0, false); - sc->mul_2_ii = make_function_with_class(sc, f, "*", g_mul_2_ii, 2, 0, false); - sc->mul_2_if = make_function_with_class(sc, f, "*", g_mul_2_if, 2, 0, false); - sc->mul_2_fi = make_function_with_class(sc, f, "*", g_mul_2_fi, 2, 0, false); - sc->mul_2_xi = make_function_with_class(sc, f, "*", g_mul_2_xi, 2, 0, false); - sc->mul_2_ix = make_function_with_class(sc, f, "*", g_mul_2_ix, 2, 0, false); - sc->mul_2_fx = make_function_with_class(sc, f, "*", g_mul_2_fx, 2, 0, false); - sc->mul_2_xf = make_function_with_class(sc, f, "*", g_mul_2_xf, 2, 0, false); - - /* / */ - f = set_function_chooser(sc->divide_symbol, divide_chooser); - sc->invert_1 = make_function_with_class(sc, f, "/", g_invert_1, 1, 0, false); - sc->divide_2 = make_function_with_class(sc, f, "/", g_divide_2, 2, 0, false); - sc->invert_x = make_function_with_class(sc, f, "/", g_invert_x, 2, 0, false); - sc->divide_by_2 = make_function_with_class(sc, f, "/", g_divide_by_2, 2, 0, false); - - /* = */ - f = set_function_chooser(sc->num_eq_symbol, num_eq_chooser); - sc->num_eq_class = c_function_class(f); - sc->num_eq_2 = make_function_with_class(sc, f, "=", g_num_eq_2, 2, 0, false); - sc->num_eq_xi = make_function_with_class(sc, f, "=", g_num_eq_xi, 2, 0, false); - sc->num_eq_ix = make_function_with_class(sc, f, "=", g_num_eq_ix, 2, 0, false); - - /* min */ - f = set_function_chooser(sc->min_symbol, min_chooser); - sc->min_2 = make_function_with_class(sc, f, "min", g_min_2, 2, 0, false); - sc->min_3 = make_function_with_class(sc, f, "min", g_min_3, 3, 0, false); - - /* max */ - f = set_function_chooser(sc->max_symbol, max_chooser); - sc->max_2 = make_function_with_class(sc, f, "max", g_max_2, 2, 0, false); - sc->max_3 = make_function_with_class(sc, f, "max", g_max_3, 3, 0, false); - - /* < */ - f = set_function_chooser(sc->lt_symbol, less_chooser); - sc->less_xi = make_function_with_class(sc, f, "<", g_less_xi, 2, 0, false); - sc->less_x0 = make_function_with_class(sc, f, "<", g_less_x0, 2, 0, false); - sc->less_xf = make_function_with_class(sc, f, "<", g_less_xf, 2, 0, false); - sc->less_2 = make_function_with_class(sc, f, "<", g_less_2, 2, 0, false); - - /* > */ - f = set_function_chooser(sc->gt_symbol, greater_chooser); - sc->greater_xi = make_function_with_class(sc, f, ">", g_greater_xi, 2, 0, false); - sc->greater_xf = make_function_with_class(sc, f, ">", g_greater_xf, 2, 0, false); - sc->greater_2 = make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false); - - /* <= */ - f = set_function_chooser(sc->leq_symbol, leq_chooser); - sc->leq_xi = make_function_with_class(sc, f, "<=", g_leq_xi, 2, 0, false); - sc->leq_2 = make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false); - sc->leq_ixx = make_function_with_class(sc, f, "<=", g_leq_ixx, 3, 0, false); - - /* >= */ - f = set_function_chooser(sc->geq_symbol, geq_chooser); - sc->geq_xi = make_function_with_class(sc, f, ">=", g_geq_xi, 2, 0, false); - sc->geq_xf = make_function_with_class(sc, f, ">=", g_geq_xf, 2, 0, false); - sc->geq_2 = make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false); - - /* log */ - f = set_function_chooser(sc->log_symbol, log_chooser); - sc->int_log2 = make_function_with_class(sc, f, "log", g_int_log2, 2, 0, false); - - /* random */ - f = set_function_chooser(sc->random_symbol, random_chooser); - sc->random_1 = make_function_with_class(sc, f, "random", g_random_1, 1, 0, false); - sc->random_i = make_function_with_class(sc, f, "random", g_random_i, 1, 0, false); - sc->random_f = make_function_with_class(sc, f, "random", g_random_f, 1, 0, false); - - /* defined? */ - f = set_function_chooser(sc->is_defined_symbol, is_defined_chooser); - sc->is_defined_in_rootlet = make_function_with_class(sc, f, "defined?", g_is_defined_in_rootlet, 2, 0, false); - - /* char=? */ - f = set_function_chooser(sc->char_eq_symbol, char_equal_chooser); - sc->simple_char_eq = make_function_with_class(sc, f, "char=?", g_simple_char_eq, 2, 0, false); - sc->char_equal_2 = make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0, false); - - /* char>? */ - f = set_function_chooser(sc->char_gt_symbol, char_greater_chooser); - sc->char_greater_2 = make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0, false); - - /* charchar_lt_symbol, char_less_chooser); - sc->char_less_2 = make_function_with_class(sc, f, "charread_char_symbol, read_char_chooser); - sc->read_char_1 = make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0, false); - - /* char-position */ - f = set_function_chooser(sc->char_position_symbol, char_position_chooser); - sc->char_position_csi = make_function_with_class(sc, f, "char-position", g_char_position_csi, 2, 1, false); - - /* string=? */ - f = set_function_chooser(sc->string_eq_symbol, string_equal_chooser); - sc->string_equal_2 = make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0, false); - sc->string_equal_2c = make_function_with_class(sc, f, "string=?", g_string_equal_2c, 2, 0, false); - - /* substring */ - sc->substring_uncopied = s7_make_safe_function(sc, "substring", g_substring_uncopied, 2, 1, false, NULL); - s7_function_set_class(sc, sc->substring_uncopied, global_value(sc->substring_symbol)); - - /* string>? */ - f = set_function_chooser(sc->string_gt_symbol, string_greater_chooser); - sc->string_greater_2 = make_function_with_class(sc, f, "string>?", g_string_greater_2, 2, 0, false); - - /* stringstring_lt_symbol, string_less_chooser); - sc->string_less_2 = make_function_with_class(sc, f, "stringstring_symbol, string_chooser); - sc->string_c1 = make_function_with_class(sc, f, "string", g_string_c1, 1, 0, false); - - /* string-append */ - f = set_function_chooser(sc->string_append_symbol, string_append_chooser); - sc->string_append_2 = make_function_with_class(sc, f, "string-append", g_string_append_2, 2, 0, false); - - /* string-ref et al */ - set_function_chooser(sc->string_ref_symbol, string_substring_chooser); - set_function_chooser(sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here */ - set_function_chooser(sc->string_to_keyword_symbol, string_substring_chooser); - set_function_chooser(sc->string_downcase_symbol, string_substring_chooser); - set_function_chooser(sc->string_upcase_symbol, string_substring_chooser); - /* if the function assumes a null-terminated string, substring needs to return a copy */ -#if (!WITH_PURE_S7) - set_function_chooser(sc->string_length_symbol, string_substring_chooser); - set_function_chooser(sc->string_to_list_symbol, string_substring_chooser); -#endif - set_function_chooser(sc->string_copy_symbol, string_copy_chooser); - - /* symbol->string */ - f = global_value(sc->symbol_to_string_symbol); - sc->symbol_to_string_uncopied = s7_make_safe_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, NULL); - s7_function_set_class(sc, sc->symbol_to_string_uncopied, f); - - /* display */ - f = set_function_chooser(sc->display_symbol, display_chooser); - sc->display_f = make_function_with_class(sc, f, "display", g_display_f, 2, 0, false); - sc->display_2 = make_function_with_class(sc, f, "display", g_display_2, 2, 0, false); - - /* vector */ - f = set_function_chooser(sc->vector_symbol, vector_chooser); - sc->vector_2 = make_function_with_class(sc, f, "vector", g_vector_2, 2, 0, false); - sc->vector_3 = make_function_with_class(sc, f, "vector", g_vector_3, 3, 0, false); - - /* vector-ref */ - f = set_function_chooser(sc->vector_ref_symbol, vector_ref_chooser); - sc->vector_ref_2 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_2, 2, 0, false); - sc->vector_ref_3 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_3, 3, 0, false); - - /* vector-set! */ - f = set_function_chooser(sc->vector_set_symbol, vector_set_chooser); - sc->vector_set_3 = make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3, 0, false); - sc->vector_set_4 = make_function_with_class(sc, f, "vector-set!", g_vector_set_4, 4, 0, false); - - /* float-vector-ref */ - f = set_function_chooser(sc->float_vector_ref_symbol, float_vector_ref_chooser); - sc->fv_ref_2 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_2, 2, 0, false); - sc->fv_ref_3 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_3, 3, 0, false); - - /* float-vector-set */ - f = set_function_chooser(sc->float_vector_set_symbol, float_vector_set_chooser); - sc->fv_set_3 = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_3, 3, 0, false); - sc->fv_set_unchecked = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_unchecked, 3, 0, false); - - /* int-vector-ref */ - f = set_function_chooser(sc->int_vector_ref_symbol, int_vector_ref_chooser); - sc->iv_ref_2 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_2, 2, 0, false); - sc->iv_ref_3 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_3, 3, 0, false); - - /* int-vector-set */ - f = set_function_chooser(sc->int_vector_set_symbol, int_vector_set_chooser); - sc->iv_set_3 = make_function_with_class(sc, f, "int-vector-set!", g_iv_set_3, 3, 0, false); - - /* byte-vector-ref */ - f = set_function_chooser(sc->byte_vector_ref_symbol, byte_vector_ref_chooser); - sc->bv_ref_2 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_2, 2, 0, false); - sc->bv_ref_3 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_3, 3, 0, false); - - /* byte-vector-set */ - f = set_function_chooser(sc->byte_vector_set_symbol, byte_vector_set_chooser); - sc->bv_set_3 = make_function_with_class(sc, f, "byte-vector-set!", g_bv_set_3, 3, 0, false); - - /* list-set! */ - f = set_function_chooser(sc->list_set_symbol, list_set_chooser); - sc->list_set_i = make_function_with_class(sc, f, "list-set!", g_list_set_i, 3, 0, false); - - /* hash-table-ref */ - f = set_function_chooser(sc->hash_table_ref_symbol, hash_table_ref_chooser); - sc->hash_table_ref_2 = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_2, 2, 0, false); - - /* hash-table-set! */ - set_function_chooser(sc->hash_table_set_symbol, hash_table_set_chooser); - - /* hash-table */ - f = set_function_chooser(sc->hash_table_symbol, hash_table_chooser); - sc->hash_table_2 = make_function_with_class(sc, f, "hash-table", g_hash_table_2, 2, 0, false); - - /* format */ - f = set_function_chooser(sc->format_symbol, format_chooser); - sc->format_f = make_function_with_class(sc, f, "format", g_format_f, 1, 0, true); - sc->format_no_column = make_function_with_class(sc, f, "format", g_format_no_column, 1, 0, true); - sc->format_just_control_string = make_function_with_class(sc, f, "format", g_format_just_control_string, 2, 0, false); - sc->format_as_objstr = make_function_with_class(sc, f, "format", g_format_as_objstr, 3, 0, true); - - /* list */ - f = set_function_chooser(sc->list_symbol, list_chooser); - sc->list_0 = make_function_with_class(sc, f, "list", g_list_0, 0, 0, false); - sc->list_1 = make_function_with_class(sc, f, "list", g_list_1, 1, 0, false); - sc->list_2 = make_function_with_class(sc, f, "list", g_list_2, 2, 0, false); - sc->list_3 = make_function_with_class(sc, f, "list", g_list_3, 3, 0, false); - sc->list_4 = make_function_with_class(sc, f, "list", g_list_4, 4, 0, false); - - /* append */ - f = set_function_chooser(sc->append_symbol, append_chooser); - sc->append_2 = make_function_with_class(sc, f, "append", g_append_2, 2, 0, false); - - /* list-ref */ - f = set_function_chooser(sc->list_ref_symbol, list_ref_chooser); - sc->list_ref_at_0 = make_function_with_class(sc, f, "list", g_list_ref_at_0, 2, 0, false); - sc->list_ref_at_1 = make_function_with_class(sc, f, "list", g_list_ref_at_1, 2, 0, false); - sc->list_ref_at_2 = make_function_with_class(sc, f, "list", g_list_ref_at_2, 2, 0, false); - - /* assoc */ - set_function_chooser(sc->assoc_symbol, assoc_chooser); - - /* member */ - set_function_chooser(sc->member_symbol, member_chooser); - - /* memq */ - f = set_function_chooser(sc->memq_symbol, memq_chooser); /* is pure-s7, use member here */ - sc->memq_2 = make_function_with_class(sc, f, "memq", g_memq_2, 2, 0, false); - sc->memq_3 = make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false); - sc->memq_4 = make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false); - sc->memq_any = make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false); - - /* tree-set-memq */ - f = set_function_chooser(sc->tree_set_memq_symbol, tree_set_memq_chooser); - sc->tree_set_memq_syms = make_function_with_class(sc, f, "tree-set-memq", g_tree_set_memq_1, 2, 0, false); - - /* eval-string */ - set_function_chooser(sc->eval_string_symbol, eval_string_chooser); - - /* dynamic-wind */ - f = set_function_chooser(sc->dynamic_wind_symbol, dynamic_wind_chooser); - sc->dynamic_wind_unchecked = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_unchecked, 3, 0, false); - sc->dynamic_wind_body = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_body, 3, 0, false); - sc->dynamic_wind_init = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_init, 3, 0, false); - - /* inlet */ - f = set_function_chooser(sc->inlet_symbol, inlet_chooser); - sc->simple_inlet = make_function_with_class(sc, f, "inlet", g_simple_inlet, 0, 0, true); - - /* sublet */ - f = set_function_chooser(sc->sublet_symbol, sublet_chooser); - sc->sublet_curlet = make_function_with_class(sc, f, "sublet", g_sublet_curlet, 3, 0, false); - - /* let-ref */ - f = set_function_chooser(sc->let_ref_symbol, let_ref_chooser); - sc->lint_let_ref = make_function_with_class(sc, f, "let-ref", g_lint_let_ref, 2, 0, false); - - /* let-set */ - f = set_function_chooser(sc->let_set_symbol, let_set_chooser); - sc->lint_let_set = make_function_with_class(sc, f, "let-set!", g_lint_let_set, 3, 0, false); - - /* values */ - f = set_function_chooser(sc->values_symbol, values_chooser); - sc->values_uncopied = make_unsafe_function_with_class(sc, f, "values", splice_in_values, 0, 0, true); - - /* list-values */ - f = set_function_chooser(sc->list_values_symbol, list_values_chooser); - sc->simple_list_values = make_function_with_class(sc, f, "list-values", g_simple_list_values, 0, 0, true); -} - - -/* ---------------- *unbound-variable-hook* ---------------- */ -static s7_pointer loaded_library(s7_scheme *sc, const char *file) -{ - for (s7_pointer p = global_value(sc->libraries_symbol); is_pair(p); p = cdr(p)) - if (local_strcmp(file, string_value(caar(p)))) - return(cdar(p)); - return(sc->nil); -} - -static void pair_set_current_input_location(s7_scheme *sc, s7_pointer p) -{ - if (current_input_port(sc) != sc->standard_input) /* (port_file_number(current_input_port(sc)) > 1) -- maybe 0 is legit? */ - { - pair_set_location(p, port_location(current_input_port(sc))); - set_has_location(p); /* current_input_port(sc) above can't be nil(?) -- it falls back on stdin now */ - } -} - -static noreturn void unbound_variable_error_nr(s7_scheme *sc, s7_pointer sym) -{ - s7_pointer err_code = NULL; - - if ((is_pair(current_code(sc))) && (s7_tree_memq(sc, sym, current_code(sc)))) err_code = current_code(sc); - if ((is_pair(sc->code)) && (s7_tree_memq(sc, sym, sc->code))) err_code = sc->code; -#if WITH_HISTORY - { - s7_pointer p; - for (p = cdr(sc->cur_code); cdr(p) != sc->cur_code; p = cdr(p)); - if ((is_pair(car(p))) && (s7_tree_memq(sc, sym, car(p)))) err_code = car(p); - } -#endif - if (err_code) - error_nr(sc, sc->unbound_variable_symbol, - set_elist_3(sc, wrap_string(sc, "unbound variable ~S in ~S", 25), sym, err_code)); - - if ((symbol_name(sym)[symbol_name_length(sym) - 1] == ',') && - (lookup_unexamined(sc, make_symbol(sc, symbol_name(sym), symbol_name_length(sym) - 1)))) - error_nr(sc, sc->unbound_variable_symbol, - set_elist_2(sc, wrap_string(sc, "unbound variable ~S (perhaps a stray comma?)", 44), sym)); - - error_nr(sc, sc->unbound_variable_symbol, - set_elist_2(sc, wrap_string(sc, "unbound variable ~S", 19), sym)); -} - -static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym) -{ - /* this always occurs in a context where we're trying to find anything, so I'll move a couple of those checks here */ - if (has_let_ref_fallback(sc->curlet)) /* an experiment -- see s7test (with-let *db* (+ int32_t (length str))) */ - return(call_let_ref_fallback(sc, sc->curlet, sym)); - /* but if the thing we want to hit this fallback happens to exist at a higher level, oops... */ - - if (sym == sc->unquote_symbol) - syntax_error_nr(sc, "unquote (',') occurred outside quasiquote: ~S", 45, current_code(sc)); - - if (safe_strcmp(symbol_name(sym), "|#")) - read_error_nr(sc, "unmatched |#"); - - /* check *autoload*, autoload_names, then *unbound-variable-hook* */ - if ((sc->autoload_names) || - (is_hash_table(sc->autoload_table)) || - ((is_procedure(sc->unbound_variable_hook)) && - (hook_has_functions(sc->unbound_variable_hook)))) - { - s7_pointer cur_code = current_code(sc); - s7_pointer value = sc->value; - s7_pointer code = sc->code; - s7_pointer current_let = sc->curlet; - s7_pointer x = sc->x; - s7_pointer z = sc->z; - /* sc->args and sc->code are pushed on the stack by s7_call, then - * restored by eval, so they are normally protected, but sc->value and current_code(sc) are - * not protected. We need current_code(sc) so that the possible eventual error - * call can tell where the error occurred, and we need sc->value because it might - * be awaiting addition to sc->args in e.g. OP_EVAL_ARGS5, and then be clobbered - * by the hook function. (+ 1 asdf) will end up evaluating (+ asdf asdf) if sc->value - * is not protected. We also need to save/restore sc->curlet in case s7_load is called. - */ - s7_pointer args = (sc->args) ? sc->args : sc->nil; - s7_pointer result = sc->undefined; - sc->temp7 = cons_unchecked(sc, current_let, cons_unchecked(sc, code, /* perhaps elist_7 except we use elist_3 above? */ - cons_unchecked(sc, args, list_4(sc, value, cur_code, x, z)))); /* not s7_list (debugger checks) */ - if (!is_pair(cur_code)) - { - /* isolated typo perhaps -- no pair to hold the position info, so make one. current_code(sc) is GC-protected, so this should be safe */ - cur_code = list_1(sc, sym); /* the error will say "(sym)" which is not too misleading */ - pair_set_current_input_location(sc, cur_code); - } - -#if (!DISABLE_AUTOLOAD) - /* check sc->autoload_names */ - if ((sc->is_autoloading) && - (sc->autoload_names)) - { - bool loaded = false; - const char *file = find_autoload_name(sc, sym, &loaded, true); - if ((file) && (!loaded)) - { - /* if we've already loaded this file, we can get the library (e) from a table [(file lib) ...] - * here it was possible to get caught in a loop: - * change file, reload, unbound var seen, check autoload, it says "load file"... (where file does not get added to *libraries*) - * so the "loaded" arg tries to catch such cases - */ - s7_pointer e = loaded_library(sc, file); - if ((!e) || (!is_let(e))) - { - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, s7_make_string(sc, file))); - e = s7_load(sc, file); /* s7_load can return NULL */ - } - result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ - if ((result == sc->undefined) && - (e) && (is_let(e))) - { - result = let_ref(sc, e, sym); - /* I think to be consistent we should add '(sym . result) to the global let */ - if (result != sc->undefined) - s7_define(sc, sc->nil, sym, result); - }}} -#endif - if (result == sc->undefined) - { -#if (!DISABLE_AUTOLOAD) - /* check the *autoload* hash table */ - if ((sc->is_autoloading) && - (is_hash_table(sc->autoload_table))) - { - /* it was possible to get in a loop here: missing paren in x.scm, checks last symbol, sees - * autoload sym -> x.scm, loads x.scm, missing paren... - */ - s7_pointer val = s7_hash_table_ref(sc, sc->autoload_table, sym); - if (is_string(val)) /* val should be a filename. *load-path* is searched if necessary */ - { - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); - s7_load(sc, string_value(val)); - } - else - if (is_closure(val)) /* val should be a function of one argument, the current (calling) environment */ - { - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); - s7_call(sc, val, set_ulist_1(sc, sc->curlet, sc->nil)); - } - result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ - } -#endif - /* check *unbound-variable-hook* */ - if ((result == sc->undefined) && - (is_procedure(sc->unbound_variable_hook)) && - (hook_has_functions(sc->unbound_variable_hook))) - { - /* (let () (set! (hook-functions *unbound-variable-hook*) (list (lambda (v) _asdf_))) _asdf_) */ - s7_pointer old_hook = sc->unbound_variable_hook; - bool old_history_enabled = s7_set_history_enabled(sc, false); - gc_protect_via_stack(sc, old_hook); - sc->unbound_variable_hook = sc->nil; - result = s7_call(sc, old_hook, set_plist_1(sc, sym)); /* not s7_apply_function */ - sc->unbound_variable_hook = old_hook; - s7_set_history_enabled(sc, old_history_enabled); - unstack(sc); - }} - sc->value = T_Ext(value); - sc->args = T_Pos(args); /* can be # */ - sc->code = code; - set_curlet(sc, current_let); - sc->x = x; - sc->z = z; - sc->temp7 = sc->unused; - if ((result != sc->undefined) && - (result != sc->unspecified)) - return(result); - } - unbound_variable_error_nr(sc, sym); - return(sc->unbound_variable_symbol); -} - -static bool gx_annotate_arg(s7_scheme *sc, s7_pointer p, s7_pointer e) -{ - if (is_gxable(car(p))) - { - opcode_t old_op = optimize_op(car(p)); - s7_pointer fxf; - set_optimize_op(car(p), old_op + 1); - fxf = (s7_pointer)fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe); - if (fxf) - { - set_has_gx(p); - set_opt2(p, fxf, OPT2_FX); - } - set_optimize_op(car(p), old_op); - return(fxf); - } - return(false); -} - -static void gx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e) -{ - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - gx_annotate_arg(sc, p, e); -} - -#define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr, true)) - -static void fx_annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer e) -{ -#if S7_DEBUGGING - s7_function fx; - if (has_fx(arg)) return; - fx = fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe); - if (fx) set_fx_direct(arg, fx); -#else - if (has_fx(arg)) return; - set_fx(arg, fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); -#endif -} - -static void fx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e) -{ - for (s7_pointer p = args; is_pair(p); p = cdr(p)) -#if S7_DEBUGGING - fx_annotate_arg(sc, p, e); /* checks has_fx */ -#else - if (!has_fx(p)) - set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); -#endif -} - -static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e) -{ - if ((hop != 1) && (is_constant_symbol(sc, car(expr)))) hop = 1; - - if ((is_closure(func)) || (is_closure_star(func))) - { - bool safe_case = is_safe_closure(func); - s7_pointer body = closure_body(func); - bool one_form = is_null(cdr(body)); - - if (is_immutable(func)) hop = 1; - if (is_null(closure_args(func))) /* no rest arg funny business */ - { - set_optimized(expr); - if ((one_form) && (safe_case) && (is_fxable(sc, car(body)))) /* fx stuff is not set yet */ - { - fx_annotate_arg(sc, body, e); - set_optimize_op(expr, hop + OP_SAFE_THUNK_A); - set_closure_one_form_fx_arg(func); - set_opt1_lambda_add(expr, func); - return(OPT_T); - } - /* thunks with fully fxable bodies are rare apparently, and the time spent here overwhelms run time gains */ - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_THUNK : ((one_form) ? OP_THUNK_O : OP_THUNK))); - set_opt1_lambda_add(expr, func); - return((safe_case) ? OPT_T : OPT_F); - } - - if (is_symbol(closure_args(func))) /* (define* (f1 . a) ...) called (f1) -- called a closure (not closure*) in define_unchecked */ - { - set_opt1_lambda_add(expr, func); - if (safe_case) - { - if (!has_fx(body)) - { - fx_annotate_args(sc, body, e); - fx_tree(sc, body, closure_args(func), NULL, NULL, false); - } - set_safe_optimize_op(expr, hop + OP_SAFE_THUNK_ANY); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + OP_THUNK_ANY); /* "thunk" because here it is called with no args, I guess */ - return(OPT_F); - } - if (is_closure_star(func)) - { - set_opt1_lambda_add(expr, func); - set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); - } - return(OPT_F); - } - if (is_c_function(func)) - { - if (c_function_min_args(func) != 0) - return(OPT_F); - if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1; - if (is_safe_procedure(func)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); - choose_c_function(sc, expr, func, 0); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + OP_C); - choose_c_function(sc, expr, func, 0); - return(OPT_F); - } - if (is_c_function_star(func)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR); - set_c_function(expr, func); - return(OPT_T); - } - return(OPT_F); -} - -static int32_t combine_ops(s7_scheme *sc, s7_pointer expr, combine_op_t cop, s7_pointer e1, s7_pointer e2) /* sc needed for debugger stuff */ -{ - switch (cop) - { - case E_C_P: - switch (op_no_hop(e1)) - { - case OP_SAFE_C_S: return(OP_SAFE_C_opSq); - case OP_SAFE_C_NC: return(OP_SAFE_C_opNCq); - case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq); - case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq); - case OP_SAFE_C_A: return(OP_SAFE_C_opAq); - case OP_SAFE_C_AA: return(OP_SAFE_C_opAAq); - case OP_SAFE_C_AAA: return(OP_SAFE_C_opAAAq); - case OP_SAFE_C_SS: - set_opt3_sym(expr, cadr(e1)); - set_opt1_sym(cdr(expr), caddr(e1)); - return(OP_SAFE_C_opSSq); - case OP_SAFE_C_opSq: - set_opt3_pair(expr, cadr(e1)); - set_opt3_sym(cdr(expr), cadadr(e1)); - return(OP_SAFE_C_op_opSqq); - case OP_SAFE_C_S_opSq: - set_opt3_pair(expr, caddr(e1)); - return(OP_SAFE_C_op_S_opSqq); - case OP_SAFE_C_opSq_S: - set_opt3_pair(expr, cadr(e1)); - return(OP_SAFE_C_op_opSq_Sq); - } - return(OP_SAFE_C_P); /* this splits out to A in optimize_func one_arg */ - - case E_C_SP: - switch (op_no_hop(e2)) - { - case OP_SAFE_C_S: return(OP_SAFE_C_S_opSq); - case OP_SAFE_C_AA: return(OP_SAFE_C_S_opAAq); - case OP_SAFE_C_SC: - set_opt2_con(cdr(expr), caddr(e2)); - return(OP_SAFE_C_S_opSCq); - case OP_SAFE_C_CS: /* expr is (* a (- 1 b)), e2 is (- 1 b) */ - set_opt2_sym(cdr(expr), caddr(e2)); - return(OP_SAFE_C_S_opCSq); - case OP_SAFE_C_SS: /* (* a (- b c)) */ - set_opt2_sym(cdr(expr), caddr(e2)); - return(OP_SAFE_C_S_opSSq); - case OP_SAFE_C_A: - set_opt3_pair(expr, cdaddr(expr)); - return(OP_SAFE_C_S_opAq); - } - return(OP_SAFE_C_SP); /* if fxable -> AA later */ - - case E_C_PS: - switch (op_no_hop(e1)) - { - case OP_SAFE_C_S: - set_opt1_sym(cdr(expr), cadr(e1)); - set_opt3_sym(expr, e2); - return(OP_SAFE_C_opSq_S); - case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq_S); - case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_S); - case OP_SAFE_C_A: return(OP_SAFE_C_opAq_S); - case OP_SAFE_C_opSSq: - set_opt1_pair(cdr(expr), cadadr(expr)); - set_opt3_pair(expr, cadr(e1)); - return(OP_SAFE_C_op_opSSqq_S); - } - return(OP_SAFE_C_PS); - - case E_C_PC: - switch (op_no_hop(e1)) - { - case OP_SAFE_C_S: - set_opt1_sym(cdr(expr), cadr(e1)); - set_opt2_con(cdr(expr), e2); - return(OP_SAFE_C_opSq_C); - case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_C); - case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq_C); - case OP_SAFE_C_SS: - set_opt3_con(cdr(expr), caddr(expr)); - return(OP_SAFE_C_opSSq_C); - } - set_opt3_con(cdr(expr), caddr(expr)); - return(OP_SAFE_C_PC); - - case E_C_CP: - switch (op_no_hop(e2)) - { - case OP_SAFE_C_S: - set_opt3_pair(expr, e2); - return(OP_SAFE_C_C_opSq); - case OP_SAFE_C_SC: - set_opt1_sym(cdr(expr), cadr(e2)); - set_opt2_con(cdr(expr), caddr(e2)); - return(OP_SAFE_C_C_opSCq); - case OP_SAFE_C_SS: - set_opt1_sym(cdr(expr), cadr(e2)); - return(OP_SAFE_C_C_opSSq); - } - return(OP_SAFE_C_CP); - - case E_C_PP: - switch (op_no_hop(e2)) - { - case OP_SAFE_C_S: - if (is_safe_c_s(e1)) - return(OP_SAFE_C_opSq_opSq); - if (optimize_op_match(e1, OP_SAFE_C_SS)) - return(OP_SAFE_C_opSSq_opSq); - break; - case OP_SAFE_C_SS: - if (optimize_op_match(e1, OP_SAFE_C_SS)) - return(OP_SAFE_C_opSSq_opSSq); - if (is_safe_c_s(e1)) - return(OP_SAFE_C_opSq_opSSq); - break; - } - return(OP_SAFE_C_PP); - - default: - break; - } - return(OP_UNOPT); -} - -static bool arg_findable(s7_scheme *sc, s7_pointer arg1, s7_pointer e) -{ - if (pair_symbol_is_safe(sc, arg1, e)) return(true); /* includes global_slot check */ - return((!sc->in_with_let) && - (is_slot(lookup_slot_from(arg1, sc->curlet)))); -} - -static bool safe_c_aa_to_ag_ga(s7_scheme *sc, s7_pointer arg, int32_t hop) -{ - if (fx_proc(cddr(arg)) == fx_s) {set_opt3_sym(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AS); return(true);} - if (fx_proc(cdr(arg)) == fx_s) {set_opt3_sym(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_SA); return(true);} - if (fx_proc(cddr(arg)) == fx_c) {set_opt3_con(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} - if (fx_proc(cdr(arg)) == fx_c) {set_opt3_con(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} - if (fx_proc(cddr(arg)) == fx_q) {set_opt3_con(arg, cadaddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} - if (fx_proc(cdr(arg)) == fx_q) {set_opt3_con(arg, cadadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} - return(false); -} - -static opt_t check_c_aa(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e) -{ - fx_annotate_args(sc, cdr(expr), e); - if (!safe_c_aa_to_ag_ga(sc, expr, hop)) - { - set_optimize_op(expr, hop + OP_SAFE_C_AA); - set_opt3_pair(expr, cddr(expr)); - } - choose_c_function(sc, expr, func, 2); - return(OPT_T); -} - -static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int32_t n_args, int32_t hop, s7_pointer e) -{ - set_opt3_arglen(cdr(expr), n_args); - if (is_c_function(func)) - { - set_safe_optimize_op(expr, hop + ((is_safe_procedure(func)) ? - ((n_args == 1) ? OP_SAFE_C_A : OP_SAFE_C_AA) : - ((n_args == 1) ? ((is_semisafe(func)) ? OP_CL_A : OP_C_A) : - ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)))); - if (op_no_hop(expr) == OP_SAFE_C_AA) - { - set_opt3_pair(expr, cddr(expr)); - if (optimize_op(expr) == HOP_SAFE_C_AA) return(check_c_aa(sc, expr, func, hop, e)); - } - set_c_function(expr, func); - return(OPT_T); - } - if ((is_closure(func)) && - (!arglist_has_rest(sc, closure_args(func)))) - { - s7_pointer body = closure_body(func); - bool one_form = is_null(cdr(body)), safe_case = is_safe_closure(func); - set_unsafely_optimized(expr); - set_opt1_lambda_add(expr, func); - if (one_form) - set_optimize_op(expr, hop + ((safe_case) ? - ((n_args == 1) ? OP_SAFE_CLOSURE_A_O : OP_SAFE_CLOSURE_AA_O) : - ((n_args == 1) ? OP_CLOSURE_A_O : OP_CLOSURE_AA_O))); - else - set_optimize_op(expr, hop + ((safe_case) ? - ((n_args == 1) ? OP_SAFE_CLOSURE_A : OP_SAFE_CLOSURE_AA) : - ((n_args == 1) ? OP_CLOSURE_A : OP_CLOSURE_AA))); - return(OPT_F); - } - if ((is_closure_star(func)) && - (lambda_has_simple_defaults(func)) && - (closure_star_arity_to_int(sc, func) >= n_args) && - (!arglist_has_rest(sc, closure_args(func)))) - { - set_unsafely_optimized(expr); - if (n_args == 1) - set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); - else - if (closure_star_arity_to_int(sc, func) == 2) - set_optimize_op(expr, ((is_safe_closure(func)) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : - OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); - else set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); - set_opt1_lambda_add(expr, func); - } - return(OPT_F); -} - -static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer e) -{ - s7_pointer x; - int64_t id; - - if ((symbol_is_in_list(sc, symbol)) && - (direct_memq(symbol, e))) /* it's probably a local variable reference */ - return(sc->nil); - /* ((!symbol_is_in_list(sc, symbol)) && (direct_memq(symbol, e))) can happen if there's an intervening lambda: - * (let loop () (with-let (for-each (lambda (a) a) (list))) (loop)) - * misses 'loop (it's not in symbol_list when recursive call is encountered) -- tricky to fix - */ - - if (is_global(symbol)) - return(global_slot(symbol)); - - /* see 59108 (OP_DEFINE_* in optimize_syntax) -- keyword version of name is used if a definition is - * contingent on some run-time decision, so we're looking here for local defines that might not happen. - * s7test.scm has a test case using acos. - */ - if ((has_keyword(symbol)) && - (symbol_is_in_list(sc, symbol_to_keyword(sc, symbol)))) - return(sc->nil); - - for (x = sc->curlet, id = symbol_id(symbol); id < let_id(x); x = let_outlet(x)); - for (; is_let(x); x = let_outlet(x)) - { - if (let_id(x) == id) - return(local_slot(symbol)); - for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); - } - return(global_slot(symbol)); /* it's no longer global perhaps (local definition now inaccessible) */ -} - -static bool is_ok_lambda(s7_scheme *sc, s7_pointer arg2) -{ - return((is_pair(arg2)) && - (is_lambda(sc, car(arg2))) && /* must start (lambda ...) */ - (is_pair(cdr(arg2))) && /* must have arg(s) */ - (is_pair(cddr(arg2))) && /* must have body */ - (s7_is_proper_list(sc, cdddr(arg2)))); -} - -static bool hop_if_constant(s7_scheme *sc, s7_pointer sym) -{ - return(((!sc->in_with_let) && (symbol_id(sym) == 0)) ? 1 : 0); /* for with-let, see s7test atanh (77261) */ -} - -static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - s7_pointer arg1 = cadr(expr); - bool func_is_safe = is_safe_procedure(func); - if (hop == 0) hop = hop_if_constant(sc, car(expr)); - if (pairs == 0) - { - if (func_is_safe) /* safe c function */ - { - set_safe_optimize_op(expr, hop + ((symbols == 0) ? OP_SAFE_C_NC : OP_SAFE_C_S)); - choose_c_function(sc, expr, func, 1); - return(OPT_T); - } - /* c function is not safe */ - if (symbols == 0) - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); /* OP_C_C never happens */ - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - } - else - { - set_unsafely_optimized(expr); - if (c_function_call(func) == g_read) - set_optimize_op(expr, hop + OP_READ_S); - else set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_S : OP_C_S)); - } - choose_c_function(sc, expr, func, 1); - return(OPT_F); - } - /* pairs == 1 */ - if (bad_pairs == 0) - { - if (func_is_safe) - { - int32_t op = combine_ops(sc, expr, E_C_P, arg1, NULL); - /* if ((hop == 1) && (!op_has_hop(arg1))) hop = 0; *//* probably not the right way to fix this (s7test tc_or_a_and_a_a_la) */ - set_safe_optimize_op(expr, hop + op); - - if ((op == OP_SAFE_C_P) && - (is_fxable(sc, arg1))) - { - set_optimize_op(expr, hop + OP_SAFE_C_A); - fx_annotate_arg(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 1); - return(OPT_T); - } - if (is_fxable(sc, arg1)) - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - choose_c_function(sc, expr, func, 1); - return(OPT_F); - }} - else /* bad_pairs == 1 */ - { - if (quotes == 1) - { - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - if (func_is_safe) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_A); - choose_c_function(sc, expr, func, 1); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); - choose_c_function(sc, expr, func, 1); - return(OPT_F); - } - /* quotes == 0 */ - if (!func_is_safe) - { - s7_pointer lambda_expr = arg1; - if ((is_ok_lambda(sc, lambda_expr)) && - (!direct_memq(car(lambda_expr), e))) /* (let ((lambda #f)) (call-with-exit (lambda ...))) */ - { - if (((c_function_call(func) == g_call_with_exit) || - (c_function_call(func) == g_call_cc) || - (c_function_call(func) == g_call_with_output_string)) && - (is_proper_list_1(sc, cadr(lambda_expr))) && - (is_symbol(caadr(lambda_expr))) && - (!is_probably_constant(caadr(lambda_expr)))) /* (call-with-exit (lambda (pi) ...) */ - { - if (c_function_call(func) == g_call_cc) - set_unsafe_optimize_op(expr, OP_CALL_CC); - else - if (c_function_call(func) == g_call_with_exit) - set_unsafe_optimize_op(expr, (is_null(cdddr(lambda_expr))) ? OP_CALL_WITH_EXIT_O : OP_CALL_WITH_EXIT); - else - { - set_unsafe_optimize_op(expr, OP_CALL_WITH_OUTPUT_STRING); - set_opt2_pair(expr, cddr(lambda_expr)); - set_opt3_sym(expr, caadr(lambda_expr)); - set_local(caadr(lambda_expr)); - return(OPT_F); - } - choose_c_function(sc, expr, func, 1); - set_opt2_pair(expr, cdr(lambda_expr)); - set_local(caadr(lambda_expr)); /* check_lambda_args normally handles this, but if hop==1, we'll skip that step */ - return(OPT_F); - } - if ((c_function_call(func) == g_with_output_to_string) && - (is_null(cadr(lambda_expr)))) - { - set_unsafe_optimize_op(expr, OP_WITH_OUTPUT_TO_STRING); - set_opt2_pair(expr, cddr(lambda_expr)); - return(OPT_F); - }}}} - set_unsafe_optimize_op(expr, hop + ((func_is_safe) ? OP_SAFE_C_P : OP_C_P)); - choose_c_function(sc, expr, func, 1); - return(OPT_F); -} - -static bool walk_fxable(s7_scheme *sc, s7_pointer tree) -{ - for (s7_pointer p = cdr(tree); is_pair(p); p = cdr(p)) - { - s7_pointer q = car(p); - if ((is_pair(q)) && - (is_optimized(q))) - { - opcode_t op = optimize_op(q); - if (is_safe_c_op(op)) return(true); - if ((op >= OP_TC_AND_A_OR_A_LA) || - ((op >= OP_THUNK) && (op < OP_BEGIN)) || - (!walk_fxable(sc, q))) - return(false); - }} - return(true); -} - -static bool is_safe_fxable(s7_scheme *sc, s7_pointer p) -{ - if (!is_pair(p)) return(true); - if (is_optimized(p)) - { - if ((fx_function[optimize_op(p)]) && - (walk_fxable(sc, (p)))) - return(true); - } - if (is_proper_quote(sc, p)) return(true); - if ((S7_DEBUGGING) && (is_optimized(p)) && (fx_function[optimize_op(p)])) fprintf(stderr, "omit %s: %s\n", op_names[optimize_op(p)], display(p)); - return(false); -} - -static opt_t fxify_closure_s(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t hop) -{ - s7_pointer body = closure_body(func); - fx_annotate_arg(sc, body, e); - /* we can't currently fx_annotate_arg(sc, cdr(expr), e) here because that opt2 field is in use elsewhere (opt2_sym, not sure where it's set) */ - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A); - if ((is_pair(car(body))) && (is_pair(cdar(body))) && (car(closure_args(func)) == cadar(body))) - { - if (optimize_op(car(body)) == HOP_SAFE_C_S) - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S); - else - if (optimize_op(car(body)) == HOP_SAFE_C_SC) - { - s7_pointer body_arg2 = caddar(body); - set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC); - if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) - set_fx_direct(cdr(expr), fx_safe_closure_s_to_vref); - else - { - set_fx_direct(cdr(expr), fx_safe_closure_s_to_sc); - if ((is_t_integer(body_arg2)) && (integer(body_arg2) == 1)) - { - if (caar(body) == sc->subtract_symbol) set_fx_direct(cdr(expr), fx_safe_closure_s_to_sub1); - if (caar(body) == sc->add_symbol) set_fx_direct(cdr(expr), fx_safe_closure_s_to_add1); - }}}} - set_closure_one_form_fx_arg(func); - fx_tree(sc, body, car(closure_args(func)), NULL, NULL, false); - return(OPT_T); -} - -static bool fxify_closure_a(s7_scheme *sc, s7_pointer func, bool one_form, bool safe_case, int32_t hop, s7_pointer expr, s7_pointer e) -{ - if (!one_form) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A)); - else - if (!safe_case) - set_optimize_op(expr, hop + OP_CLOSURE_A_O); - else - { - s7_pointer body = closure_body(func); - if (!is_fxable(sc, car(body))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_O); - else - { - fx_annotate_arg(sc, body, e); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A); - if ((is_pair(car(body))) && - (optimize_op(car(body)) == HOP_SAFE_C_SC) && - (car(closure_args(func)) == cadar(body))) - { - s7_pointer body_arg2 = caddar(body); - set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_TO_SC); - /* why is this setting expr whereas _s case above sets cdr(expr)? */ - if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) - set_fx_direct(expr, fx_safe_closure_a_to_vref); - else set_fx_direct(expr, fx_safe_closure_a_to_sc); - } - set_closure_one_form_fx_arg(func); - fx_tree(sc, body, car(closure_args(func)), NULL, NULL, false); - return(true); - }} - return(false); -} - -static opt_t optimize_closure_sym(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e) -{ - if (fx_count(sc, expr) != args) /* fx_count starts at cdr, args here is the number of exprs in cdr(expr) -- so this means "are all args fxable" */ - return(OPT_F); - set_opt3_arglen(cdr(expr), args); - set_opt1_lambda_add(expr, func); - fx_annotate_args(sc, cdr(expr), e); - if (is_safe_closure(func)) - { - s7_pointer body = closure_body(func); - if (!has_fx(body)) /* does this have any effect? */ - { - fx_annotate_args(sc, body, e); - fx_tree(sc, body, closure_args(func), NULL, NULL, false); - } - set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM); - return(OPT_F); -} - -static opt_t optimize_closure_a_sym(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e) -{ - if (fx_count(sc, expr) != args) return(OPT_F); - set_opt3_arglen(cdr(expr), args); - set_opt1_lambda_add(expr, func); - fx_annotate_args(sc, cdr(expr), e); - if (is_safe_closure(func)) - { - s7_pointer body = closure_body(func); - if (!has_fx(body)) /* does this have any effect? */ - { - fx_annotate_args(sc, body, e); - fx_tree(sc, body, car(closure_args(func)), cdr(closure_args(func)), NULL, false); - } - set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM); - return(OPT_F); -} - -static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t symbols, s7_pointer e) -{ - bool one_form, safe_case; - s7_pointer body, arg1 = cadr(expr); - int32_t arit = closure_arity_to_int(sc, func); - if (arit != 1) - { - if (is_symbol(closure_args(func))) /* (arit == -1) is ambiguous: (define (f . a)...) and (define (f a . b)...) both are -1 here */ - return(optimize_closure_sym(sc, expr, func, hop, 1, e)); - if ((arit == -1) && (is_symbol(cdr(closure_args(func))))) - return(optimize_closure_a_sym(sc, expr, func, hop, 1, e)); - return(OPT_F); - } - safe_case = is_safe_closure(func); - body = closure_body(func); - one_form = is_null(cdr(body)); - if (is_immutable(func)) hop = 1; - - if (symbols == 1) - { - set_opt2_sym(expr, arg1); - set_opt1_lambda_add(expr, func); - if (one_form) - { - if (safe_case) - { - if (is_fxable(sc, car(body))) - return(fxify_closure_s(sc, func, expr, e, hop)); - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_O); /* tleft 7638 if _O here, 7692 if not (and claims 80 in the begin setup) */ - } - else set_optimize_op(expr, hop + OP_CLOSURE_S_O); - } - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_S : OP_CLOSURE_S)); - set_unsafely_optimized(expr); - return(OPT_F); - } - if (fx_count(sc, expr) == 1) - { - set_unsafely_optimized(expr); - set_opt1_lambda_add(expr, func); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - if (fxify_closure_a(sc, func, one_form, safe_case, hop, expr, e)) return(OPT_T); - set_unsafely_optimized(expr); - return(OPT_F); - } - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_P : OP_CLOSURE_P)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 1); - set_unsafely_optimized(expr); - if ((safe_case) && (one_form) && (is_fxable(sc, car(closure_body(func))))) - { - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_P_A); /* other possibilities: 3p fp (ap|pa only get a few hits), but none of these matter much */ - fx_annotate_arg(sc, closure_body(func), e); - } - return(OPT_F); /* don't check is_optimized here for OPT_T */ -} - -static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - s7_pointer arg1; - /* very often, expr is already optimized, quoted stuff is counted under "bad_pairs"! as well as quotes */ - if (quotes > 0) - { - if (direct_memq(sc->quote_symbol, e)) - return(OPT_OOPS); - if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; - } - arg1 = cadr(expr); - /* need in_with_let -> search only rootlet not lookup */ - if ((symbols == 1) && - (!arg_findable(sc, arg1, e))) - { - /* wrap the bad arg in a check symbol lookup */ - if (s7_is_aritable(sc, func, 1)) - { - set_fx_direct(cdr(expr), fx_unsafe_s); - return(wrap_bad_args(sc, func, expr, 1, hop, e)); - } - return(OPT_F); - } - if ((is_c_function(func)) && (c_function_is_aritable(func, 1))) - return(optimize_c_function_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - - if (is_closure(func)) - return(optimize_closure_one_arg(sc, expr, func, hop, symbols, e)); - - if (is_closure_star(func)) - { - if (is_null(closure_args(func))) - return(OPT_F); - if (fx_count(sc, expr) == 1) - { - bool safe_case = is_safe_closure(func); - if (is_immutable(func)) hop = 1; - fx_annotate_arg(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 1); - set_unsafely_optimized(expr); - - if ((safe_case) && (is_null(cdr(closure_args(func))))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1); - else - if (lambda_has_simple_defaults(func)) - { - if (arglist_has_rest(sc, closure_args(func))) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); - } - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - } - return(OPT_F); - } - - if ((is_c_function_star(func)) && - (fx_count(sc, expr) == 1) && - (c_function_max_args(func) >= 1) && - (!is_symbol_and_keyword(arg1))) /* the only arg should not be a keyword (needs error checks later) */ - { - if ((hop == 0) && ((is_immutable(func)) || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) hop = 1; - set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_A); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - set_c_function(expr, func); - return(OPT_T); - } - - if (((is_any_vector(func)) || (is_pair(func))) && - (is_fxable(sc, arg1))) - { - set_unsafe_optimize_op(expr, (is_pair(func) ? OP_IMPLICIT_PAIR_REF_A : OP_IMPLICIT_VECTOR_REF_A)); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - return(OPT_T); - } - - if ((func == sc->s7_starlet) && /* (*s7* ...) */ - (((quotes == 1) && (is_symbol(cadr(arg1)))) || - (is_symbol_and_keyword(arg1)))) - { - s7_pointer sym = (quotes == 1) ? cadr(arg1) : arg1; - if (is_keyword(sym)) sym = keyword_symbol(sym); /* might even be ':print-length */ - set_safe_optimize_op(expr, OP_IMPLICIT_S7_STARLET_REF_S); - set_opt3_int(expr, s7_starlet_symbol(sym)); - return(OPT_T); - } - - if (is_let(func)) - { - if ((is_pair(arg1)) && (car(arg1) == sc->quote_symbol)) - { - set_opt3_con(expr, cadr(arg1)); - set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_C); - return(OPT_T); - } - if (is_fxable(sc, arg1)) - { - set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_A); - set_opt3_any(expr, arg1); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - return(OPT_T); - }} - - /* unknown_* for other cases is set later(? -- we're getting eval-args...) */ - /* op_safe_c_p for (< (values 1 2 3)) op_s_s for (op arg) - * but is it better to wait for unknown* ? These are not hit often at this point (except in s7test). - * do they end up in op_s_a or whatever after unknown*? - */ - return((is_optimized(expr)) ? OPT_T : OPT_F); -} - -static bool unsafe_is_safe(s7_scheme *sc, s7_pointer f, s7_pointer e) -{ - if (!is_symbol(f)) return(false); - f = find_uncomplicated_symbol(sc, f, e); /* how to catch local c-funcs here? */ - if (!is_slot(f)) return(false); - return(is_safe_c_function(slot_value(f))); -} - -static opt_t set_any_closure_np(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op) -{ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); - set_opt3_arglen(cdr(expr), num_args); - set_unsafe_optimize_op(expr, op); - set_opt1_lambda_add(expr, func); - return(OPT_F); -} - -static bool two_args_ok(s7_scheme *sc, s7_pointer expr, s7_pointer e) -{ - if ((is_symbol(car(expr))) && ((car(expr) == sc->member_symbol) || (car(expr) == sc->assoc_symbol))) return(true); - return(unsafe_is_safe(sc, cadr(expr), e)); -} - -static void opt_sp_1(s7_scheme *sc, s7_function g, s7_pointer expr) -{ - set_opt1_any(cdr(expr), - (s7_pointer)((intptr_t)((g == g_cons) ? OP_SAFE_CONS_SP_1 : - (((g == g_multiply) || (g == g_multiply_2)) ? OP_SAFE_MULTIPLY_SP_1 : - (((g == g_add) || (g == g_add_2)) ? OP_SAFE_ADD_SP_1 : OP_SAFE_C_SP_1))))); -} - -static opt_t set_any_c_np(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op) -{ - /* we get safe/semisafe funcs here of 2 args and up! very few more than 5 */ - /* would safe_c_pp work for cl? or should unknown_* deal with op_cl_*? why aren't unknown* used in op_safe_c and op_c? - * 2 | 3 args store on stack rather than consing? then use sc->t2|3 to pass to fn_proc (unless unsafe) - * or use op_stack? error clears this? op-any-c-fp: op_any_c_2p|3p|fp? -- mimic clo_3p|4p? - * all: 3 1 0 any_c_np (* 0.5 (- n 1) y)?? - */ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - { - set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe)); - if (!has_fx(p)) - gx_annotate_arg(sc, p, e); - } - set_opt3_arglen(cdr(expr), num_args); /* for op_unknown_np */ - set_unsafe_optimize_op(expr, op); - choose_c_function(sc, expr, func, num_args); /* we can use num_args -- mv will redirect to generic call */ - return(OPT_F); -} - -static s7_function io_function(s7_function func) -{ - if (func == g_with_input_from_string) return(with_string_in); - if (func == g_with_input_from_file) return(with_file_in); - if (func == g_with_output_to_file) return(with_file_out); - if (func == g_call_with_input_string) return(call_string_in); - if (func == g_call_with_input_file) return(call_file_in); - return(call_file_out); /* call_with_output_to_file */ -} - -static void fixup_closure_star_aa(s7_scheme *sc, s7_pointer f, s7_pointer code, int32_t hop) -{ - int32_t arity = closure_star_arity_to_int(sc, f); - bool safe_case = is_safe_closure(f); - s7_pointer arg1 = cadr(code), par1 = car(closure_args(f)); - - if (is_pair(par1)) par1 = car(par1); - set_opt3_arglen(cdr(code), 2); - set_unsafely_optimized(code); - - if ((arity == 1) && (is_symbol_and_keyword(arg1)) && (keyword_symbol(arg1) == par1)) - set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_KA : OP_CLOSURE_STAR_KA)); - else - if ((lambda_has_simple_defaults(f)) && (arity == 2)) - set_optimize_op(code, hop + ((is_safe_closure(f)) ? ((is_null(cdr(closure_body(f)))) ? OP_SAFE_CLOSURE_STAR_AA_O : - OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); - else set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA_2 : OP_CLOSURE_STAR_NA)); -} - -static int32_t check_lambda(s7_scheme *sc, s7_pointer form, bool optl); - -static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, - int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); - if (quotes > 0) - { - if (direct_memq(sc->quote_symbol, e)) - return(OPT_OOPS); - if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; - } - if (((is_symbol(arg1)) && - (!arg_findable(sc, arg1, e))) || - ((is_symbol(arg2)) && - (!arg_findable(sc, arg2, e)))) - { - /* wrap bad args */ - if ((is_fxable(sc, arg1)) && - (is_fxable(sc, arg2)) && - (s7_is_aritable(sc, func, 2))) - { - fx_annotate_args(sc, cdr(expr), e); - return(wrap_bad_args(sc, func, expr, 2, hop, e)); - } - return(OPT_F); - } - /* end of bad symbol wrappers */ - - if (is_c_function(func) && (c_function_is_aritable(func, 2))) - { - /* this is a mess */ - bool func_is_safe = is_safe_procedure(func); - if (hop == 0) hop = hop_if_constant(sc, car(expr)); - - if (pairs == 0) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - /* another case here: set-car! and set-cdr! are safe if symbols==1 and arg1 is the symbol (i.e. arg2 is a constant) */ - if (symbols == 0) - set_optimize_op(expr, hop + OP_SAFE_C_NC); - else - if (symbols == 2) /* these two symbols are almost never the same, (sqrt (+ (* x x) (* y y))) */ - { - set_optimize_op(expr, hop + OP_SAFE_C_SS); - set_opt2_sym(cdr(expr), arg2); - } - else - if (is_normal_symbol(arg1)) - { - set_opt2_con(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_SC); - } - else - { - set_opt1_con(cdr(expr), arg1); - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_CS); - } - set_optimized(expr); - choose_c_function(sc, expr, func, 2); - return(OPT_T); - } - - set_unsafely_optimized(expr); - if (symbols == 2) - { - if (c_function_call(func) == g_apply) - { - set_optimize_op(expr, OP_APPLY_SS); - set_opt1_cfunc(expr, func); /* not quite set_c_function */ - set_opt2_sym(expr, arg2); - } - else - { - if (is_semisafe(func)) - { - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_CL_SS); - } - else set_optimize_op(expr, hop + OP_C_SS); - choose_c_function(sc, expr, func, 2); - }} - else - { - set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - choose_c_function(sc, expr, func, 2); - if (is_safe_procedure(opt1_cfunc(expr))) - { - clear_unsafe(expr); - /* symbols can be 0..2 here, no pairs */ - set_optimized(expr); - if (symbols == 1) - { - if (is_normal_symbol(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_SC); - set_opt2_con(cdr(expr), arg2); - } - else - { - set_opt1_con(cdr(expr), arg1); - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_CS); - }} - return(OPT_T); - }} - return(OPT_F); - } - - /* pairs != 0 */ - if ((bad_pairs == 0) && - (pairs == 2)) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - int32_t op = combine_ops(sc, expr, E_C_PP, arg1, arg2); - set_safe_optimize_op(expr, hop + op); - if (op == OP_SAFE_C_PP) - { - if (((op_no_hop(cadr(expr))) == OP_SAFE_CLOSURE_S_TO_SC) && - ((op_no_hop(caddr(expr))) == OP_SAFE_CLOSURE_S_TO_SC) && - (is_global(caadr(expr))) && (is_global(caaddr(expr)))) - { - /* ideally this would be OP not HOP, but safe_closure_s_to_sc is too picky */ - /* set_opt3_pair(expr, caddr(expr)); */ /* set_opt3_arglen(cdr(expr), 2); */ - set_safe_optimize_op(expr, HOP_SAFE_C_FF); - } - - opt_sp_1(sc, c_function_call(func), expr); /* calls set_opt1_any, sets opt1(cdr(expr)) to OP_SAFE_CONS_SP_1 and friends */ - if (is_fxable(sc, arg1)) - { - if (is_fxable(sc, arg2)) - return(check_c_aa(sc, expr, func, hop, e)); /* AA case */ - set_optimize_op(expr, hop + OP_SAFE_C_AP); - fx_annotate_arg(sc, cdr(expr), e); - gx_annotate_arg(sc, cddr(expr), e); - set_opt3_arglen(cdr(expr), 2); - } - else - if (is_fxable(sc, arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PA); - fx_annotate_arg(sc, cddr(expr), e); - gx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - } - else gx_annotate_args(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 2); /* this might change the op to safe_c_c, so it has to be last */ - return(OPT_T); - }} - - if ((bad_pairs == 0) && - (pairs == 1)) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - combine_op_t orig_op; - int32_t op; - - if (is_pair(arg1)) - { - orig_op = (is_normal_symbol(arg2)) ? E_C_PS : E_C_PC; - op = combine_ops(sc, expr, orig_op, arg1, arg2); - } - else - { - orig_op = (is_normal_symbol(arg1)) ? E_C_SP : E_C_CP; - op = combine_ops(sc, expr, orig_op, arg1, arg2); - } - if ((((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) && - (is_fxable(sc, arg2))) || - (((op == OP_SAFE_C_PS) || (op == OP_SAFE_C_PC)) && - (is_fxable(sc, arg1)))) - { - fx_annotate_args(sc, cdr(expr), e); - if (!safe_c_aa_to_ag_ga(sc, expr, hop)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); - set_opt3_pair(expr, cddr(expr)); - }} - else - { - set_safe_optimize_op(expr, hop + op); - if ((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) - { - opt_sp_1(sc, c_function_call(func), expr); - set_opt3_any(cdr(expr), arg1); - } - else - if (op == OP_SAFE_C_PC) - set_opt3_con(cdr(expr), arg2); - } - choose_c_function(sc, expr, func, 2); - return(OPT_T); - }} - - if ((bad_pairs == 1) && (quotes == 1)) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - if (symbols == 1) - { - set_optimized(expr); - if (is_normal_symbol(arg1)) - { - set_opt2_con(cdr(expr), cadr(arg2)); - set_optimize_op(expr, hop + OP_SAFE_C_SC); - } - else - { - set_opt1_con(cdr(expr), cadr(arg1)); - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_CS); - } - choose_c_function(sc, expr, func, 2); - return(OPT_T); - } - if ((pairs == 1) && (is_pair(arg2))) /* QC never happens */ - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_CQ); - set_opt2_con(cdr(expr), cadr(arg2)); - choose_c_function(sc, expr, func, 2); - return(OPT_T); - } - if (!is_safe_c_s(arg1)) - { - if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) - return(check_c_aa(sc, expr, func, hop, e)); - }} - else - if (pairs == 1) - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - choose_c_function(sc, expr, func, 2); - return(OPT_F); - }} - - if (quotes == 2) - { - if (func_is_safe) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); /* op_safe_c_nc -> fx_c_nc appears to leave quoted pairs quoted? */ - set_opt3_pair(expr, cddr(expr)); - } - else - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - set_opt3_arglen(cdr(expr), 2); - } - fx_annotate_args(sc, cdr(expr), e); - choose_c_function(sc, expr, func, 2); - return((func_is_safe) ? OPT_T : OPT_F); - } - - if ((pairs == 1) && - (quotes == 0) && - ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) - { - if (symbols == 1) - { - set_optimized(expr); - if (is_normal_symbol(arg1)) /* this is what optimize_expression uses to count symbols */ - { - set_optimize_op(expr, hop + OP_SAFE_C_SP); - opt_sp_1(sc, c_function_call(func), expr); - } - else set_optimize_op(expr, hop + OP_SAFE_C_PS); - choose_c_function(sc, expr, func, 2); - if (bad_pairs == 0) - return(OPT_T); - set_unsafe(expr); - return(OPT_F); - } - if (symbols == 0) - { - set_optimized(expr); - if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) - return(check_c_aa(sc, expr, func, hop, e)); - if (is_pair(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PC); - set_opt3_con(cdr(expr), arg2); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_CP); - opt_sp_1(sc, c_function_call(func), expr); - set_opt3_any(cdr(expr), arg1); - } - choose_c_function(sc, expr, func, 2); - if (bad_pairs == 0) - return(OPT_T); - set_unsafe(expr); - return(OPT_F); - }} - - if ((pairs == 2) && - ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) - { - if ((bad_pairs == 1) && - (is_safe_c_s(arg1))) - { - /* unsafe func here won't work unless we check that later and make the new arg list (for list-values etc) - * (and it has to be the last pair else the unknown_g stuff can mess up) - */ - if ((car(arg2) == sc->quote_symbol) && - (is_global(sc->quote_symbol))) - { - if (!is_proper_list_1(sc, cdr(arg2))) - return(OPT_OOPS); - set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_C); - set_opt1_sym(cdr(expr), cadr(arg1)); - set_opt2_con(cdr(expr), cadr(arg2)); - choose_c_function(sc, expr, func, 2); - return(OPT_T); - }} - if (quotes == 0) - { - set_unsafely_optimized(expr); - if (is_fxable(sc, arg1)) - { - if (is_fxable(sc, arg2)) - return(check_c_aa(sc, expr, func, hop, e)); - set_optimize_op(expr, hop + OP_SAFE_C_AP); - opt_sp_1(sc, c_function_call(func), expr); - fx_annotate_arg(sc, cdr(expr), e); - gx_annotate_arg(sc, cddr(expr), e); - } - else - if (is_fxable(sc, arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PA); - fx_annotate_arg(sc, cddr(expr), e); - gx_annotate_arg(sc, cdr(expr), e); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_PP); - opt_sp_1(sc, c_function_call(func), expr); - gx_annotate_args(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 2); - return(OPT_F); - } - if (quotes == 1) - { - if ((car(arg1) == sc->quote_symbol) && - (is_global(sc->quote_symbol))) - { - if (!is_proper_list_1(sc, cdr(arg1))) - return(OPT_OOPS); - set_optimize_op(expr, hop + OP_SAFE_C_CP); - opt_sp_1(sc, c_function_call(func), expr); - set_opt3_any(cdr(expr), cadr(arg1)); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_PC); - set_opt3_con(cdr(expr), cadr(arg2)); - } - set_unsafely_optimized(expr); - choose_c_function(sc, expr, func, 2); - return(OPT_F); - }} - - if (func_is_safe) - { - if (fx_count(sc, expr) == 2) - return(check_c_aa(sc, expr, func, hop, e)); - } - else - { - if (is_fxable(sc, arg1)) - { - if (is_fxable(sc, arg2)) - { - if ((c_function_call(func) == g_apply) && - (is_normal_symbol(arg1))) - { - set_optimize_op(expr, OP_APPLY_SA); - if ((is_pair(arg2)) && - (is_normal_symbol(car(arg2)))) /* arg2 might be ((if expr op1 op2) ...) */ - { - s7_pointer lister = lookup(sc, car(arg2)); - if ((is_c_function(lister)) && - (is_pair(c_function_signature(lister))) && - (car(c_function_signature(lister)) == sc->is_proper_list_symbol)) - set_optimize_op(expr, OP_APPLY_SL); - } - set_opt1_cfunc(expr, func); /* not quite set_c_function */ - } - else set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - } - else - { - if (((c_function_call(func) == g_with_input_from_string) || - (c_function_call(func) == g_with_input_from_file) || - (c_function_call(func) == g_with_output_to_file)) && - (is_ok_lambda(sc, arg2)) && - (is_null(cadr(arg2))) && - (!direct_memq(car(arg2), e))) /* lambda is redefined?? */ - { - set_unsafe_optimize_op(expr, (is_string(arg1)) ? OP_WITH_IO_C : OP_WITH_IO); - set_opt2_pair(expr, cddr(arg2)); - set_opt1_any(expr, (s7_pointer)io_function(c_function_call(func))); - return(OPT_F); - } - if (((c_function_call(func) == g_call_with_input_string) || - (c_function_call(func) == g_call_with_input_file) || - (c_function_call(func) == g_call_with_output_file)) && - (is_ok_lambda(sc, arg2)) && - (is_proper_list_1(sc, cadr(arg2))) && - (is_symbol(caadr(arg2))) && - (!is_probably_constant(caadr(arg2))) && - (!direct_memq(sc->lambda_symbol, e))) /* lambda is redefined?? */ - { - set_unsafe_optimize_op(expr, (is_string(arg1)) ? OP_WITH_IO_C : OP_WITH_IO); - set_opt2_pair(expr, cddr(arg2)); - set_opt3_sym(expr, caadr(arg2)); - set_opt1_any(expr, (s7_pointer)io_function(c_function_call(func))); - return(OPT_F); - } - set_unsafe_optimize_op(expr, hop + OP_C_AP); - fx_annotate_arg(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 2); - return(OPT_F); - } - - if ((is_semisafe(func)) && - (is_symbol(car(expr))) && - (car(expr) != sc->values_symbol) && - (is_fxable(sc, arg2)) && - (is_pair(arg1)) && - (car(arg1) == sc->lambda_symbol)) - { - fx_annotate_arg(sc, cddr(expr), e); - set_unsafe_optimize_op(expr, hop + OP_CL_FA); - check_lambda(sc, arg1, true); /* this changes symbol_list */ - - clear_symbol_list(sc); /* so restore it */ - for (s7_pointer p = e; is_pair(p); p = cdr(p)) - if (is_normal_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - - /* two seq args can't happen here (func_2_args = map + lambda + seq, arg1 is the lambda form, arg2 is fxable (see above) */ - choose_c_function(sc, expr, func, 2); - if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && - ((is_proper_list_1(sc, cadr(arg1))) && /* one parameter */ - (!is_possibly_constant(caadr(arg1))))) /* parameter name not trouble */ - { - /* built-in permanent closure here was not much faster */ - set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure : NULL); - set_opt3_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FA); - } - return(OPT_F); - }} - return(set_any_c_np(sc, func, expr, e, 2, hop + OP_ANY_C_NP)); /* OP_C_PP doesn't exist */ - } - - if (is_closure(func)) - { - bool one_form, safe_case; - s7_pointer body; - int32_t arit = closure_arity_to_int(sc, func); - - if (arit != 2) - { - if (is_symbol(closure_args(func))) - return(optimize_closure_sym(sc, expr, func, hop, 2, e)); - if ((arit == -1) && (is_symbol(cdr(closure_args(func))))) /* (define (f a . b) ...) */ - return(optimize_closure_a_sym(sc, expr, func, hop, 2, e)); - return(OPT_F); - } - if (is_immutable(func)) hop = 1; - - body = closure_body(func); - one_form = is_null(cdr(body)); - safe_case = is_safe_closure(func); - - if ((pairs == 0) && - (symbols >= 1)) - { - set_unsafely_optimized(expr); - set_opt1_lambda_add(expr, func); - if (symbols == 2) - { - set_opt2_sym(expr, arg2); - if (!one_form) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SS : OP_CLOSURE_SS)); - else - if (!safe_case) - set_optimize_op(expr, hop + OP_CLOSURE_SS_O); - else - if (!is_fxable(sc, car(body))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_O); - else - { - fx_annotate_arg(sc, body, e); - fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func)), NULL, false); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_A); - /* fx_annotate_args(sc, cdr(expr), e); */ - set_closure_one_form_fx_arg(func); - return(OPT_T); - } - return(OPT_F); - } - if (is_normal_symbol(arg1)) - { - if (one_form) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); /* _A case is very rare */ - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)); - set_opt2_con(expr, arg2); - return(OPT_F); - }} - - if ((!arglist_has_rest(sc, closure_args(func))) && - (fx_count(sc, expr) == 2)) - { - if (!one_form) - set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA)); - else - if (!safe_case) - set_optimize_op(expr, hop + OP_CLOSURE_AA_O); - else - if (!is_fxable(sc, car(body))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_O); - else - { - fx_annotate_arg(sc, body, e); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_A); /* safe_closure_as|sa_a? */ - set_closure_one_form_fx_arg(func); - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); - return(OPT_T); - } - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); - return(OPT_F); - } - - if (is_fxable(sc, arg1)) - { - set_unsafely_optimized(expr); - fx_annotate_arg(sc, cdr(expr), e); - set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ - return(OPT_F); - } - - if ((is_pair(arg1)) && - (car(arg1) == sc->lambda_symbol) && - (is_pair(cdr(arg1))) && /* not (lambda) */ - (is_fxable(sc, arg2)) && - (is_null(cdr(closure_body(func))))) - { - fx_annotate_arg(sc, cddr(expr), e); - set_opt2_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, hop + OP_CLOSURE_FA); - check_lambda(sc, arg1, false); - - clear_symbol_list(sc); /* clobbered in check_lambda so restore it? */ - for (s7_pointer p = e; is_pair(p); p = cdr(p)) - if (is_normal_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - - /* check_lambda calls optimize_lambda if define in progress, else just optimize on the body */ - clear_safe_closure_body(cddr(arg1)); /* otherwise we need to fixup the local let for the optimizer -- see s7test intersection case 91492 */ - set_opt1_lambda_add(expr, func); - return(OPT_F); - } - - if (is_fxable(sc, arg2)) - { - set_unsafely_optimized(expr); - fx_annotate_arg(sc, cddr(expr), e); - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ - return(OPT_F); - } - - if (is_safe_closure(func)) /* clo* too */ - return(set_any_closure_np(sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_PP)); - - set_unsafely_optimized(expr); - set_optimize_op(expr, hop + OP_CLOSURE_PP); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ - return(OPT_F); - } - - if (is_closure_star(func)) - { - if (is_immutable(func)) hop = 1; - if (fx_count(sc, expr) == 2) - { - fixup_closure_star_aa(sc, func, expr, hop); - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - return(OPT_F); - }} - - if ((is_c_function_star(func)) && - (fx_count(sc, expr) == 2) && - (c_function_max_args(func) >= 1) && - (!is_symbol_and_keyword(arg2))) - { - if ((hop == 0) && ((is_immutable(func)) || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) hop = 1; - set_optimized(expr); - set_optimize_op(expr, hop + OP_SAFE_C_STAR_AA); /* k+c? = cc */ - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - set_c_function(expr, func); - return(OPT_T); - } - - if ((((is_any_vector(func)) && (vector_rank(func) == 2)) || (is_pair(func))) && - (is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) - { - set_unsafe_optimize_op(expr, ((is_pair(func)) ? OP_IMPLICIT_PAIR_REF_AA : OP_IMPLICIT_VECTOR_REF_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - return(OPT_T); - } - return((is_optimized(expr)) ? OPT_T : OPT_F); -} - -static opt_t optimize_safe_c_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, s7_pointer e) -{ - s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); - if (pairs == 0) - { - set_optimized(expr); - if (symbols == 0) - set_optimize_op(expr, hop + OP_SAFE_C_NC); - else - { - clear_has_fx(cdr(expr)); - if (symbols == 3) - { - set_optimize_op(expr, hop + OP_SAFE_C_SSS); - set_opt1_sym(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - } - else - if (symbols == 2) - if (!is_normal_symbol(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_CSS); - set_opt1_sym(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - } - else - if (!is_normal_symbol(arg3)) - { - set_opt2_con(cdr(expr), arg3); - set_opt1_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_SSC); - } - else - { - set_opt1_con(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCS); - } - else - if (is_normal_symbol(arg1)) - { - set_opt1_con(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCC); - } - else - if (is_normal_symbol(arg2)) - { - set_opt1_sym(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_opt3_con(cdr(expr), arg1); - set_optimize_op(expr, hop + OP_SAFE_C_CSC); - } - else - { - set_opt1_sym(cdr(expr), arg3); - set_opt2_con(cdr(expr), arg2); - set_opt3_con(cdr(expr), arg1); - set_optimize_op(expr, hop + OP_SAFE_C_CCS); - }} - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - - /* pairs != 0 */ - if (fx_count(sc, expr) == 3) - { - set_optimized(expr); - if (quotes == 1) - { - if ((symbols == 2) && - (is_normal_symbol(arg1)) && - (is_normal_symbol(arg3))) - { - set_opt1_con(cdr(expr), cadr(arg2)); /* fx_c_scs uses opt1_con */ - set_opt2_sym(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - if (symbols == 1) - { - if ((is_normal_symbol(arg3)) && - (is_proper_quote(sc, arg2)) && - (is_safe_c_s(arg1))) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS); /* lg */ - set_opt1_con(cdr(expr), cadr(arg2)); /* opt1_con is T_Pos|Ext (unchecked) */ - set_opt2_sym(cdr(expr), arg3); - set_opt3_sym(cdr(expr), cadr(arg1)); - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - if ((is_normal_symbol(arg2)) && - (is_proper_quote(sc, arg1)) && - (!is_pair(arg3))) - { - set_optimize_op(expr, hop + OP_SAFE_C_CSC); - set_opt1_sym(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_opt3_con(cdr(expr), cadr(arg1)); - choose_c_function(sc, expr, func, 3); - return(OPT_T); - }}} - - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - set_opt3_pair(expr, cddr(expr)); - set_optimize_op(expr, hop + OP_SAFE_C_AAA); - - if (pairs == 1) - { - if (is_pair(arg1)) set_optimize_op(expr, hop + OP_SAFE_C_AGG); - - if ((symbols == 0) && (is_pair(arg2))) - set_optimize_op(expr, hop + OP_SAFE_C_CAC); - else - { - if ((symbols == 1) && (is_pair(arg3))) - set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_C_CSA : OP_SAFE_C_SCA)); - else - { - if (symbols == 2) - { - if (is_normal_symbol(arg1)) - { - if (is_normal_symbol(arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_SSA); - clear_has_fx(cdr(expr)); /* has_fx might have been on (see s7test) */ - } - else set_optimize_op(expr, hop + OP_SAFE_C_SAS); - } - else - if (is_pair(arg1)) - set_optimize_op(expr, hop + OP_SAFE_C_ASS); - }}}} - else - if ((is_normal_symbol(arg1)) && (pairs == 2)) - set_optimize_op(expr, hop + OP_SAFE_C_SAA); - - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - return(OPT_F); /* tell caller to try something else */ -} - -static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, - int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - s7_pointer arg1, arg2, arg3; - if ((quotes > 0) && - (direct_memq(sc->quote_symbol, e))) - return(OPT_OOPS); - - arg1 = cadr(expr); - arg2 = caddr(expr); - arg3 = cadddr(expr); - if (((is_symbol(arg1)) && - (!arg_findable(sc, arg1, e))) || - ((is_symbol(arg2)) && - (!arg_findable(sc, arg2, e))) || - ((is_symbol(arg3)) && - (!arg_findable(sc, arg3, e)))) - { - /* wrap bad args */ - if ((is_fxable(sc, arg1)) && - (is_fxable(sc, arg2)) && - (is_fxable(sc, arg3)) && - (s7_is_aritable(sc, func, 3))) - { - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - if (is_c_function(func)) - { - if (is_safe_procedure(func)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_AAA); - set_opt3_pair(cdr(expr), cdddr(expr)); - set_opt3_pair(expr, cddr(expr)); - } - else set_safe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_NA : OP_C_NA)); - set_c_function(expr, func); - return(OPT_T); - } - if ((is_closure(func)) && - (closure_arity_to_int(sc, func) == 3) && - (!arglist_has_rest(sc, closure_args(func)))) - { - set_unsafely_optimized(expr); - set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_3A : OP_CLOSURE_3A)); - set_opt1_lambda_add(expr, func); - return(OPT_F); - } - if ((is_closure_star(func)) && - (lambda_has_simple_defaults(func)) && - (closure_star_arity_to_int(sc, func) != 0) && - (closure_star_arity_to_int(sc, func) != 1)) - { - set_unsafely_optimized(expr); - if ((is_safe_closure(func)) && (closure_star_arity_to_int(sc, func) == 3)) - set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); - else set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); - set_opt1_lambda_add(expr, func); - }} - return(OPT_F); - } /* end of bad symbol wrappers */ - - if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; - - if (is_c_function(func) && (c_function_is_aritable(func, 3))) - { - if (hop == 0) hop = hop_if_constant(sc, car(expr)); - if ((is_safe_procedure(func)) || - ((is_maybe_safe(func)) && (unsafe_is_safe(sc, arg3, e)))) - { - if (optimize_safe_c_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, e) == OPT_T) - return(OPT_T); - if ((is_normal_symbol(arg1)) && (is_normal_symbol(arg2))) - { - set_opt3_pair(expr, arg3); - set_unsafe_optimize_op(expr, hop + OP_SAFE_C_SSP); - choose_c_function(sc, expr, func, 3); - return(OPT_F); - } - return(set_any_c_np(sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); - } - /* func is not safe */ - if (fx_count(sc, expr) == 3) - { - set_optimized(expr); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - if (is_semisafe(func)) - set_optimize_op(expr, hop + (((is_normal_symbol(arg1)) && (is_normal_symbol(arg3))) ? OP_CL_SAS : OP_CL_NA)); - else set_optimize_op(expr, hop + OP_C_NA); - choose_c_function(sc, expr, func, 3); - set_unsafe(expr); - return(OPT_F); - } - - /* (define (hi) (catch #t (lambda () 1) (lambda args 2))) - * first arg list must be (), second a symbol - */ - if (c_function_call(func) == g_catch) - { - if (((bad_pairs == 2) && (!is_pair(arg1))) || - ((bad_pairs == 3) && (car(arg1) == sc->quote_symbol))) - { - s7_pointer body_lambda = arg2, error_lambda = arg3; - if ((is_ok_lambda(sc, body_lambda)) && - (is_ok_lambda(sc, error_lambda)) && - (is_null(cadr(body_lambda))) && - (((is_symbol(cadr(error_lambda))) && /* (lambda args ... */ - (!is_probably_constant(cadr(error_lambda)))) || - ((is_pair(cadr(error_lambda))) && /* (lambda (type info) ... */ - (is_pair(cdadr(error_lambda))) && - (is_null(cddadr(error_lambda))) && - (!is_probably_constant(caadr(error_lambda))) && /* (lambda (pi ...) ...) */ - (!is_probably_constant(cadadr(error_lambda)))))) - { - s7_pointer error_result = caddr(error_lambda); - set_unsafely_optimized(expr); - if ((arg1 == sc->T) && /* tag is #t */ - (is_null(cdddr(error_lambda))) && /* error lambda body is one expr */ - ((!is_symbol(error_result)) || /* (lambda args #f) */ - ((is_pair(cadr(error_lambda))) && - (error_result == caadr(error_lambda)))) && /* (lambda (type info) type) */ - ((!is_pair(error_result)) || - (car(error_result) == sc->quote_symbol) || /* (lambda args 'a) */ - ((car(error_result) == sc->car_symbol) && - (is_pair(cdr(error_result))) && /* (lambda (type info) (car)) */ - (cadr(error_result) == cadr(error_lambda))))) /* (lambda args (car args) -> error-type */ - { - set_optimize_op(expr, OP_C_CATCH_ALL); /* catch_all* = #t tag, error handling can skip to the simple lambda body */ - set_c_function(expr, func); - - if (is_pair(error_result)) - error_result = (car(error_result) == sc->quote_symbol) ? cadr(error_result) : sc->unused; - else - if (is_symbol(error_result)) - error_result = sc->unused; - set_opt2_con(expr, error_result); /* for op_c_catch_all|_a -> stack */ - - set_opt1_pair(cdr(expr), cddr(body_lambda)); - if (is_null(cdddr(body_lambda))) - { - if (is_fxable(sc, caddr(body_lambda))) - { - set_optimize_op(expr, OP_C_CATCH_ALL_A); - set_fx_direct(cddr(body_lambda), fx_choose(sc, cddr(body_lambda), sc->curlet, let_symbol_is_safe)); - } - else - { - set_opt1_pair(cdr(expr), caddr(body_lambda)); - set_optimize_op(expr, OP_C_CATCH_ALL_O); - /* fn got no hits */ - }}} - else - { - set_optimize_op(expr, OP_C_CATCH); /* mainly c_catch_p, but this is not a common case */ - choose_c_function(sc, expr, func, 3); - } - return(OPT_F); - }}} - - if ((is_semisafe(func)) && - (is_symbol(car(expr))) && (car(expr) != sc->values_symbol) && - (is_fxable(sc, arg2)) && (is_fxable(sc, arg3)) && - (is_pair(arg1)) && (car(arg1) == sc->lambda_symbol)) - { - choose_c_function(sc, expr, func, 3); - if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && - (is_proper_list_2(sc, cadr(arg1))) && /* two parameters */ - (is_symbol(caadr(arg1))) && (!is_possibly_constant(caadr(arg1))) && /* parameter name not trouble */ - (is_symbol(cadadr(arg1))) && (!is_possibly_constant(cadadr(arg1)))) - { - fx_annotate_args(sc, cddr(expr), e); - check_lambda(sc, arg1, true); /* this changes symbol_list */ - - clear_symbol_list(sc); /* so restore it */ - for (s7_pointer p = e; is_pair(p); p = cdr(p)) - if (is_normal_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - - set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure_2 : NULL); - set_opt3_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FAA); - return(OPT_F); - }} - - if ((is_safe_procedure(func)) || - ((is_semisafe(func)) && - (((car(expr) != sc->assoc_symbol) && (car(expr) != sc->member_symbol)) || - (unsafe_is_safe(sc, arg3, e))))) - return(set_any_c_np(sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); - return(set_any_c_np(sc, func, expr, e, 3, hop + OP_ANY_C_NP)); - } - - /* not c func */ - if (is_closure(func)) - { - int32_t arit = closure_arity_to_int(sc, func); - if (arit != 3) - { - if (is_symbol(closure_args(func))) - return(optimize_closure_sym(sc, expr, func, hop, 3, e)); - return(OPT_F); - } - if (is_immutable(func)) hop = 1; - - if (symbols == 3) - { - s7_pointer body = closure_body(func); - bool one_form = is_null(cdr(body)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 3); - - if (is_safe_closure(func)) - { - if ((one_form) && - (is_fxable(sc, car(body)))) - { - set_opt2_sym(expr, arg2); - set_opt3_sym(expr, arg3); - fx_annotate_arg(sc, body, e); - fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func)), caddr(closure_args(func)), false); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S_A); - set_closure_one_form_fx_arg(func); - } - else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)); - return(OPT_F); - } - - if (fx_count(sc, expr) == 3) - { - if (is_safe_closure(func)) - { - if ((!is_pair(arg2)) && (!is_pair(arg3))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AGG); - else - if (is_normal_symbol(arg1)) - set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); - else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3A); - } - else - if ((is_normal_symbol(arg2)) && (is_normal_symbol(arg3))) - set_optimize_op(expr, hop + OP_CLOSURE_ASS); - else - if (is_normal_symbol(arg1)) - set_optimize_op(expr, hop + ((is_normal_symbol(arg3)) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); - else - if (is_normal_symbol(arg3)) - set_optimize_op(expr, hop + OP_CLOSURE_AAS); - else set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_CLOSURE_ASA : OP_CLOSURE_3A)); - set_unsafely_optimized(expr); - fx_annotate_args(sc, cdr(expr), e); - - if (is_fx_treeable(cdr(expr))) - fx_tree(sc, closure_body(func), car(closure_args(func)), cadr(closure_args(func)), caddr(closure_args(func)), false); - - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 3); - return(OPT_F); - } - return(set_any_closure_np(sc, func, expr, e, 3, hop + OP_ANY_CLOSURE_3P)); - } - - if (is_closure_star(func)) - { - if ((!lambda_has_simple_defaults(func)) || - (closure_star_arity_to_int(sc, func) == 0) || - (closure_star_arity_to_int(sc, func) == 1)) - return(OPT_F); - if (fx_count(sc, expr) == 3) - { - if (is_immutable(func)) hop = 1; - if ((is_safe_closure(func)) && (closure_star_arity_to_int(sc, func) == 3)) - set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); - else set_unsafe_optimize_op(expr, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 3); - return(OPT_F); - }} - - if ((is_c_function_star(func)) && - (fx_count(sc, expr) == 3) && - (c_function_max_args(func) >= 2)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - set_c_function(expr, func); - return(OPT_T); - } - /* implicit_vector_3a doesn't happen */ - - if (bad_pairs > quotes) return(OPT_F); - return((is_optimized(expr)) ? OPT_T : OPT_F); -} - -static bool symbols_are_safe(s7_scheme *sc, s7_pointer args, s7_pointer e) -{ - for (s7_pointer p = args; is_pair(p); p = cdr(p)) - { - s7_pointer arg = car(p); - if ((is_normal_symbol(arg)) && - (!arg_findable(sc, arg, e))) - return(false); - } - return(true); -} - -static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, - int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) -{ - bool func_is_closure; - if (quotes > 0) - { - if (direct_memq(sc->quote_symbol, e)) - return(OPT_OOPS); - if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; - } - if ((is_c_function(func)) && (c_function_is_aritable(func, args))) - { - if (hop == 0) hop = hop_if_constant(sc, car(expr)); - if (is_safe_procedure(func)) - { - if (pairs == 0) - { - if (symbols == 0) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); - choose_c_function(sc, expr, func, args); - return(OPT_T); - } - if (symbols == args) - { - if (symbols_are_safe(sc, cdr(expr), e)) - set_safe_optimize_op(expr, hop + OP_SAFE_C_NS); - else - { - set_safe_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA)); - fx_annotate_args(sc, cdr(expr), e); - } - set_opt3_arglen(cdr(expr), args); - choose_c_function(sc, expr, func, args); - return(OPT_T); - }} - - if (fx_count(sc, expr) == args) - { - s7_pointer p; - set_optimized(expr); - set_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - choose_c_function(sc, expr, func, args); - - for (p = cdr(expr); (is_pair(p)) && (is_pair(cdr(p))); p = cddr(p)) - { - if (is_normal_symbol(car(p))) - break; - if ((is_pair(car(p))) && - ((!is_pair(cdar(p))) || (caar(p) != sc->quote_symbol))) - break; - } - if (is_null(p)) - { - set_optimize_op(expr, hop + OP_SAFE_C_ALL_CA); - for (p = cdr(expr); is_pair(p); p = cddr(p)) - { - clear_has_fx(p); - set_opt2_con(p, (is_pair(car(p))) ? cadar(p) : car(p)); - }} - return(OPT_T); - } - return(set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); - } - /* c_func is not safe */ - if (fx_count(sc, expr) == args) /* trigger_size doesn't matter for unsafe funcs */ - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_NA : OP_C_NA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - choose_c_function(sc, expr, func, args); - return(OPT_F); - } - return(set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */ - } - - func_is_closure = is_closure(func); - if (func_is_closure) - { - int32_t arit = closure_arity_to_int(sc, func); - if (arit != args) - { - if (is_symbol(closure_args(func))) - return(optimize_closure_sym(sc, expr, func, hop, args, e)); - return(OPT_F); - } - if (is_immutable(func)) hop = 1; - - if (fx_count(sc, expr) == args) - { - bool safe_case = is_safe_closure(func); - set_unsafely_optimized(expr); - set_unsafe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_NA : ((args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA))); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - set_opt1_lambda_add(expr, func); - - if ((symbols == args) && - (symbols_are_safe(sc, cdr(expr), e))) - { - if (safe_case) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_NS); - else set_optimize_op(expr, hop + ((args == 4) ? ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S) : OP_CLOSURE_NS)); - } - return(OPT_F); - } - if (args == 4) - return(set_any_closure_np(sc, func, expr, e, 4, hop + OP_ANY_CLOSURE_4P)); - return(set_any_closure_np(sc, func, expr, e, args, hop + OP_ANY_CLOSURE_NP)); - } - - if ((is_closure_star(func)) && - ((!lambda_has_simple_defaults(func)) || - (closure_star_arity_to_int(sc, func) == 0) || - (closure_star_arity_to_int(sc, func) == 1))) - return(OPT_F); - - if ((is_c_function_star(func)) && - (fx_count(sc, expr) == args) && - (c_function_max_args(func) >= (args / 2))) - { - if (is_immutable(func)) hop = 1; - set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - set_c_function(expr, func); - return(OPT_T); - } - if (((func_is_closure) || - (is_closure_star(func))) && - (fx_count(sc, expr) == args)) - { - set_unsafely_optimized(expr); - if (func_is_closure) - set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_NA : ((args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA))); - else set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - set_opt1_lambda_add(expr, func); - return(OPT_F); - } - return((is_optimized(expr)) ? OPT_T : OPT_F); -} - -static bool vars_syntax_ok(s7_pointer vars) -{ - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((!is_pair(var)) || - (!is_symbol(car(var))) || - (!is_pair(cdr(var)))) - return(false); - } - return(true); -} - -static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7_pointer e, bool export_ok); - -static bool vars_opt_ok(s7_scheme *sc, s7_pointer vars, int32_t hop, s7_pointer e) -{ - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer init = cadar(p); - /* if ((is_slot(global_slot(caar(p)))) && (is_c_function(global_value(caar(p))))) return(false); */ /* too draconian (see snd-test) */ - if ((is_pair(init)) && - (!is_checked(init)) && - (optimize_expression(sc, init, hop, e, false) == OPT_OOPS)) - return(false); - } - return(true); -} - -static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e, bool export_ok) -{ - opcode_t op = syntax_opcode(func); - s7_pointer body = cdr(expr), vars; - bool body_export_ok = true; - - sc->w = e; - switch (op) - { - case OP_QUOTE: - case OP_MACROEXPAND: - return((is_proper_list_1(sc, body)) ? OPT_F : OPT_OOPS); - - case OP_LET: - case OP_LETREC: - case OP_LET_STAR: - case OP_LETREC_STAR: - if (is_symbol(cadr(expr))) - { - if (!is_pair(cddr(expr))) /* (let name . x) */ - return(OPT_F); - vars = caddr(expr); - if (!is_list(vars)) return(OPT_OOPS); - body = cdddr(expr); - } - else - { - vars = cadr(expr); - body = cddr(expr); - if (is_null(vars)) - e = cons(sc, sc->nil, e); /* () in e = empty let */ - else - if (!is_pair(vars)) - return(OPT_OOPS); - } - if (!is_pair(body)) return(OPT_OOPS); - - if (!vars_syntax_ok(vars)) - return(OPT_OOPS); - - if ((op == OP_LETREC) || (op == OP_LETREC_STAR)) - { - e = collect_variables(sc, vars, e); - if (!vars_opt_ok(sc, vars, hop, e)) - return(OPT_OOPS); - } - else - if (op == OP_LET) - { - if (!vars_opt_ok(sc, vars, hop, e)) - return(OPT_OOPS); - e = collect_variables(sc, vars, e); - } - else - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((is_pair(cadr(var))) && - (!is_checked(cadr(var))) && - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - e = cons(sc, add_symbol_to_list(sc, car(var)), e); - sc->w = e; - } - if (is_symbol(cadr(expr))) - { - e = cons(sc, add_symbol_to_list(sc, cadr(expr)), e); - sc->w = e; - } - break; - - case OP_LET_TEMPORARILY: - vars = cadr(expr); - if (!is_list(vars)) return(OPT_OOPS); - body = cddr(expr); - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(vars); - if ((is_pair(var)) && - (is_pair(cdr(var))) && - (is_pair(cadr(var))) && - (!is_checked(cadr(var))) && - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - } - /* e = cons(sc, sc->nil, e); */ /* !? currently let-temporarily does not make a new let, so it is like begin? */ - body_export_ok = export_ok; /* (list x (let-temporarily () (define x 0))) just as in begin */ - break; - - case OP_DO: - vars = cadr(expr); - if (is_null(vars)) - e = cons(sc, sc->nil, e); - else - if (!is_pair(vars)) - return(OPT_OOPS); - body = cddr(expr); - - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((!is_pair(var)) || - (!is_symbol(car(var))) || - (!is_pair(cdr(var)))) - return(OPT_OOPS); - if ((is_pair(cadr(var))) && - (!is_checked(cadr(var))) && - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) /* the init field -- locals are not defined yet */ - return(OPT_OOPS); - } - e = collect_variables(sc, vars, e); - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = cddar(p); - if ((is_pair(var)) && - (is_pair(car(var))) && - (!is_checked(car(var))) && - (optimize_expression(sc, car(var), hop, e, false) == OPT_OOPS)) /* the step field -- locals are defined */ - return(OPT_OOPS); - } - break; - - case OP_BEGIN: - body_export_ok = export_ok; /* (list x (begin (define x 0))) */ - break; - - case OP_WITH_BAFFLE: - e = cons(sc, sc->nil, e); - break; - - case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR: - case OP_BACRO: case OP_BACRO_STAR: - return(OPT_F); - - case OP_DEFINE_MACRO: case OP_DEFINE_MACRO_STAR: - case OP_DEFINE_CONSTANT: case OP_DEFINE_EXPANSION: case OP_DEFINE_EXPANSION_STAR: - case OP_DEFINE: case OP_DEFINE_STAR: - /* define adds a name to the incoming let (e), the added name is inserted into e after the first, so the caller - * can flush added symbols by maintaining its own pointer into the list if blockers set the car. - * the list is used both to see local symbols and to catch "complicated" functions (find_uncomplicated_symbol). - * In cases like (if expr (define...)) we can't tell at this level whether the define takes place, so - * its name should not be in "e", but it needs to be marked for find_uncomplicated_symbol in a way - * that can be distinguished from members of "e". So in that (rare) case, we use the associated keyword. - * Then find_uncomplicated_symbol can use has_keyword to tell if the keyword search is needed. - * export_ok is trying to protect against optimizing (list x (define x 0)) as op_safe_c_sp and all related cases - */ - vars = cadr(expr); - body = cddr(expr); - if (is_pair(vars)) - { - if ((export_ok) && - (is_symbol(car(vars)))) - { - add_symbol_to_list(sc, car(vars)); - if (is_pair(e)) - { - if (car(e) != sc->if_keyword) - set_cdr(e, cons(sc, car(vars), cdr(e))); /* export it */ - else add_symbol_to_list(sc, symbol_to_keyword(sc, car(vars))); - } - else e = cons(sc, car(vars), e); - } - e = collect_parameters(sc, cdr(vars), e); - body_export_ok = export_ok; - } - else - { - if ((export_ok) && - (is_symbol(vars))) - { - /* actually if this is defining a function, the name should probably be included in the local let - * but that's next-to-impossible to guarantee unless it's (define x (lambda...)) of course. - */ - sc->temp9 = e; - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ - (optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS)) /* "body" here is not body in terms of export_ok */ - { - sc->temp9 = sc->unused; - return(OPT_OOPS); - } - sc->temp9 = sc->unused; - - add_symbol_to_list(sc, vars); - if (is_pair(e)) - { - if (car(e) != sc->if_keyword) - set_cdr(e, cons(sc, vars, cdr(e))); /* export it */ - else add_symbol_to_list(sc, symbol_to_keyword(sc, vars)); - } - /* else e = cons(sc, vars, e); */ /* ?? should this be set-cdr etc? */ - return(OPT_F); - } - body_export_ok = false; - } - break; - - case OP_LAMBDA: case OP_LAMBDA_STAR: - case OP_MACRO: case OP_MACRO_STAR: - vars = cadr(expr); - if (is_null(vars)) - e = cons(sc, sc->nil, e); - else - if ((!is_pair(vars)) && (!is_symbol(vars))) - return(OPT_OOPS); - e = collect_parameters(sc, vars, e); - body = cddr(expr); - break; - - case OP_SET: - if ((is_pair(cadr(expr))) && (caadr(expr) == sc->outlet_symbol)) - return(OPT_OOPS); - if (!is_pair(cddr(expr))) - return(OPT_OOPS); - if ((is_pair(cadr(expr))) && - (!is_checked(cadr(expr)))) - { - set_checked(cadr(expr)); - for (s7_pointer lp = cdadr(expr); is_pair(lp); lp = cdr(lp)) - if ((is_pair(car(lp))) && - (!is_checked(car(lp))) && - (optimize_expression(sc, car(lp), hop, e, body_export_ok) == OPT_OOPS)) - return(OPT_OOPS); - } - if ((is_pair(caddr(expr))) && - (!is_checked(caddr(expr))) && - (optimize_expression(sc, caddr(expr), hop, e, body_export_ok) == OPT_OOPS)) - return(OPT_OOPS); - - if ((is_pair(cadr(expr))) && (caadr(expr) == sc->s7_starlet_symbol)) - return(OPT_T); - return(OPT_F); - - case OP_WITH_LET: - /* we usually can't trust anything here, so hop ought to be off. For example, - * (define (hi) (let ((e (sublet (curlet) :abs (lambda (a) (- a 1))))) (with-let e (abs -1)))) - * returns 1 if hop is 1, but -2 otherwise. (with-let (unlet)...) is safe however. - */ - { - bool old_with_let = sc->in_with_let; - sc->in_with_let = (old_with_let) || (!is_pair(body)) || (!is_pair(car(body))) || - ((caar(body) != sc->unlet_symbol) && /* (caar(body) != sc->rootlet_symbol) && */ (caar(body) != sc->curlet_symbol)); - /* not rootlet here: (let ((i 0)) (_rd3_ (with-let (rootlet) ((null? i) i)))) */ - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (!is_checked(car(p))) && - (optimize_expression(sc, car(p), 0, sc->nil, body_export_ok) == OPT_OOPS)) - { - sc->in_with_let = old_with_let; - return(OPT_OOPS); - } - sc->in_with_let = old_with_let; - return(OPT_F); - } - - case OP_CASE: - if ((is_pair(cadr(expr))) && - (!is_checked(cadr(expr))) && - (optimize_expression(sc, cadr(expr), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - for (s7_pointer p = cddr(expr); is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (is_pair(cdar(p)))) - for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) - if ((is_pair(car(rst))) && - (!is_checked(car(rst))) && - (optimize_expression(sc, car(rst), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - return(OPT_F); - - case OP_COND: /* split opt is necessary: (cond (lambda (x) ...)) */ - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - if (is_pair(car(p))) - { - s7_pointer test = caar(p); - e = cons(sc, sc->if_keyword, e); /* I think this is a marker in case define is encountered? (see above) */ - if ((is_pair(test)) && - (!is_checked(test)) && - (optimize_expression(sc, test, hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) - if ((is_pair(car(rst))) && - (!is_checked(car(rst))) && - (optimize_expression(sc, car(rst), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - } - { - s7_pointer p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - { - s7_pointer q; - if ((!is_pair(car(p))) || (!is_fxable(sc, caar(p)))) - break; - if (!is_pair(cdar(p))) - break; - for (q = cdar(p); is_pair(q); q = cdr(q)) - if ((car(q) == sc->feed_to_symbol) || (!is_fxable(sc, car(q)))) - break; - if (!is_null(q)) break; - } - if (!is_null(p)) return(OPT_F); - set_safe_optimize_op(expr, OP_COND_NA_NA); - } - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - { - set_fx_direct(car(p), fx_choose(sc, car(p), e, pair_symbol_is_safe)); - for (s7_pointer q = cdar(p); is_pair(q); q = cdr(q)) - set_fx_direct(q, fx_choose(sc, q, e, pair_symbol_is_safe)); - } - return(OPT_T); - - case OP_IF: case OP_WHEN: case OP_UNLESS: - if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) - return(OPT_OOPS); - case OP_OR: case OP_AND: - e = cons(sc, sc->if_keyword, e); - break; - - default: - break; - } - - sc->temp9 = e; - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ - (optimize_expression(sc, car(p), hop, e, body_export_ok) == OPT_OOPS)) - { - sc->temp9 = sc->unused; - return(OPT_OOPS); - } - sc->temp9 = sc->unused; - - if ((hop == 1) && - ((is_syntax(car(expr))) || - (symbol_id(car(expr)) == 0))) - { - if (op == OP_IF) - { - s7_pointer test = cdr(expr), b1, b2, p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(OPT_F); - if (!is_null(p)) return(OPT_OOPS); - if ((is_pair(cdr(test))) && (is_pair(cddr(test))) && (!is_null(cdddr(test)))) - return(OPT_OOPS); - - for (p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); - - b1 = cdr(test); - b2 = cdr(b1); - if ((fx_proc(b1) == fx_q) && - (is_pair(b2))) - { - set_opt3_con(test, cadar(b1)); - if (fx_proc(b2) == fx_q) - { - set_safe_optimize_op(expr, OP_IF_A_C_C); - set_opt1_con(expr, cadar(b1)); - set_opt2_con(expr, cadar(b2)); - return(OPT_T); - } - set_opt1_pair(expr, b1); - set_opt2_pair(expr, b2); - set_safe_optimize_op(expr, OP_IF_A_A_A); - } - else - { - if ((is_pair(car(test))) && - (caar(test) == sc->not_symbol) && - (is_fxable(sc, cadar(test)))) - { - set_fx_direct(cdar(test), fx_choose(sc, cdar(test), e, pair_symbol_is_safe)); - set_opt1_pair(expr, cdar(test)); - set_opt2_pair(expr, b1); - if (is_pair(b2)) set_opt3_pair(expr, b2); - set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_NOT_A_A : OP_IF_NOT_A_A_A); - } - else - { - if ((is_pair(b2)) && (fx_proc(b1) == fx_c) && (fx_proc(b2) == fx_c)) - { - set_safe_optimize_op(expr, OP_IF_A_C_C); - set_opt1_con(expr, car(b1)); - set_opt2_con(expr, car(b2)); - return(OPT_T); - } - if ((fx_proc(test) == fx_and_2a) && (fx_proc(b1) == fx_s)) - { - set_opt1_pair(expr, cdadr(expr)); - set_opt2_pair(expr, cddadr(expr)); - set_opt3_sym(expr, car(b1)); - set_safe_optimize_op(expr, OP_IF_AND2_S_A); - return(OPT_T); - } - set_opt1_pair(expr, b1); - if (is_pair(b2)) set_opt2_pair(expr, b2); - set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_A_A : ((fx_proc(test) == fx_s) ? OP_IF_S_A_A : OP_IF_A_A_A)); - }} - return(OPT_T); - } - else - { - if ((op == OP_OR) || (op == OP_AND)) - { - int32_t args, pairs = 0; - s7_pointer p, sym = NULL; - bool c_s_is_ok = true; - - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(OPT_F); - if (!is_null(p)) return(OPT_OOPS); - for (args = 0, p = cdr(expr); is_pair(p); p = cdr(p), args++) /* this only applies to or/and */ - if (is_pair(car(p))) - { - pairs++; - if ((c_s_is_ok) && - ((!is_h_safe_c_s(car(p))) || - ((sym) && (sym != cadar(p))))) - c_s_is_ok = false; - else sym = (is_pair(cdar(p))) ? cadar(p) : sc->unspecified; - } - - if ((c_s_is_ok) && (args == 2) && (pairs == 2)) - { - if (op == OP_OR) - { - set_opt3_sym(cdr(expr), cadadr(expr)); - if ((is_symbol(caadr(expr))) && (symbol_type(caadr(expr)) > 0) && (is_global(caadr(expr))) && - ((is_symbol(caaddr(expr))) && (symbol_type(caaddr(expr)) > 0) && (is_global(caaddr(expr))))) - { - set_opt3_int(expr, symbol_type(caadr(expr))); - set_opt2_int(cdr(expr), symbol_type(caaddr(expr))); - set_safe_optimize_op(expr, OP_OR_S_TYPE_2); - } - else set_safe_optimize_op(expr, OP_OR_S_2); - } - else - { - set_opt3_sym(cdr(expr), cadadr(expr)); - set_safe_optimize_op(expr, OP_AND_S_2); - } - return(OPT_T); - } - - for (p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); - if (op == OP_OR) - { - if (args == 2) - set_safe_optimize_op(expr, OP_OR_2A); - else - { - if (args == 3) - set_safe_optimize_op(expr, OP_OR_3A); - else set_safe_optimize_op(expr, OP_OR_N); - } - return(OPT_T); - } - if (args == 2) - set_safe_optimize_op(expr, OP_AND_2A); - else set_safe_optimize_op(expr, (args == 3) ? OP_AND_3A : OP_AND_N); - return(OPT_T); - } - else - if (op == OP_BEGIN) - { - s7_pointer p; - if (!is_pair(cdr(expr))) return(OPT_F); - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(OPT_F); - if (!is_null(p)) return(OPT_OOPS); - for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); - set_safe_optimize_op(expr, ((is_pair(cddr(expr))) && (is_null(cdddr(expr)))) ? OP_BEGIN_AA : OP_BEGIN_NA); - return(OPT_T); - }}} /* fully fxable lets don't happen much: even let-2a-a is scarcely used */ - return(OPT_F); -} - - -static opt_t optimize_funcs(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t orig_hop, s7_pointer e) -{ - int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0; - s7_pointer p; - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display_80(expr)); - for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the args (the calling expression) */ - { - s7_pointer car_p = car(p); - if (is_normal_symbol(car_p)) /* for opt func */ - symbols++; - else - if (is_pair(car_p)) - { - pairs++; - if (!is_checked(car_p)) - { - opt_t res; - if ((is_pair(car(car_p))) && (caar(car_p) == sc->let_symbol)) /* TODO: fix this! ((let () quasiquote) (vector i x)) -> apply in a function! */ - res = OPT_F; /* maybe: is_syntactic_symbol through car(car_p)? */ - else res = optimize_expression(sc, car_p, orig_hop, e, false); - if (res == OPT_F) - { - bad_pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - } - else - if (res == OPT_OOPS) - return(OPT_OOPS); - } - else - if ((!is_optimized(car_p)) || - (is_unsafe(car_p))) - { - bad_pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - }}} - if (is_null(p)) /* if not null, dotted list of args, (cons 1 . 2) etc -- error perhaps? */ - { - switch (args) - { - case 0: return(optimize_thunk(sc, expr, func, hop, e)); - case 1: return(optimize_func_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - case 2: return(optimize_func_two_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - case 3: return(optimize_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - default: return(optimize_func_many_args(sc, expr, func, hop, args, pairs, symbols, quotes, bad_pairs, e)); - }} - return(OPT_OOPS); /* was OPT_F, but this is always an error */ -} - -static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7_pointer e, bool export_ok) -{ - s7_pointer car_expr = car(expr); - int32_t orig_hop = hop; - set_checked(expr); - - if (is_symbol(car_expr)) - { - s7_pointer slot; - if (is_syntactic_symbol(car_expr)) - { - if (!is_pair(cdr(expr))) - return(OPT_OOPS); - return(optimize_syntax(sc, expr, T_Syn(global_value(car_expr)), hop, e, export_ok)); - } - slot = find_uncomplicated_symbol(sc, car_expr, e); /* local vars (recursive calls too??) are considered complicated */ - if (is_slot(slot)) - { - s7_pointer func = slot_value(slot); - if (is_syntax(func)) /* not is_syntactic -- here we have the value */ - return((is_pair(cdr(expr))) ? optimize_syntax(sc, expr, func, hop, e, export_ok) : OPT_OOPS); /* e can be extended via set-cdr! here */ - - if (is_any_macro(func)) - return(OPT_F); - - /* we miss implicit indexing here because at this time, the data are not set */ - if ((is_t_procedure(func)) || /* t_procedure_p: c_funcs, closures, etc */ - ((is_applicable(func)) && - (is_safe_procedure(func)))) /* built-in applicable objects like vectors */ - { - if ((hop != 0) && - ((is_any_closure(func)) || /* see use-redef in s7test -- I'm not sure about this */ - ((!is_global(car_expr)) && - ((!is_slot(global_slot(car_expr))) || - (global_value(car_expr) != func)))) && - (!is_immutable(car_expr)) && /* list|apply-values -- can't depend on opt1 here because it might not be global, or might be redefined locally */ - (!is_immutable(slot))) /* (define-constant...) */ - { - /* (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a)) (f1 12)) - * (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a 1)) (f1 12)) - * and similar define* cases - */ - hop = 0; - /* this is very tricky! See s7test for some cases. Basically, we need to protect a recursive call - * of the current function being optimized from being confused with some previous definition - * of the same name. But method lists have global names so the global bit is off even though the - * thing is actually a safe global. But no closure can be considered safe in the hop sense -- - * even a global function might be redefined at any time, and previous uses of it in other functions - * need to reflect its new value. - * So, closures are always checked, but built-in functions are used as if never redefined until that redefinition. - * Syntax handling is already impure in s7, so the special handling of built-in functions doesn't - * offend me much. Consider each a sort of reader macro until someone redefines it -- previous - * uses might not be affected because they might have been optimized away -- the result depends on the - * current optimizer. - * Another case (from K Matheussen): - * (define (call-func func arg1 arg2) (define (call) (func arg1 arg2)) (call)) (call-func + 1 2.5) (call-func - 5 2) - * when we get here originally "func" is +, hop=1, but just checking for !is_global(car_expr) is - * not good enough -- if we load mockery.scm, nothing is global! - * Yet another case (define (test-abs) (define (abs x) (+ x 1)) (format *stderr* "abs ~A~%" (abs -1))) - * when optimize_syntax sees the (define abs ...), it inserts abs into e so that the caller's e is extended (set-cdr!) - * so that find_uncomplicated_symbol above will be unhappy when we reach (abs -1) as the format arg. - * This can be confused if lambda is redefined at some point, but... - */ - } - return(optimize_funcs(sc, expr, func, hop, orig_hop, e)); - }} - else - if ((sc->undefined_identifier_warnings) && - (slot == sc->undefined) && /* car_expr is not in e or global */ - (symbol_tag(car_expr) == 0)) /* and we haven't looked it up earlier */ - { - s7_pointer p = current_input_port(sc); - if ((is_input_port(p)) && - (port_file(p) != stdin) && - (!port_is_closed(p)) && - (port_filename(p))) - s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", display(car_expr), port_filename(p), port_line_number(p)); - else s7_warn(sc, 1024, "; %s might be undefined\n", display(car_expr)); - symbol_set_tag(car_expr, 1); /* one warning is enough */ - } - - /* car_expr is a symbol but it's not a built-in procedure or a safe case = vector etc */ - { - /* else maybe it's something like a let variable binding: (sqrtfreq (sqrt frequency)) */ - s7_pointer p; - int32_t len = 0, pairs = 0, symbols = 0; - - for (p = cdr(expr); is_pair(p); p = cdr(p), len++) - { - s7_pointer car_p = car(p); - if (is_pair(car_p)) - { - pairs++; - if ((!is_checked(car_p)) && - (optimize_expression(sc, car_p, hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - } - else - if (is_symbol(car_p)) - symbols++; - } - if ((is_null(p)) && /* (+ 1 . 2) */ - (!is_optimized(expr))) - { - /* len=0 case is almost entirely arglists */ - set_opt1_con(expr, sc->unused); - - if (pairs == 0) - { - if (len == 0) - { - /* hoping to catch object application here, as in readers in Snd */ - set_unsafe_optimize_op(expr, OP_UNKNOWN); - return(OPT_F); - } - if (len == 1) - { - if (car_expr != sc->quote_symbol) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */ - set_unsafe_optimize_op(expr, (is_normal_symbol(cadr(expr))) ? OP_UNKNOWN_S : OP_UNKNOWN_A); - fx_annotate_arg(sc, cdr(expr), e); /* g->a later if closure */ - return(OPT_F); - } - if (len == 2) - { - set_unsafely_optimized(expr); - set_optimize_op(expr, OP_UNKNOWN_GG); - return(OPT_F); - } - if (len >= 3) - { - if (len == symbols) - { - set_unsafe_optimize_op(expr, OP_UNKNOWN_NS); - set_opt3_arglen(cdr(expr), len); - return(OPT_F); - } - if (fx_count(sc, expr) == len) - { - set_unsafe_optimize_op(expr, OP_UNKNOWN_NA); - set_opt3_arglen(cdr(expr), len); - return(OPT_F); - }}} - else /* pairs != 0 */ - { - s7_pointer arg1 = cadr(expr); - if ((pairs == 1) && (len == 1)) - { - if ((car_expr == sc->quote_symbol) && - (direct_memq(sc->quote_symbol, e))) - return(OPT_OOPS); - - if (is_fxable(sc, arg1)) - { - set_opt3_arglen(cdr(expr), 1); - fx_annotate_arg(sc, cdr(expr), e); - set_unsafe_optimize_op(expr, OP_UNKNOWN_A); - return(OPT_F); - }} - if (fx_count(sc, expr) == len) - { - set_unsafe_optimize_op(expr, (len == 1) ? OP_UNKNOWN_A : ((len == 2) ? OP_UNKNOWN_AA : OP_UNKNOWN_NA)); - set_opt3_arglen(cdr(expr), len); - if (len <= 2) fx_annotate_args(sc, cdr(expr), e); - return(OPT_F); - } - set_unsafe_optimize_op(expr, OP_UNKNOWN_NP); - set_opt3_arglen(cdr(expr), len); - return(OPT_F); - }}}} - else - { - /* car(expr) is not a symbol, but there might be interesting stuff here */ - /* (define (hi a) (case 1 ((1) (if (> a 2) a 2)))) */ - s7_pointer p; - - if (is_c_function(car_expr)) /* (#_abs x) etc */ - return(optimize_funcs(sc, expr, car_expr, 1, orig_hop, e)); - - if (is_syntax(car_expr)) /* (#_cond ...) */ - { - if (!is_pair(cdr(expr))) - return(OPT_OOPS); - return(optimize_syntax(sc, expr, car_expr, orig_hop, e, export_ok)); - } - if (is_any_macro(car_expr)) - return(OPT_F); - - /* if car is a pair, we can't easily tell whether its value is (say) + or cond, so we need to catch this case and fixup fx settings */ - for (p = expr; is_pair(p); p = cdr(p)) - if (((is_symbol(car(p))) && (is_syntactic_symbol(car(p)))) || - ((is_pair(car(p))) && (!is_checked(car(p))) && - (optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS))) - return(OPT_OOPS); - /* here we get for example: - * ((if (not (let? p)) write write-to-vector) obj p) ; not uncomplicated/c-function [((if 3d fourth third) p) in index] - * ((if (symbol? (cadr f)) cadr (if (pair? (cadr f)) caadr not)) f) ; fx not symbol -- opif_a_aaq_a - * ((if (input-port? port) call-with-input-file call-with-output-file) port proc) ; not safe I guess - */ - } - return(OPT_F); -} - -static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e) -{ - s7_pointer x; - for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x)) - { - s7_pointer obj = car(x); - set_checked(x); - if (is_pair(obj)) - { - if ((!is_checked(obj)) && - (optimize_expression(sc, obj, hop, e, true) == OPT_OOPS)) - { - s7_pointer p; - for (p = cdr(x); is_pair(p); p = cdr(p)); - if (!is_null(p)) - syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); - return(OPT_OOPS); - }} - else /* new 22-Sep-19, but I don't think this saves anything over falling into trailers */ - if (is_symbol(obj)) - set_optimize_op(obj, (is_keyword(obj)) ? OP_CONSTANT : OP_SYMBOL); - else set_optimize_op(obj, OP_CONSTANT); - } - if (!is_list(x)) - syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); - return(OPT_F); -} - - -static bool symbol_is_in_arg_list(s7_pointer sym, s7_pointer lst) -{ - s7_pointer x; - for (x = lst; is_pair(x); x = cdr(x)) - if ((sym == car(x)) || - ((is_pair(car(x))) && (sym == caar(x)))) - return(true); - return(sym == x); -} - -static void check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *arity, s7_pointer form) -{ - s7_pointer x; - int32_t i; - - if (!is_list(args)) - { - if (is_constant(sc, args)) /* (lambda :a ...) or (define (f :a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "lambda parameter is a constant: (~S ~S ...)", 43), car(form), cadr(form))); - /* we currently accept (lambda i i . i) (lambda quote i) (lambda : : . #()) (lambda : 1 . "") - * at this level, but when the lambda form is evaluated, it will trigger an error. - */ - if (is_symbol(args)) set_local(args); - if (arity) (*arity) = -1; - return; - } - for (i = 0, x = args; is_pair(x); i++, x = cdr(x)) - { - s7_pointer car_x = car(x); - if (is_constant(sc, car_x)) /* (lambda (pi) pi), constant here means not a symbol */ - { - if (is_pair(car_x)) /* (lambda ((:hi . "hi") . "hi") 1) */ - error_nr(sc, sc->syntax_error_symbol, /* don't use ~A here or below, (lambda #\null do) for example */ - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a pair (perhaps use lambda*?): (~S ~S ...)", 65), - car_x, car(form), cadr(form))); - if ((car_x == sc->rest_keyword) && - ((car(form) == sc->define_symbol) || (car(form) == sc->lambda_symbol))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_5(sc, wrap_string(sc, "lambda parameter is ~S? (~S ~S ...), perhaps use ~S", 51), - car_x, car(form), cadr(form), - (car(form) == sc->define_symbol) ? sc->define_star_symbol : sc->lambda_star_symbol)); - error_nr(sc, sc->syntax_error_symbol, /* (lambda (a :b c) 1) */ - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: (~S ~S ...)", 46), - car_x, car(form), cadr(form))); - } - if (symbol_is_in_arg_list(car_x, cdr(x))) /* (lambda (a a) ...) or (lambda (a . a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is used twice in the parameter list, (~S ~S ...)", 68), - car_x, car(form), cadr(form))); - set_local(car_x); - } - if (is_not_null(x)) - { - if (is_constant(sc, x)) /* (lambda (a . 0.0) a) or (lambda (a . :b) a) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda :rest parameter ~S is a constant in (~S ~S ...)", 54), - x, car(form), cadr(form))); - i = -i - 1; - } - if (arity) (*arity) = i; -} - -static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, s7_pointer body, s7_pointer form) /* checks closure*, macro*, and bacro* */ -{ - s7_pointer top, v, w; - int32_t i; - bool has_defaults; - - if (!is_list(args)) - { - if (is_constant(sc, args)) /* (lambda* :a ...) or (define* (f . :a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "lambda* parameter is a constant: (~S ~S ...)", 44), car(form), cadr(form))); - if (is_symbol(args)) set_local(args); - return(args); - } - - has_defaults = false; - top = args; - for (i = 0, v = args, w = args; is_pair(w); i++, v = w, w = cdr(w)) - { - s7_pointer car_w = car(w); - if (is_pair(car_w)) - { - has_defaults = true; - if (is_constant(sc, car(car_w))) /* (lambda* ((:a 1)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a constant: (~S ~S ...)", 47), - car(car_w), car(form), cadr(form))); - if (symbol_is_in_arg_list(caar(w), cdr(w))) /* (lambda* ((a 1) a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S occurs twice in the argument list: (~S ~S ...)", 67), - car(car_w), car(form), cadr(form))); - if (!is_pair(cdr(car_w))) - { - if (is_null(cdr(car_w))) /* (lambda* ((a)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S default value missing in (~S ~S ...)", 57), - car_w, car(form), cadr(form))); - error_nr(sc, sc->syntax_error_symbol, /* (lambda* ((a . 0.0)) a) */ - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a dotted pair in (~S ~S ...)", 52), - car_w, car(form), cadr(form))); - } - if ((is_pair(cadr(car_w))) && /* (lambda* ((a (quote . -1))) ...) */ - (s7_list_length(sc, cadr(car_w)) < 0)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S default value is not a proper list in (~S ~S ...)", 70), - car_w, car(form), cadr(form))); - if (is_not_null(cddr(car_w))) /* (lambda* ((a 0.0 'hi)) a) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S has multiple default values in (~S ~S ...)", 63), - car_w, car(form), cadr(form))); - - set_local(car(car_w)); - } - else - if (car_w != sc->rest_keyword) - { - if (is_constant(sc, car_w)) - { - if (car_w != sc->allow_other_keys_keyword) - error_nr(sc, sc->syntax_error_symbol, /* (lambda* (pi) ...) */ - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a constant: (~S ~S ...)", 47), - car_w, car(form), cadr(form))); - if (is_not_null(cdr(w))) /* (lambda* (:allow-other-keys x) x) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, ":allow-other-keys should be the last parameter: (~S ~S ...)", 59), - car(form), cadr(form))); - if (w == top) /* (lambda* (:allow-other-keys) 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, ":allow-other-keys can't be the only parameter: (~S ~S ...)", 58), - car(form), cadr(form))); - set_allow_other_keys(top); - set_cdr(v, sc->nil); - } - if (symbol_is_in_arg_list(car_w, cdr(w))) /* (lambda* (a a) ...) or (lambda* (a . a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is used twice in the parameter list: (~S ~S ...)", 69), - car_w, car(form), cadr(form))); - - if (!is_keyword(car_w)) set_local(car_w); - } - else - { - has_defaults = true; - if (!is_pair(cdr(w))) /* (lambda* (:rest) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "lambda* :rest parameter missing in (~S ~S ...)", 46), - car(form), cadr(form))); - if (!is_symbol(cadr(w))) /* (lambda* (:rest (a 1)) ...) */ - { - if (!is_pair(cadr(w))) /* (lambda* (:rest 1) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter is not a symbol: ~S in (~S ~S ...)", 58), - w, car(form), cadr(form))); - error_nr(sc, sc->syntax_error_symbol, /* (lambda* (:rest '(1 2)) 1) */ - set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter can't have a default value: ~S in (~S ~S ...)", 69), - w, car(form), cadr(form))); - } - if (is_constant(sc, cadr(w))) /* (lambda* (a :rest x) ...) where x is locally a constant */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "lambda*: ~S is immutable, so it can't be the :rest parameter name: (~S ~S ...)", 78), - cadr(w), car(form), cadr(form))); - set_local(cadr(w)); - }} - if (is_not_null(w)) - { - if (is_constant(sc, w)) /* (lambda* (a . 0.0) a) or (lambda* (a . :b) a) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter ~S is a constant, (~S ~S ...)", 53), - w, car(form), cadr(form))); - if (is_symbol(w)) - set_local(w); - } - else - if ((body) && (!has_defaults) && (is_pair(args))) - set_has_no_defaults(body); - return(top); -} - -static void set_rec_tc_args(s7_scheme *sc, s7_int args) -{ - if (sc->rec_tc_args == -1) - sc->rec_tc_args = args; - else - if (sc->rec_tc_args != args) - sc->rec_tc_args = -2; -} - -typedef enum {UNSAFE_BODY=0, RECUR_BODY, SAFE_BODY, VERY_SAFE_BODY} body_t; -static body_t min_body(body_t b1, body_t b2) {return((b1 < b2) ? b1 : b2);} -static body_t body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end); - -static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at_end) /* called only from body_is_safe */ -{ - s7_pointer expr = car(x); - body_t result = VERY_SAFE_BODY; - - if (is_symbol_and_syntactic(expr)) - { - if (!is_pair(cdr(x))) return(UNSAFE_BODY); - switch (symbol_syntax_op_checked(x)) - /* symbol_syntax_op(expr) here gets tangled in fx_annotation order problems! -- fix this?!? - * it appears that safe bodies are marked unsafe because the opts are out-of-order? - */ - { - case OP_OR: case OP_AND: case OP_BEGIN: case OP_WITH_BAFFLE: - return(body_is_safe(sc, func, cdr(x), at_end)); - - case OP_MACROEXPAND: - return(UNSAFE_BODY); - - case OP_QUOTE: case OP_QUOTE_UNCHECKED: - return(((!is_pair(cdr(x))) || (!is_null(cddr(x)))) ? UNSAFE_BODY : VERY_SAFE_BODY); /* (quote . 1) or (quote 1 2) etc */ - - case OP_IF: - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - result = form_is_safe(sc, func, cadr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (is_pair(caddr(x))) - { - result = min_body(result, form_is_safe(sc, func, caddr(x), at_end)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if ((is_pair(cdddr(x))) && - (is_pair(cadddr(x)))) - return(min_body(result, form_is_safe(sc, func, cadddr(x), at_end))); - return(result); - - case OP_WHEN: case OP_UNLESS: - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - result = form_is_safe(sc, func, cadr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - return(min_body(result, body_is_safe(sc, func, cddr(x), at_end))); - - case OP_COND: - { - bool follow = false; - s7_pointer p = cdr(x); - for (s7_pointer sp = x; is_pair(p); p = cdr(p)) - { - s7_pointer ex = car(p); - if (!is_pair(ex)) return(UNSAFE_BODY); - if (is_pair(car(ex))) - { - result = min_body(result, form_is_safe(sc, func, car(ex), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (is_pair(cdr(ex))) - { - result = min_body(result, body_is_safe(sc, func, cdr(ex), at_end)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - return((is_null(p)) ? result : UNSAFE_BODY); - } - - case OP_CASE: - { - bool follow = false; - s7_pointer sp, p; - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - result = form_is_safe(sc, func, cadr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - sp = cdr(x); - for (p = cdr(sp); is_pair(p); p = cdr(p)) - { - if (!is_pair(car(p))) return(UNSAFE_BODY); - if (is_pair(cdar(p))) - { - result = min_body(result, body_is_safe(sc, func, cdar(p), at_end)); /* null cdar(p) ok here */ - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - return(result); - } - - case OP_SET: - /* if we set func, we have to abandon the tail call scan: (let () (define (hi a) (let ((v (vector 1 2 3))) (set! hi v) (hi a))) (hi 1)) */ - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (cadr(x) == func) return(UNSAFE_BODY); - - /* car(x) is set!, cadr(x) is settee or obj, caddr(x) is val */ - if (is_pair(caddr(x))) - { - result = form_is_safe(sc, func, caddr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - return((is_pair(cadr(x))) ? min_body(result, form_is_safe(sc, func, cadr(x), false)) : result); - /* not OP_DEFINE even in simple cases (safe_closure assumes constant funclet) */ - - case OP_WITH_LET: - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - return((is_pair(cadr(x))) ? UNSAFE_BODY : min_body(body_is_safe(sc, sc->F, cddr(x), at_end), SAFE_BODY)); - /* shadowing can happen in with-let -- symbols are global so local_slots are shadowable */ - - case OP_LET_TEMPORARILY: - if (!is_pair(cadr(x))) return(UNSAFE_BODY); - for (s7_pointer p = cadr(x); is_pair(p); p = cdr(p)) - { - if ((!is_pair(car(p))) || - (!is_pair(cdar(p)))) - return(UNSAFE_BODY); - if (is_pair(cadar(p))) - { - result = min_body(result, form_is_safe(sc, sc->F, cadar(p), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - }} - return(min_body(result, body_is_safe(sc, sc->F, cddr(x), at_end))); - - /* in the name binders, we first have to check that "func" actually is the same thing as the caller's func */ - case OP_LET: case OP_LET_STAR: case OP_LETREC: case OP_LETREC_STAR: - { - bool follow = false; - s7_pointer let_name, sp, vars = cadr(x), body = cddr(x); - if (is_symbol(vars)) - { - if (!is_pair(body)) return(UNSAFE_BODY); /* (let name . res) */ - if (vars == func) return(UNSAFE_BODY); /* named let shadows caller */ - let_name = vars; - vars = caddr(x); - body = cdddr(x); - if (is_symbol(func)) - add_symbol_to_list(sc, func); - } - else let_name = func; - - for (sp = NULL; is_pair(vars); vars = cdr(vars)) - { - s7_pointer let_var = car(vars), var_name; - - if ((!is_pair(let_var)) || - (!is_pair(cdr(let_var)))) - return(UNSAFE_BODY); - var_name = car(let_var); - if ((!is_symbol(var_name)) || - (var_name == let_name) || /* let var shadows caller */ - (var_name == func)) - return(UNSAFE_BODY); - add_symbol_to_list(sc, var_name); - - if (is_pair(cadr(let_var))) - { - result = min_body(result, form_is_safe(sc, let_name, cadr(let_var), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - follow = (!follow); - if (follow) - { - if (!sp) - sp = vars; - else - { - sp = cdr(sp); - if (vars == sp) return(UNSAFE_BODY); - }}} - return(min_body(result, body_is_safe(sc, let_name, body, (let_name != func) || at_end))); - } - - case OP_DO: /* (do (...) (...) ...) */ - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - bool follow = false; - s7_pointer vars = cadr(x); - s7_pointer sp = vars; - for (; is_pair(vars); vars = cdr(vars)) - { - s7_pointer do_var = car(vars); - if ((!is_pair(do_var)) || - (!is_pair(cdr(do_var))) || /* (do ((a . 1) (b . 2)) ...) */ - (car(do_var) == func) || - (!is_symbol(car(do_var)))) - return(UNSAFE_BODY); - - add_symbol_to_list(sc, car(do_var)); - - if (is_pair(cadr(do_var))) - result = min_body(result, form_is_safe(sc, func, cadr(do_var), false)); - if ((is_pair(cddr(do_var))) && (is_pair(caddr(do_var)))) - result = min_body(result, form_is_safe(sc, func, caddr(do_var), false)); - if (result == UNSAFE_BODY) - return(UNSAFE_BODY); - if (sp != vars) - { - if (follow) {sp = cdr(sp); if (vars == sp) return(UNSAFE_BODY);} - follow = (!follow); - }}} - if (is_pair(caddr(x))) - result = min_body(result, body_is_safe(sc, func, caddr(x), at_end)); - return(min_body(result, body_is_safe(sc, func, cdddr(x), false))); - - /* define and friends are not safe: (define (a) (define b 3)...) tries to put b in the current let, - * but in a safe func, that's a constant. See s7test L 1865 for an example. - */ - default: - /* OP_LAMBDA is major case here */ - /* try to catch weird cases like: - * (let () (define (hi1 a) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) - * (let () (define (hi1 a) (define (ho1 b) b) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) - */ - return(UNSAFE_BODY); - }} - else /* car(x) is not syntactic */ - { - if (expr == func) /* try to catch tail call, expr is car(x) */ - { - bool follow = false; - s7_pointer sp = x, p; - sc->got_rec = true; /* (walk (car tree)) lint and almost all others in s7test */ - set_rec_tc_args(sc, proper_list_length(cdr(x))); - if (!at_end) {result = RECUR_BODY; sc->not_tc = true;} - for (p = cdr(x); is_pair(p); p = cdr(p)) - { - if (is_pair(car(p))) - { - if (caar(p) == func) /* func called as arg, so not tail call */ - { - sc->not_tc = true; - result = RECUR_BODY; - } - result = min_body(result, form_is_safe(sc, func, car(p), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - else - if (car(p) == func) /* func itself as arg */ - return(UNSAFE_BODY); - - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - if ((at_end) && (!sc->not_tc) && (is_null(p))) /* tail call, so safe */ - { - sc->got_tc = true; - set_rec_tc_args(sc, proper_list_length(cdr(x))); - return(result); - } - if (result != UNSAFE_BODY) result = RECUR_BODY; - return(result); - } - - if (is_symbol(expr)) /* expr=car(x) */ - { - s7_pointer f, f_slot; - bool c_safe; - - if (symbol_is_in_list(sc, expr)) return(UNSAFE_BODY); - f_slot = lookup_slot_from(expr, sc->curlet); - if (!is_slot(f_slot)) - return(UNSAFE_BODY); - f = slot_value(f_slot); - if (is_c_function(f)) - { - if ((expr == sc->apply_symbol) && (is_pair(cdr(x))) && (is_symbol(cadr(x)))) /* (apply ...) */ - { - s7_pointer cadr_f = lookup_unexamined(sc, cadr(x)); /* "unexamined" to skip unbound_variable */ - c_safe = ((cadr_f) && /* (cadr_f != sc->undefined) && */ - ((is_safe_c_function(cadr_f)) || - ((is_closure(cadr_f)) && (is_very_safe_closure(cadr_f))))); - } - else c_safe = (is_safe_or_scope_safe_procedure(f)); - } - else c_safe = false; - - result = ((is_sequence(f)) || - ((is_closure(f)) && (is_very_safe_closure(f))) || - ((c_safe) && ((is_immutable(f_slot)) || (is_global(expr))))) ? VERY_SAFE_BODY : SAFE_BODY; - - if ((c_safe) || - ((is_any_closure(f)) && (is_safe_closure(f))) || - (is_sequence(f))) - { - bool follow = false; - s7_pointer sp = x, p = cdr(x); - - for (; is_pair(p); p = cdr(p)) - { - if (is_unquoted_pair(car(p))) - { - if (caar(p) == func) - { - sc->got_rec = true; /* (+ 1 (recur (- x 1))) t123 (and others) */ - set_rec_tc_args(sc, proper_list_length(cdar(p))); - return(RECUR_BODY); - } - if ((is_c_function(f)) && (is_scope_safe(f)) && - (caar(p) == sc->lambda_symbol)) - { - s7_pointer largs, lbody, q; - body_t lresult; - - if (!is_pair(cdar(p))) /* (lambda . /) */ - return(UNSAFE_BODY); - largs = cadar(p); - lbody = cddar(p); - for (q = largs; is_pair(q); q = cdr(q)) - { - if (!is_symbol(car(q))) - return(UNSAFE_BODY); - add_symbol_to_list(sc, car(q)); - } - lresult = body_is_safe(sc, func, lbody, false); - result = min_body(result, lresult); - } - else result = min_body(result, form_is_safe(sc, func, car(p), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - else - if (car(p) == func) /* the current function passed as an argument to something */ - return(UNSAFE_BODY); - - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - return((is_null(p)) ? result : UNSAFE_BODY); - } - if ((expr == sc->quote_symbol) && - (is_proper_list_1(sc, cdr(x))) && - (is_global(sc->quote_symbol))) - return(result); - - if (expr == sc->values_symbol) /* (values) is safe, as is (values x) if x is: (values (define...)) */ - { - if (is_null(cdr(x))) return(result); - if ((is_pair(cdr(x))) && (is_null(cddr(x)))) - return((is_pair(cadr(x))) ? min_body(result, form_is_safe(sc, func, cadr(x), false)) : result); - }} - return(UNSAFE_BODY); /* not recur_body here if at_end -- possible defines in body etc */ - } - return(result); -} - -static body_t body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end) -{ - bool follow = false; - s7_pointer p = body; - body_t result = VERY_SAFE_BODY; - for (s7_pointer sp = body; is_pair(p); p = cdr(p)) - { - if (is_pair(car(p))) - { - result = min_body(result, form_is_safe(sc, func, car(p), (at_end) && (is_null(cdr(p))))); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (p != body) - { - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - }} - return((is_null(p)) ? result : UNSAFE_BODY); -} - -static bool tree_has_definers_or_binders(s7_scheme *sc, s7_pointer tree) -{ - for (s7_pointer p = tree; is_pair(p); p = cdr(p)) - if (tree_has_definers_or_binders(sc, car(p))) - return(true); - return((is_symbol(tree)) && - (is_definer_or_binder(tree))); -} - -static bool check_recur_if(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - s7_pointer test = cadr(body); - if (is_fxable(sc, test)) /* if_(A)... */ - { - s7_pointer obody = cddr(body), orig = NULL; - s7_pointer true_p = car(obody); /* if_a_(A)... */ - s7_pointer false_p = cadr(obody); /* if_a_a_(if...) */ - - if ((vars <= 2) && - (is_fxable(sc, true_p)) && - (is_proper_list_4(sc, false_p))) - { - if (car(false_p) == sc->if_symbol) - { - s7_pointer test2 = cadr(false_p); - s7_pointer true2 = caddr(false_p); - s7_pointer false2 = cadddr(false_p); - if ((is_fxable(sc, test2)) && - (is_proper_list_3(sc, false2)) && /* opa_laaq or oplaa_laaq */ - (is_h_optimized(false2))) /* the c-op */ - { - s7_pointer la1 = cadr(false2); - s7_pointer la2 = caddr(false2); - if ((is_fxable(sc, true2)) && - (((vars == 1) && (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2))) || - (((vars == 2) && (is_proper_list_3(sc, la1)) && (is_proper_list_3(sc, la2))))) && - (car(la1) == name) && (car(la2) == name) && - (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && - ((vars == 1) || ((is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2)))))) - { - set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq : OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_args(sc, cdr(false_p), args); - fx_annotate_args(sc, cdr(la1), args); - fx_annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL, NULL, false); - set_opt1_pair(body, cdr(false_p)); - set_opt3_pair(body, false2); - set_opt3_pair(false2, cdr(la2)); - return(true); - } - if ((vars == 2) && (is_proper_list_3(sc, true2)) && - (car(true2) == name) && - (is_fxable(sc, cadr(true2))) && (is_fxable(sc, caddr(true2))) && - (is_fxable(sc, cadr(false2))) && - (is_proper_list_3(sc, la2)) && - (car(la2) == name) && /* actually, not needed because func is TC (not RECUR) if not == name */ - (is_fxable(sc, cadr(la2))) && - (is_fxable(sc, caddr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq); - fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ - fx_annotate_arg(sc, obody, args); /* if_a_(A)... */ - fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_if_(A)... */ - fx_annotate_args(sc, cdr(true2), args); /* if_a_a_if_a_l(AA)... */ - fx_annotate_arg(sc, cdr(false2), args); /* if_a_a_if_a_laa_op(A).. */ - fx_annotate_args(sc, cdr(la2), args); /* if_a_a_if_a_laa_opa_l(AA)q */ - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, false2); - set_opt3_pair(false2, la2); - return(true); - }}} - - if (car(false_p) == sc->and_symbol) - { - s7_pointer a1 = cadr(false_p); - s7_pointer a2 = caddr(false_p); - s7_pointer a3 = cadddr(false_p); - if ((is_fxable(sc, a1)) && - (is_proper_list_3(sc, a2)) && (is_proper_list_3(sc, a3)) && - (car(a2) == name) && (car(a3) == name) && - (is_fxable(sc, cadr(a2))) && (is_fxable(sc, cadr(a3))) && - (is_fxable(sc, caddr(a2))) && (is_fxable(sc, caddr(a3)))) - { - set_safe_optimize_op(body, OP_RECUR_IF_A_A_AND_A_LAA_LAA); - fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ - fx_annotate_arg(sc, cddr(body), args); /* if_a_(A)... */ - fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_and_(A)... */ - fx_annotate_args(sc, cdr(a2), args); /* if_a_a_and_a_l(AA)... */ - fx_annotate_args(sc, cdr(a3), args); /* if_a_a_and_a_laa_l(AA) */ - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, false_p); - return(true); - }}} - - if ((is_fxable(sc, true_p)) && - (is_pair(false_p)) && - (is_h_optimized(false_p)) && - (is_pair(cdr(false_p))) && - (is_pair(cddr(false_p)))) - orig = false_p; - else - if ((is_fxable(sc, false_p)) && - (is_pair(true_p)) && - (is_h_optimized(true_p)) && - (is_pair(cdr(true_p))) && - (is_pair(cddr(true_p)))) - { - orig = true_p; - /* true_p = false_p; */ - false_p = orig; - obody = cdr(obody); - } - - if (orig) - { - if (is_null(cdddr(false_p))) /* 2 args to outer (c) func */ - { - if ((is_fxable(sc, cadr(false_p))) || (is_fxable(sc, caddr(false_p)))) - { - s7_pointer la = (is_fxable(sc, cadr(false_p))) ? caddr(false_p) : cadr(false_p); - if ((is_pair(la)) && - (car(la) == name) && - (is_pair(cdr(la))) && - (is_fxable(sc, cadr(la)))) - { - if ((vars == 1) && (is_null(cddr(la)))) - set_safe_optimize_op(body, (orig == cadddr(body)) ? - ((la == cadr(false_p)) ? OP_RECUR_IF_A_A_opLA_Aq : OP_RECUR_IF_A_A_opA_LAq) : - ((la == cadr(false_p)) ? OP_RECUR_IF_A_opLA_Aq_A : OP_RECUR_IF_A_opA_LAq_A)); - else - if ((vars == 2) && - (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) && - (is_null(cdddr(la)))) - set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opA_LAAq : OP_RECUR_IF_A_opA_LAAq_A); - else - { - if ((vars == 3) && - (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) && - (is_pair(cdddr(la))) && (is_fxable(sc, cadddr(la))) && - (is_null(cddddr(la))) && - (orig == cadddr(body))) - set_safe_optimize_op(body, OP_RECUR_IF_A_A_opA_L3Aq); - else return(false); - } - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_arg(sc, (la == cadr(false_p)) ? cddr(false_p) : cdr(false_p), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la); - return(true); - }} - else - { - s7_pointer la1 = cadr(false_p); - s7_pointer la2 = caddr(false_p); - if ((vars == 1) && - (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2)) && - (car(la1) == name) && (car(la2) == name) && - (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2)))) - { - set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opLA_LAq : OP_RECUR_IF_A_opLA_LAq_A); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_arg(sc, cdr(la1), args); - fx_annotate_arg(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la2); - return(true); - }}} - else /* 3 args to c func */ - { - if ((vars == 1) && - (is_pair(cdddr(false_p))) && - (is_null(cddddr(false_p)))) - { - s7_pointer la1 = cadr(false_p); - s7_pointer la2 = caddr(false_p); - s7_pointer la3 = cadddr(false_p); - if ((is_proper_list_2(sc, la2)) && (is_proper_list_2(sc, la3)) && - (car(la2) == name) && (car(la3) == name) && - (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3)))) - { - if ((is_proper_list_2(sc, la1)) && (car(la1) == name) && (is_fxable(sc, cadr(la1)))) - { - if (orig != cadddr(body)) - return(false); - set_safe_optimize_op(body, OP_RECUR_IF_A_A_opLA_LA_LAq); - fx_annotate_arg(sc, cdr(la1), args); - } - else - if (is_fxable(sc, la1)) - { - set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opA_LA_LAq : OP_RECUR_IF_A_opA_LA_LAq_A); - fx_annotate_arg(sc, cdr(false_p), args); - } - else return(false); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_arg(sc, cdr(la2), args); - fx_annotate_arg(sc, cdr(la3), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la3); - return(true); - }}}}} - - if ((vars == 3) && - (is_fxable(sc, test))) - { - s7_pointer true_p = caddr(body); - s7_pointer false_p = cadddr(body); - if ((is_fxable(sc, true_p)) && - (is_proper_list_4(sc, false_p)) && - (car(false_p) == name)) - { - s7_pointer l3a = cdr(false_p); - s7_pointer la1 = car(l3a); - s7_pointer la2 = cadr(l3a); - s7_pointer la3 = caddr(l3a); - if ((is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)) && (is_proper_list_4(sc, la3)) && - (car(la1) == name) && (car(la2) == name) && (car(la3) == name) && - (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3))) && - (is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))) && (is_fxable(sc, caddr(la3))) && - (is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2))) && (is_fxable(sc, cadddr(la3)))) - { - set_safe_optimize_op(body, OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq); - fx_annotate_args(sc, cdr(la1), args); - fx_annotate_args(sc, cdr(la2), args); - fx_annotate_args(sc, cdr(la3), args); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la3); - return(true); - }}} - return(false); -} - -static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - if ((car(body) == sc->if_symbol) && - (proper_list_length(body) == 4)) - return(check_recur_if(sc, name, vars, args, body)); - - if ((car(body) == sc->and_symbol) && - (vars == 2) && - (proper_list_length(body) == 3) && - (proper_list_length(caddr(body)) == 4) && - (caaddr(body) == sc->or_symbol) && - (is_fxable(sc, cadr(body)))) - { - s7_pointer or_p = caddr(body); - s7_pointer la1 = caddr(or_p); - s7_pointer la2 = cadddr(or_p); - if ((is_fxable(sc, cadr(or_p))) && - (proper_list_length(la1) == 3) && - (proper_list_length(la2) == 3) && - (car(la1) == name) && - (car(la2) == name) && - (is_fxable(sc, cadr(la1))) && - (is_fxable(sc, caddr(la1))) && - (is_fxable(sc, cadr(la2))) && - (is_fxable(sc, caddr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_AND_A_OR_A_LAA_LAA); - fx_annotate_args(sc, cdr(la1), args); - fx_annotate_args(sc, cdr(la2), args); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(or_p), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, or_p); - return(true); - }} - - if (car(body) == sc->cond_symbol) - { - s7_pointer clause = cadr(body), clause2 = NULL; - if ((is_proper_list_1(sc, (cdr(clause)))) && - (is_fxable(sc, car(clause))) && - (is_fxable(sc, cadr(clause)))) - { - s7_pointer la_clause = caddr(body); - s7_int len = proper_list_length(body); - if (len == 4) - { - if ((is_proper_list_2(sc, la_clause)) && - (is_fxable(sc, car(la_clause)))) - { - clause2 = la_clause; - la_clause = cadddr(body); - } - else return(false); - } - if ((is_proper_list_2(sc, la_clause)) && - ((car(la_clause) == sc->else_symbol) || (car(la_clause) == sc->T)) && - (is_pair(cadr(la_clause)))) - { - la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a laa) */ - if (is_proper_list_2(sc, cdr(la_clause))) - { - if (is_h_optimized(la_clause)) - { - if ((is_fxable(sc, cadr(la_clause))) && - ((len == 3) || - ((len == 4) && (vars == 2) && - (is_proper_list_3(sc, cadr(clause2))) && - (caadr(clause2) == name)))) - { - s7_pointer la = caddr(la_clause); - if ((is_pair(la)) && - (car(la) == name) && - (is_pair(cdr(la))) && - (is_fxable(sc, cadr(la))) && - (((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && - (is_pair(cddr(la))) && - (is_fxable(sc, caddr(la))) && - (is_null(cdddr(la)))))) - { - if (len == 3) - set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_COND_A_A_opA_LAq : OP_RECUR_COND_A_A_opA_LAAq); - else - { - s7_pointer laa = cadr(clause2); - if ((is_fxable(sc, cadr(laa))) && /* args to first laa */ - (is_fxable(sc, caddr(laa)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_opA_LAAq); - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdr(laa), args); - } - else return(false); - } - fx_annotate_args(sc, clause, args); - fx_annotate_arg(sc, cdr(la_clause), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - set_opt3_pair(body, la_clause); - set_opt3_pair(la_clause, la); - return(true); - }} - else - { - if ((len == 4) && - (is_fxable(sc, cadr(clause2)))) - { - s7_pointer la1 = cadr(la_clause); - s7_pointer la2 = caddr(la_clause); - bool happy = false; - - if ((vars == 1) && - (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2)) && - (car(la1) == name) && (car(la2) == name) && (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLA_LAq); - fx_annotate_arg(sc, cdr(la1), args); - happy = true; - } - else - if ((vars == 2) && - /* (is_fxable(sc, cadr(clause2))) && */ - (is_proper_list_3(sc, la2)) && (car(la2) == name) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, caddr(la2)))) - { - if (is_fxable(sc, la1)) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opA_LAAq); - fx_annotate_arg(sc, cdr(la_clause), args); - happy = true; - } - else - if ((is_proper_list_3(sc, la1)) && - (car(la1) == name) && - (is_fxable(sc, cadr(la1))) && - (is_fxable(sc, caddr(la1)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opLAA_LAAq); - fx_annotate_args(sc, cdr(la1), args); - happy = true; - }} - if (happy) - { - set_opt3_pair(la_clause, cdr(la2)); - fx_annotate_args(sc, clause, args); - fx_annotate_args(sc, clause2, args); - fx_annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - set_opt3_pair(body, la_clause); - return(true); - }}}} - else - { - if (clause2) - { - s7_pointer laa = cadr(clause2); - if ((vars == 2) && (len == 4) && - (is_proper_list_3(sc, laa)) && (car(laa) == name) && (is_fxable(sc, cadr(laa))) && (is_fxable(sc, caddr(laa)))) - { - s7_pointer la1 = cadr(la_clause); - s7_pointer la2 = caddr(la_clause); - if ((is_fxable(sc, la1)) && - (is_proper_list_3(sc, la2)) && (car(la2) == name) && (is_fxable(sc, cadr(la2))) && (is_fxable(sc, caddr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_LAA_LopA_LAAq); - fx_annotate_args(sc, clause, args); - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdr(laa), args); - fx_annotate_arg(sc, cdr(la_clause), args); - fx_annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, la_clause); - set_opt3_pair(la_clause, cdr(la2)); - return(true); - }}}}}}}} - return(false); -} - -static bool check_tc_when(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - s7_pointer test_expr = cadr(body); - if (is_fxable(sc, test_expr)) - { - s7_pointer p; - for (p = cddr(body); is_pair(cdr(p)); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - if ((is_proper_list_1(sc, p)) && /* i.e. p is the last form in the when body */ - (is_pair(car(p))) && - (caar(p) == name)) - { - s7_pointer laa = car(p); - if ((is_pair(cdr(laa))) && (is_fxable(sc, cadr(laa)))) - { - if (is_null(cddr(laa))) - { - if (vars != 1) return(false); - set_safe_optimize_op(body, OP_TC_WHEN_LA); - } - else - if (is_fxable(sc, caddr(laa))) - { - if (is_null(cdddr(laa))) - { - if (vars != 2) return(false); - set_safe_optimize_op(body, OP_TC_WHEN_LAA); - } - else - if ((vars == 3) && (is_fxable(sc, cadddr(laa))) && (is_null(cddddr(laa)))) - set_safe_optimize_op(body, OP_TC_WHEN_L3A); - else return(false); - } - fx_annotate_arg(sc, cdr(body), args); - for (p = cddr(body); is_pair(cdr(p)); p = cdr(p)) - fx_annotate_arg(sc, p, args); - fx_annotate_args(sc, cdr(laa), args); - fx_tree(sc, cdr(body), car(args), (is_pair(cdr(args))) ? cadr(args) : NULL, ((is_pair(cdr(args))) && (is_pair(cddr(args)))) ? caddr(args) : NULL, false); - return(true); - }}} - return(false); -} - -static bool check_tc_case(s7_scheme *sc, s7_pointer name, s7_pointer args, s7_pointer body) -{ - /* vars == 1, opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ - s7_pointer clauses; - s7_int len; - bool got_else = false, results_fxable = true; - for (clauses = cddr(body), len = 0; is_pair(clauses); clauses = cdr(clauses), len++) - { - s7_pointer clause = car(clauses), result; - if (is_proper_list_1(sc, car(clause))) - { - if (!is_simple(caar(clause))) - return(false); /* even if key is a small int, selector might be a mutable alias of that, so = will fail */ - set_opt1_any(clauses, caar(clause)); - } - else - { - if ((car(clause) != sc->else_symbol) || - (!is_null(cdr(clauses)))) - return(false); - got_else = true; - } - set_opt2_any(clauses, NULL); - result = cdr(clause); - if (is_null(result)) - return(false); - if (is_proper_list_1(sc, result)) - { - if (is_fxable(sc, car(result))) - { - fx_annotate_arg(sc, result, args); - set_opt2_any(clauses, result); - } - else - if ((is_proper_list_2(sc, car(result))) && - (caar(result) == name) && - (is_fxable(sc, cadar(result)))) - { - set_has_tc(car(result)); - set_opt2_any(clauses, car(result)); - fx_annotate_arg(sc, cdar(result), args); - } - else results_fxable = false; - } - else results_fxable = false; - if (!opt2_any(clauses)) - { - if (car(result) == sc->feed_to_symbol) - return(false); - if (tree_count(sc, name, result, 0) != 0) - return(false); - set_opt2_any(clauses, result); - }} - if ((!got_else) || (!is_null(clauses))) - return(false); - set_optimize_op(body, OP_TC_CASE_LA); - set_opt3_arglen(cdr(body), (len < 6) ? len : 0); - fx_annotate_arg(sc, cdr(body), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, true); - if (results_fxable) set_optimized(body); - return(results_fxable); -} - -static bool check_tc_cond(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - s7_pointer p = cdr(body), clause1 = car(p); - if ((is_proper_list_2(sc, clause1)) && (is_fxable(sc, car(clause1)))) /* cond_a... */ - { - p = cdr(p); - if ((is_pair(p)) && (is_null(cdr(p))) && ((caar(p) == sc->else_symbol) || (caar(p) == sc->T))) - { - s7_pointer else_clause; - if (((vars != 1) && (vars != 2)) || (tree_count(sc, name, body, 0) != 1)) return(false); - else_clause = cdar(p); - if (is_proper_list_1(sc, else_clause)) - { - s7_pointer la = car(else_clause); - fx_annotate_arg(sc, clause1, args); - if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) - { - if ((is_fxable(sc, cadr(la))) && - ((((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la))))))) - { - bool zs_fxable = is_fxable(sc, cadr(clause1)); - set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_Z_LA : OP_TC_COND_A_Z_LAA); - if (zs_fxable) fx_annotate_arg(sc, cdr(clause1), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - if (zs_fxable) set_optimized(body); - set_opt1_pair(cdr(body), cdadr(body)); - set_opt3_pair(cdr(body), cdadr(caddr(body))); - return(zs_fxable); - }} - else - { - la = cadr(clause1); - if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) - { - if ((is_fxable(sc, cadr(la))) && - (((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))))) - { - bool zs_fxable = is_fxable(sc, car(else_clause)); - set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_LA_Z : OP_TC_COND_A_LAA_Z); - if (zs_fxable) fx_annotate_arg(sc, else_clause, args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - if (zs_fxable) set_optimized(body); - set_opt1_pair(cdr(body), cdaddr(body)); - set_opt3_pair(cdr(body), cdadr(cadr(body))); - return(zs_fxable); - }}}} - return(false); - } - if (is_proper_list_2(sc, p)) - { - s7_pointer clause2 = car(p); - if ((is_proper_list_2(sc, clause2)) && - (is_fxable(sc, car(clause2)))) - { - s7_pointer else_p = cdr(p); - s7_pointer else_clause = car(else_p); - - if ((is_proper_list_2(sc, else_clause)) && - ((car(else_clause) == sc->else_symbol) || (car(else_clause) == sc->T))) - { - bool zs_fxable = true; - if ((vars == 2) && /* ...laa_laa case */ - (is_proper_list_3(sc, cadr(clause2))) && (caadr(clause2) == name) && - (is_fxable(sc, cadadr(clause2))) && (is_safe_fxable(sc, caddadr(clause2))) && - (is_proper_list_3(sc, cadr(else_clause))) && (caadr(else_clause) == name) && - (is_fxable(sc, cadadr(else_clause))) && (is_safe_fxable(sc, caddadr(else_clause)))) - { - set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA); - if (is_fxable(sc, cadr(clause1))) - fx_annotate_args(sc, clause1, args); - else - { - fx_annotate_arg(sc, clause1, args); - zs_fxable = false; - } - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdadr(clause2), args); - fx_annotate_args(sc, cdadr(else_clause), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, cadr(else_clause)); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - } - - if ((tree_count(sc, name, body, 0) == 1) && /* needed to filter out cond_a_a_a_laa_opa_laa */ - - (((is_pair(cadr(else_clause))) && (caadr(else_clause) == name) && - (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadadr(else_clause))) && - (((vars == 1) && (is_null(cddadr(else_clause)))) || - ((vars == 2) && (is_proper_list_3(sc, cadr(else_clause))) && (is_fxable(sc, caddadr(else_clause)))))) || - - ((is_pair(cadr(clause2))) && (caadr(clause2) == name) && - (is_pair(cdadr(clause2))) && (is_fxable(sc, cadadr(clause2))) && - (((vars == 1) && (is_null(cddadr(clause2)))) || - ((vars == 2) && (is_pair(cddadr(clause2))) && (is_fxable(sc, caddadr(clause2))) && (is_null(cdddr(cadr(clause2))))))))) - { - s7_pointer test2 = clause2; - s7_pointer la_test = else_clause; - if (vars == 1) - { - if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) - set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LA); - else - { - set_optimize_op(body, OP_TC_COND_A_Z_A_LA_Z); - test2 = else_clause; - la_test = clause2; - fx_annotate_arg(sc, clause2, args); - }} - else - if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) - { - set_opt3_pair(body, cdadr(else_clause)); - set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA); - } - else - { - set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_Z); - test2 = else_clause; - la_test = clause2; - set_opt3_pair(body, cdadr(la_test)); - fx_annotate_arg(sc, clause2, args); - } - if (is_fxable(sc, cadr(clause1))) - fx_annotate_args(sc, clause1, args); - else - { - fx_annotate_arg(sc, clause1, args); - zs_fxable = false; - } - if (is_fxable(sc, cadr(test2))) - fx_annotate_args(sc, test2, args); - else - { - fx_annotate_arg(sc, test2, args); - zs_fxable = false; - } - fx_annotate_args(sc, cdadr(la_test), args); - fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL, NULL, false); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - }}}}} - return(false); -} - -static bool check_tc_let(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - s7_pointer let_body = caddr(body); /* body: (let ((x (- y 1))) (if (<= x 0) 0 (f1 (- x 1)))) etc */ - if (((vars == 2) && ((car(let_body) == sc->if_symbol) || (car(let_body) == sc->when_symbol) || (car(let_body) == sc->unless_symbol))) || - ((vars == 1) && (car(let_body) == sc->if_symbol))) - { - s7_pointer test_expr = cadr(let_body); - if (is_fxable(sc, test_expr)) - { - if ((car(let_body) == sc->if_symbol) && (is_pair(cdddr(let_body)))) - { - s7_pointer laa = cadddr(let_body); - if ((is_pair(laa)) && /* else caddr is laa and cadddr is z */ - (car(laa) == name) && - (((vars == 1) && (is_proper_list_2(sc, laa))) || - ((vars == 2) && (is_proper_list_3(sc, laa)) && (is_safe_fxable(sc, caddr(laa))))) && - (is_fxable(sc, cadr(laa)))) - { - bool z_fxable; - set_optimize_op(body, (vars == 1) ? OP_TC_LET_IF_A_Z_LA : OP_TC_LET_IF_A_Z_LAA); - fx_annotate_arg(sc, cdaadr(body), args); /* let var binding, caadr: (x (- y 1)) etc */ - fx_tree(sc, cdaadr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); /* these are references to laa args, applied to the let var binding */ - fx_annotate_arg(sc, cdr(let_body), args); /* test_expr */ - fx_annotate_args(sc, cdr(laa), args); - z_fxable = is_fxable(sc, caddr(let_body)); - if (z_fxable) fx_annotate_arg(sc, cddr(let_body), args); - fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, NULL, false); - fx_tree_outer(sc, cdr(let_body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - if (z_fxable) set_optimized(body); - return(z_fxable); - }} - else - { - s7_pointer p; - for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - if ((is_proper_list_1(sc, p)) && - (is_proper_list_3(sc, car(p))) && - (caar(p) == name)) - { - s7_pointer laa = car(p); - if ((is_fxable(sc, cadr(laa))) && - (is_safe_fxable(sc, caddr(laa)))) - { - set_optimize_op(body, (car(let_body) == sc->when_symbol) ? OP_TC_LET_WHEN_LAA : OP_TC_LET_UNLESS_LAA); - fx_annotate_arg(sc, cdaadr(body), args); /* outer var */ - fx_annotate_arg(sc, cdr(let_body), args); /* test */ - for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p)) - fx_annotate_arg(sc, p, args); - fx_annotate_args(sc, cdr(laa), args); - fx_tree(sc, cdaadr(body), car(args), cadr(args), NULL, false); /* these are references to the outer let */ - fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, NULL, false); - fx_tree_outer(sc, cdr(let_body), car(args), cadr(args), NULL, false); - set_optimized(body); - return(true); - }}}}} - else - { - if (car(let_body) == sc->cond_symbol) /* vars=#loop pars, args=names thereof (arglist) */ - { - s7_pointer var_name; - bool all_fxable = true; - for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) - { - s7_pointer clause = car(p); - if ((is_proper_list_2(sc, clause)) && - (is_fxable(sc, car(clause)))) /* test is ok */ - { - s7_pointer result; - - if ((!is_pair(cdr(p))) && - (car(clause) != sc->else_symbol) && (car(clause) != sc->T)) - return(false); - - result = cadr(clause); - if ((is_pair(result)) && - (car(result) == name)) /* result is recursive call */ - { - s7_int i = 0; - for (s7_pointer arg = cdr(result); is_pair(arg); i++, arg = cdr(arg)) - if (!is_fxable(sc, car(arg))) - return(false); - if (i != vars) - return(false); - }} - else return(false); - } - /* cond form looks ok */ - set_optimize_op(body, OP_TC_LET_COND); - set_opt3_arglen(cdr(body), vars); - fx_annotate_arg(sc, cdaadr(body), args); /* let var */ - if (vars > 0) - fx_tree(sc, cdaadr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, vars > 3); - var_name = caaadr(body); - for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) - { - s7_pointer clause = car(p); - s7_pointer result = cadr(clause); - fx_annotate_arg(sc, clause, args); - if ((is_pair(result)) && (car(result) == name)) - { - set_has_tc(cdr(clause)); - fx_annotate_args(sc, cdr(result), args); - } - else - if (is_fxable(sc, result)) - fx_annotate_arg(sc, cdr(clause), args); - else all_fxable = false; - fx_tree(sc, clause, var_name, NULL, NULL, false); /* just 1 let var */ - if (vars > 0) - fx_tree_outer(sc, clause, car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, vars > 3); - } - if (all_fxable) set_optimized(body); - return(all_fxable); - }} - return(false); -} - -/* tc lets can be let* or let+vars that don't refer to previous names, and there are more cond/if choices */ - -static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) -{ - if (!is_pair(body)) return(false); - - if (((vars == 1) || (vars == 2) || (vars == 3)) && - ((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) && - (is_pair(cdr(body))) && - (is_fxable(sc, cadr(body))) && - (is_pair(cddr(body)))) - { - s7_pointer orx = caddr(body); - if (((car(orx) == sc->or_symbol) || (car(orx) == sc->and_symbol)) && - (car(body) != car(orx)) && - (is_fxable(sc, cadr(orx)))) - { - s7_int len = proper_list_length(orx); - if ((len == 3) || - ((vars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1) && (is_fxable(sc, caddr(orx))))) /* the ...or|and_a_a_la case below? */ - { - s7_pointer tc = (len == 3) ? caddr(orx) : cadddr(orx); - if ((is_pair(tc)) && - (car(tc) == name) && - (is_pair(cdr(tc))) && - (is_fxable(sc, cadr(tc))) && - (((vars == 1) && (is_null(cddr(tc)))) || - ((vars == 2) && (is_pair(cddr(tc))) && (is_null(cdddr(tc))) && (is_safe_fxable(sc, caddr(tc)))) || - ((vars == 3) && (is_pair(cddr(tc))) && (is_pair(cdddr(tc))) && (is_null(cddddr(tc))) && - (is_safe_fxable(sc, caddr(tc))) && (is_safe_fxable(sc, cadddr(tc)))))) - { - if (vars == 1) - set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? - ((len == 3) ? OP_TC_AND_A_OR_A_LA : OP_TC_AND_A_OR_A_A_LA) : - ((len == 3) ? OP_TC_OR_A_AND_A_LA : OP_TC_OR_A_AND_A_A_LA)); - else - if (vars == 2) - set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LAA : OP_TC_OR_A_AND_A_LAA); - else set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_L3A : OP_TC_OR_A_AND_A_L3A); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(orx), args); - if (len == 4) fx_annotate_arg(sc, cddr(orx), args); - fx_annotate_args(sc, cdr(tc), args); - /* if ((fx_proc(cdr(tc)) == fx_c_sca) && (fn_proc(cadr(tc)) == g_substring)) -> g_substring_uncopied); */ - /* for that to be safe we need to be sure nothing in the body looks for null-termination (e.g.. string->number) */ - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), (vars == 3) ? caddr(args) : NULL, false); - return(true); - }}} - else - { - if ((vars == 1) && - (car(body) == sc->or_symbol) && - (is_fxable(sc, orx)) && - (is_pair(cdddr(body))) && - (is_pair(cadddr(body)))) - { - s7_pointer and_p = cadddr(body); - if ((is_proper_list_4(sc, and_p)) && - (car(and_p) == sc->and_symbol) && - (is_fxable(sc, cadr(and_p))) && - (is_fxable(sc, caddr(and_p)))) - { - s7_pointer la = cadddr(and_p); - if ((is_proper_list_2(sc, la)) && - (car(la) == name) && - (is_fxable(sc, cadr(la)))) - { - set_safe_optimize_op(body, OP_TC_OR_A_A_AND_A_A_LA); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cddr(body), args); - fx_annotate_arg(sc, cdr(and_p), args); - fx_annotate_arg(sc, cddr(and_p), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - return(true); - }}} - else - { - if ((vars == 1) && (car(body) == sc->and_symbol) && (car(orx) == sc->if_symbol) && - (is_proper_list_4(sc, orx)) && (is_fxable(sc, cadr(orx))) && (tree_count(sc, name, orx, 0) == 1)) - { - bool z_first = ((is_pair(cadddr(orx))) && (car(cadddr(orx)) == name)); - s7_pointer la = (z_first) ? cadddr(orx) : caddr(orx); - if ((car(la) == name) && (is_proper_list_2(sc, la)) && (is_fxable(sc, cadr(la)))) - { - bool z_fxable = true; - s7_pointer z = (z_first) ? cddr(orx) : cdddr(orx); - set_optimize_op(body, (z_first) ? OP_TC_AND_A_IF_A_Z_LA : OP_TC_AND_A_IF_A_LA_Z); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(orx), args); - fx_annotate_arg(sc, cdr(la), args); - if (is_fxable(sc, car(z))) fx_annotate_arg(sc, z, args); else z_fxable = false; - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - if (z_fxable) set_optimized(body); - return(z_fxable); - }}}}} - - if ((vars == 3) && - (((car(body) == sc->or_symbol) && (is_proper_list_2(sc, cdr(body)))) || - ((car(body) == sc->if_symbol) && (is_proper_list_3(sc, cdr(body))) && (caddr(body) == sc->T))) && - (is_fxable(sc, cadr(body)))) - { - s7_pointer and_p = (car(body) == sc->or_symbol) ? caddr(body) : cadddr(body); - if ((is_proper_list_4(sc, and_p)) && - (car(and_p) == sc->and_symbol) && - (is_fxable(sc, cadr(and_p))) && - (is_fxable(sc, caddr(and_p)))) - { - s7_pointer la = cadddr(and_p); - if ((is_proper_list_4(sc, la)) && - (car(la) == name) && - (is_fxable(sc, cadr(la))) && - (is_safe_fxable(sc, caddr(la))) && - (is_safe_fxable(sc, cadddr(la)))) - { - set_safe_optimize_op(body, OP_TC_OR_A_AND_A_A_L3A); - set_opt3_pair(cdr(body), (car(body) == sc->or_symbol) ? cdaddr(body) : cdr(cadddr(body))); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(and_p), args); - fx_annotate_arg(sc, cddr(and_p), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - return(true); - }}} - - if (((vars >= 1) && (vars <= 3)) && - (car(body) == sc->if_symbol) && - (proper_list_length(body) == 4)) - { - s7_pointer test = cadr(body); - if (is_fxable(sc, test)) - { - s7_pointer true_p = caddr(body); - s7_pointer false_p = cadddr(body); - s7_int true_len = proper_list_length(true_p); - s7_int false_len = proper_list_length(false_p); - - fx_annotate_arg(sc, cdr(body), args); - - if (vars == 1) - { - if ((false_len == 2) && - (car(false_p) == name) && - (is_fxable(sc, cadr(false_p)))) - { - set_optimize_op(body, OP_TC_IF_A_Z_LA); - fx_annotate_arg(sc, cdr(false_p), args); /* arg */ - set_opt1_pair(cdr(body), cddr(body)); - set_opt3_pair(cdr(body), cdar(cdddr(body))); - if (!is_fxable(sc, true_p)) return(false); - fx_annotate_arg(sc, cddr(body), args); /* result */ - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_optimized(body); /* split here and elsewhere from set_optimize_op is deliberate */ - return(true); - } - if ((true_len == 2) && - (car(true_p) == name) && - (is_fxable(sc, cadr(true_p)))) - { - set_optimize_op(body, OP_TC_IF_A_LA_Z); - fx_annotate_arg(sc, cdr(true_p), args); /* arg */ - set_opt1_pair(cdr(body), cdddr(body)); - set_opt3_pair(cdr(body), cdar(cddr(body))); - if (!is_fxable(sc, false_p)) return(false); - fx_annotate_arg(sc, cdddr(body), args); /* result */ - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_optimized(body); - return(true); - }} - - if (vars == 2) - { - if ((false_len == 3) && - (car(false_p) == name) && - (is_fxable(sc, cadr(false_p))) && - (is_safe_fxable(sc, caddr(false_p)))) - { - set_optimize_op(body, OP_TC_IF_A_Z_LAA); - fx_annotate_args(sc, cdr(false_p), args); - set_opt1_pair(cdr(body), cddr(body)); /* body == code in op, if_z */ - set_opt3_pair(cdr(body), cdar(cdddr(body))); /* la */ - if (!is_fxable(sc, true_p)) return(false); - fx_annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_optimized(body); - return(true); - } - if ((true_len == 3) && - (car(true_p) == name) && - (is_fxable(sc, cadr(true_p))) && - (is_safe_fxable(sc, caddr(true_p)))) - { - set_optimize_op(body, OP_TC_IF_A_LAA_Z); - fx_annotate_args(sc, cdr(true_p), args); - set_opt1_pair(cdr(body), cdddr(body)); - set_opt3_pair(cdr(body), cdar(cddr(body))); - if (!is_fxable(sc, false_p)) return(false); - fx_annotate_arg(sc, cdddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_optimized(body); - return(true); - }} - - if (vars == 3) - { - if ((false_len == 4) && - (car(false_p) == name) && - (is_fxable(sc, cadr(false_p))) && (is_safe_fxable(sc, caddr(false_p))) && (is_safe_fxable(sc, cadddr(false_p)))) - { - set_optimize_op(body, OP_TC_IF_A_Z_L3A); - fx_annotate_args(sc, cdr(false_p), args); - set_opt1_pair(cdr(body), cddr(body)); - set_opt3_pair(cdr(body), cdar(cdddr(body))); - if (!is_fxable(sc, true_p)) return(false); - fx_annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - set_optimized(body); - return(true); - } - if ((true_len == 4) && - (car(true_p) == name) && - (is_fxable(sc, cadr(true_p))) && (is_safe_fxable(sc, caddr(true_p))) && (is_safe_fxable(sc, cadddr(true_p)))) - { - set_optimize_op(body, OP_TC_IF_A_L3A_Z); - fx_annotate_args(sc, cdr(true_p), args); - set_opt1_pair(cdr(body), cdddr(body)); - set_opt3_pair(cdr(body), cdar(cddr(body))); - if (!is_fxable(sc, false_p)) return(false); - fx_annotate_arg(sc, cdddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - set_optimized(body); - return(true); - }} - - if ((false_len == 4) && - (car(false_p) == sc->if_symbol)) - { - s7_pointer in_test = cadr(false_p); - s7_pointer in_true = caddr(false_p); - s7_pointer in_false = cadddr(false_p); - if (is_fxable(sc, in_test)) - { - s7_pointer la = NULL, z; - if ((is_pair(in_false)) && - (car(in_false) == name) && - (is_pair(cdr(in_false))) && - (is_fxable(sc, cadr(in_false)))) - { - la = in_false; - z = cddr(false_p); - } - else - if ((is_pair(in_true)) && - (car(in_true) == name) && - (is_pair(cdr(in_true))) && - (is_fxable(sc, cadr(in_true)))) - { - la = in_true; - z = cdddr(false_p); - } - if ((la) && ((vars == 3) || (!s7_tree_memq(sc, name, car(z))))) - { - if (((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_safe_fxable(sc, caddr(la)))) || - ((vars == 3) && (is_proper_list_4(sc, in_true)) && (car(in_true) == name) && - (is_proper_list_4(sc, in_false)) && (is_safe_fxable(sc, caddr(la))) && (is_safe_fxable(sc, cadddr(la))) && - (is_fxable(sc, cadr(in_true))) && (is_safe_fxable(sc, caddr(in_true))) && (is_safe_fxable(sc, cadddr(in_true))))) - { - bool zs_fxable = true; - if (vars == 1) - set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LA : OP_TC_IF_A_Z_IF_A_LA_Z); - else - if (vars == 2) - set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_LAA : OP_TC_IF_A_Z_IF_A_LAA_Z); - else set_optimize_op(body, OP_TC_IF_A_Z_IF_A_L3A_L3A); - if (is_fxable(sc, true_p)) /* outer (z) result */ - fx_annotate_arg(sc, cddr(body), args); - else zs_fxable = false; - fx_annotate_arg(sc, cdr(false_p), args); /* inner test */ - fx_annotate_args(sc, cdr(la), args); /* la arg(s) */ - if (vars == 3) - fx_annotate_args(sc, cdr(in_true), args); - else - if (is_fxable(sc, car(z))) - fx_annotate_arg(sc, z, args); /* inner (z) result */ - else zs_fxable = false; - if ((has_fx(cddr(body))) && (has_fx(z))) - fx_tree(sc, cdr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, false); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - }}}} - - if ((vars == 2) && - (false_len == 3) && - (car(false_p) == sc->let_star_symbol)) - { - s7_pointer letv = cadr(false_p), letb, v; - - if (!is_pair(letv)) return(false); - letb = caddr(false_p); - for (v = letv; is_pair(v); v = cdr(v)) - if (!is_fxable(sc, cadar(v))) - return(false); - if ((is_proper_list_4(sc, letb)) && - (car(letb) == sc->if_symbol) && - (is_fxable(sc, cadr(letb)))) - { - s7_pointer laa = cadddr(letb); - if ((car(laa) == name) && - (is_proper_list_3(sc, laa)) && - (is_fxable(sc, cadr(laa))) && - (is_safe_fxable(sc, caddr(laa)))) - { - bool zs_fxable; - set_safe_optimize_op(body, OP_TC_IF_A_Z_LET_IF_A_Z_LAA); - fx_annotate_args(sc, cdr(laa), args); - zs_fxable = is_fxable(sc, caddr(letb)); - fx_annotate_args(sc, cdr(letb), args); - for (v = letv; is_pair(v); v = cdr(v)) - fx_annotate_arg(sc, cdar(v), args); - fx_tree(sc, cdar(letv), car(args), cadr(args), NULL, true); /* first var of let*, second var of let* can't be fx_treed */ - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, true); /* these are references to the outer let */ - fx_tree(sc, cdr(laa), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); - fx_tree(sc, cdr(letb), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); - fx_tree_outer(sc, cddr(letb), car(args), cadr(args), NULL, true); - if (!is_fxable(sc, caddr(body))) - return(false); - fx_annotate_arg(sc, cddr(body), args); - return(zs_fxable); - }}}}} - - /* let */ - if ((is_proper_list_3(sc, body)) && - (car(body) == sc->let_symbol) && - (is_proper_list_1(sc, cadr(body))) && - (is_fxable(sc, cadr(caadr(body)))) && /* let one var is fxable */ - (is_pair(caddr(body)))) - return(check_tc_let(sc, name, vars, args, body)); - - /* cond */ - if ((car(body) == sc->cond_symbol) && - (vars <= 2)) - return(check_tc_cond(sc, name, vars, args, body)); - - /* case */ - if ((vars == 1) && - (car(body) == sc->case_symbol) && - (is_pair(cdr(body))) && - (is_fxable(sc, cadr(body)))) - return(check_tc_case(sc, name, args, body)); - - /* when */ - if ((vars >= 1) && (vars <= 3) && - (car(body) == sc->when_symbol) && - (is_fxable(sc, cadr(body)))) - return(check_tc_when(sc, name, vars, args, body)); - return(false); -} - -static void mark_fx_treeable(s7_scheme *sc, s7_pointer body) -{ /* it is possible to encounter a cyclic body here -- should we protect against that if safety>0? */ - if (is_pair(body)) /* slightly faster than the other way of writing this */ - { - if (is_pair(car(body))) - { - set_is_fx_treeable(body); - mark_fx_treeable(sc, car(body)); - } - mark_fx_treeable(sc, cdr(body)); - } -} - -static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer func, s7_pointer args, s7_pointer body) -{ /* func is either sc->unused or a symbol */ - s7_int len = s7_list_length(sc, body); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display_80(body)); - if (len < 0) /* (define (hi) 1 . 2) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: function body messed up, ~A", 31), - (unstarred_lambda) ? sc->lambda_symbol : sc->lambda_star_symbol, - sc->code)); - if (len > 0) /* i.e. not circular */ - { - body_t result; - s7_pointer p, lst, cleared_args; - - clear_symbol_list(sc); - for (p = args; is_pair(p); p = cdr(p)) - add_symbol_to_list(sc, (is_symbol(car(p))) ? car(p) : caar(p)); - if (!is_null(p)) - add_symbol_to_list(sc, p); - sc->got_tc = false; - sc->not_tc = false; - sc->got_rec = false; - sc->rec_tc_args = -1; - result = ((is_symbol(func)) && (symbol_is_in_list(sc, func))) ? UNSAFE_BODY : body_is_safe(sc, func, body, true); /* (define (f f)...) */ - clear_symbol_list(sc); - - /* if the body is safe, we can optimize the calling sequence */ - if (!unstarred_lambda) - { - bool happy = true; - /* check default vals -- if none is an expression or symbol, set simple args */ - for (p = args; is_pair(p); p = cdr(p)) - { - s7_pointer arg = car(p); - if ((is_pair(arg)) && /* has default value */ - (is_pair(cdr(arg))) && /* is not a ridiculous improper list */ - ((is_symbol(cadr(arg))) || /* if default value might involve eval in any way, it isn't simple */ - (is_unquoted_pair(cadr(arg))))) /* pair as default only ok if it is (quote ...) */ - { - happy = false; - if ((result > UNSAFE_BODY) && - (tree_has_definers_or_binders(sc, cadr(arg)))) /* if the default has a definer, body is not safe (funclet is not stable) */ - result = UNSAFE_BODY; - break; - }} - if (happy) - lambda_set_simple_defaults(body); - } - if (result >= SAFE_BODY) /* not RECUR_BODY here (need new let for cons-r in s7test) */ - { - set_safe_closure_body(body); - if (result == VERY_SAFE_BODY) - set_very_safe_closure_body(body); - } - if (is_symbol(func)) - { - lst = list_1(sc, add_symbol_to_list(sc, func)); - sc->temp1 = lst; - } - else lst = sc->nil; - - if (optimize(sc, body, 1, cleared_args = collect_parameters(sc, args, lst)) == OPT_OOPS) - clear_all_optimizations(sc, body); - else - if (result >= RECUR_BODY) - { - int32_t nvars; - mark_fx_treeable(sc, body); - - for (nvars = 0, p = args; (is_pair(p)) && (!is_symbol_and_keyword(car(p))); nvars++, p = cdr(p)); - if ((is_null(p)) && - (nvars > 0)) - { - fx_annotate_args(sc, body, cleared_args); /* almost useless -- we need a recursive traversal here but that collides with check_if et al */ - fx_tree(sc, body, /* this usually costs more than it saves! */ - (is_pair(car(args))) ? caar(args) : car(args), - (nvars > 1) ? ((is_pair(cadr(args))) ? caadr(args) : cadr(args)) : NULL, - (nvars > 2) ? ((is_pair(caddr(args))) ? caaddr(args) : caddr(args)) : NULL, - nvars > 3); - } - if (((unstarred_lambda) || ((is_null(p)) && (nvars == sc->rec_tc_args))) && - (is_null(cdr(body)))) - { /* (if #t|#f...) happens only rarely */ - if (sc->got_tc) - { - if (check_tc(sc, func, nvars, args, car(body))) - set_safe_closure_body(body); /* (very_)safe_closure set above if > RECUR_BODY */ - /* if not check_tc, car(body) is either not a tc op or it is not optimized so that is_fxable will return false */ - } - if ((sc->got_rec) && - (!is_tc_op(optimize_op(car(body)))) && - (check_recur(sc, func, nvars, args, car(body)))) - set_safe_closure_body(body); - }} - if (is_symbol(func)) - { - sc->temp1 = sc->unused; - free_cell(sc, lst); - } - sc->got_tc = false; - sc->not_tc = false; - sc->got_rec = false; - } -} - -static int32_t check_lambda(s7_scheme *sc, s7_pointer form, bool opt) -{ - /* code is a lambda form: (lambda (a b) (+ a b)) */ - /* this includes unevaluated symbols (direct symbol table refs) in macro arg list */ - s7_pointer code, body; - int32_t arity = 0; - - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, form))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "lambda: body is cyclic: ~S", 26), form)); - - code = cdr(form); - if (!is_pair(code)) /* (lambda) or (lambda . 1) */ - syntax_error_nr(sc, "lambda: no arguments? ~A", 24, form); - - body = cdr(code); - if (!is_pair(body)) /* (lambda #f) */ - syntax_error_nr(sc, "lambda: no body? ~A", 19, form); - - /* in many cases, this is a no-op -- we already checked at define */ - check_lambda_args(sc, car(code), &arity, sc->code); - /* clear_symbol_list(sc); */ /* not used in check_lambda_args and clobbers optimize_expression find_uncomplicated_symbol check */ - - /* look for (define f (let (...) (lambda ...))) and treat as equivalent to (define (f ...)...) - * one problem the hop=0 fixes is that safe closures assume the old let exists, so we need to check for define below - * I wonder about apply define... - */ - /* OP_LET1 should work here also, (let ((f (lambda...)))), but subsequent calls assume a saved let if safe - * to mimic define, we need to parallel op_define_with_setter + make_funclet, I think - */ - if ((opt) || - (main_stack_op(sc) == OP_DEFINE1) || - (((sc->stack_end - sc->stack_start) > 4) && - (((opcode_t)(sc->stack_end[-5])) == OP_DEFINE1) && /* surely if define is ok, so is define dilambda? 16-Apr-16 */ - (sc->op_stack_now > sc->op_stack) && - ((*(sc->op_stack_now - 1)) == (s7_pointer)global_value(sc->dilambda_symbol)))) - optimize_lambda(sc, true, sc->unused, car(code), body); - else - if (optimize(sc, body, 0, - /* ((sc->op_stack_now > sc->op_stack) && (is_c_function((*(sc->op_stack_now - 1)))) && (is_scope_safe((*(sc->op_stack_now - 1))))) ? 1 : 0, */ - /* this works except when someone resets outlet(curlet) after defining a local function! */ - collect_parameters(sc, car(code), sc->nil)) == OPT_OOPS) - clear_all_optimizations(sc, body); - pair_set_syntax_op(form, OP_LAMBDA_UNCHECKED); - if (arity < -1) arity++; /* confusing! at least 0 = (), but (lambda arg...) has same "arity" here as (lambda (a . b)...)? */ - set_opt3_any(code, (s7_pointer)((intptr_t)arity)); - return(arity); -} - -static s7_pointer op_lambda(s7_scheme *sc, s7_pointer code) -{ - int32_t arity = check_lambda(sc, code, false); - code = cdr(code); - set_opt3_any(code, (s7_pointer)((intptr_t)arity)); - return(make_closure(sc, car(code), cdr(code), T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity)); -} - -static inline s7_pointer op_lambda_unchecked(s7_scheme *sc, s7_pointer code) -{ - int32_t arity = (int32_t)((intptr_t)opt3_any(cdr(code))); - return(make_closure_gc_checked(sc, cadr(code), cddr(code), T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity)); -} - -static void check_lambda_star(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, sc->code))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "lambda*: body is cyclic: ~S", 27), sc->code)); - - if ((!is_pair(code)) || - (!is_pair(cdr(code)))) /* (lambda*) or (lambda* #f) */ - syntax_error_nr(sc, "lambda*: no arguments or no body? ~A", 36, sc->code); - - set_car(code, check_lambda_star_args(sc, car(code), NULL, sc->code)); - if ((sc->safety > NO_SAFETY) || - (main_stack_op(sc) != OP_DEFINE1)) - { - if (optimize(sc, cdr(code), 0, collect_parameters(sc, car(code), sc->nil)) == OPT_OOPS) - clear_all_optimizations(sc, cdr(code)); - } - else optimize_lambda(sc, false, sc->unused, car(code), cdr(code)); - - pair_set_syntax_op(sc->code, OP_LAMBDA_STAR_UNCHECKED); - sc->code = code; -} - - -/* -------------------------------- case -------------------------------- */ -static inline bool is_undefined_feed_to(s7_scheme *sc, s7_pointer sym) -{ - return((sym == sc->feed_to_symbol) && - ((symbol_ctr(sc->feed_to_symbol) == 0) || (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))); -} - -static bool is_all_fxable(s7_scheme *sc, s7_pointer x) -{ - for (s7_pointer p = x; is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(false); - return(true); -} - -static s7_pointer check_case(s7_scheme *sc) -{ - /* we're not checking repeated or ridiculous (non-eqv?) keys here because they aren't errors */ - bool keys_simple = true, has_feed_to = false, keys_single = true, bodies_simple = true, has_else = false, use_fx = true; - int32_t key_type = T_FREE; - s7_pointer x, carc, code = cdr(sc->code), form = sc->code; - - if (!is_pair(code)) /* (case) or (case . 1) */ - syntax_error_nr(sc, "case has no selector: ~S", 25, form); - if (!is_pair(cdr(code))) /* (case 1) or (case 1 . 1) */ - syntax_error_nr(sc, "case has no clauses?: ~S", 25, form); - if (!is_pair(cadr(code))) /* (case 1 1) */ - syntax_error_nr(sc, "case clause is not a pair? ~S", 29, form); - set_opt3_any(code, sc->unspecified); - - for (x = cdr(code); is_pair(x); x = cdr(x)) - { - s7_pointer y, car_x; - if (!is_pair(car(x))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case clause ~S messed up in ~A", 30), - x, object_to_truncated_string(sc, form, 80))); - car_x = car(x); - - if (!is_list(cdr(car_x))) /* (case 1 ((1))) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case clause result ~S is messed up in ~A", 40), - car_x, object_to_truncated_string(sc, form, 80))); - if ((bodies_simple) && - ((is_null(cdr(car_x))) || (!is_null(cddr(car_x))))) - bodies_simple = false; - - use_fx = ((use_fx) && (is_pair(cdr(car_x))) && (is_all_fxable(sc, cdr(car_x)))); - y = car(car_x); - if (!is_pair(y)) - { - if ((y != sc->else_symbol) && /* (case 1 (2 1)) */ - ((!is_symbol(y)) || - (s7_symbol_value(sc, y) != sc->else_symbol))) /* "proper list" below because: (case 1 (() 2) ... */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "case clause key-list ~S in ~S is not a proper list or 'else', in ~A", 67), - y, car_x, object_to_truncated_string(sc, form, 80))); - has_else = true; - if (is_not_null(cdr(x))) /* (case 1 (else 1) ((2) 1)) */ - syntax_error_nr(sc, "case 'else' clause is not the last clause: ~S", 45, x); - if (!is_null(cdr(car_x))) /* else (else) so return selector */ - { - if (is_pair(cddr(car_x))) - { - set_opt3_any(code, cdr(car_x)); - bodies_simple = false; - } - else - { - set_opt3_any(code, ((bodies_simple) && (keys_single)) ? cadr(car_x) : cdr(car_x)); - set_opt1_clause(x, cadr(car_x)); - }}} - else - { - if (!is_simple(car(y))) keys_simple = false; - if (!is_null(cdr(y))) keys_single = false; - if (key_type == T_FREE) - key_type = type(car(y)); - else - if (key_type != type(car(y))) - key_type = NUM_TYPES; - if (key_type == T_SYMBOL) set_case_key(car(y)); - - for (y = cdr(y); is_pair(y); y = cdr(y)) - { - if (!is_simple(car(y))) - keys_simple = false; - if (key_type != type(car(y))) - key_type = NUM_TYPES; - if (key_type == T_SYMBOL) set_case_key(car(y)); - } - if (!is_null(y)) /* (case () ((1 . 2) . hi) . hi) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case key list ~S is improper, in ~A", 35), - car_x, object_to_truncated_string(sc, form, 80))); - } - y = car_x; - if (!s7_is_proper_list(sc, cdr(y))) /* (case 2 ((1 2) 1 . 2)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case: stray dot? ~S in ~A", 25), - y, object_to_truncated_string(sc, form, 80))); - if ((is_pair(cdr(y))) && (is_undefined_feed_to(sc, cadr(y)))) - { - has_feed_to = true; - if (!is_pair(cddr(y))) /* (case 1 (else =>)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case: '=>' target missing: ~S in ~A", 35), - y, object_to_truncated_string(sc, form, 80))); - if (is_pair(cdddr(y))) /* (case 1 (else => + - *)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case: '=>' has too many targets: ~S in ~A", 41), - y, object_to_truncated_string(sc, form, 80))); - }} - if (is_not_null(x)) /* (case x ((1 2)) . 1) */ - syntax_error_nr(sc, "case: stray dot? ~S", 19, form); - - if ((keys_single) && - (bodies_simple)) - { - for (x = cdr(code); is_not_null(x); x = cdr(x)) - { - set_opt2_any(x, caar(x)); - if (is_pair(opt2_any(x))) - { - set_opt2_any(x, car(opt2_any(x))); - if (is_pair(cdar(x))) - set_opt1_clause(x, cadar(x)); - }}} - else - for (x = cdr(code); is_not_null(x); x = cdr(x)) - { - set_opt2_any(x, caar(x)); - if ((is_pair(opt2_any(x))) && - (is_pair(cdar(x)))) - set_opt1_clause(x, cadar(x)); - } - if (key_type == T_INTEGER) - set_has_integer_keys(form); - - /* X_Y_Z: X (selector): S=symbol, A=fxable, P=any, Y: E(keys simple) G(any keys) I(integer keys) , Z: S: no =>, bodies simple, keys single G: all else, -- ?? */ - pair_set_syntax_op(form, OP_CASE_P_G_G); /* fallback on this */ - if ((has_feed_to) || - (!bodies_simple) || /* x_x_g g=general keys or bodies */ - (!keys_single)) - { - if (!keys_simple) /* x_g_g */ - { - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, OP_CASE_A_G_G); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, OP_CASE_P_G_G); - } - else /* x_e_g */ - { - if (!has_else) set_opt3_any(code, sc->unused); /* affects all that goto CASE_E_G */ - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, (key_type == T_SYMBOL) ? OP_CASE_A_S_G : OP_CASE_A_E_G); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, OP_CASE_P_E_G); - }} - else /* x_x_s */ - if (!keys_simple) /* x_g|i_s */ - { - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, ((!WITH_GMP) && (key_type == T_INTEGER)) ? OP_CASE_A_I_S : OP_CASE_A_G_S); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, ((!WITH_GMP) && (key_type == T_INTEGER)) ? OP_CASE_P_I_S : OP_CASE_P_G_S); - } - else /* x_e_s */ - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, OP_CASE_A_E_S); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, OP_CASE_P_E_S); - - if ((use_fx) && (has_else) && (!has_feed_to)) - { - opcode_t op = optimize_op(form); - if ((op == OP_CASE_A_E_S) || (op == OP_CASE_A_G_S) || (op == OP_CASE_A_S_G) || ((!WITH_GMP) && (op == OP_CASE_A_I_S))) - { - pair_set_syntax_op(form, - (op == OP_CASE_A_I_S) ? OP_CASE_A_I_S_A : - ((op == OP_CASE_A_E_S) ? OP_CASE_A_E_S_A : - ((op == OP_CASE_A_S_G) ? OP_CASE_A_S_G_A : OP_CASE_A_G_S_A))); - for (x = cdr(code); is_pair(x); x = cdr(x)) - { - s7_pointer clause = cdar(x); - fx_annotate_args(sc, clause, sc->curlet); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, clause); - if (is_null(cdr(x))) set_opt3_any(code, clause); - }}} - carc = cadr(form); - if (!is_pair(carc)) - { - sc->value = (is_symbol(carc)) ? lookup_checked(sc, carc) : carc; - return(NULL); - } - push_stack_no_args_direct(sc, OP_CASE_G_G); - sc->code = carc; - return(carc); -} - -#if (!WITH_GMP) -static bool op_case_i_s(s7_scheme *sc) -{ - s7_pointer selector = sc->value; - s7_pointer else_clause = opt3_any(cdr(sc->code)); - if (else_clause != sc->unspecified) - { - if (is_t_integer(selector)) - { - s7_int val = integer(selector); - for (s7_pointer x = cddr(sc->code); is_pair(cdr(x)); x = cdr(x)) - if (integer(opt2_any(x)) == val) - { - sc->code = opt1_clause(x); - return(false); - }} - sc->code = else_clause; - return(false); - } - if (is_t_integer(selector)) - { - s7_int val = integer(selector); - for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) - if (integer(opt2_any(x)) == val) - { - sc->code = opt1_clause(x); - return(false); - }} - sc->value = sc->unspecified; - return(true); -} - -static inline s7_pointer fx_case_a_i_s_a(s7_scheme *sc, s7_pointer code) /* inline saves about 30 in tleft */ -{ - s7_pointer selector = fx_call(sc, cdr(code)); - if (is_t_integer(selector)) - { - s7_int val = integer(selector); - for (s7_pointer x = cddr(sc->code); is_pair(cdr(x)); x = cdr(x)) - if (integer(opt2_any(x)) == val) - return(fx_call(sc, cdar(x))); - } - return(fx_call(sc, opt3_any(cdr(code)))); -} -#endif - -static bool op_case_e_g_1(s7_scheme *sc, s7_pointer selector, bool ok) -{ - s7_pointer x; - if (ok) - { - for (x = cddr(sc->code); is_pair(x); x = cdr(x)) - { - s7_pointer y = opt2_any(x); - if (!is_pair(y)) /* i.e. else? */ - goto ELSE_CASE_1; - do { - if (car(y) == selector) - goto ELSE_CASE_1; - y = cdr(y); - } while (is_pair(y)); - } - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - - sc->code = opt3_any(cdr(sc->code)); - if (sc->code == sc->unused) /* set in check_case if no else clause */ - sc->value = sc->unspecified; - else - if (is_pair(sc->code)) - goto ELSE_CASE_2; - pop_stack(sc); - return(true); - - ELSE_CASE_1: - /* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */ - sc->code = T_Lst(cdar(x)); - if (is_null(sc->code)) /* sc->value is already the selector */ - { - pop_stack(sc); - return(true); - } - - ELSE_CASE_2: - if (is_null(cdr(sc->code))) - { - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - - if (is_undefined_feed_to(sc, car(sc->code))) - return(false); - - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); -} - -static inline s7_pointer fx_call_all(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p; - for (p = code; is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - return(fx_call(sc, p)); -} - -static s7_pointer fx_case_a_s_g_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer selector = fx_call(sc, cdr(code)); - if (is_case_key(selector)) - for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) - { - s7_pointer y = opt2_any(x); - if (!is_pair(y)) /* i.e. else? */ - return(fx_call_all(sc, cdar(x))); /* else clause */ - do { - if (car(y) == selector) - return(fx_call_all(sc, cdar(x))); - y = cdr(y); - } while (is_pair(y)); - } - return(fx_call_all(sc, opt3_any(cdr(code)))); /* selector is not a case-key */ -} - -#define if_pair_set_up_begin(Sc) if (is_pair(cdr(Sc->code))) {check_stack_size(Sc); push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code));} Sc->code = car(Sc->code); -#define if_pair_set_up_begin_unchecked(Sc) if (is_pair(cdr(Sc->code))) push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code)); Sc->code = car(Sc->code); -/* using the one_form bit here was slower */ - -static bool op_case_g_g(s7_scheme *sc) -{ - s7_pointer x; - if (has_integer_keys(sc->code)) - { - s7_int selector; - sc->code = cddr(sc->code); - if (is_t_integer(sc->value)) - selector = integer(sc->value); - else - { -#if WITH_GMP - if ((is_t_big_integer(sc->value)) && (mpz_fits_slong_p(big_integer(sc->value)))) - selector = mpz_get_si(big_integer(sc->value)); - else -#endif - { - for (x = sc->code; is_pair(x); x = cdr(x)) - if (!is_pair(caar(x))) - goto ELSE_CASE; - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - }} - for (x = sc->code; is_pair(x); x = cdr(x)) - { - s7_pointer y = caar(x); - if (!is_pair(y)) - goto ELSE_CASE; - for (; is_pair(y); y = cdr(y)) - if (integer(car(y)) == selector) - goto ELSE_CASE; - } - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - sc->code = cddr(sc->code); - if (is_simple(sc->value)) - { - for (x = sc->code; is_pair(x); x = cdr(x)) - { - s7_pointer y = caar(x); - if (!is_pair(y)) - goto ELSE_CASE; - do { - if (car(y) == sc->value) - goto ELSE_CASE; - y = cdr(y); - } while (is_pair(y)); - } - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - for (x = sc->code; is_pair(x); x = cdr(x)) - { - s7_pointer y = caar(x); - if (!is_pair(y)) - goto ELSE_CASE; - for (; is_pair(y); y = cdr(y)) - if (s7_is_eqv(sc, car(y), sc->value)) - goto ELSE_CASE; - } - sc->value = sc->unspecified; /* this was sc->nil but the spec says case value is unspecified if no clauses match */ - pop_stack(sc); - return(true); - - ELSE_CASE: - /* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */ - sc->code = T_Lst(cdar(x)); - if (is_null(sc->code)) /* sc->value is already the selector */ - { - pop_stack(sc); - return(true); - } - if (is_null(cdr(sc->code))) - { - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - if (is_undefined_feed_to(sc, car(sc->code))) - return(false); - if_pair_set_up_begin_unchecked(sc); - sc->cur_op = optimize_op(sc->code); - return(true); -} - -static void op_case_e_s(s7_scheme *sc) -{ - s7_pointer selector = sc->value; - if (is_simple(selector)) - for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) - if (opt2_any(x) == selector) - { - sc->code = opt1_clause(x); - return; - } - sc->code = opt3_any(cdr(sc->code)); -} - -static s7_pointer fx_case_a_e_s_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer selector = fx_call(sc, cdr(code)); - if (is_simple(selector)) - for (s7_pointer x = cddr(code); is_pair(x); x = cdr(x)) - if (opt2_any(x) == selector) - return(fx_call(sc, cdar(x))); - return(fx_call(sc, opt3_any(cdr(code)))); -} - -static void op_case_g_s(s7_scheme *sc) -{ - s7_pointer selector = sc->value; - for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) - if (s7_is_eqv(sc, opt2_any(x), selector)) - { - sc->code = opt1_clause(x); - return; - } - sc->code = opt3_any(cdr(sc->code)); -} - -static inline s7_pointer fx_case_a_g_s_a(s7_scheme *sc, s7_pointer code) /* split into int/any cases in g_g, via has_integer_keys(sc->code) */ -{ - s7_pointer selector = fx_call(sc, cdr(code)); - for (s7_pointer x = cddr(code); is_pair(x); x = cdr(x)) - if (s7_is_eqv(sc, opt2_any(x), selector)) - return(fx_call(sc, cdar(x))); - return(fx_call(sc, opt3_any(cdr(code)))); -} - - -/* -------------------------------- let -------------------------------- */ -static void check_let_a_body(s7_scheme *sc, s7_pointer form) -{ - s7_pointer code = cdr(form); - if (is_fxable(sc, cadr(code))) - { - fx_annotate_arg(sc, cdr(code), set_plist_1(sc, caaar(code))); /* was sc->curlet) ? */ - fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false); - pair_set_syntax_op(form, OP_LET_A_A_OLD); - } - else - if (is_pair(cadr(code))) - { - pair_set_syntax_op(form, OP_LET_A_P_OLD); - if (is_fx_treeable(cdaar(code))) fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false); - } -} - -static void check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer start) -{ - s7_pointer binding = car(start), code = cdr(form); - if (is_pair(cadr(binding))) - { - /* this is not a named let */ - pair_set_syntax_op(form, ((is_pair(cdr(code))) && (is_null(cddr(code)))) ? OP_LET_ONE_P_OLD : OP_LET_ONE_OLD); - set_opt2_sym(cdr(code), car(binding)); /* these don't collide -- cdr(code) and code */ - set_opt2_pair(code, cadr(binding)); - if (is_optimized(cadr(binding))) - { - if ((optimize_op(cadr(binding)) == HOP_SAFE_C_SS) && - (fn_proc(cadr(binding)) == g_assq)) - { - set_opt2_sym(code, cadadr(binding)); - pair_set_syntax_op(form, OP_LET_opaSSq_OLD); - set_opt3_sym(cdr(code), caddadr(binding)); - set_opt1_sym(code, car(binding)); - } - else - if (is_fxable(sc, cadr(binding))) - { - set_opt2_pair(code, binding); - pair_set_syntax_op(form, OP_LET_A_OLD); - fx_annotate_arg(sc, cdr(binding), sc->curlet); - if (is_null(cddr(code))) - check_let_a_body(sc, form); - else - { - s7_pointer p; - for (p = cdr(code); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - if (is_null(p)) - { - pair_set_syntax_op(form, OP_LET_A_NA_OLD); - fx_annotate_args(sc, cdr(code), set_plist_1(sc, car(binding))); - fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); - return; - } - if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); - }}}} - else - { - set_opt2_pair(code, binding); - pair_set_syntax_op(form, OP_LET_A_OLD); - fx_annotate_arg(sc, cdr(binding), sc->curlet); - if (is_null(cddr(code))) - check_let_a_body(sc, form); - else - { - fx_annotate_args(sc, cdr(code), set_plist_1(sc, caaar(code))); /* no effect if not syntactic -- how to fix? */ - if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); - }} - if ((optimize_op(form) == OP_LET_A_OLD) && - (is_pair(cddr(code))) && (is_null(cdddr(code)))) - pair_set_syntax_op(form, OP_LET_A_OLD_2); -} - -static s7_pointer check_named_let(s7_scheme *sc, int32_t vars) -{ - s7_pointer code = cdr(sc->code); - set_opt2_int(code, vars); - if (vars == 0) - { - pair_set_syntax_op(sc->code, OP_NAMED_LET_NO_VARS); - set_opt1_pair(sc->code, cddr(code)); - optimize_lambda(sc, true, car(code), sc->nil, cddr(code)); - } - else - { - bool fx_ok = true; - pair_set_syntax_op(sc->code, OP_NAMED_LET); - /* this is (let name ...) so the initial values need to be removed from the closure arg list */ - - sc->args = T_Pair(safe_list_if_possible(sc, vars)); - for (s7_pointer ex = cadr(code), exp = sc->args; is_pair(ex); ex = cdr(ex), exp = cdr(exp)) - { - s7_pointer val = cdar(ex); - s7_function fx = fx_choose(sc, val, sc->curlet, let_symbol_is_safe); - if (fx) set_fx_direct(val, fx); else fx_ok = false; - car(exp) = caar(ex); - } - if (fx_ok) - { - set_opt1_pair(code, caadr(code)); - if (vars == 2) set_opt3_pair(code, cadadr(code)); - pair_set_syntax_op(sc->code, (vars == 1) ? OP_NAMED_LET_A : ((vars == 2) ? OP_NAMED_LET_AA : OP_NAMED_LET_NA)); - } - optimize_lambda(sc, true, car(code), sc->args, cddr(code)); /* car(code) is the name */ - clear_list_in_use(sc->args); - sc->args = sc->nil; - } - return(code); -} - -static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ -{ - s7_pointer x, start, code = cdr(sc->code), form = sc->code; - bool named_let; - int32_t vars; - - if (!is_pair(code)) /* (let . 1) */ - { - if (is_null(code)) /* (let) */ - syntax_error_nr(sc, "let has no variables or body: ~A", 32, form); - syntax_error_nr(sc, "let form is an improper list? ~A", 32, form); - } - - if (!is_pair(cdr(code))) /* (let () ) or (let () . 1) */ - syntax_error_nr(sc, "let has no body: ~A", 19, form); - - if ((!is_list(car(code))) && /* (let 1 ...) */ - (!is_normal_symbol(car(code)))) - syntax_error_nr(sc, "let variable list is messed up or missing: ~A", 45, form); - - named_let = (is_symbol(car(code))); - if (named_let) - { - if (!is_list(cadr(code))) /* (let hi #t) */ - syntax_error_nr(sc, "let variable list is messed up: ~A", 34, form); - if (!is_pair(cddr(code))) /* (let hi () . =>) or (let hi () ) */ - { - if (is_null(cddr(code))) - syntax_error_nr(sc, "named let has no body: ~A", 25 , form); - syntax_error_nr(sc, "named let stray dot? ~A", 23, form); - } - if (is_constant_symbol(sc, car(code))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, form)); - set_local(car(code)); - start = cadr(code); - } - else start = car(code); - - clear_symbol_list(sc); - for (vars = 0, x = start; is_pair(x); vars++, x = cdr(x)) - { - s7_pointer y, carx = car(x); - - if ((!is_pair(carx)) || (is_null(cdr(carx)))) /* (let ((x)) ...) or (let ((x 1) . (y 2)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let variable declaration, but no value?: ~A in ~A", 49), - x, object_to_truncated_string(sc, form, 80))); - - if (!(is_pair(cdr(carx)))) /* (let ((x . 1))...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, is not a proper list in ~A", 56), - x, object_to_truncated_string(sc, form, 80))); - - if (is_not_null(cddr(carx))) /* (let ((x 1 2 3)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, has more than one value in ~A", 59), - x, object_to_truncated_string(sc, form, 80))); - y = car(carx); - if (!(is_symbol(y))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "bad variable ~S in let (it is not a symbol) in ~A", 49), - carx, object_to_truncated_string(sc, form, 80))); - - if (is_constant_symbol(sc, y)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, x)); - - /* check for name collisions -- not sure this is required by Scheme */ - if (symbol_is_in_list(sc, y)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "duplicate identifier in let: ~S in ~S", 37), y, form)); - add_symbol_to_list(sc, y); - set_local(y); - } - /* (let ('1) quote) -> 1 */ - - if (is_not_null(x)) /* (let* ((a 1) . b) a) */ - syntax_error_nr(sc, "let variable list improper?: ~A", 31, form); - - if (!s7_is_proper_list(sc, cdr(code))) /* (let ((a 1)) a . 1) */ - syntax_error_nr(sc, "stray dot in let body: ~S", 25, cdr(code)); - - if (named_let) - return(check_named_let(sc, vars)); - - if (vars == 0) /* !in_heap does not happen much here */ - pair_set_syntax_op(form, OP_LET_NO_VARS); - else - { - pair_set_syntax_op(form, OP_LET_UNCHECKED); - if (vars == 1) - check_let_one_var(sc, form, start); - else - { - /* this used to check that vars < gc_trigger_size, but I can't see why */ - opcode_t opt = OP_UNOPT; - for (s7_pointer p = start; is_pair(p); p = cdr(p)) - { - x = car(p); - if (is_fxable(sc, cadr(x))) - { - set_fx_direct(cdr(x), fx_choose(sc, cdr(x), sc->curlet, let_symbol_is_safe)); - if (opt == OP_UNOPT) - opt = OP_LET_NA_OLD; - } - else opt = OP_LET_UNCHECKED; - } - pair_set_syntax_op(form, opt); - if ((opt == OP_LET_NA_OLD) && - (is_null(cddr(code)))) /* 1 form in body */ - { - if (vars == 2) - { - pair_set_syntax_op(form, OP_LET_2A_OLD); - set_opt1_pair(code, caar(code)); - set_opt2_pair(code, cadar(code)); - } - else - if (vars == 3) - { - pair_set_syntax_op(form, OP_LET_3A_OLD); - set_opt1_pair(code, cadar(code)); - set_opt2_pair(code, caddar(code)); - }}}} - - /* if safe_c or safe_closure as car(body), null cdr(body), see if only vars as args - * symbol_list is intact?? - */ - if (optimize_op(form) >= OP_LET_NA_OLD) - { - if ((!in_heap(form)) && - (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) /* recur_body is apparently never hit */ - set_opt3_let(code, make_semipermanent_let(sc, car(code))); - else - { - set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ - set_opt3_let(code, sc->nil); - }} - - /* fx_tree inits */ - if ((is_pair(code)) && - /* (is_let(sc->curlet)) && */ /* not rootlet=() but treeable is only in functions */ - (is_fx_treeable(code)) && /* was is_funclet(sc->curlet) 27-Sep-21, but that seems too restrictive */ - (tis_slot(let_slots(sc->curlet)))) - { - s7_pointer s1 = let_slots(sc->curlet), s2 = next_slot(s1), s3 = NULL; - bool more_vars = false; - if (tis_slot(s2)) - { - if (tis_slot(next_slot(s2))) - { - s3 = next_slot(s2); - more_vars = tis_slot(next_slot(s3)); - s3 = slot_symbol(s3); - } - s2 = slot_symbol(s2); - } - s1 = slot_symbol(s1); - for (s7_pointer p = car(code); is_pair(p); p = cdr(p)) /* var list */ - { - s7_pointer init = cdar(p); - fx_tree(sc, init, s1, s2, s3, more_vars); - }} - return(code); -} - -static bool op_named_let_1(s7_scheme *sc, s7_pointer args) /* args = vals in decl order */ -{ - s7_pointer body = cddr(sc->code), x; - s7_int n = opt2_int(sc->code); - for (x = cadr(sc->code), sc->w = sc->nil; is_pair(x); x = cdr(x)) - { - sc->w = cons(sc, caar(x), sc->w); - x = cdr(x); - if (!is_pair(x)) break; - sc->w = cons_unchecked(sc, caar(x), sc->w); - } - sc->w = proper_list_reverse_in_place(sc, sc->w); /* init values (args) are also in "reversed" order */ - sc->curlet = make_let(sc, sc->curlet); - sc->x = make_closure_unchecked(sc, sc->w, body, T_CLOSURE, n); - add_slot(sc, sc->curlet, car(sc->code), sc->x); - sc->curlet = make_let(sc, sc->curlet); /* inner let */ - - for (x = sc->w; is_not_null(args); x = cdr(x)) /* reuse the value cells as the new let slots */ - { - s7_pointer sym = car(x), new_args = cdr(args); - reuse_as_slot(sc, args, sym, unchecked_car(args)); /* args=slot, sym=symbol, car(args)=value */ - slot_set_next(args, let_slots(sc->curlet)); - let_set_slots(sc->curlet, args); - symbol_set_local_slot(sym, let_id(sc->curlet), args); - args = new_args; - } - closure_set_let(sc->x, sc->curlet); - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - sc->x = sc->unused; - sc->code = T_Pair(body); - sc->w = sc->unused; - return(true); -} - -static bool op_let1(s7_scheme *sc) -{ - s7_pointer x, y, e; - uint64_t id; - /* building a list, then reusing it below as the let/slots seems stupid, but if we make the let first, and - * add slots, there are other problems. The let/slot ids (and symbol_set_local_slot) need to wait - * until the args are evaluated, if an arg invokes call/cc, the let on the stack needs to be copied - * including let_dox_code if it is used to save sc->code (there are 3 things that need to be protected), - * (we win currently because copy_stack copies the list), and make-circular-iterator if called twice (s7test) - * hangs -- I can't see why! Otherwise, the let/slots approach is slightly faster (less than 1% however). - */ - while (true) - { - sc->args = cons(sc, sc->value, sc->args); - if (is_pair(sc->code)) - { - x = cdar(sc->code); - if (has_fx(x)) - { -#if S7_DEBUGGING - s7_pointer old_args = sc->args; -#endif - sc->value = fx_call(sc, x); -#if S7_DEBUGGING - if (sc->args != old_args) - { - fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(old_args), display(sc->args)); - gdb_break(); - } -#endif - } - else - { - check_stack_size(sc); - push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); - sc->code = car(x); - return(false); - } - sc->code = cdr(sc->code); - } - else break; - } - x = proper_list_reverse_in_place(sc, sc->args); - sc->code = car(x); /* restore the original form */ - y = cdr(x); /* use sc->args as the new let */ - sc->temp8 = y; - set_curlet(sc, reuse_as_let(sc, x, sc->curlet)); - - if (is_symbol(car(sc->code))) - return(op_named_let_1(sc, y)); /* inner let here */ - - e = sc->curlet; - id = let_id(e); - if (is_pair(y)) - { - s7_pointer sym, args = cdr(y), sp; - x = car(sc->code); - sym = caar(x); - reuse_as_slot(sc, y, sym, unchecked_car(y)); - symbol_set_local_slot(sym, id, y); - let_set_slots(e, y); - sp = y; - y = args; - - for (x = cdr(x); is_not_null(y); x = cdr(x)) - { - sym = caar(x); - args = cdr(args); - reuse_as_slot(sc, y, sym, unchecked_car(y)); - symbol_set_local_slot(sym, id, y); - slot_set_next(sp, y); - sp = y; - y = args; - } - slot_set_next(sp, slot_end(sc)); - } - sc->code = T_Pair(cdr(sc->code)); - sc->temp8 = sc->unused; - return(true); -} - -static bool op_let(s7_scheme *sc) -{ - /* sc->code is everything after the let: (let ((a 1)) a) so sc->code is (((a 1)) a) */ - /* car can be either a list or a symbol ("named let") */ - bool named_let; - - sc->code = check_let(sc); - sc->value = sc->code; - named_let = is_symbol(car(sc->code)); - sc->code = (named_let) ? cadr(sc->code) : car(sc->code); - if (is_null(sc->code)) /* (let [name] () ...): no bindings, so skip that step */ - { - sc->code = sc->value; - sc->curlet = make_let(sc, sc->curlet); - if (named_let) /* see also below -- there are 3 cases */ - { - s7_pointer body = cddr(sc->code); - set_opt2_int(cdr(sc->code), 0); - sc->x = make_closure_unchecked(sc, sc->nil, body, T_CLOSURE, 0); - /* args = () in new closure, see NAMED_LET_NO_VARS above */ - /* if this is a safe closure, we can build its let in advance and name it (a thunk in this case) */ - set_funclet(closure_let(sc->x)); - funclet_set_function(closure_let(sc->x), car(sc->code)); - add_slot_checked(sc, sc->curlet, car(sc->code), sc->x); - sc->curlet = make_let(sc, sc->curlet); /* inner let */ - sc->code = T_Pair(body); - sc->x = sc->unused; - } - else sc->code = T_Pair(cdr(sc->code)); - return(true); - } - sc->args = sc->nil; - return(op_let1(sc)); -} - -static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars */ -{ - s7_pointer code = cadr(sc->code); - s7_pointer x = cdar(code); - sc->args = list_1(sc, cdr(sc->code)); - if (has_fx(x)) - sc->value = fx_call(sc, x); - else - { - push_stack(sc, OP_LET1, sc->args, cdr(code)); - sc->code = car(x); - return(false); /* goto EVAL */ - } - sc->code = cdr(code); - return(op_let1(sc)); -} - -static bool op_named_let(s7_scheme *sc) -{ - sc->args = sc->nil; - sc->value = cdr(sc->code); - sc->code = cadr(sc->value); - return(op_let1(sc)); -} - -static void op_named_let_no_vars(s7_scheme *sc) -{ - s7_pointer arg = cadr(sc->code); - sc->code = opt1_pair(sc->code); /* cdddr(sc->code) */ - sc->curlet = inline_make_let(sc, sc->curlet); - sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0); /* sc->args is a temp here */ - add_slot_checked(sc, sc->curlet, arg, sc->args); - sc->curlet = make_let(sc, sc->curlet); /* inner let */ -} - -static void op_named_let_a(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - sc->code = cddr(args); - sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) */ - sc->curlet = make_let(sc, sc->curlet); - sc->w = list_1_unchecked(sc, car(opt1_pair(args))); /* caaadr(args), subsequent calls will need a normal list of pars in closure_args */ - sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 1); /* picks up curlet (this is the funclet?) */ - add_slot(sc, sc->curlet, car(args), sc->x); /* the function */ - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, car(sc->w), sc->args); /* inner let */ - closure_set_let(sc->x, sc->curlet); - sc->x = sc->unused; - sc->w = sc->unused; -} - -static void op_named_let_aa(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - sc->code = cddr(args); - sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) == init val of first par */ - sc->value = fx_call(sc, cdr(opt3_pair(args))); /* cdadadr = init val of second */ - sc->curlet = make_let(sc, sc->curlet); - sc->w = list_2_unchecked(sc, car(opt1_pair(args)), car(opt3_pair(args))); /* subsequent calls will need a normal list of pars in closure_args */ - sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 2); /* picks up curlet (this is the funclet?) */ - add_slot(sc, sc->curlet, car(args), sc->x); /* the function */ - sc->curlet = inline_make_let_with_two_slots(sc, sc->curlet, car(sc->w), sc->args, cadr(sc->w), sc->value); /* inner let */ - closure_set_let(sc->x, sc->curlet); - sc->x = sc->unused; - sc->w = sc->unused; -} - -static bool op_named_let_na(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - sc->args = sc->nil; - for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p)) - { - sc->args = cons(sc, sc->value = fx_call(sc, cdar(p)), sc->args); - p = cdr(p); - if (!is_pair(p)) break; - sc->args = cons_unchecked(sc, sc->value = fx_call(sc, cdar(p)), sc->args); - } - sc->args = proper_list_reverse_in_place(sc, sc->args); - return(op_named_let_1(sc, sc->args)); /* sc->code = (name vars . body), args = vals in decl order, op_named_let_1 handles inner let */ -} - -static void op_let_no_vars(s7_scheme *sc) -{ - sc->curlet = inline_make_let(sc, sc->curlet); - sc->code = T_Pair(cddr(sc->code)); /* ignore the () */ -} - -static void op_let_one_new(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_LET_ONE_NEW_1, cdr(sc->code)); - sc->code = opt2_pair(sc->code); -} - -static void op_let_one_p_new(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - push_stack_no_args(sc, OP_LET_ONE_P_NEW_1, cdr(sc->code)); - sc->code = T_Pair(opt2_pair(sc->code)); -} - -static void op_let_one_old(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - push_stack_no_args_direct(sc, OP_LET_ONE_OLD_1); - sc->code = opt2_pair(sc->code); -} - -static void op_let_one_old_1(s7_scheme *sc) -{ - s7_pointer let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = cdr(sc->code); -} - -static void op_let_one_p_old(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - push_stack_no_args_direct(sc, OP_LET_ONE_P_OLD_1); - sc->code = T_Pair(opt2_pair(sc->code)); -} - -static void op_let_one_p_old_1(s7_scheme *sc) -{ - s7_pointer let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = cadr(sc->code); -} - -static Inline void inline_op_let_a_new(s7_scheme *sc) /* three calls in eval, all get hits */ -{ - sc->code = cdr(sc->code); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, car(opt2_pair(sc->code)), fx_call(sc, cdr(opt2_pair(sc->code)))); -} - -static Inline void inline_op_let_a_old(s7_scheme *sc) /* tset(2) fb(0) cb(4) left(2) */ -{ - s7_pointer let; - sc->code = cdr(sc->code); - let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); -} - -static inline void op_let_a_old(s7_scheme *sc) {return(inline_op_let_a_old(sc));} - -static void op_let_a_a_new(s7_scheme *sc) -{ - s7_pointer binding; - sc->code = cdr(sc->code); - binding = opt2_pair(sc->code); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, car(binding), fx_call(sc, cdr(binding))); - sc->value = fx_call(sc, cdr(sc->code)); - free_cell(sc, sc->curlet); /* don't free let_slots here unless checked first (can be null after fx_call above?) */ - /* upon return, we continue, so sc->curlet should be ok */ -} - -static void op_let_a_a_old(s7_scheme *sc) /* these are not called as fx*, and restoring sc->curlet has noticeable cost (e.g. 8 in thash) */ -{ - s7_pointer let; - sc->code = cdr(sc->code); - let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->value = fx_call(sc, cdr(sc->code)); -} - -static void op_let_a_na_new(s7_scheme *sc) -{ - s7_pointer binding, p; - sc->code = cdr(sc->code); - binding = opt2_pair(sc->code); - sc->curlet = make_let_with_slot(sc, sc->curlet, car(binding), fx_call(sc, cdr(binding))); - for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p)) fx_call(sc, p); - sc->value = fx_call(sc, p); - free_cell(sc, sc->curlet); /* see above */ -} - -/* this and others like it could easily be fx funcs, but check_let is called too late, so it's never seen as fxable */ -static void op_let_a_na_old(s7_scheme *sc) -{ - s7_pointer let, p; - sc->code = cdr(sc->code); - let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p)) fx_call(sc, p); - sc->value = fx_call(sc, p); -} - -static inline void op_let_opassq(s7_scheme *sc) -{ - s7_pointer in_val, lst; - sc->code = cdr(sc->code); - in_val = lookup(sc, opt2_sym(sc->code)); /* cadadr(caar(sc->code)); */ - lst = lookup(sc, opt3_sym(cdr(sc->code))); - if (is_pair(lst)) - sc->value = s7_assq(sc, in_val, lst); - else sc->value = (is_null(lst)) ? sc->F : g_assq(sc, set_plist_2(sc, in_val, lst)); -} - -static inline void op_let_opassq_old(s7_scheme *sc) -{ - s7_pointer let; - op_let_opassq(sc); - let = update_let_with_slot(sc, opt3_let(sc->code), sc->value); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = T_Pair(cdr(sc->code)); -} - -static inline void op_let_opassq_new(s7_scheme *sc) -{ - op_let_opassq(sc); - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value); - sc->code = T_Pair(cdr(sc->code)); -} - -static Inline void inline_op_let_na_new(s7_scheme *sc) /* called once in eval, case gsl lg mock */ -{ - s7_pointer let, sp = NULL; - new_cell(sc, let, T_LET | T_SAFE_PROCEDURE); - let_set_id(let, sc->let_number + 1); - let_set_slots(let, slot_end(sc)); - let_set_outlet(let, sc->curlet); - sc->args = let; - for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer arg = cdar(p); - sc->value = fx_call(sc, arg); - if (!sp) - { - add_slot(sc, let, caar(p), sc->value); - sp = let_slots(let); - } - else sp = inline_add_slot_at_end(sc, let_id(let), sp, caar(p), sc->value); - } - sc->let_number++; - set_curlet(sc, let); - sc->code = T_Pair(cddr(sc->code)); -} - -static void op_let_na_old(s7_scheme *sc) -{ - s7_pointer let = opt3_let(cdr(sc->code)); - s7_pointer slot = let_slots(let); - uint64_t id = ++sc->let_number; - sc->args = let; - let_set_id(let, id); - let_set_outlet(let, sc->curlet); - for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p), slot = next_slot(slot)) - { - /* GC protected because it's a semipermanent let? or perhaps use sc->args? */ - slot_set_value(slot, fx_call(sc, cdar(p))); - symbol_set_local_slot_unincremented(slot_symbol(slot), id, slot); - } - set_curlet(sc, let); - sc->code = T_Pair(cddr(sc->code)); -} - -static void op_let_2a_new(s7_scheme *sc) /* 2 vars, 1 expr in body */ -{ - s7_pointer code = cdr(sc->code); - s7_pointer a1 = opt1_pair(code); /* caar(code) */ - s7_pointer a2 = opt2_pair(code); /* cadar(code) */ - sc->curlet = inline_make_let_with_two_slots(sc, sc->curlet, car(a1), fx_call(sc, cdr(a1)), car(a2), fx_call(sc, cdr(a2))); - sc->code = cadr(code); -} - -static inline void op_let_2a_old(s7_scheme *sc) /* 2 vars, 1 expr in body */ -{ - s7_pointer code = cdr(sc->code); - s7_pointer let = update_let_with_two_slots(sc, opt3_let(code), fx_call(sc, cdr(opt1_pair(code))), fx_call(sc, cdr(opt2_pair(code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = cadr(code); -} - -static void op_let_3a_new(s7_scheme *sc) /* 3 vars, 1 expr in body */ -{ - s7_pointer code = cdr(sc->code); - s7_pointer a1 = caar(code); - s7_pointer a2 = opt1_pair(code); /* cadar */ - s7_pointer a3 = opt2_pair(code); /* caddar */ - gc_protect_via_stack(sc, fx_call(sc, cdr(a1))); /* fx_call might be fx_car_t (etc) so it needs to precede the new let */ - set_stack_protected2(sc, fx_call(sc, cdr(a2))); - sc->curlet = inline_make_let_with_two_slots(sc, sc->curlet, car(a2), stack_protected2(sc), car(a3), fx_call(sc, cdr(a3))); - add_slot(sc, sc->curlet, car(a1), stack_protected1(sc)); - unstack(sc); - sc->code = cadr(code); -} - -static void op_let_3a_old(s7_scheme *sc) /* 3 vars, 1 expr in body */ -{ - s7_pointer code = cdr(sc->code); - s7_pointer let = update_let_with_three_slots(sc, opt3_let(code), fx_call(sc, cdr(caar(code))), fx_call(sc, cdr(opt1_pair(code))), fx_call(sc, cdr(opt2_pair(code)))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - sc->code = cadr(code); -} - - -/* -------------------------------- let* -------------------------------- */ -static bool check_let_star(s7_scheme *sc) -{ - s7_pointer vars, form = sc->code, code = cdr(sc->code); - bool named_let, fxable = true, shadowing = false; - - if (!is_pair(code)) /* (let* . 1) */ - syntax_error_nr(sc, "let* variable list is messed up: ~A", 35, form); - if (!is_pair(cdr(code))) /* (let* ()) */ - syntax_error_nr(sc, "let* has no body: ~A", 20, form); - - named_let = (is_symbol(car(code))); - - if (named_let) - { - if (!is_list(cadr(code))) /* (let* hi #t) */ - syntax_error_nr(sc, "let* variable list is messed up: ~A", 35, form); - if (!is_pair(cddr(code))) /* (let* hi () . =>) or (let* hi () ) */ - { - if (is_null(cddr(code))) - syntax_error_nr(sc, "named let* has no body: ~A", 26, form); - syntax_error_nr(sc, "named let* stray dot? ~A", 24, form); - } - if (is_constant_symbol(sc, car(code))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, form)); - set_local(car(code)); - } - else - if (!is_list(car(code))) /* (let* x ... ) */ - syntax_error_nr(sc, "let* variable declaration value is missing: ~A", 46, form); - - clear_symbol_list(sc); - for (vars = ((named_let) ? cadr(code) : car(code)); is_pair(vars); vars = cdr(vars)) - { - s7_pointer var, var_and_val = car(vars); - if (!is_pair(var_and_val)) /* (let* (3) ... */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable list, ~A, is messed up in ~A", 42), - var_and_val, object_to_truncated_string(sc, form, 80))); - - if (!(is_pair(cdr(var_and_val)))) /* (let* ((x . 1))...) */ - { - if (is_null(cdr(var_and_val))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable declaration, but no value?: ~A in ~A", 50), - var_and_val, object_to_truncated_string(sc, form, 80))); - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable declaration is not a proper list: ~A in ~A", 56), - var_and_val, object_to_truncated_string(sc, form, 80))); - } - if (!is_null(cddr(var_and_val))) /* (let* ((c 1 2)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable declaration has more than one value?: ~A in ~A", 60), - var_and_val, object_to_truncated_string(sc, form, 80))); - - var = car(var_and_val); - if (!(is_symbol(var))) /* (let* ((3 1)) 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "bad variable, ~S, in let* (it is not a symbol): ~A", 50), - var, object_to_truncated_string(sc, form, 80))); - - if (is_constant_symbol(sc, var)) /* (let* ((pi 3)) ...) */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, var_and_val)); - - if ((named_let) && (symbol_is_in_arg_list(var, cdr(vars)))) /* (let* loop ((a 1) (a 2)) ...) -- added 2-Dec-19 */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "named let* parameter, ~A, is used twice in the parameter list in ~A", 67), - var, object_to_truncated_string(sc, form, 80))); - /* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error */ - - if (symbol_is_in_list(sc, var)) shadowing = true; - add_symbol_to_list(sc, var); - set_local(var); - } - if (!is_null(vars)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable list is not a proper list: ~A in ~A", 49), - vars, object_to_truncated_string(sc, form, 80))); - - if (!s7_is_proper_list(sc, cdr(code))) - syntax_error_nr(sc, "stray dot in let* body: ~S", 26, cdr(code)); - - if (shadowing) - fxable = false; - else - for (vars = (named_let) ? cadr(code) : car(code); is_pair(vars); vars = cdr(vars)) - if (is_fxable(sc, cadar(vars))) - set_fx_direct(cdar(vars), fx_choose(sc, cdar(vars), sc->curlet, let_star_symbol_is_safe)); - else fxable = false; - - if (named_let) - { - if (is_null(cadr(code))) - { - pair_set_syntax_op(form, OP_NAMED_LET_NO_VARS); - set_opt1_pair(form, cdddr(form)); - } - else - { - pair_set_syntax_op(form, OP_NAMED_LET_STAR); - set_opt2_con(code, cadr(caadr(code))); - } - sc->value = cdr(code); - if (is_null(car(sc->value))) /* (let* name () ... */ - { - s7_pointer let_sym = car(code); - sc->curlet = make_let(sc, sc->curlet); - sc->code = T_Pair(cdr(sc->value)); - add_slot_checked(sc, sc->curlet, let_sym, make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE_STAR, 0)); - sc->curlet = make_let(sc, sc->curlet); /* inner let */ - return(false); - } - sc->curlet = make_let(sc, sc->curlet); - push_stack(sc, OP_LET_STAR1, code, cadr(code)); - sc->code = cadr(caadr(code)); /* first var val */ - return(true); - } - if (is_null(car(code))) - { - pair_set_syntax_op(form, OP_LET_NO_VARS); /* (let* () ...) */ - - sc->curlet = make_let(sc, sc->curlet); - sc->code = T_Pair(cdr(code)); - return(false); - } - else - if (is_null(cdar(code))) - { - check_let_one_var(sc, form, car(code)); /* (let* ((var...))...) -> (let ((var...))...) */ - if (optimize_op(form) >= OP_LET_NA_OLD) - { - if ((!in_heap(form)) && - (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) - set_opt3_let(code, make_semipermanent_let(sc, car(code))); - else - { - set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ - set_opt3_let(code, sc->nil); - }}} - else /* multiple variables */ - { - if (fxable) - { - pair_set_syntax_op(form, OP_LET_STAR_NA); - if ((is_null(cddr(code))) && - (is_fxable(sc, cadr(code)))) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_LET_STAR_NA_A); - }} - else pair_set_syntax_op(form, OP_LET_STAR2); - set_opt2_con(code, cadaar(code)); - } - push_stack(sc, ((intptr_t)((shadowing) ? OP_LET_STAR_SHADOWED : OP_LET_STAR1)), code, car(code)); - /* args is the let body, saved for later, code is the list of vars+initial-values */ - sc->code = cadr(caar(code)); - /* caar(code) = first var/val pair, we've checked that all these guys are legit, so cadr of that is the value */ - return(true); -} - -static bool op_let_star_shadowed(s7_scheme *sc) -{ - while (true) - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value); - sc->code = cdr(sc->code); - if (is_pair(sc->code)) - { - s7_pointer x = cdar(sc->code); - if (has_fx(x)) - sc->value = fx_call(sc, x); - else - { - push_stack_direct(sc, OP_LET_STAR_SHADOWED); - sc->code = car(x); - return(true); - }} - else break; - } - sc->code = cdr(sc->args); /* original sc->code set in push_stack above */ - return(false); -} - -static inline bool op_let_star1(s7_scheme *sc) -{ - uint64_t let_counter = S7_INT64_MAX; - s7_pointer sp = NULL; - while (true) - { - if (let_counter == sc->capture_let_counter) - { - if (sp == NULL) - { - add_slot_checked(sc, sc->curlet, caar(sc->code), sc->value); - sp = let_slots(sc->curlet); - } - else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(sc->code), sc->value); - } - else - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value); - sp = let_slots(sc->curlet); - let_counter = sc->capture_let_counter; - } - sc->code = cdr(sc->code); - if (is_pair(sc->code)) - { - s7_pointer x = cdar(sc->code); - if (has_fx(x)) - sc->value = fx_call(sc, x); - else - { - push_stack_direct(sc, OP_LET_STAR1); - sc->code = car(x); - return(true); - }} - else break; - } - sc->code = sc->args; /* original sc->code set in push_stack above */ - if (is_symbol(car(sc->code))) - { - s7_pointer name = car(sc->code), body = cddr(sc->code), args = cadr(sc->code); - /* now we need to declare the new function (in the outer let) -- must delay this because init might reference same-name outer func */ - /* but the let name might be shadowed by a variable: (let* x ((x 1))...) so the name's symbol_id can be incorrect */ - if (symbol_id(name) > let_id(let_outlet(sc->curlet))) - { - s7_int cur_id = symbol_id(name); - s7_pointer cur_slot = local_slot(name); - symbol_set_id_unchecked(name, let_id(let_outlet(sc->curlet))); - add_slot_checked(sc, let_outlet(sc->curlet), name, - make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); - symbol_set_id_unchecked(name, cur_id); - set_local_slot(name, cur_slot); - } - else add_slot_checked(sc, let_outlet(sc->curlet), name, - make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); - - sc->code = body; - } - else sc->code = T_Pair(cdr(sc->code)); - return(false); -} - -static void op_let_star_na(s7_scheme *sc) -{ - /* fx safe does not mean we can dispense with the inner lets (curlet is safe for example) */ - s7_pointer sp = NULL; - uint64_t let_counter = S7_INT64_MAX; - sc->code = cdr(sc->code); - for (s7_pointer p = car(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer val = fx_call(sc, cdar(p)); /* eval in outer let */ - if (let_counter == sc->capture_let_counter) - { - if (!sp) - { - add_slot_checked(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - } - else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(p), val); - } - else - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - let_counter = sc->capture_let_counter; - }} - sc->code = T_Pair(cdr(sc->code)); -} - -static void op_let_star_na_a(s7_scheme *sc) -{ - s7_pointer sp = NULL; - uint64_t let_counter = S7_INT64_MAX; - sc->code = cdr(sc->code); - for (s7_pointer p = car(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer val = fx_call(sc, cdar(p)); - if (let_counter == sc->capture_let_counter) - { - if (!sp) - { - add_slot_checked(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - } - else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(p), val); - } - else - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - let_counter = sc->capture_let_counter; - }} - sc->value = fx_call(sc, cdr(sc->code)); -} - -static void op_named_let_star(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); /* code: (name vars ...) */ - sc->curlet = make_let(sc, sc->curlet); - push_stack(sc, OP_LET_STAR1, code, cadr(code)); - sc->code = opt2_con(code); -} - -static void op_let_star2(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - push_stack(sc, OP_LET_STAR1, code, car(code)); - sc->code = opt2_con(code); -} - - -/* -------------------------------- letrec, letrec* -------------------------------- */ -static void check_letrec(s7_scheme *sc, bool letrec) -{ - s7_pointer x, code = cdr(sc->code); - s7_pointer caller = (letrec) ? sc->letrec_symbol : sc->letrec_star_symbol; - - if ((!is_pair(code)) || /* (letrec . 1) */ - (!is_list(car(code)))) /* (letrec 1 ...) */ - syntax_error_with_caller_nr(sc, "~A: variable list is messed up: ~A", 34, caller, sc->code); - - if (!is_pair(cdr(code))) /* (letrec ()) */ - syntax_error_with_caller_nr(sc, "~A has no body: ~A", 18, caller, sc->code); - - clear_symbol_list(sc); - for (x = car(code); is_not_null(x); x = cdr(x)) - { - s7_pointer y, carx; - if (!is_pair(x)) /* (letrec ((a 1) . 2) ...) */ - syntax_error_with_caller_nr(sc, "~A: improper list of variables? ~A", 34, caller, sc->code); - - carx = car(x); - if (!is_pair(carx)) /* (letrec (1 2) #t) */ - syntax_error_with_caller_nr(sc, "~A: bad variable ~S (should be a pair (name value))", 51, caller, carx); - if (!(is_symbol(car(carx)))) - syntax_error_with_caller_nr(sc, "~A: bad variable ~S (it is not a symbol)", 40, caller, carx); - - y = car(carx); - if (is_constant_symbol(sc, y)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->letrec_symbol, x)); - - if (!is_pair(cdr(carx))) /* (letrec ((x . 1))...) */ - { - if (is_null(cdr(carx))) /* (letrec ((x)) x) -- perhaps this is legal? */ - syntax_error_with_caller_nr(sc, "~A: variable declaration has no value?: ~A", 42, caller, carx); - syntax_error_with_caller_nr(sc, "~A: variable declaration is not a proper list?: ~A", 50, caller, carx); - } - if (is_not_null(cddr(carx))) /* (letrec ((x 1 2 3)) ...) */ - syntax_error_with_caller_nr(sc, "~A: variable declaration has more than one value?: ~A", 53, caller, carx); - - /* check for name collisions -- this is needed in letrec* else which of the two legit values does our "rec" refer to, so to speak */ - if (symbol_is_in_list(sc, y)) - syntax_error_with_caller_nr(sc, "~A: duplicate identifier: ~A", 28, caller, y); - add_symbol_to_list(sc, y); - set_local(y); - } - - if (!s7_is_proper_list(sc, cdr(code))) - syntax_error_with_caller_nr(sc, "stray dot in ~A body: ~S", 24, caller, cdr(code)); - - for (x = car(code); is_pair(x); x = cdr(x)) - if (is_fxable(sc, cadar(x))) - set_fx_direct(cdar(x), fx_choose(sc, cdar(x), sc->curlet, let_symbol_is_safe_or_listed)); - - pair_set_syntax_op(sc->code, (letrec) ? OP_LETREC_UNCHECKED : OP_LETREC_STAR_UNCHECKED); -} - -static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer func_name, s7_pointer outer_let); - -static void letrec_setup_closures(s7_scheme *sc) -{ - for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) - if (is_closure(slot_value(slot))) - { - s7_pointer func = slot_value(slot); - if ((!is_safe_closure(func)) || - (!is_optimized(car(closure_body(func))))) - optimize_lambda(sc, true, slot_symbol(slot), closure_args(func), closure_body(func)); - if (is_safe_closure_body(closure_body(func))) - { - set_safe_closure(func); - if (is_very_safe_closure_body(closure_body(func))) - set_very_safe_closure(func); - } - make_funclet(sc, func, slot_symbol(slot), closure_let(func)); - } -} - -static void op_letrec2(s7_scheme *sc) -{ - for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) - if (is_checked_slot(slot)) - slot_set_value(slot, slot_pending_value(slot)); - letrec_setup_closures(sc); -} - -static bool op_letrec_unchecked(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - /* get all local vars and set to # - * get parallel list of values - * eval each member of values list with let still full of #'s - * assign each value to its variable - * eval body - * which means that (letrec ((x x)) x) is not an error! - * but this assumes the environment is not changed by evaluating the exprs? - * (letrec ((a (define b 1))) b) -- if let, the define takes place in the calling let, not the current let - * (letrec ((f1 (lambda (x) (f2 (* 2 x))))) (define (f2 y) (- y 1)) (f1 3)) -> 5 (Guile says unbound f2) - * I think I need to check here that slot_pending_value is set (using the is_checked bit below): - * (letrec ((i (begin (define xyz 37) 0))) (curlet)): (inlet 'i 0 'xyz 37) -- is this correct? - */ - sc->curlet = make_let(sc, sc->curlet); - if (is_pair(car(code))) - { - s7_pointer slot; - for (s7_pointer x = car(code); is_not_null(x); x = cdr(x)) - { - slot = add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); - slot_set_pending_value(slot, sc->undefined); - slot_set_expression(slot, cdar(x)); - set_checked_slot(slot); - } - for (slot = let_slots(sc->curlet); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); - if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC1, slot, code); - sc->code = car(slot_expression(slot)); - return(true); - } - op_letrec2(sc); - } - sc->code = T_Pair(cdr(code)); - return(false); -} - -static bool op_letrec1(s7_scheme *sc) -{ - s7_pointer slot; - slot_set_pending_value(sc->args, sc->value); - for (slot = next_slot(sc->args); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); - if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC1, slot, sc->code); - sc->code = car(slot_expression(slot)); - return(true); - } - op_letrec2(sc); - sc->code = T_Pair(cdr(sc->code)); - return(false); -} - - -static bool op_letrec_star_unchecked(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - /* get all local vars and set to # - * eval each member of values list and assign immediately, as in let* - * eval body - */ - sc->curlet = make_let(sc, sc->curlet); - if (is_pair(car(code))) - { - s7_pointer slot; - for (s7_pointer x = car(code); is_not_null(x); x = cdr(x)) - { - slot = add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); - slot_set_expression(slot, cdar(x)); - } - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - - for (slot = let_slots(sc->curlet); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC_STAR1, slot, code); - sc->code = car(slot_expression(slot)); - return(true); - }} - sc->code = T_Pair(cdr(code)); - return(false); -} - -static bool op_letrec_star1(s7_scheme *sc) -{ - s7_pointer slot = sc->args; - slot_set_value(slot, sc->value); - - for (slot = next_slot(slot); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC_STAR1, slot, sc->code); - sc->code = car(slot_expression(slot)); - return(true); - } - letrec_setup_closures(sc); - sc->code = T_Pair(cdr(sc->code)); - return(false); -} - - -/* -------------------------------- let-temporarily -------------------------------- */ -static void check_let_temporarily(s7_scheme *sc) -{ - s7_pointer x, form = sc->code, code = cdr(sc->code); - bool all_fx, all_s7; - - if ((!is_pair(code)) || /* (let-temporarily . 1) */ - (!is_list(car(code)))) /* (let-temporarily 1 ...) */ - syntax_error_nr(sc, "let-temporarily: variable list is messed up: ~A", 47, form); - /* cdr(code) = body can be nil */ - - all_fx = is_pair(car(code)); - all_s7 = all_fx; - - for (x = car(code); is_not_null(x); x = cdr(x)) - { - s7_pointer carx, caarx; - if (!is_pair(x)) /* (let-temporarily ((a 1) . 2) ...) */ - syntax_error_nr(sc, "let-temporarily: improper list of variables? ~A", 47, form); - - carx = car(x); - if (!is_pair(carx)) /* (let-temporarily (1 2) #t) */ - syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a pair (name value))", 67, carx); - - caarx = car(carx); - if (is_symbol(caarx)) - { - if (is_constant_symbol(sc, caarx)) /* (let-temporarily ((pi 3)) ...) */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, x)); - } - else - if (!is_pair(caarx)) /* (let-temporarily ((1 2)) ...) */ - syntax_error_nr(sc, "let-temporarily: bad variable ~S (the name should be a symbol or a pair)", 73, carx); - - if (!is_pair(cdr(carx))) /* (let-temporarily ((x . 1))...) */ - syntax_error_nr(sc, "let-temporarily: variable declaration value is messed up: ~S", 60, carx); - - if (is_not_null(cddr(carx))) /* (let-temporarily ((x 1 2 3)) ...) */ - syntax_error_nr(sc, "let-temporarily: variable declaration has more than one value?: ~A", 66, carx); - - if ((all_fx) && - ((!is_symbol(caarx)) || (!is_fxable(sc, cadr(carx))))) /* if all_fx, each var is (symbol fxable-expr) */ - all_fx = false; - if ((all_s7) && - ((!is_pair(caarx)) || (car(caarx) != sc->s7_starlet_symbol) || - (!is_quoted_symbol(cadr(caarx))) || (is_keyword(cadr(cadr(caarx)))) || - (!is_fxable(sc, cadr(carx))))) - all_s7 = false; - } - if (!s7_is_proper_list(sc, cdr(code))) - syntax_error_nr(sc, "stray dot in let-temporarily body: ~S", 37, cdr(code)); - - if ((all_fx) || (all_s7)) - { - pair_set_syntax_op(form, (all_fx) ? ((is_null(cdar(code))) ? OP_LET_TEMP_A : OP_LET_TEMP_NA) : OP_LET_TEMP_S7); - for (x = car(code); is_pair(x); x = cdr(x)) - fx_annotate_arg(sc, cdar(x), sc->curlet); - - if ((optimize_op(form) == OP_LET_TEMP_A) && (is_pair(cdr(code))) && (is_null(cddr(code))) && (is_fxable(sc, cadr(code)))) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_LET_TEMP_A_A); - } - else - if (all_s7) /* not OP_LET_TEMP_NA */ - { - s7_pointer var = caar(code); - if ((is_fxable(sc, cadr(var))) && /* code: ((((*s7* 'openlets) fxable-expr)) ...) */ - (is_null(cdar(code)))) - { - if ((is_quoted_symbol(cadar(var))) && - (s7_starlet_symbol(cadr(cadar(var))) == SL_OPENLETS)) /* (cadr(cadar(var)) == make_symbol_with_strlen(sc, "openlets"))) */ - { - pair_set_syntax_op(form, OP_LET_TEMP_S7_DIRECT); - set_opt1_pair(form, cdr(var)); - }}} - - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) {fx_curlet_tree(sc, code); fx_curlet_tree_in(sc, code);} - } - else - { - pair_set_syntax_op(form, OP_LET_TEMP_UNCHECKED); - if ((is_pair(car(code))) && (is_null(cdar(code))) && (is_pair(caar(code)))) - { - s7_pointer var = caar(code); - s7_pointer val = cadr(var); - var = car(var); - if ((is_pair(var)) && (car(var) == sc->setter_symbol) && (is_pair(cdr(var))) && (is_pair(cddr(var))) && (val == sc->F)) - { - /* (let-temporarily (((setter (slot-symbol cp) (slot-env cp)) #f)) ...) reactive.scm */ - optimize_expression(sc, cadr(var), 0, sc->curlet, false); - optimize_expression(sc, caddr(var), 0, sc->curlet, false); - if ((is_fxable(sc, cadr(var))) && (is_fxable(sc, caddr(var)))) - { - fx_annotate_args(sc, cdr(var), sc->curlet); - pair_set_syntax_op(form, OP_LET_TEMP_SETTER); - }}}} -} - -static void op_let_temp_unchecked(s7_scheme *sc) -{ - sc->code = cdr(sc->code); /* step past let-temporarily */ - sc->args = list_4(sc, car(sc->code), sc->nil, sc->nil, sc->nil); - push_stack_direct(sc, OP_GC_PROTECT); - /* sc->args: varlist, settees, old_values, new_values */ -} - -static void op_let_temp_init1_1(s7_scheme *sc) -{ - if ((is_symbol(sc->value)) && (is_symbol_from_symbol(sc->value))) /* (let-temporarily (((symbol ...))) ..) */ - { - clear_symbol_from_symbol(sc->value); - if (is_immutable(sc->value)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, sc->value)); - sc->value = s7_symbol_value(sc, sc->value); - } - set_caddr(sc->args, cons(sc, sc->value, caddr(sc->args))); -} - -static bool op_let_temp_init1(s7_scheme *sc) -{ - while (is_pair(car(sc->args))) - { - /* eval car, add result to old-vals list, if any vars undefined, error */ - s7_pointer binding = caar(sc->args); - s7_pointer settee = car(binding); - s7_pointer new_value = cadr(binding); - cadr(sc->args) = cons(sc, settee, cadr(sc->args)); - binding = cdddr(sc->args); - set_car(binding, cons_unchecked(sc, new_value, car(binding))); - car(sc->args) = cdar(sc->args); - if (is_symbol(settee)) /* get initial values */ - set_caddr(sc->args, cons_unchecked(sc, lookup_checked(sc, settee), caddr(sc->args))); - else - { - if (is_pair(settee)) - { - push_stack_direct(sc, OP_LET_TEMP_INIT1); - sc->code = settee; - return(true); - } - set_caddr(sc->args, cons_unchecked(sc, new_value, caddr(sc->args))); - }} - car(sc->args) = cadr(sc->args); - return(false); -} - -typedef enum {goto_start, goto_begin, fall_through, goto_do_end_clauses, goto_safe_do_end_clauses, - goto_eval, goto_apply_lambda, goto_do_end, goto_top_no_pop, goto_apply, - goto_eval_args, goto_eval_args_top, goto_do_unchecked, goto_pop_read_list, - goto_read_tok, goto_feed_to, goto_set_unchecked, goto_unopt} goto_t; - -static goto_t op_let_temp_init2(s7_scheme *sc) -{ - /* now eval set car new-val, cadr=settees, cadddr=new_values */ - while (is_pair(car(sc->args))) - { - s7_pointer settee = caar(sc->args), slot, p = cdddr(sc->args); - s7_pointer new_value = caar(p); - set_car(p, cdar(p)); - car(sc->args) = cdar(sc->args); - if ((!is_symbol(settee)) || (is_pair(new_value))) - { - if (is_symbol(settee)) - { - push_stack_direct(sc, OP_LET_TEMP_INIT2); /* (let-temporarily (((*s7* 'print-length) 32)) ...) */ - push_stack_no_args(sc, OP_SET_FROM_LET_TEMP, settee); - sc->code = new_value; - return(goto_eval); - } - sc->code = set_plist_3(sc, sc->set_symbol, settee, new_value); - push_stack_direct(sc, OP_LET_TEMP_INIT2); - return(goto_set_unchecked); - } - slot = lookup_slot_from(settee, sc->curlet); - if (!is_slot(slot)) unbound_variable_error_nr(sc, settee); - if (is_immutable_slot(slot)) immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - if (is_symbol(new_value)) new_value = lookup_checked(sc, new_value); - slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, new_value) : new_value); - } - car(sc->args) = cadr(sc->args); - /* pop_stack(sc); */ /* this clobbers sc->args! 7-May-22 */ - unstack(sc); /* pop_stack_no_args(sc) in effect */ - sc->code = cdr(sc->stack_end[0]); - if (is_pair(sc->code)) - { - push_stack_direct(sc, OP_LET_TEMP_DONE); - return(goto_begin); - } - sc->value = sc->nil; /* so (let-temporarily ( () like begin I guess */ - return(fall_through); -} - -static bool op_let_temp_done1(s7_scheme *sc) -{ - while (is_pair(car(sc->args))) - { - s7_pointer settee = caar(sc->args), p = cddr(sc->args); - sc->value = caar(p); - set_car(p, cdar(p)); - car(sc->args) = cdar(sc->args); - - if ((is_pair(settee)) && (car(settee) == sc->s7_starlet_symbol) && /* (let-temporarily (((*s7* (symbol "print-length")) 43))...) */ - ((is_symbol_and_keyword(cadr(settee))) || - ((is_pair(cadr(settee))) && (caadr(settee) == sc->quote_symbol) && (is_symbol(cadadr(settee)))))) - { - s7_pointer sym = cadr(settee); - if (is_pair(sym)) sym = cadr(sym); - s7_starlet_set_1(sc, T_Sym(sym), sc->value); - } - else - { - s7_pointer slot; - if (!is_symbol(settee)) - { - push_stack_direct(sc, OP_LET_TEMP_DONE1); /* save args and (pending) body value==sc->code */ - if ((is_pair(sc->value)) || (is_symbol(sc->value))) - sc->code = set_plist_3(sc, sc->set_symbol, settee, set_plist_2(sc, sc->quote_symbol, sc->value)); - else sc->code = set_plist_3(sc, sc->set_symbol, settee, sc->value); - return(false); /* goto set_unchecked */ - } - slot = lookup_slot_from(settee, sc->curlet); - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - if (slot_has_setter(slot)) /* maybe setter changed in let-temp body? else setter has already checked the init value */ - slot_set_value(slot, call_setter(sc, slot, sc->value)); - else slot_set_value(slot, sc->value); - }} - pop_stack(sc); /* not unstack */ - sc->value = sc->code; - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(true); /* goto start */ -} - -static bool *s7_starlet_immutable_field = NULL; - -static bool op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7* 'field) fx-able-value) */ -{ - s7_pointer p, code = cdr(sc->code); /* don't use sc->code here -- it can be changed */ - s7_pointer *end = sc->stack_end; - for (p = car(code); is_pair(p); p = cdr(p)) - { - s7_pointer old_value, field = cadadr(caar(p)); /* p: (((*s7* 'expansions?) #f)) -- no keywords here (see check_let_temporarily) */ - if (s7_starlet_immutable_field[s7_starlet_symbol(field)]) - error_nr(sc, sc->immutable_error_symbol, - set_elist_2(sc, wrap_string(sc, "let-temporarily: can't set! (*s7* '~S)", 38), field)); - old_value = s7_starlet(sc, s7_starlet_symbol(field)); - push_stack(sc, OP_LET_TEMP_S7_UNWIND, old_value, field); - } - for (p = car(code); is_pair(p); p = cdr(p), end += 4) - s7_starlet_set_1(sc, T_Sym(end[0]), fx_call(sc, cdar(p))); - sc->code = cdr(code); - return(is_pair(sc->code)); /* sc->code can be null if no body */ -} - -static void op_let_temp_s7_unwind(s7_scheme *sc) -{ - s7_starlet_set_1(sc, T_Sym(sc->code), sc->args); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static bool op_let_temp_s7_direct(s7_scheme *sc) -{ - s7_pointer new_val; - push_stack_no_code(sc, OP_LET_TEMP_S7_DIRECT_UNWIND, (sc->has_openlets) ? sc->T : sc->F); - new_val = fx_call(sc, opt1_pair(sc->code)); - sc->has_openlets = (new_val != sc->F); - sc->code = cddr(sc->code); /* cddr is body of let-temp */ - return(is_pair(sc->code)); -} - -static void op_let_temp_s7_direct_unwind(s7_scheme *sc) -{ - sc->has_openlets = (sc->args != sc->F); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let) -{ - /* called in call/cc, call-with-exit and, catch (unwind to catch) */ - check_stack_size(sc); - push_stack_direct(sc, OP_GC_PROTECT); - sc->args = T_Ext(args); - set_curlet(sc, let); - op_let_temp_done1(sc); /* an experiment 6-Nov-21, was eval(sc, OP_LET_TEMP_DONE) */ -} - -static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value) -{ - if (slot_has_setter(slot)) /* setter has to be called because it might affect other vars (*clm-srate* -> mus-srate etc), but it should not change sc->value */ - { - s7_pointer old_value = sc->value; - slot_set_value(slot, call_setter(sc, slot, new_value)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); */ - sc->value = old_value; - } - else slot_set_value(slot, new_value); -} - -static void op_let_temp_unwind(s7_scheme *sc) -{ - let_temp_unwind(sc, sc->code, sc->args); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - -static bool op_let_temp_na(s7_scheme *sc) /* all entries are of the form (symbol fx-able-value) */ -{ - s7_pointer p, slot; - s7_pointer *end = sc->stack_end; - sc->code = cdr(sc->code); - - for (p = car(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - s7_pointer settee = car(var); - slot = lookup_slot_from(settee, sc->curlet); - if (!is_slot(slot)) - unbound_variable_error_nr(sc, settee); - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); - } - for (p = car(sc->code); is_pair(p); p = cdr(p), end += 4) - { - s7_pointer var = car(p); - s7_pointer new_val = fx_call(sc, cdr(var)); - slot = end[0]; - if (slot_has_setter(slot)) - slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ - else slot_set_value(slot, new_val); - } - sc->code = cdr(sc->code); - return(is_pair(sc->code)); /* sc->code can be null if no body */ -} - -static bool op_let_temp_a(s7_scheme *sc) /* one entry */ -{ - s7_pointer var, settee, new_val, slot; - sc->code = cdr(sc->code); - var = caar(sc->code); - settee = car(var); - slot = lookup_slot_from(settee, sc->curlet); - if (!is_slot(slot)) - unbound_variable_error_nr(sc, settee); - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); - new_val = fx_call(sc, cdr(var)); - if (slot_has_setter(slot)) - slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ - else slot_set_value(slot, new_val); - sc->code = cdr(sc->code); - return(is_pair(sc->code)); /* sc->code can be null if no body */ -} - -static s7_pointer fx_let_temp_a_a(s7_scheme *sc, s7_pointer code) /* one entry, body is fx'd */ -{ - s7_pointer result; - op_let_temp_a(sc); - result = fx_call(sc, sc->code); - pop_stack(sc); - let_temp_unwind(sc, sc->code, sc->args); - return(result); -} - -static bool op_let_temp_setter(s7_scheme *sc) -{ - s7_pointer var, slot, sym, e = sc->curlet; - sc->code = cdr(sc->code); - var = caaar(sc->code); - sym = fx_call(sc, cdr(var)); - set_curlet(sc, fx_call(sc, cddr(var))); - slot = lookup_slot_from(sym, sc->curlet); - set_curlet(sc, e); - push_stack(sc, OP_LET_TEMP_SETTER_UNWIND, slot_setter(slot), slot); - slot_set_setter(slot, sc->F); - sc->code = cdr(sc->code); - return(is_pair(sc->code)); /* sc->code can be null if no body */ -} - -static void op_let_temp_setter_unwind(s7_scheme *sc) -{ - slot_set_setter(sc->code, sc->args); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); -} - - -/* -------------------------------- quote -------------------------------- */ -static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code) -{ - if (!is_pair(cdr(code))) /* (quote . -1) */ - { - if (is_null(cdr(code))) - syntax_error_nr(sc, "quote: not enough arguments: ~A", 31, code); - syntax_error_nr(sc, "quote: stray dot?: ~A", 21, code); - } - if (is_not_null(cddr(code))) /* (quote . (1 2)) or (quote 1 1) */ - syntax_error_nr(sc, "quote: too many arguments ~A", 28, code); - pair_set_syntax_op(code, OP_QUOTE_UNCHECKED); - return(cadr(code)); -} - - -/* -------------------------------- and -------------------------------- */ -static bool check_and(s7_scheme *sc, s7_pointer expr) -{ - /* this, check_or and check_if might not be called -- optimize_syntax can short-circuit it to return fx* choices */ - s7_pointer p, code = cdr(expr); - int32_t any_nils = 0, len; - - if (is_null(code)) - { - sc->value = sc->T; - return(true); - } - for (len = 0, p = code; is_pair(p); p = cdr(p), len++) - { - s7_function callee = (has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet, let_symbol_is_safe); /* fx_proc can be nil! */ - if (!callee) any_nils++; - set_fx(p, callee); - } - if (is_not_null(p)) /* (and . 1) (and #t . 1) */ - syntax_error_nr(sc, "and: stray dot?: ~A", 19, expr); - - if ((fx_proc(code)) && - (is_proper_list_1(sc, cdr(code)))) - { - if ((fx_proc(code) == fx_is_pair_s) || (fx_proc(code) == fx_is_pair_t)) - { - pair_set_syntax_op(expr, OP_AND_PAIR_P); - set_opt3_sym(expr, cadar(code)); - set_opt2_con(expr, cadr(code)); - } - else pair_set_syntax_op(expr, (any_nils > 0) ? OP_AND_AP : OP_AND_2A); - } - else - { - pair_set_syntax_op(expr, (any_nils > 0) ? OP_AND_P : OP_AND_N); - if ((any_nils == 1) && (len > 2)) - { - if (!has_fx(code)) - pair_set_syntax_op(expr, OP_AND_SAFE_P1); - else - if (!has_fx(cdr(code))) - pair_set_syntax_op(expr, OP_AND_SAFE_P2); - else - if ((!has_fx(cddr(code))) && (len == 3)) - pair_set_syntax_op(expr, OP_AND_SAFE_P3); - }} - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_current_code(sc, sc->code); - return(false); -} - -static bool op_and_pair_p(s7_scheme *sc) -{ - if (!is_pair(lookup(sc, opt3_sym(sc->code)))) /* cadadr(sc->code) */ - { - sc->value = sc->F; - return(true); - } - sc->code = opt2_con(sc->code); /* caddr(sc->code); */ - return(false); -} - -static bool op_and_ap(s7_scheme *sc) -{ - /* we know fx_proc is set on sc->code, and there are only two branches */ - if (is_false(sc, fx_call(sc, cdr(sc->code)))) - { - sc->value = sc->F; - return(true); - } - sc->code = caddr(sc->code); - return(false); -} - -static void op_and_safe_p1(s7_scheme *sc) /* sc->code: (and (func...) (fx...)...) */ -{ - sc->code = cdr(sc->code); /* new value will be pushed below */ - push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST); - sc->code = car(sc->code); -} - -static bool op_and_safe_p2(s7_scheme *sc) -{ - sc->value = fx_call(sc, cdr(sc->code)); - if (is_false(sc, sc->value)) return(true); - sc->code = cddr(sc->code); - push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST); - sc->code = car(sc->code); - return(false); -} - -static bool op_and_safe_p3(s7_scheme *sc) -{ - sc->value = fx_call(sc, cdr(sc->code)); - if (is_false(sc, sc->value)) return(true); - sc->code = cddr(sc->code); - sc->value = fx_call(sc, sc->code); - if (is_false(sc, sc->value)) return(true); - sc->code = cadr(sc->code); - return(false); -} - - -/* -------------------------------- or -------------------------------- */ -static bool check_or(s7_scheme *sc, s7_pointer expr) -{ - s7_pointer p, code = cdr(expr); - bool any_nils = false; - if (is_null(code)) - { - sc->value = sc->F; - return(true); - } - for (p = code; is_pair(p); p = cdr(p)) - { - s7_function callee = (has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet, let_symbol_is_safe); - if (!callee) any_nils = true; - set_fx(p, callee); - } - if (is_not_null(p)) - syntax_error_nr(sc, "or: stray dot?: ~A", 18, expr); - - if ((fx_proc(code)) && - (is_proper_list_1(sc, cdr(code)))) /* list_1 of cdr so there are 2 exprs */ - pair_set_syntax_op(expr, (any_nils) ? OP_OR_AP : OP_OR_2A); - else pair_set_syntax_op(expr, (any_nils) ? OP_OR_P : OP_OR_N); - - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_current_code(sc, sc->code); - return(false); -} - -static bool op_or_ap(s7_scheme *sc) -{ - /* we know fx_proc is set on sc->code, and there are only two branches */ - sc->value = fx_call(sc, cdr(sc->code)); - if (is_true(sc, sc->value)) - return(true); - sc->code = caddr(sc->code); - return(false); -} - - -/* -------------------------------- if -------------------------------- */ -static void fb_if_annotate(s7_scheme *sc, s7_pointer code, s7_pointer form) -{ - if (optimize_op(form) == OP_IF_A_P) - { - if (is_fxable(sc, cadr(code))) - { - pair_set_syntax_op(form, OP_IF_A_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_opt1_pair(form, cdr(code)); - fb_annotate(sc, form, code, OP_IF_B_A); - } - else fb_annotate(sc, form, code, OP_IF_B_P); - } - if (optimize_op(form) == OP_IF_A_R) - fb_annotate(sc, form, code, OP_IF_B_R); - if (optimize_op(form) == OP_IF_A_N_N) - fb_annotate(sc, form, cdar(code), OP_IF_B_N_N); - if (optimize_op(form) == OP_IF_A_P_P) - { - if (is_fxable(sc, cadr(code))) - { - set_opt1_pair(form, cdr(code)); - if (is_fxable(sc, caddr(code))) - { - pair_set_syntax_op(form, OP_IF_A_A_A); /* b_a_a never happens? */ - set_opt2_pair(form, cddr(code)); - } - else - { - pair_set_syntax_op(form, OP_IF_A_A_P); - fb_annotate(sc, form, code, OP_IF_B_A_P); - } - fx_annotate_args(sc, cdr(code), sc->curlet); - } - else - if (is_fxable(sc, caddr(code))) - { - pair_set_syntax_op(form, OP_IF_A_P_A); - fx_annotate_args(sc, cdr(code), sc->curlet); - set_opt2_pair(form, cddr(code)); - fb_annotate(sc, form, code, OP_IF_B_P_A); - } - else fb_annotate(sc, form, code, OP_IF_B_P_P); - } -} - -#define choose_if_optc(Opc, One, Reversed, Not) \ - ((One) ? ((Reversed) ? OP_ ## Opc ## _R : \ - ((Not) ? OP_ ## Opc ## _N : OP_ ## Opc ## _P)) : \ - ((Not) ? OP_ ## Opc ## _N_N : OP_ ## Opc ## _P_P)) - -static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool reversed) /* cdr(form) == sc->code */ -{ - s7_pointer code = cdr(form); - s7_pointer test = car(code); - bool not_case = false; - - if ((!reversed) && - (is_pair(test)) && - (car(test) == sc->not_symbol)) - { - if (!is_proper_list_1(sc, cdr(test))) return; /* (not) or (not a b) */ - not_case = true; - test = cadr(test); - } - - set_opt1_any(form, cadr(code)); - if (!one_branch) set_opt2_any(form, caddr(code)); - - if (is_pair(test)) - { - if (is_optimized(test)) - { - if (is_h_safe_c_nc(test)) /* replace these with fx_and* */ - { - pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case)); - if (not_case) - { - set_fx(cdar(code), fx_choose(sc, cdar(code), sc->curlet, let_symbol_is_safe)); - if (!reversed) set_opt3_pair(form, cdadr(form)); - } - else set_fx(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - fb_if_annotate(sc, code, form); - return; - } - if ((is_h_safe_c_s(test)) && - (is_symbol(car(test)))) - { - uint8_t typ = symbol_type(car(test)); - if (typ > 0) - { - pair_set_syntax_op(form, choose_if_optc(IF_IS_TYPE_S, one_branch, reversed, not_case)); - set_opt3_byte(code, typ); - if (optimize_op(form) == OP_IF_IS_TYPE_S_P_P) - { - if (is_fxable(sc, caddr(code))) - { - set_opt2_pair(form, cddr(code)); - if (is_fxable(sc, cadr(code))) - { - set_opt1_pair(form, cdr(code)); - fx_annotate_args(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_A); - } - else - { - set_opt1_any(form, cadr(code)); - pair_set_syntax_op(form, OP_IF_IS_TYPE_S_P_A); - fx_annotate_arg(sc, cddr(code), sc->curlet); - } - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - } - else - if (is_fxable(sc, cadr(code))) - { - set_opt2_any(form, caddr(code)); - set_opt1_pair(form, cdr(code)); - fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_P); - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - }}} - else - { - pair_set_syntax_op(form, choose_if_optc(IF_opSq, one_branch, reversed, not_case)); - if (not_case) set_opt1_pair(code, cadar(code)); /* code is cdr(if...): ((not (f sym)) ...) */ - } - clear_has_fx(code); - set_opt2_sym(code, cadr(test)); - return; - } - if (is_fxable(sc, test)) - { - if ((optimize_op(test) == OP_OR_2A) || (optimize_op(test) == OP_AND_2A)) - { - if (optimize_op(test) == OP_OR_2A) - pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case)); - else pair_set_syntax_op(form, choose_if_optc(IF_AND2, one_branch, reversed, not_case)); - clear_has_fx(code); - set_opt2_pair(code, cdr(test)); - set_opt3_pair(code, cddr(test)); - return; - } - if (optimize_op(test) == OP_AND_3A) - { - pair_set_syntax_op(form, choose_if_optc(IF_AND3, one_branch, reversed, not_case)); - clear_has_fx(code); - set_opt2_pair(code, cdr(test)); - set_opt3_pair(code, cddr(test)); - set_opt1_pair(code, cdddr(test)); - return; - } - - pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case)); - if (not_case) - { - set_fx_direct(cdar(code), fx_choose(sc, cdar(code), sc->curlet, let_symbol_is_safe)); - if (!reversed) set_opt3_pair(form, cdadr(form)); - } - else set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - fb_if_annotate(sc, code, form); - } - else - { - pair_set_syntax_op(form, choose_if_optc(IF_P, one_branch, reversed, not_case)); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_any(code, (not_case) ? cadar(code) : car(code)); - } - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) - fx_curlet_tree(sc, code); - } - else - { - pair_set_syntax_op(form, choose_if_optc(IF_P, one_branch, reversed, not_case)); - clear_has_fx(code); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_any(code, (not_case) ? cadar(code) : car(code)); - if (is_symbol_and_syntactic(car(test))) - { - pair_set_syntax_op(test, symbol_syntax_op_checked(test)); - if ((symbol_syntax_op(car(test)) == OP_AND) || - (symbol_syntax_op(car(test)) == OP_OR)) - { - opcode_t new_op; - if (symbol_syntax_op(car(test)) == OP_AND) - check_and(sc, test); - else check_or(sc, test); - new_op = symbol_syntax_op_checked(test); - if ((new_op == OP_AND_P) || (new_op == OP_AND_AP) || (new_op == OP_AND_PAIR_P) || - (new_op == OP_AND_N) || (new_op == OP_AND_SAFE_P1) || (new_op == OP_AND_SAFE_P2) || (new_op == OP_AND_SAFE_P3)) - { - pair_set_syntax_op(form, choose_if_optc(IF_ANDP, one_branch, reversed, not_case)); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_pair(code, (not_case) ? cdadar(code) : cdar(code)); - } - else - if ((new_op == OP_OR_P) || (new_op == OP_OR_AP)) - { - pair_set_syntax_op(form, choose_if_optc(IF_ORP, one_branch, reversed, not_case)); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_pair(code, (not_case) ? cdadar(code) : cdar(code)); - }}}}} - else /* test is symbol or constant, but constant here is nutty */ - if (is_safe_symbol(test)) - { - pair_set_syntax_op(form, choose_if_optc(IF_S, one_branch, reversed, not_case)); - if (not_case) set_opt1_sym(code, cadar(code)); /* code is cdr(if...): ((not sym) ...) */ - if (optimize_op(form) == OP_IF_S_P_P) - { - if (is_fxable(sc, caddr(code))) - { - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_opt2_pair(form, cddr(code)); /* opt1_any set above to cadr(code) */ - if (is_fxable(sc, cadr(code))) - { - pair_set_syntax_op(form, OP_IF_S_A_A); - fx_annotate_args(sc, cdr(code), sc->curlet); - set_opt1_pair(form, cdr(code)); - } - else - { - pair_set_syntax_op(form, OP_IF_S_P_A); - fx_annotate_arg(sc, cddr(code), sc->curlet); - } - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - } - else - if (is_fxable(sc, cadr(code))) - { - pair_set_syntax_op(form, OP_IF_S_A_P); - fx_annotate_arg(sc, cdr(code), sc->curlet); - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_opt1_pair(form, cdr(code)); - set_opt2_any(form, caddr(code)); - }}} -} - -/* (cond <> (else <>)) only happens in old-fashioned code, so set_if_opts covers if/when/unless but not cond */ - -static s7_pointer check_if(s7_scheme *sc, s7_pointer form) -{ - s7_pointer cdr_code, code = cdr(form); - if (!is_pair(code)) /* (if) or (if . 1) */ - syntax_error_nr(sc, "(if): if needs at least 2 expressions: ~A", 41, form); - - cdr_code = cdr(code); - if (!is_pair(cdr_code)) /* (if 1) */ - { - if (is_null(cdr(code))) - syntax_error_nr(sc, "~S: if needs another clause", 27, form); - syntax_error_nr(sc, "~S: stray dot?", 14, form); /* (if 1 . 2) */ - } - - if (is_pair(cdr(cdr_code))) - { - if (is_not_null(cddr(cdr_code))) /* (if 1 2 3 4) */ - syntax_error_nr(sc, "too many clauses for if: ~A", 27, form); - } - else - if (is_not_null(cdr(cdr_code))) /* (if 1 2 . 3) */ - syntax_error_nr(sc, "if: ~A has improper list?", 25, form); - - pair_set_syntax_op(form, OP_IF_UNCHECKED); - set_if_opts(sc, form, is_null(cdr(cdr_code)), false); - set_current_code(sc, sc->code); - return(code); -} - -static void op_if(s7_scheme *sc) -{ - sc->code = check_if(sc, sc->code); - push_stack_no_args(sc, OP_IF1, cdr(sc->code)); - sc->code = car(sc->code); -} - -static void op_if_unchecked(s7_scheme *sc) -{ - push_stack_no_args(sc, OP_IF1, cddr(sc->code)); - sc->code = cadr(sc->code); -} - -static bool op_if1(s7_scheme *sc) -{ - sc->code = (is_true(sc, sc->value)) ? car(sc->code) : unchecked_car(cdr(sc->code)); - /* even pre-optimization, (if #f #f) ==> # because unique_car(sc->nil) = sc->unspecified */ - if (is_pair(sc->code)) - return(true); - sc->value = (is_symbol(sc->code)) ? lookup_checked(sc, sc->code) : sc->code; - return(false); -} - - -/* -------------------------------- when -------------------------------- */ -static void check_when(s7_scheme *sc) -{ - s7_pointer form = sc->code, code = cdr(sc->code); - - if (!is_pair(code)) /* (when) or (when . 1) */ - syntax_error_nr(sc, "when has no expression or body: ~A", 35, form); - if (!is_pair(cdr(code))) /* (when 1) or (when 1 . 1) */ - syntax_error_nr(sc, "when has no body?: ~A", 22, form); - if (!s7_is_proper_list(sc, cddr(code))) - syntax_error_nr(sc, "when: stray dot? ~A", 19, form); - - pair_set_syntax_op(form, OP_WHEN_P); - if (is_null(cddr(code))) - set_if_opts(sc, form, true, false); /* use if where possible */ - else - { - s7_pointer test = car(code); - if (is_safe_symbol(test)) - { - pair_set_syntax_op(form, OP_WHEN_S); - set_opt2_con(form, cadr(code)); - set_opt3_pair(form, cddr(code)); - } - else - /* fxable body doesn't happen very often -- a dozen or so hits in the standard tests */ - if (is_fxable(sc, test)) - { - pair_set_syntax_op(form, OP_WHEN_A); - if (is_pair(car(code))) set_opt2_pair(form, cdar(code)); - set_opt3_pair(form, cdr(code)); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); /* "A" in when_a */ - - if (fx_proc(code) == fx_and_2a) - pair_set_syntax_op(form, OP_WHEN_AND_2A); - else - if (fx_proc(code) == fx_and_3a) - pair_set_syntax_op(form, OP_WHEN_AND_3A); - } - else - if ((is_pair(test)) && (car(test) == sc->and_symbol)) - { - opcode_t new_op; - pair_set_syntax_op(test, symbol_syntax_op_checked(test)); - check_and(sc, test); - new_op = symbol_syntax_op_checked(test); - if (new_op == OP_AND_AP) - pair_set_syntax_op(form, OP_WHEN_AND_AP); - }} - push_stack_no_args(sc, OP_WHEN_PP, cdr(code)); - set_current_code(sc, sc->code); - sc->code = car(code); -} - -static bool op_when_s(s7_scheme *sc) -{ - if (is_true(sc, lookup(sc, cadr(sc->code)))) - { - push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */ - sc->code = opt2_con(sc->code); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_when_a(s7_scheme *sc) -{ - if (is_true(sc, fx_call(sc, cdr(sc->code)))) - { - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */ - sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_when_and_2a(s7_scheme *sc) -{ - if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) && (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code)))))) - { - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */ - sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_when_and_3a(s7_scheme *sc) -{ - if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) && - (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code))))) && - (is_true(sc, fx_call(sc, cddr(opt2_pair(sc->code)))))) - { - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */ - sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static void op_when_p(s7_scheme *sc) -{ - push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code)); - sc->code = cadr(sc->code); -} - -static bool op_when_and_ap(s7_scheme *sc) -{ - s7_pointer andp = cdadr(sc->code); - if (is_true(sc, fx_call(sc, andp))) - { - push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code)); - sc->code = cadr(andp); - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_when_pp(s7_scheme *sc) -{ - if (is_true(sc, sc->value)) - { - if_pair_set_up_begin_unchecked(sc); - return(false); - } - sc->value = sc->unspecified; - return(true); -} - - -/* -------------------------------- unless -------------------------------- */ -static void check_unless(s7_scheme *sc) -{ - s7_pointer form = sc->code, code = cdr(sc->code); - - if (!is_pair(code)) /* (unless) or (unless . 1) */ - syntax_error_nr(sc, "unless has no expression or body: ~A", 37, form); - if (!is_pair(cdr(code))) /* (unless 1) or (unless 1 . 1) */ - syntax_error_nr(sc, "unless has no body?: ~A", 24, form); - if (!s7_is_proper_list(sc, cddr(code))) - syntax_error_nr(sc, "unless: stray dot? ~A", 21, form); - - pair_set_syntax_op(form, OP_UNLESS_P); - if (is_null(cddr(code))) - set_if_opts(sc, form, true, true); - else - if (is_safe_symbol(car(code))) - { - pair_set_syntax_op(form, OP_UNLESS_S); - set_opt2_con(form, cadr(code)); - set_opt3_pair(form, cddr(code)); - } - else - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, OP_UNLESS_A); - set_opt2_con(form, cadr(code)); - set_opt3_pair(form, cddr(code)); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - } - push_stack_no_args(sc, OP_UNLESS_PP, cdr(code)); - set_current_code(sc, sc->code); - sc->code = car(code); -} - -static bool op_unless_s(s7_scheme *sc) -{ - if (is_false(sc, lookup(sc, cadr(sc->code)))) - { - push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */ - sc->code = opt2_con(sc->code); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_unless_a(s7_scheme *sc) -{ - if (is_false(sc, fx_call(sc, cdr(sc->code)))) - { - push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */ - sc->code = opt2_con(sc->code); /* caddr(sc->code) */ - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static void op_unless_p(s7_scheme *sc) -{ - push_stack_no_args(sc, OP_UNLESS_PP, cddr(sc->code)); - sc->code = cadr(sc->code); -} - -static bool op_unless_pp(s7_scheme *sc) -{ - if (is_false(sc, sc->value)) - { - if_pair_set_up_begin_unchecked(sc); - return(false); - } - sc->value = sc->unspecified; - return(true); -} - - -/* -------------------------------- begin -------------------------------- */ -static bool op_begin(s7_scheme *sc, s7_pointer code) -{ - s7_pointer form = cdr(code); - if (!s7_is_proper_list(sc, form)) /* proper list includes () */ - syntax_error_nr(sc, "unexpected dot? ~A", 18, code); - if (is_null(form)) /* (begin) -> () */ - { - sc->value = sc->nil; - return(true); - } - pair_set_syntax_op(sc->code, ((is_pair(cdr(form))) && (is_null(cddr(form)))) ? OP_BEGIN_2_UNCHECKED : OP_BEGIN_UNCHECKED); /* begin_1 doesn't happen much */ - return(false); -} - - -/* -------------------------------- define -------------------------------- */ -static s7_pointer print_truncate(s7_scheme *sc, s7_pointer code) -{ - if (tree_len(sc, code) > sc->print_length) - return(object_to_truncated_string(sc, code, sc->print_length * 10)); - return(code); -} - -static void check_define(s7_scheme *sc) -{ - s7_pointer func, caller, code = cdr(sc->code); - bool starred = (sc->cur_op == OP_DEFINE_STAR); - if (starred) - { - caller = sc->define_star_symbol; - sc->cur_op = OP_DEFINE_STAR_UNCHECKED; - } - else caller = (sc->cur_op == OP_DEFINE) ? sc->define_symbol : sc->define_constant_symbol; - - if (!is_pair(code)) - syntax_error_with_caller_nr(sc, "~A: nothing to define? ~A", 25, caller, sc->code); /* (define) */ - - if (!is_pair(cdr(code))) - { - if (is_null(cdr(code))) - syntax_error_with_caller_nr(sc, "~A: no value? ~A", 16, caller, sc->code); /* (define var) */ - syntax_error_with_caller_nr(sc, "~A: stray dot? ~A", 17, caller, sc->code); /* (define var . 1) */ - } - if (!is_pair(car(code))) - { - if (is_not_null(cddr(code))) /* (define var 1 . 2) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: more than one value? ~A", 27), caller, print_truncate(sc, sc->code))); - if (starred) - syntax_error_nr(sc, "define* is restricted to functions: ~S", 38, sc->code); - - func = car(code); - if (!is_symbol(func)) /* (define 3 a) */ - syntax_error_with_caller2_nr(sc, "~A: can't define ~W (~A); it should be a symbol", 47, caller, func, object_type_name(sc, func)); - if (is_keyword(func)) /* (define :hi 1) */ - syntax_error_with_caller_nr(sc, "~A ~A: keywords are constants", 29, caller, func); - if (is_syntactic_symbol(func)) /* (define and a) */ - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_80(sc->code)); - set_local(func); - } - if ((is_pair(cadr(code))) && /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */ - ((caadr(code) == sc->lambda_symbol) || - (caadr(code) == sc->lambda_star_symbol)) && - (symbol_id(caadr(code)) == 0)) - { - /* not is_global here because that bit might not be set for initial symbols (why not? -- redef as method etc) */ - if (!is_pair(cdadr(code))) /* (define x (lambda . 1)) */ - syntax_error_with_caller_nr(sc, "~A: stray dot? ~A", 17, caller, sc->code); - if (!is_pair(cddr(cadr(code)))) /* (define f (lambda (arg))) */ - syntax_error_with_caller_nr(sc, "~A: no body: ~A", 15, caller, sc->code); - if (caadr(code) == sc->lambda_star_symbol) - check_lambda_star_args(sc, cadadr(code), cddr(cadr(code)), cadr(code)); - else check_lambda_args(sc, cadadr(code), NULL, cadr(code)); - optimize_lambda(sc, caadr(code) == sc->lambda_symbol, func, cadadr(code), cddr(cadr(code))); - }} - else - { - func = caar(code); - if (!is_symbol(func)) /* (define (3 a) a) */ - syntax_error_with_caller2_nr(sc, "~A: can't define ~S, ~A (should be a symbol)", 44, caller, func, object_type_name(sc, func)); - if (is_syntactic_symbol(func)) /* (define (and a) a) */ - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_80(sc->code)); - set_local(func); - } - if (starred) - set_cdar(code, check_lambda_star_args(sc, cdar(code), cdr(code), sc->code)); - else check_lambda_args(sc, cdar(code), NULL, sc->code); - optimize_lambda(sc, !starred, func, cdar(code), cdr(code)); - } - - if (sc->cur_op == OP_DEFINE) - { - if ((is_pair(car(code))) && - (!is_possibly_constant(func))) - pair_set_syntax_op(sc->code, OP_DEFINE_FUNCHECKED); - else pair_set_syntax_op(sc->code, OP_DEFINE_UNCHECKED); - } - else pair_set_syntax_op(sc->code, (starred) ? OP_DEFINE_STAR_UNCHECKED : OP_DEFINE_CONSTANT_UNCHECKED); -} - -static bool op_define_unchecked(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code), locp; - - if ((is_pair(car(code))) && (has_location(car(code)))) - locp = car(code); - else locp = ((is_pair(cadr(code))) && (has_location(cadr(code)))) ? cadr(code) : sc->nil; - - if ((sc->cur_op == OP_DEFINE_STAR_UNCHECKED) && /* sc->cur_op changed above if define* */ - (is_pair(cdar(code)))) - { - sc->value = make_closure(sc, cdar(code), cdr(code), T_CLOSURE_STAR, CLOSURE_ARITY_NOT_SET); - /* closure_body might not be cdr(code) after make_closure (add_trace) */ - if ((is_pair(locp)) && (has_location(locp))) - { - pair_set_location(closure_body(sc->value), pair_location(locp)); - set_has_location(closure_body(sc->value)); - } - sc->code = caar(code); - return(false); - } - - if (!is_pair(car(code))) - { - s7_pointer x = car(code); - sc->code = cadr(code); - if (is_pair(sc->code)) - { - push_stack_no_args(sc, OP_DEFINE1, x); - sc->cur_op = optimize_op(sc->code); - return(true); - } - sc->value = (is_symbol(sc->code)) ? lookup_global(sc, sc->code) : sc->code; - sc->code = x; - } - else - { - s7_pointer args = cdar(code); - /* a closure. If we called this same code earlier (a local define), the only thing - * that is new here is the environment -- we can't blithely save the closure object - * in opt2 somewhere, and pick it up the next time around (since call/cc might take - * us back to the previous case). We also can't re-use opt2(sc->code) because opt2 - * is not cleared in the gc. - */ - s7_pointer x = make_closure(sc, args, cdr(code), T_CLOSURE | ((!s7_is_proper_list(sc, args)) ? T_COPY_ARGS : 0), (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET); - if ((is_pair(locp)) && (has_location(locp))) - { - pair_set_location(closure_body(x), pair_location(locp)); - set_has_location(closure_body(x)); - } - sc->value = T_Ext(x); - sc->code = caar(code); - } - return(false); -} - -static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer func_name, s7_pointer outer_let) -{ - s7_pointer new_let, arg; - new_cell_no_check(sc, new_let, T_LET | T_FUNCLET); - let_set_id(new_let, ++sc->let_number); - let_set_outlet(new_let, outer_let); - closure_set_let(new_func, new_let); - funclet_set_function(new_let, func_name); /* *function* returns at least funclet_function */ - let_set_slots(new_let, slot_end(sc)); - - arg = closure_args(new_func); - if (is_null(arg)) - { - let_set_slots(new_let, slot_end(sc)); - return(new_let); - } - - if (is_safe_closure(new_func)) - { - s7_pointer last_slot = NULL; - if (is_closure(new_func)) - { - if (is_pair(arg)) - { - last_slot = make_slot(sc, car(arg), sc->nil); - slot_set_next(last_slot, slot_end(sc)); - let_set_slots(new_let, last_slot); - symbol_set_local_slot(car(arg), let_id(new_let), last_slot); - for (arg = cdr(arg); is_pair(arg); arg = cdr(arg)) - last_slot = inline_add_slot_at_end(sc, let_id(new_let), last_slot, car(arg), sc->nil); - } - if (is_symbol(arg)) - { - if (last_slot) - last_slot = add_slot_at_end(sc, let_id(new_let), last_slot, arg, sc->nil); - else - { - last_slot = make_slot(sc, arg, sc->nil); - slot_set_next(last_slot, slot_end(sc)); - let_set_slots(new_let, last_slot); - symbol_set_local_slot(arg, let_id(new_let), last_slot); - } - set_is_rest_slot(last_slot); - }} - else /* closure_star */ - { - s7_pointer slot, first_default = sc->nil; - let_set_slots(new_let, slot_end(sc)); - for (; is_pair(arg); arg = cdr(arg)) - { - s7_pointer par = car(arg); - if (is_pair(par)) - { - s7_pointer val = cadr(par); - slot = add_slot_checked(sc, new_let, car(par), sc->nil); - slot_set_expression(slot, val); - if ((is_symbol(val)) || (is_pair(val))) - { - if (is_null(first_default)) - first_default = slot; - set_slot_defaults(slot); - }} - else - if (is_keyword(par)) - { - if (par == sc->rest_keyword) - { - arg = cdr(arg); - slot = add_slot_checked(sc, new_let, car(arg), sc->nil); - slot_set_expression(slot, sc->nil); - }} - else - { - slot = add_slot_checked(sc, new_let, par, sc->nil); - slot_set_expression(slot, sc->F); - }} - if (is_symbol(arg)) - { - slot = add_slot_checked(sc, new_let, arg, sc->nil); /* set up rest arg */ - set_is_rest_slot(slot); - slot_set_expression(slot, sc->nil); - } - if (tis_slot(let_slots(new_let))) - { - let_set_slots(new_let, reverse_slots(sc, let_slots(new_let))); - slot_set_pending_value(let_slots(new_let), first_default); - }} - set_immutable_let(new_let); - } - else let_set_slots(new_let, slot_end(sc)); /* if unsafe closure, arg-holding-let will be created on each call */ - return(new_let); -} - -static bool op_define_constant(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - if ((!is_pair(code)) || (!is_pair(cdr(code)))) /* (define-constant) */ - syntax_error_nr(sc, "define-constant: not enough arguments: ~S", 41, sc->code); - - if (is_symbol_and_keyword(car(code))) /* (define-constant :rest :allow-other-keys) */ - { - if (car(code) == cadr(code)) /* (define-constant pi pi) returns pi */ - { - sc->value = car(code); - return(true); - } - syntax_error_with_caller_nr(sc, "~A ~A: keywords are constants", 29, sc->define_constant_symbol, car(code)); - } - if ((is_symbol(car(code))) && /* (define-constant abs abs): "abs will not be touched" */ - (car(code) == cadr(code)) && - (symbol_id(car(code)) == 0) && /* else (let iter ... (define-constant iter iter) ...) -> segfault on later calls */ - (is_null(cddr(code)))) - { - s7_pointer sym = car(code); - set_immutable_slot(global_slot(sym)); /* id == 0 so its global */ - set_possibly_constant(sym); - sc->value = lookup_checked(sc, car(code)); - return(true); - } - push_stack_no_args(sc, OP_DEFINE_CONSTANT1, car(code)); - return(false); -} - -static void op_define_constant1(s7_scheme *sc) -{ - if (is_pair(sc->code)) - sc->code = car(sc->code); /* (define-constant (ex3 a)...) */ - if (is_symbol(sc->code)) - { - s7_pointer slot = lookup_slot_from(sc->code, sc->curlet); - set_possibly_constant(sc->code); - set_immutable_slot(slot); - if (is_any_closure(slot_value(slot))) - set_immutable(slot_value(slot)); /* for the optimizer mainly */ - } -} - -static inline void define_funchecked(s7_scheme *sc) -{ - s7_pointer new_func, code = cdr(sc->code); - sc->value = caar(code); /* func name */ - - new_cell(sc, new_func, T_CLOSURE | ((!s7_is_proper_list(sc, cdar(code))) ? T_COPY_ARGS : 0)); - closure_set_args(new_func, cdar(code)); - closure_set_body(new_func, cdr(code)); - if (is_pair(cddr(code))) set_closure_has_multiform(new_func); else set_closure_has_one_form(new_func); - closure_set_setter(new_func, sc->F); - closure_set_arity(new_func, CLOSURE_ARITY_NOT_SET); - sc->capture_let_counter++; - - if (is_safe_closure_body(cdr(code))) - { - set_safe_closure(new_func); - if (is_very_safe_closure_body(cdr(code))) - set_very_safe_closure(new_func); - make_funclet(sc, new_func, sc->value, sc->curlet); - } - else closure_set_let(new_func, sc->curlet); /* unsafe closures created by other functions do not support *function* */ - - if (let_id(sc->curlet) < symbol_id(sc->value)) - sc->let_number++; /* dummy let, force symbol lookup */ - add_slot_unchecked(sc, sc->curlet, sc->value, new_func, sc->let_number); - sc->value = new_func; -} - -static s7_pointer cur_op_to_caller(s7_scheme *sc, opcode_t op) -{ - switch (op) - { - case OP_DEFINE_MACRO: return(sc->define_macro_symbol); - case OP_DEFINE_MACRO_STAR: return(sc->define_macro_star_symbol); - case OP_DEFINE_BACRO: return(sc->define_bacro_symbol); - case OP_DEFINE_BACRO_STAR: return(sc->define_bacro_star_symbol); - case OP_DEFINE_EXPANSION: return(sc->define_expansion_symbol); - case OP_DEFINE_EXPANSION_STAR: return(sc->define_expansion_star_symbol); - case OP_MACRO: return(sc->macro_symbol); - case OP_MACRO_STAR: return(sc->macro_star_symbol); - case OP_BACRO: return(sc->bacro_symbol); - case OP_BACRO_STAR: return(sc->bacro_star_symbol); - } - return(sc->define_macro_symbol); -} - -static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op, s7_pointer form) -{ - s7_pointer mac_name, args, caller = cur_op_to_caller(sc, op); - - if (!is_pair(sc->code)) /* (define-macro . 1) */ - syntax_error_with_caller_nr(sc, "~A name missing (stray dot?): ~A", 32, caller, sc->code); - if (!is_pair(car(sc->code))) /* (define-macro a ...) */ - wrong_type_error_nr(sc, caller, 1, car(sc->code), wrap_string(sc, "a list: (name ...)", 18)); - - mac_name = caar(sc->code); - if (!is_symbol(mac_name)) - syntax_error_with_caller_nr(sc, "~A: ~S is not a symbol?", 23, caller, mac_name); - if (is_syntactic_symbol(mac_name)) - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(mac_name), display_80(sc->code)); - set_local(mac_name); - } - if (is_constant_symbol(sc, mac_name)) - syntax_error_with_caller_nr(sc, "~A: ~S is constant", 18, caller, mac_name); - - if (!is_pair(cdr(sc->code))) /* (define-macro (...)) */ - syntax_error_with_caller_nr(sc, "~A ~A, but no body?", 19, caller, mac_name); - - if (s7_list_length(sc, cdr(sc->code)) < 0) /* (define-macro (hi) 1 . 2) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, sc->code)); - - args = cdar(sc->code); - if ((!is_list(args)) && - (!is_symbol(args))) - error_nr(sc, sc->syntax_error_symbol, /* (define-macro (mac . 1) ...) */ - set_elist_3(sc, wrap_string(sc, "macro ~A argument list is ~S?", 29), mac_name, args)); - - if ((op == OP_DEFINE_MACRO) || (op == OP_DEFINE_BACRO) || (op == OP_DEFINE_EXPANSION)) - { - for (; is_pair(args); args = cdr(args)) - if (!is_symbol(car(args))) - error_nr(sc, sc->syntax_error_symbol, /* (define-macro (mac 1) ...) */ - set_elist_3(sc, wrap_string(sc, "~A parameter name, ~A, is not a symbol", 38), caller, car(args))); - check_lambda_args(sc, cdar(sc->code), NULL, form); - } - else set_cdar(sc->code, check_lambda_star_args(sc, args, NULL, form)); - return(sc->code); -} - -static s7_pointer check_macro(s7_scheme *sc, opcode_t op, s7_pointer form) -{ - s7_pointer args, caller = cur_op_to_caller(sc, op); - - if (!is_pair(sc->code)) /* sc->code = cdr(form) */ /* (macro) or (macro . 1) */ - syntax_error_with_caller_nr(sc, "~S: ~S has no parameters or body?", 33, caller, form); - if (!is_pair(cdr(sc->code))) /* (macro (a)) */ - syntax_error_with_caller_nr(sc, "~S: ~S has no body?", 19, caller, form); - - args = car(sc->code); - if ((!is_list(args)) && - (!is_symbol(args))) - error_nr(sc, sc->syntax_error_symbol, /* (macro #(0) ...) */ - set_elist_2(sc, wrap_string(sc, "macro parameter list is ~S?", 27), args)); - - if ((op == OP_MACRO) || (op == OP_BACRO)) - { - for (; is_pair(args); args = cdr(args)) - if (!is_symbol(car(args))) - error_nr(sc, sc->syntax_error_symbol, /* (macro (1) ...) */ - set_elist_3(sc, wrap_string(sc, "~A parameter name, ~A, is not a symbol", 38), caller, car(args))); - check_lambda_args(sc, car(sc->code), NULL, form); - } - else set_car(sc->code, check_lambda_star_args(sc, args, NULL, form)); - - if (s7_list_length(sc, cdr(sc->code)) < 0) /* (macro () 1 . 2) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, form)); - - return(sc->code); -} - -static void op_macro(s7_scheme *sc) /* (macro (x) `(+ ,x 1)) */ -{ - s7_pointer form = sc->code; - sc->code = cdr(sc->code); - if ((!is_pair(sc->code)) || (!mac_is_ok(sc->code))) /* (macro)? or (macro . #\a)? */ - { - check_macro(sc, sc->cur_op, form); - set_mac_is_ok(sc->code); - } - sc->value = make_macro(sc, sc->cur_op, false); -} - -static void op_define_macro(s7_scheme *sc) -{ - s7_pointer form = sc->code; - sc->code = cdr(sc->code); - check_define_macro(sc, sc->cur_op, form); - if ((is_immutable(sc->curlet)) && - (is_let(sc->curlet))) /* not () */ - syntax_error_nr(sc, "define-macro ~S: let is immutable", 33, caar(sc->code)); /* need syntax_error_any_with_caller? */ - sc->value = make_macro(sc, sc->cur_op, true); -} - -static bool unknown_any(s7_scheme *sc, s7_pointer f, s7_pointer code); -static void apply_macro_star_1(s7_scheme *sc); - -static opcode_t fixup_macro_d(s7_scheme *sc, opcode_t op, s7_pointer mac) -{ - if (closure_arity_unknown(mac)) - closure_set_arity(mac, s7_list_length(sc, closure_args(mac))); - return(op); -} - -static inline bool op_macro_d(s7_scheme *sc, uint8_t typ) -{ - sc->value = lookup(sc, car(sc->code)); - if (type(sc->value) != typ) /* for-each (etc) called a macro before, now it's something else -- a very rare case */ - return(unknown_any(sc, sc->value, sc->code)); - - /* it's probably safer to always copy the list here, but that costs 4-5% in tmac, whereas this costs 3% -- maybe not worth the code? */ - if (closure_arity(sc->value) <= 0) - sc->args = copy_proper_list(sc, cdr(sc->code)); - else sc->args = cdr(sc->code); - - sc->code = sc->value; /* the macro */ - check_stack_size(sc); /* (define-macro (f) (f)) (f) */ - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = inline_make_let(sc, closure_let(sc->code)); - return(false); /* fall into apply_lambda */ -} - -static bool op_macro_star_d(s7_scheme *sc) -{ - if (op_macro_d(sc, T_MACRO_STAR)) return(true); - apply_macro_star_1(sc); - return(false); -} - -static void transfer_macro_info(s7_scheme *sc, s7_pointer mac) -{ - s7_pointer body = closure_body(mac); - if (has_pair_macro(mac)) - { - set_maclet(sc->curlet); - funclet_set_function(sc->curlet, pair_macro(body)); - } - if (has_location(body)) - { - let_set_file(sc->curlet, pair_file_number(body)); - let_set_line(sc->curlet, pair_line_number(body)); - set_has_let_file(sc->curlet); - } -} - -static goto_t op_expansion(s7_scheme *sc) -{ - int64_t loc = current_stack_top(sc) - 1; - s7_pointer caller = (is_pair(stack_args(sc->stack, loc))) ? car(stack_args(sc->stack, loc)) : sc->F; /* this can be garbage */ - if ((loc >= 3) && - (stack_op(sc->stack, loc) != OP_READ_QUOTE) && /* '(expansion ...) */ - (stack_op(sc->stack, loc) != OP_READ_VECTOR) && /* #(expansion ...) */ - (caller != sc->quote_symbol) && /* (quote (expansion ...)) */ - (caller != sc->macroexpand_symbol) && /* (macroexpand (expansion ...)) */ - (caller != sc->define_expansion_symbol) && /* (define-expansion ...) being reloaded/redefined */ - (caller != sc->define_expansion_star_symbol)) /* (define-expansion* ...) being reloaded/redefined */ - { - s7_pointer symbol = car(sc->value), slot; - /* we're playing fast and loose with sc->curlet in the reader, so here we need a disaster check */ - if (!is_let(sc->curlet)) sc->curlet = sc->nil; - - if ((symbol_id(symbol) == 0) || - (sc->curlet == sc->nil)) - slot = global_slot(symbol); - else slot = lookup_slot_from(symbol, sc->curlet); - - sc->code = (is_slot(slot)) ? slot_value(slot) : sc->undefined; - if ((!is_either_macro(sc->code)) || (!is_expansion(sc->code))) - clear_expansion(symbol); - else - { - /* call the reader macro */ - sc->args = cdr(sc->value); - push_stack_no_code(sc, OP_EXPANSION, sc->nil); - sc->curlet = make_let(sc, closure_let(sc->code)); - transfer_macro_info(sc, sc->code); - if (!is_macro_star(sc->code)) - return(goto_apply_lambda); - apply_macro_star_1(sc); - return(goto_begin); - /* bacros don't seem to make sense here -- they are tied to the run-time environment, - * procedures would need to evaluate their arguments in rootlet - */ - }} - return(fall_through); -} - -static void macroexpand_c_macro(s7_scheme *sc) /* callgrind shows this when it's actually calling apply_c_function (code is identical) */ -{ - s7_int len = proper_list_length(sc->args); - if (len < c_macro_min_args(sc->code)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); - if (c_macro_max_args(sc->code) < len) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); - sc->value = c_macro_call(sc->code)(sc, sc->args); -} - -static goto_t macroexpand(s7_scheme *sc) -{ - switch (type(sc->code)) - { - case T_MACRO: - sc->curlet = make_let(sc, closure_let(sc->code)); - return(goto_apply_lambda); - case T_BACRO: - sc->curlet = make_let(sc, sc->curlet); - return(goto_apply_lambda); - case T_MACRO_STAR: - sc->curlet = make_let(sc, closure_let(sc->code)); - apply_macro_star_1(sc); - return(goto_begin); - case T_BACRO_STAR: - sc->curlet = make_let(sc, sc->curlet); - apply_macro_star_1(sc); - return(goto_begin); - case T_C_MACRO: - macroexpand_c_macro(sc); - return(goto_start); - default: - syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, sc->args); - } - return(fall_through); /* for the compiler */ -} - -static goto_t op_macroexpand(s7_scheme *sc) -{ - s7_pointer form = sc->code; - sc->code = cdr(sc->code); - /* mimic APPLY, but don't push OP_EVAL_MACRO or OP_EXPANSION - * (define-macro (mac a) `(+ ,a 1)) (macroexpand (mac 3)), sc->code: ((mac 3)) - */ - if ((!is_pair(sc->code)) || - (!is_pair(car(sc->code)))) - syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, form); - - if (!is_null(cdr(sc->code))) - syntax_error_nr(sc, "macroexpand: too many arguments: ~A", 35, form); - - if (is_pair(caar(sc->code))) /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */ - { - push_stack_no_args_direct(sc, OP_MACROEXPAND_1); - sc->code = caar(sc->code); - return(goto_eval); - } - - sc->args = cdar(sc->code); - if (!is_list(sc->args)) /* (macroexpand (mac . 7)) */ - syntax_error_nr(sc, "can't macroexpand ~S: the macro's argument list is not a list", 61, car(sc->code)); - - if (!is_symbol(caar(sc->code))) - { - if (!is_any_macro(caar(sc->code))) - syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, sc->code); - sc->code = caar(sc->code); - return(macroexpand(sc)); - } - sc->code = lookup_checked(sc, caar(sc->code)); - return(macroexpand(sc)); -} - -static goto_t op_macroexpand_1(s7_scheme *sc) -{ - sc->args = cdar(sc->code); - sc->code = sc->value; - return(macroexpand(sc)); -} - -static void op_eval_macro(s7_scheme *sc) /* after (scheme-side) macroexpansion, evaluate the resulting expression */ -{ - /* (define-macro (hi a) `(+ ,a 1)), (hi 2), here with value: (+ 2 1) */ - if (is_multiple_value(sc->value)) - { - /* a normal macro's result is evaluated (below) and its value replaces the macro invocation, - * so if a macro returns multiple values, evaluate each one, then replace the macro - * invocation with (apply values evaluated-results-in-a-list). We need to save the - * new list of results, and where we are in the macro's output list, so code=macro output, - * args=new list. If it returns (values), should we use #? I think that - * happens now without generating a multiple_value object: - * (define-macro (hi) (values)) (hi) -> # - * (define-macro (ho) (values '(+ 1 2) '(* 3 4))) (+ 1 (ho) 3) -> 19 - * (define-macro (ha) (values '(define a 1) '(define b 2))) (let () (ha) (+ a b)) -> 3 - */ - push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->value)); - sc->code = car(sc->value); - } - else sc->code = sc->value; -} - -static bool op_eval_macro_mv(s7_scheme *sc) -{ - if (is_null(sc->code)) /* end of values list */ - { - sc->value = splice_in_values(sc, multiple_value(proper_list_reverse_in_place(sc, cons(sc, sc->value, sc->args)))); - return(true); - } - push_stack(sc, OP_EVAL_MACRO_MV, cons(sc, sc->value, sc->args), cdr(sc->code)); - sc->code = car(sc->code); - return(false); -} - -static void op_finish_expansion(s7_scheme *sc) -{ - /* after the expander has finished, if a list was returned, we need to add some annotations. - * if the expander returned (values), the list-in-progress vanishes! (This mimics map and *#readers*). - */ - if (sc->value == sc->no_value) - sc->stack_end[-1] = (s7_pointer)OP_READ_NEXT; - else - if (is_pair(sc->value)) - sc->value = copy_body(sc, sc->value); -} - - -/* -------------------------------- with-let -------------------------------- */ -static void check_with_let(s7_scheme *sc) -{ - s7_pointer form = cdr(sc->code); - - if (!is_pair(form)) /* (with-let . "hi") */ - syntax_error_nr(sc, "with-let takes an environment argument: ~A", 42, sc->code); - if (!is_pair(cdr(form))) /* (with-let e) -> an error? */ - syntax_error_nr(sc, "with-let body is messed up: ~A", 30, sc->code); - if (!s7_is_proper_list(sc, cdr(form))) /* (with-let e . 3) */ - syntax_error_nr(sc, "stray dot in with-let body: ~S", 30, sc->code); - - pair_set_syntax_op(sc->code, ((is_normal_symbol(car(form))) && - (is_normal_symbol(cadr(form))) && /* (with-let lt a) is not the same as (with-let lt :a) */ - (is_null(cddr(form)))) ? OP_WITH_LET_S : OP_WITH_LET_UNCHECKED); - set_current_code(sc, sc->code); -} - -static bool op_with_let_unchecked(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - sc->value = car(sc->code); - if (!is_pair(sc->value)) - { - if (is_symbol(sc->value)) - sc->value = lookup_checked(sc, sc->value); - sc->code = cdr(sc->code); - return(false); - } - push_stack_no_args(sc, OP_WITH_LET1, cdr(sc->code)); - sc->code = sc->value; /* eval let arg */ - return(true); -} - -static s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg) -{ - s7_pointer code = cdr(arg); - s7_pointer e = lookup_checked(sc, car(code)); - if ((!is_let(e)) && (e != sc->rootlet)) - { - e = find_let(sc, e); - if (!is_let(e)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), car(code))); - } - e = let_ref(sc, e, cadr(code)); /* (with-let e s) -> (let-ref e s) */ - if (e == sc->undefined) - unbound_variable_error_nr(sc, cadr(code)); - return(e); -} - -static void activate_with_let(s7_scheme *sc, s7_pointer e) -{ - if (!is_let(e)) /* (with-let . "hi") */ - { - s7_pointer new_e = find_let(sc, e); - if (!is_let(new_e)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), e)); - e = new_e; - } - if (e == sc->rootlet) - sc->curlet = sc->nil; /* (with-let (rootlet) ...) */ - else - { - set_with_let_let(e); - let_set_id(e, ++sc->let_number); - set_curlet(sc, e); - update_symbol_ids(sc, e); - } -} - - -/* -------------------------------- cond -------------------------------- */ -static void check_cond(s7_scheme *sc) -{ - bool has_feed_to = false, result_fx = true, result_single = true; - s7_pointer x, code = cdr(sc->code), form = sc->code; - - if (!is_pair(code)) /* (cond) or (cond . 1) */ - syntax_error_nr(sc, "cond, but no body: ~A", 21, form); - - for (x = code; is_pair(x); x = cdr(x)) - if (!is_pair(car(x))) /* (cond 1) or (cond (#t 1) 3) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "every clause in cond must be a pair: ~S in ~A", 45), - car(x), object_to_truncated_string(sc, form, 80))); - else - { - s7_pointer y = car(x); - if (!s7_is_proper_list(sc, cdr(y))) /* (cond (xxx . 1)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "stray dot? ~S in ~A", 19), - y, object_to_truncated_string(sc, form, 80))); - if (is_pair(cdr(y))) - { - if (is_pair(cddr(y))) result_single = false; - if (is_undefined_feed_to(sc, cadr(y))) - { - has_feed_to = true; - if (!is_pair(cddr(y))) /* (cond (#t =>)) or (cond (#t => . 1)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "cond: '=>' target missing? ~S in ~A", 36), - x, object_to_truncated_string(sc, form, 80))); - if (is_pair(cdddr(y))) /* (cond (1 => + abs)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "cond: '=>' has too many targets: ~S in ~A", 41), - x, object_to_truncated_string(sc, form, 80))); - }} - else result_single = false; - } - if (is_not_null(x)) /* (cond ((1 2)) . 1) */ - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond: stray dot? ~S", 19), form)); - - for (x = code; is_pair(x); x = cdr(x)) - { - s7_pointer p = car(x); - /* clear_has_fx(p); */ /* a kludge -- if has_fx here (and not re-fx'd below), someone messed up earlier -- but was fx_treeable set? */ - if (is_fxable(sc, car(p))) - fx_annotate_arg(sc, p, sc->curlet); - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!has_fx(p)) - { - s7_function f = fx_choose(sc, p, sc->curlet, let_symbol_is_safe); - if (f) set_fx_direct(p, f); else result_fx = false; - }} - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - - if (has_feed_to) - { - pair_set_syntax_op(form, OP_COND_UNCHECKED); - if (is_null(cdr(code))) - { - s7_pointer expr = car(code), f; - f = caddr(expr); - if ((is_proper_list_3(sc, f)) && - (car(f) == sc->lambda_symbol)) - { - s7_pointer arg = cadr(f); - if ((is_pair(arg)) && - (is_null(cdr(arg))) && - (is_symbol(car(arg)))) /* (define (hi) (cond (#t => (lambda (s) s)))) */ - { - set_opt2_lambda(code, caddar(code)); /* (lambda ...) above */ - pair_set_syntax_op(form, OP_COND_FEED); - }}}} - else - { - s7_pointer p; - bool xopt = true; - int32_t i; - - pair_set_syntax_op(form, OP_COND_SIMPLE); - for (i = 0, p = code; xopt && (is_pair(p)); i++, p = cdr(p)) - xopt = ((has_fx(car(p))) && (is_pair(cdar(p)))); - if (xopt) - { - pair_set_syntax_op(form, (result_fx) ? OP_COND_NA_NA : ((result_single) ? OP_COND_NA_NP_O : OP_COND_NA_NP)); - if (result_single) - { - if (i == 2) - { - p = caadr(code); - if ((p == sc->else_symbol) || (p == sc->T)) - pair_set_syntax_op(form, OP_COND_NA_2E); - } - else - if (i == 3) - { - p = caaddr(code); - if ((p == sc->else_symbol) || (p == sc->T)) - pair_set_syntax_op(form, OP_COND_NA_3E); - }}} - else - if (result_single) - pair_set_syntax_op(form, OP_COND_SIMPLE_O); - } - set_opt3_any(code, caar(code)); -} - -static bool op_cond_unchecked(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - if (has_fx(car(sc->code))) - { - sc->value = fx_call(sc, car(sc->code)); /* false -> fall through into cond1 */ - return(false); - } - push_stack_no_args_direct(sc, OP_COND1); /* true -> push cond1, goto eval */ - sc->code = opt3_any(sc->code); /* caar */ - return(true); -} - -static bool op_cond_simple(s7_scheme *sc) /* no => */ -{ - sc->code = cdr(sc->code); - if (has_fx(car(sc->code))) - { - sc->value = fx_call(sc, car(sc->code)); - return(false); - } - push_stack_no_args_direct(sc, OP_COND1_SIMPLE); - sc->code = opt3_any(sc->code); /* caar */ - return(true); -} - -static bool op_cond_simple_o(s7_scheme *sc) /* no =>, no null or multiform consequent */ -{ - sc->code = cdr(sc->code); - if (has_fx(car(sc->code))) - { - sc->value = fx_call(sc, car(sc->code)); - return(false); - } - push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O); - sc->code = opt3_any(sc->code); /* caar */ - return(true); -} - -static bool op_cond1(s7_scheme *sc) -{ - while (true) - { - if (is_true(sc, sc->value)) /* test is true, so evaluate result */ - { - sc->code = cdar(sc->code); - if (is_pair(sc->code)) - { - if (is_null(cdr(sc->code))) - { - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - pop_stack(sc); - return(true); /* goto top_no_pop */ - } - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - /* check_cond catches stray dots */ - if (is_undefined_feed_to(sc, car(sc->code))) - return(false); - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - sc->code = cdr(sc->code); - if (is_pair(cdr(sc->code))) - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - } - else push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - /* sc->code is () */ - if (is_multiple_value(sc->value)) /* (+ 1 (cond ((values 2 3)))) */ - sc->value = splice_in_values(sc, multiple_value(sc->value)); - /* no result clause, so return test, (cond (#t)) -> #t, (cond ((+ 1 2))) -> 3 */ - pop_stack(sc); - return(true); - } - sc->code = cdr(sc->code); /* go to next clause */ - if (is_null(sc->code)) - { - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); - else - { - push_stack_no_args_direct(sc, OP_COND1); - sc->code = caar(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - }} - return(true); /* make the compiler happy */ -} - -static bool op_cond1_simple(s7_scheme *sc) -{ - while (true) - { - if (is_true(sc, sc->value)) - { - sc->code = T_Lst(cdar(sc->code)); - if (is_null(sc->code)) - { - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - pop_stack(sc); - return(true); - } - if (!has_fx(sc->code)) - return(false); - sc->value = fx_call(sc, sc->code); - sc->code = cdr(sc->code); - if (is_pair(sc->code)) return(false); /* goto begin */ - pop_stack(sc); - return(true); /* goto top_no_pop */ - } - sc->code = cdr(sc->code); - if (is_null(sc->code)) - { - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } - if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); - else - { - push_stack_no_args_direct(sc, OP_COND1_SIMPLE); - sc->code = caar(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - }} -} - -static bool op_cond1_simple_o(s7_scheme *sc) -{ - while (true) - { - if (is_true(sc, sc->value)) - { - sc->code = cdar(sc->code); - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - return(true); /* goto start */ - } - sc->code = car(sc->code); - return(false); - } - sc->code = cdr(sc->code); - if (is_null(sc->code)) - { - sc->value = sc->unspecified; - return(true); - } - if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); - else - { - check_stack_size(sc); /* 4-May-21 snd-test */ - push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O); - sc->code = caar(sc->code); - return(false); - }} -} - -static bool op_cond_na_np(s7_scheme *sc) /* all tests are fxable, results may be a mixture, no =>, no missing results */ -{ - for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p)) - if (is_true(sc, fx_call(sc, car(p)))) - { - for (p = T_Lst(cdar(p)); is_pair(p); p = cdr(p)) - if (has_fx(T_Pair(p))) - sc->value = fx_call(sc, p); - else - { - if (is_pair(cdr(p))) - push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p)); - sc->code = car(p); - return(false); - } - return(true); - } - sc->value = sc->unspecified; - return(true); -} - -static bool op_cond_na_np_1(s7_scheme *sc) /* continuing to handle a multi-statement result from cond_na_np */ -{ - for (s7_pointer p = sc->code; is_pair(p); p = cdr(p)) - if (has_fx(T_Pair(p))) - sc->value = fx_call(sc, p); - else - { - if (is_pair(cdr(p))) - push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p)); - sc->code = car(p); - return(false); - } - return(true); -} - -static Inline bool inline_op_cond_na_np_o(s7_scheme *sc) /* all tests are fxable, results may be a mixture, no =>, no missing results, all result one expr */ -{ /* called once in eval, b case cb lg rclo str */ - for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p)) - if (is_true(sc, fx_call(sc, car(p)))) - { - p = cdar(p); - if (has_fx(T_Pair(p))) - { - sc->value = fx_call(sc, p); - return(true); - } - sc->code = car(p); - return(false); - } - sc->value = sc->unspecified; - return(true); -} - -static inline bool fx_cond_value(s7_scheme *sc, s7_pointer p) -{ - if (has_fx(p)) - { - sc->value = fx_call(sc, p); - return(true); - } - sc->code = car(p); - return(false); -} - -static bool op_cond_na_2e(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p))); -} - -static bool op_cond_na_3e(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - if (is_true(sc, fx_call(sc, car(p)))) - return(fx_cond_value(sc, cdar(p))); - p = cdr(p); - return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p))); -} - -static bool op_cond_feed(s7_scheme *sc) -{ - /* (cond (expr => p)) where p is (lambda (s) ...) -- see check_cond */ - sc->code = cdr(sc->code); - if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); - else - { - push_stack_no_args_direct(sc, OP_COND_FEED_1); - sc->code = caar(sc->code); - return(true); - } - return(false); -} - -static void op_cond_feed_1(s7_scheme *sc) -{ - if (is_multiple_value(sc->value)) - sc->code = cons(sc, opt2_lambda(sc->code), multiple_value(sc->value)); - else - { - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, caadr(opt2_lambda(sc->code)), sc->value); - sc->code = caddr(opt2_lambda(sc->code)); - } -} - -static bool feed_to(s7_scheme *sc) -{ - if (is_multiple_value(sc->value)) - { - sc->args = multiple_value(sc->value); - clear_multiple_value(sc->args); - if (is_symbol(cadr(sc->code))) - { - sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ - return(true); - }} - else - { - if (is_symbol(cadr(sc->code))) - { - sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ - sc->args = (needs_copied_args(sc->code)) ? list_1(sc, sc->value) : set_plist_1(sc, sc->value); - return(true); - } - sc->args = list_1(sc, sc->value); /* not plist here */ - } - push_stack_direct(sc, OP_FEED_TO_1); - sc->code = cadr(sc->code); /* need to evaluate the target function */ - return(false); -} - - -/* -------------------------------- set! -------------------------------- */ -static void check_set(s7_scheme *sc) -{ - s7_pointer form = sc->code, code = cdr(sc->code); - if (!is_pair(code)) - { - if (is_null(code)) /* (set!) */ - syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); - syntax_error_nr(sc, "set!: stray dot? ~A", 19, form); /* (set! . 1) */ - } - if (!is_pair(cdr(code))) - { - if (is_null(cdr(code))) /* (set! var) */ - syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); - syntax_error_nr(sc, "set!: stray dot? ~A", 19, form); /* (set! var . 1) */ - } - if (is_not_null(cddr(code))) /* (set! var 1 2) */ - syntax_error_nr(sc, "~A: too many arguments to set!", 30, form); - - /* cadr (the value) has not yet been evaluated */ - if (is_pair(car(code))) - { - if ((is_pair(caar(code))) && - (!is_list(cdar(code)))) /* (set! ('(1 2) . 0) 1) */ - syntax_error_nr(sc, "improper list of arguments to set!: ~A", 38, form); - if (!s7_is_proper_list(sc, car(code))) /* (set! ("hi" . 1) #\a) or (set! (#(1 2) . 1) 0) */ - syntax_error_nr(sc, "set! target is an improper list: (set! ~A ...)", 46, car(code)); - } - else - if (!is_symbol(car(code))) /* (set! 12345 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "set! can't change ~S, ~S", 24), car(code), form)); - else - if (is_constant_symbol(sc, car(code))) /* (set! pi 3) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, (is_keyword(car(code))) ? "set!: can't change keyword's value: ~S in ~S" : - "set!: can't alter constant's value: ~S in ~S", 44), - car(code), form)); - if (is_pair(car(code))) - { - /* here we have (set! (...) ...) */ - s7_pointer inner = car(code), value = cadr(code); - pair_set_syntax_op(form, OP_SET_UNCHECKED); /* if not pair car, op_set_normal below */ - if (is_symbol(car(inner))) - { - if (is_null(cdr(inner))) /* (set! (symbol) ...) */ - { - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_opSq_A); /* (set! (symbol) fxable) */ - fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) = value */ - }} - else - if (is_null(cddr(inner))) /* we check cddr(code) above */ /* this leaves (set! (vect i j) 1) unhandled so we go to OP_SET_UNCHECKED */ - { - s7_pointer index = cadr(inner); - if (is_fxable(sc, index)) - { - if ((car(inner) == sc->let_ref_symbol) && (!is_pair(cddr(inner)))) /* perhaps also check for hash-table-ref */ - /* (let () (define (func) (catch #t (lambda () (set! (let-ref (list 1)) 1)) (lambda args 'error))) (func) (func)) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_2(sc, wrap_string(sc, "set!: not enough arguments for let-ref: ~S", 42), sc->code)); - fx_annotate_arg(sc, cdar(code), sc->curlet); /* cdr(inner) -> index */ - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_opSAq_A); /* (set! (symbol fxable) fxable) */ - fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ - - if (car(inner) == sc->s7_starlet_symbol) /* (set! (*s7* 'field) value) */ - { - s7_pointer sym = (is_symbol(index)) ? - ((is_keyword(index)) ? keyword_symbol(index) : index) : - ((is_quoted_symbol(index)) ? cadr(index) : index); - if ((is_symbol(sym)) && (s7_starlet_symbol(sym) != SL_NO_FIELD)) - { - set_safe_optimize_op(form, OP_IMPLICIT_S7_STARLET_SET); - set_opt3_sym(form, sym); - }}} - else pair_set_syntax_op(form, OP_SET_opSAq_P); /* (set! (symbol fxable) any) */ - }} - else - if ((is_null(cdddr(inner))) && - (car(inner) != sc->with_let_symbol)) /* (set! (with-let lt a) 32) needs to be handled by op_set_with_let_1 */ - { - s7_pointer index1 = cadr(inner), index2 = caddr(inner); - if ((is_fxable(sc, index1)) && (is_fxable(sc, index2))) - { - fx_annotate_args(sc, cdar(code), sc->curlet); /* cdr(inner) -> index1 and 2 */ - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_opSAAq_A); /* (set! (symbol fxable fxable) fxable) */ - fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ - } - else pair_set_syntax_op(form, OP_SET_opSAAq_P); /* (set! (symbol fxable fxable) any) */ - }}} - return; - } - pair_set_syntax_op(form, OP_SET_NORMAL); - if (is_symbol(car(code))) - { - s7_pointer settee = car(code), value = cadr(code); - s7_pointer slot = lookup_slot_from(settee, sc->curlet); - if ((is_slot(slot)) && - (!slot_has_setter(slot)) && - (!is_syntactic_symbol(settee))) - { - if (is_normal_symbol(value)) - { - s7_pointer slot1 = lookup_slot_from(value, sc->curlet); - if ((is_slot(slot1)) && (!slot_has_setter(slot1))) - { - pair_set_syntax_op(form, OP_SET_S_S); - set_opt2_sym(code, value); - }} - else - if ((!is_pair(value)) || - ((car(value) == sc->quote_symbol) && (is_pair(cdr(value))))) /* (quote . 1) ? */ - { - pair_set_syntax_op(form, OP_SET_S_C); - set_opt2_con(code, (is_pair(value)) ? cadr(value) : value); - } - else - { - pair_set_syntax_op(form, OP_SET_S_P); - if (is_optimized(value)) - { - if (optimize_op(value) == HOP_SAFE_C_SS) - { - if (settee == cadr(value)) - { - pair_set_syntax_op(form, OP_INCREMENT_SA); - fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */ - set_opt2_pair(code, cddr(value)); - } - else - { - pair_set_syntax_op(form, OP_SET_S_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - }} - else - { - if (is_fxable(sc, value)) /* value = cadr(code) */ - { - pair_set_syntax_op(form, OP_SET_S_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - } - if ((is_safe_c_op(optimize_op(value))) && - (is_pair(cdr(value))) && - (settee == cadr(value)) && - (!is_null(cddr(value)))) - { - if (is_null(cdddr(value))) - { - if (is_fxable(sc, caddr(value))) - { - pair_set_syntax_op(form, OP_INCREMENT_SA); - fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */ - set_opt2_pair(code, cddr(value)); - }} - else - if ((is_null(cddddr(value))) && - (is_fxable(sc, caddr(value))) && - (is_fxable(sc, cadddr(value)))) - { - pair_set_syntax_op(form, OP_INCREMENT_SAA); - fx_annotate_args(sc, cddr(value), sc->curlet); - /* fx_annotate_arg(sc, cdddr(value), sc->curlet); */ - set_opt2_pair(code, cddr(value)); - }}}} - if ((is_h_optimized(value)) && - (is_safe_c_op(optimize_op(value))) && /* else might not be opt1_cfunc? (opt1_lambda probably) */ - (!is_unsafe(value)) && /* is_unsafe(value) can happen! */ - (is_not_null(cdr(value)))) /* (set! x (y)) */ - { - if (is_not_null(cddr(value))) - { - if ((caddr(value) == int_one) && - (cadr(value) == settee)) - { - if (opt1_cfunc(value) == sc->add_x1) - pair_set_syntax_op(form, OP_INCREMENT_BY_1); - else - if (opt1_cfunc(value) == sc->subtract_x1) - pair_set_syntax_op(form, OP_DECREMENT_BY_1); - } - else - if ((cadr(value) == int_one) && - (caddr(value) == settee) && - (opt1_cfunc(value) == sc->add_1x)) - pair_set_syntax_op(form, OP_INCREMENT_BY_1); - else - if ((settee == caddr(value)) && - (is_safe_symbol(cadr(value))) && - (caadr(code) == sc->cons_symbol)) - { - pair_set_syntax_op(form, OP_SET_CONS); - set_opt2_sym(code, cadr(value)); - }}}}}} -} - -static void op_set_s_c(s7_scheme *sc) -{ - s7_pointer slot = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - if (is_immutable(slot)) - error_nr(sc, sc->immutable_error_symbol, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); - slot_set_value(slot, sc->value = opt2_con(cdr(sc->code))); -} - -static inline void op_set_s_s(s7_scheme *sc) -{ - s7_pointer slot = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - if (is_immutable(slot)) - error_nr(sc, sc->immutable_error_symbol, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); - slot_set_value(slot, sc->value = lookup(sc, opt2_sym(cdr(sc->code)))); -} - -static Inline void op_set_s_a(s7_scheme *sc) -{ - s7_pointer slot = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - if (is_immutable(slot)) - error_nr(sc, sc->immutable_error_symbol, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code))); - slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code))); -} - -static void op_set_s_p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args(sc, OP_SET_SAFE, cadr(sc->code)); /* only path to op_set_safe, but we're not safe! cadr(sc->code) might be immutable */ - sc->code = caddr(sc->code); -} - -static void op_set_safe(s7_scheme *sc) /* name is misleading -- we need to check for immutable slot */ -{ - s7_pointer slot = lookup_slot_from(sc->code, sc->curlet); - if (is_slot(slot)) - { - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sc->code)); - slot_set_value(slot, sc->value); - } - else - if (has_let_set_fallback(sc->curlet)) - sc->value = call_let_set_fallback(sc, sc->curlet, sc->code, sc->value); - else unbound_variable_error_nr(sc, sc->code); -} - -static void op_set_from_let_temp(s7_scheme *sc) -{ - s7_pointer settee = sc->code; - s7_pointer slot = lookup_slot_from(settee, sc->curlet); - if (!is_slot(slot)) - unbound_variable_error_nr(sc, settee); - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, sc->value) : sc->value); -} - -static inline void op_set_cons(s7_scheme *sc) -{ - s7_pointer slot = lookup_slot_from(cadr(sc->code), sc->curlet); - slot_set_value(slot, sc->value = cons(sc, lookup(sc, opt2_sym(cdr(sc->code))), slot_value(slot))); /* ([set!] bindings (cons v bindings)) */ -} - -static void op_increment_saa(s7_scheme *sc) -{ - s7_pointer slot, arg, val; - sc->code = cdr(sc->code); - slot = lookup_slot_from(car(sc->code), sc->curlet); - arg = opt2_pair(sc->code); /* cddr(value) */ - val = fx_call(sc, cdr(arg)); - set_car(sc->t3_2, fx_call(sc, arg)); - set_car(sc->t3_3, val); - set_car(sc->t3_1, slot_value(slot)); - slot_set_value(slot, sc->value = fn_proc(cadr(sc->code))(sc, sc->t3_1)); -} - -static void op_increment_sa(s7_scheme *sc) -{ - s7_pointer slot, arg; - sc->code = cdr(sc->code); - slot = lookup_slot_from(car(sc->code), sc->curlet); - arg = opt2_pair(sc->code); - set_car(sc->t2_2, fx_call(sc, arg)); - set_car(sc->t2_1, slot_value(slot)); - slot_set_value(slot, sc->value = fn_proc(cadr(sc->code))(sc, sc->t2_1)); -} - -static noreturn void no_setter_error_nr(s7_scheme *sc, s7_pointer obj) -{ - /* sc->code here is form without set!: ((abs 1) 2) from (set! (abs 1) 2) - * but in implicit case, (let ((L (list 0))) (set! (L 0 0) 2)), code is ((0 0) 2) - * at entry to s7_error: ((0 0 2)?? but we print something from define-hook-function if in the repl - * add indices and new-value args, is unevaluated code always available? - */ - int32_t typ = type(obj); - if (!is_pair(car(sc->code))) sc->code = cdr(sc->code); - - if (type(caar(sc->code)) >= T_C_FUNCTION_STAR) - error_nr(sc, sc->no_setter_symbol, - set_elist_6(sc, wrap_string(sc, "~W (~A) does not have a setter: (set! (~W~{~^ ~S~}) ~S)", 55), - caar(sc->code), sc->type_names[typ], caar(sc->code), cdar(sc->code), cadr(sc->code))); - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "~A (~A) does not have a setter: (set! ~S ~S)", 44), - caar(sc->code), sc->type_names[typ], - (is_pair(car(sc->code))) ? copy_proper_list(sc, car(sc->code)) : car(sc->code), - (is_pair(cadr(sc->code))) ? copy_proper_list(sc, cadr(sc->code)) : cadr(sc->code))); - /* copy is necessary due to the way quoted lists|symbols are handled in op_set_with_let_1|2 and copy_tree */ -} - -static bool pair3_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_pointer arg, s7_pointer value) -{ - if (!c_function_is_aritable(setf, 2)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_6(sc, wrap_string(sc, "set!: two arguments? (~A ~S ~S), ~A is (setter ~A)", 50), setf, arg, value, setf, obj)); - if (!is_safe_procedure(setf)) /* if unsafe, we can't call c_function_call(setf) directly (need drop into eval+apply) */ - { - sc->code = setf; - sc->args = list_2(sc, arg, value); - return(true); - } - sc->value = c_function_call(setf)(sc, with_list_t2(arg, value)); - return(false); -} - -static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer value) -{ - switch (type(obj)) - { - case T_C_OBJECT: - sc->value = (*(c_object_set(sc, obj)))(sc, with_list_t3(obj, arg, value)); - break; - - case T_FLOAT_VECTOR: - sc->value = g_fv_set_3(sc, with_list_t3(obj, arg, value)); - break; - case T_INT_VECTOR: - sc->value = g_iv_set_3(sc, with_list_t3(obj, arg, value)); - break; - case T_BYTE_VECTOR: - sc->value = g_bv_set_3(sc, with_list_t3(obj, arg, value)); - break; - case T_VECTOR: -#if WITH_GMP - sc->value = g_vector_set_3(sc, with_list_t3(obj, arg, value)); -#else - if (vector_rank(obj) > 1) - sc->value = g_vector_set(sc, with_list_t3(obj, arg, value)); - else - { - s7_int index; - if (!is_t_integer(arg)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); - index = integer(arg); - if (index < 0) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must not be negative: ~S", 43), sc->code)); - if (index >= vector_length(obj)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be less than vector length: ~S", 54), sc->code)); - if (is_immutable(obj)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, obj)); - if (is_typed_vector(obj)) - value = typed_vector_setter(sc, obj, index, value); - else vector_element(obj, index) = value; - sc->value = T_Ext(value); - } -#endif - break; - - case T_STRING: -#if WITH_GMP - sc->value = g_string_set(sc, with_list_t3(obj, arg, value)); -#else - { - s7_int index; - if (!is_t_integer(arg)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), sc->code)); - index = integer(arg); - if (index < 0) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must not be negative: ~S", 30), sc->code)); - if (index >= string_length(obj)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must be less than sequence length: ~S", 43), sc->code)); - if (is_immutable(obj)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, obj)); - if (!is_character(value)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "string-set!: value must be a character: ~S", 42), sc->code)); - string_value(obj)[index] = (char)s7_character(value); - sc->value = value; - } -#endif - break; - - case T_PAIR: - sc->value = g_list_set(sc, with_list_t3(obj, arg, value)); - break; - - case T_HASH_TABLE: - if (is_immutable(obj)) /* not checked in s7_hash_table_set */ - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->hash_table_set_symbol, obj)); - sc->value = s7_hash_table_set(sc, obj, arg, value); - break; - - case T_LET: - sc->value = let_set(sc, obj, arg, value); /* this checks immutable */ - break; - - case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: - case T_C_FUNCTION_STAR: /* obj here is a c_function, but its setter could be a closure and vice versa below */ - if (is_c_function(c_function_setter(obj))) - return(pair3_cfunc(sc, obj, c_function_setter(obj), arg, value)); - sc->code = c_function_setter(obj); /* closure/macro */ - sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); - return(true); /* goto APPLY; not redundant -- setter type might not match getter type */ - - case T_C_MACRO: /* (set! (setter quasiquote) (lambda args args)) (define (f) (set! (quasiquote 1) (setter 'i))) (f) (f) */ - if (is_c_function(c_macro_setter(obj))) - return(pair3_cfunc(sc, obj, c_macro_setter(obj), arg, value)); - sc->code = c_macro_setter(obj); - sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); - return(true); /* goto APPLY; */ - - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - if (is_c_function(closure_setter(obj))) - return(pair3_cfunc(sc, obj, closure_setter(obj), arg, value)); - sc->code = closure_setter(obj); - sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); - return(true); /* goto APPLY; */ - - default: - no_setter_error_nr(sc, obj); /* possibly a continuation/goto? */ - } - return(false); -} - -static bool op_set_opsq_a(s7_scheme *sc) /* (set! (symbol) fxable) */ -{ - s7_pointer setf, value, code = cdr(sc->code); - s7_pointer obj = lookup_checked(sc, caar(code)); - - if ((is_sequence(obj)) && (!is_c_object(obj))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "set!: not enough arguments for ~S: ~S", 37), caar(code), sc->code)); - - setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = cdr(code); - return(true); - } - value = fx_call(sc, cdr(code)); - if (is_c_function(setf)) - { - if (c_function_min_args(setf) > 1) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "set!: not enough arguments: (~A ~S)", 35), setf, value)); - sc->value = c_function_call(setf)(sc, with_list_t1(value)); - return(false); - } - sc->code = setf; - sc->args = list_1(sc, value); - return(true); -} - -static bool op_set_opsaq_a(s7_scheme *sc) /* (set! (symbol fxable) fxable) */ -{ - s7_pointer index, value, code = cdr(sc->code); - s7_pointer obj = lookup_checked(sc, caar(code)); - bool result; - if (could_be_macro_setter(obj)) - { - s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} - value = fx_call(sc, cdr(code)); - gc_protect_via_stack(sc, value); - if (dont_eval_args(obj)) /* this check is ridiculously expensive! 60 in tstar, similar lg, but it's faster than is_any_macro */ - index = cadar(code); /* if obj is a c_macro, surely we don't want to evaluate cdar(code)? */ - else index = fx_call(sc, cdar(code)); - set_stack_protected2(sc, index); - result = set_pair3(sc, obj, index, value); - unstack(sc); - return(result); -} - -static inline bool op_set_opsaq_p(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - /* ([set!] (car a) (cadr a)) */ - /* here the pair can't generate multiple values, or if it does, it's an error (caught below) - * splice_in_values will notice the OP_SET_opSAq_P_1 and complain. - * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a)) str)) (hi) (hi)) is "a23" - * (let ((v (make-vector '(2 3) 0))) (set! (v (values 0 1)) 23) v) -> #2D((0 23 0) (0 0 0)) - */ - s7_pointer obj = lookup_checked(sc, caar(code)); - if (could_be_macro_setter(obj)) - { - s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} - push_stack(sc, OP_SET_opSAq_P_1, obj, code); - sc->code = cadr(code); - return(false); -} - -static inline bool op_set_opsaq_p_1(s7_scheme *sc) -{ - s7_pointer value = sc->value; - s7_pointer index; - if (dont_eval_args(sc->args)) /* see above */ - index = cadar(sc->code); - else index = fx_call(sc, cdar(sc->code)); - return(set_pair3(sc, sc->args, index, value)); /* not lookup, (set! (_!asdf!_ 3) 'a) -> unbound_variable */ -} - -static bool pair4_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_pointer index1, s7_pointer index2, s7_pointer value) -{ - if (!c_function_is_aritable(setf, 3)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_7(sc, wrap_string(sc, "set!: three arguments? (~A ~S ~S ~S), ~A is (setter ~A)", 55), setf, index1, index2, value, setf, obj)); - if (!is_safe_procedure(setf)) - { - sc->code = setf; - sc->args = list_3(sc, index1, index2, value); - return(true); - } - sc->value = c_function_call(setf)(sc, with_list_t3(index1, index2, value)); - return(false); -} - -static bool set_pair4(s7_scheme *sc, s7_pointer obj, s7_pointer index1, s7_pointer index2, s7_pointer value) -{ - switch (type(obj)) - { - case T_C_OBJECT: - sc->value = (*(c_object_ref(sc, obj)))(sc, with_list_t2(obj, index1)); - return(set_pair3(sc, sc->value, index2, value)); - - case T_FLOAT_VECTOR: - sc->value = g_float_vector_set(sc, with_list_t4(obj, index1, index2, value)); /* would set_plist_4 be faster? or fv_unchecked_set_4? */ - break; - case T_INT_VECTOR: - sc->value = g_int_vector_set(sc, with_list_t4(obj, index1, index2, value)); - break; - case T_BYTE_VECTOR: - sc->value = g_byte_vector_set(sc, with_list_t4(obj, index1, index2, value)); - break; - case T_VECTOR: - if (vector_rank(obj) == 2) - sc->value = g_vector_set_4(sc, with_list_t4(obj, index1, index2, value)); - else - { - sc->value = g_vector_ref(sc, with_list_t2(obj, index1)); - return(set_pair3(sc, sc->value, index2, value)); - } - break; - - case T_PAIR: - sc->value = g_list_ref(sc, with_list_t2(obj, index1)); - return(set_pair3(sc, sc->value, index2, value)); - - case T_HASH_TABLE: - sc->value = s7_hash_table_ref(sc, obj, index1); - return(set_pair3(sc, sc->value, index2, value)); - - case T_LET: - sc->value = let_ref(sc, obj, index1); - return(set_pair3(sc, sc->value, index2, value)); - - case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: - case T_C_FUNCTION_STAR: /* obj here is a c_function, but its setter could be a closure and vice versa below */ - if (is_c_function(c_function_setter(obj))) - return(pair4_cfunc(sc, obj, c_function_setter(obj), index1, index2, value)); - sc->code = c_function_setter(obj); /* closure|macro */ - sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); - return(true); /* goto APPLY; not redundant -- setter type might not match getter type */ - - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - if (is_c_function(closure_setter(obj))) - return(pair4_cfunc(sc, obj, closure_setter(obj), index1, index2, value)); - sc->code = closure_setter(obj); - sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); - return(true); /* goto APPLY; */ - - default: - no_setter_error_nr(sc, obj); /* possibly a continuation/goto or string */ - } - return(false); /* goto start */ -} - -static bool op_set_opsaaq_a(s7_scheme *sc) /* (set! (symbol fxable fxable) fxable) */ -{ - s7_pointer index1, value, code = cdr(sc->code); - s7_pointer obj = lookup_checked(sc, caar(code)); - bool result; - if (could_be_macro_setter(obj)) - { - s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} - value = fx_call(sc, cdr(code)); - gc_protect_via_stack(sc, value); - index1 = fx_call(sc, cdar(code)); - set_stack_protected2(sc, index1); - result = set_pair4(sc, obj, index1, fx_call(sc, cddar(code)), value); - unstack(sc); - return(result); -} - -static bool op_set_opsaaq_p(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - s7_pointer obj = lookup_checked(sc, caar(code)); - if (could_be_macro_setter(obj)) - { - s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); - if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} - push_stack(sc, OP_SET_opSAAq_P_1, obj, code); - sc->code = cadr(code); - return(false); -} - -static bool op_set_opsaaq_p_1(s7_scheme *sc) -{ - s7_pointer value = sc->value; - bool result; - s7_pointer index1 = fx_call(sc, cdar(sc->code)); - gc_protect_via_stack(sc, index1); - result = set_pair4(sc, sc->args, index1, fx_call(sc, cddar(sc->code)), value); - unstack(sc); - return(result); -} - -static bool op_set1(s7_scheme *sc) -{ - s7_pointer lx = lookup_slot_from(sc->code, sc->curlet); /* if unbound variable hook here, we need the binding, not the current value */ - if (is_slot(lx)) - { - if (is_immutable(lx)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, slot_symbol(lx))); - if (slot_has_setter(lx)) - { - s7_pointer func = slot_setter(lx); - if (is_c_function(func)) - sc->value = call_c_function_setter(sc, func, sc->code, sc->value); /* perhaps better: apply_c_function -- has argnum error checks */ - else - if (is_any_procedure(func)) - { - /* don't push OP_EVAL_DONE here and call eval(sc, OP_APPLY) below -- setter might hit an error */ - /* 41297 (set! (v) val) where v=vector gets the setter, but calls vector-set! with no args */ - push_stack_no_args(sc, OP_SET_FROM_SETTER, lx); - if (has_let_arg(func)) - sc->args = list_3(sc, sc->code, sc->value, sc->curlet); - else sc->args = list_2(sc, sc->code, sc->value); /* these lists are reused as the closure_let slots in apply_lambda via apply_closure */ - sc->code = func; - return(false); /* goto APPLY */ - }} - slot_set_value(lx, sc->value); - symbol_increment_ctr(sc->code); /* see define setfib example in s7test.scm -- I'm having second thoughts about this... */ - return(true); /* continue */ - } - if (!has_let_set_fallback(sc->curlet)) /* (with-let (mock-hash-table 'b 2) (set! b 3)) */ - error_nr(sc, sc->unbound_variable_symbol, set_elist_4(sc, wrap_string(sc, "~S is unbound in (set! ~S ~S)", 29), sc->code, sc->code, sc->value)); - sc->value = call_let_set_fallback(sc, sc->curlet, sc->code, sc->value); - return(true); -} - -static bool op_set_with_let_1(s7_scheme *sc) -{ - s7_pointer e, b, x = sc->value; - /* from the T_SYNTAX branch of op_set_pair: (set! (with-let e b) x) as in let-temporarily - * here sc->value is the new value for the settee = x, args has the (as yet unevaluated) let and settee-expression. - * 'b above can be a pair = generalized set in the 'e environment. - */ - if (!is_pair(sc->args)) /* (set! (with-let) ...) */ - syntax_error_nr(sc, "with-let needs a let and a symbol: (set! (with-let) ~$)", 55, sc->value); - if (!is_pair(cdr(sc->args))) /* (set! (with-let e) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "with-let in (set! (with-let ~S) ~$) has no symbol to set?", 57), car(sc->args), sc->value)); - - e = car(sc->args); - b = cadr(sc->args); - if (is_multiple_value(x)) /* (set! (with-let lt) (values 1 2)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "can't (set! (with-let ~S ~S) (values ~{~S~^ ~})): too many values", 65), e, b, x)); - - if (is_symbol(e)) - { - if (is_symbol(b)) - { - e = lookup_checked(sc, e); /* the let */ - if (!is_let(e)) - wrong_type_error_nr(sc, sc->let_set_symbol, 1, e, a_let_string); - sc->value = let_set_1(sc, e, b, x); - pop_stack(sc); - return(true); - } - sc->value = lookup_checked(sc, e); - sc->code = set_plist_3(sc, sc->set_symbol, b, ((is_symbol(x)) || (is_pair(x))) ? set_plist_2(sc, sc->quote_symbol, x) : x); - /* (let* ((x (vector 1 2)) (lt (curlet))) (set! (with-let lt (x 0)) 32) x) here: (set! (x 0) 32) */ - return(false); /* goto SET_WITH_LET */ - } - sc->code = e; /* 'e above, an expression we need to evaluate */ - sc->args = set_plist_2(sc, b, x); /* can't reuse sc->args here via set-car! etc */ - push_stack_direct(sc, OP_SET_WITH_LET_2); - sc->cur_op = optimize_op(sc->code); - return(true); /* goto top_no_pop */ -} - -static bool op_set_with_let_2(s7_scheme *sc) -{ - s7_pointer b, x; - /* here sc->value = let = 'e, args = '(b x) where 'b might be a pair */ - if (!is_let(sc->value)) - wrong_type_error_nr(sc, sc->let_set_symbol, 1, sc->value, a_let_string); - b = car(sc->args); - if ((!is_symbol(b)) && (!is_pair(b))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "can't set ~S in ~$", 18), b, set_ulist_1(sc, global_value(sc->set_symbol), sc->args))); - x = cadr(sc->args); - if (is_symbol(b)) /* b is a symbol -- everything else is ready so call let-set! */ - { - sc->value = let_set_1(sc, sc->value, b, x); - return(true); /* continue */ - } - if ((is_symbol(x)) || (is_pair(x))) /* (set! (with-let (inlet :v (vector 1 2)) (v 0)) 'a) */ - sc->code = list_3(sc, sc->set_symbol, b, - ((is_symbol(x)) || (is_pair(x))) ? list_2(sc, sc->quote_symbol, x) : x); - else sc->code = cons(sc, sc->set_symbol, sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) 16), x=16 b=(*s7* 'print-length) */ - return(false); /* fall into SET_WITH_LET */ -} - -static bool op_set_normal(s7_scheme *sc) -{ - s7_pointer x; - sc->code = cdr(sc->code); - x = cadr(sc->code); - if (is_pair(x)) - { - push_stack_no_args(sc, OP_SET1, car(sc->code)); - sc->code = x; - return(true); - } - sc->value = (is_symbol(x)) ? lookup_checked(sc, x) : T_Ext(x); - sc->code = car(sc->code); - return(false); -} - -static Inline void inline_op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) -- why is this always inlined? saves 22 in concordance */ -{ - s7_pointer val, y = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - val = slot_value(y); - if (is_t_integer(val)) - sc->value = make_integer(sc, integer(val) + 1); - else - switch (type(val)) - { - case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) + denominator(val); - denominator(sc->value) = denominator(val); - break; - case T_REAL: - sc->value = make_real(sc, real(val) + 1.0); - break; - case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) + 1.0); - set_imag_part(sc->value, imag_part(val)); - break; - default: - sc->value = add_p_pp(sc, val, int_one); - break; - } - slot_set_value(y, sc->value); -} - -static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */ -{ - s7_pointer val, y = T_Slt(lookup_slot_from(cadr(sc->code), sc->curlet)); - val = slot_value(y); - if (is_t_integer(val)) - sc->value = make_integer(sc, integer(val) - 1); /* increment (set!) returns the new value in sc->value */ - else - switch (type(val)) - { - case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - numerator(sc->value) = numerator(val) - denominator(val); - denominator(sc->value) = denominator(val); - break; - case T_REAL: - sc->value = make_real(sc, real(val) - 1.0); - break; - case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) - 1.0); - set_imag_part(sc->value, imag_part(val)); - break; - default: - sc->value = g_subtract(sc, set_plist_2(sc, val, int_one)); - break; - } - slot_set_value(y, sc->value); -} - - -/* ---------------- implicit ref/set ---------------- */ -static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form); - -static Inline bool inline_op_implicit_vector_ref_a(s7_scheme *sc) /* called once in eval */ -{ - s7_pointer x; - s7_pointer v = lookup_checked(sc, car(sc->code)); - if (!is_any_vector(v)) - { - sc->last_function = v; - return(false); - } - x = fx_call(sc, cdr(sc->code)); - if ((s7_is_integer(x)) && - (vector_rank(v) == 1)) - { - s7_int index = s7_integer_clamped_if_gmp(sc, x); - if ((index < vector_length(v)) && (index >= 0)) - { - sc->value = (is_float_vector(v)) ? make_real(sc, float_vector(v, index)) : vector_getter(v)(sc, v, index); - return(true); - }} - sc->value = vector_ref_1(sc, v, set_plist_1(sc, x)); - return(true); -} - -static bool op_implicit_vector_ref_aa(s7_scheme *sc) /* if Inline 70 in concordance */ -{ - s7_pointer x, y, code; - s7_pointer v = lookup_checked(sc, car(sc->code)); - if ((!is_any_vector(v)) || (vector_rank(v) != 2)) - { - sc->last_function = v; - return(false); - } - code = cdr(sc->code); - x = fx_call(sc, code); - gc_protect_via_stack(sc, x); - y = fx_call(sc, cdr(code)); - set_stack_protected2(sc, y); - if ((s7_is_integer(x)) && (s7_is_integer(y)) && - (vector_rank(v) == 2)) - { - s7_int ix = s7_integer_clamped_if_gmp(sc, x); - s7_int iy = s7_integer_clamped_if_gmp(sc, y); - if ((ix >= 0) && (iy >= 0) && - (ix < vector_dimension(v, 0)) && (iy < vector_dimension(v, 1))) - { - s7_int index = (ix * vector_offset(v, 0)) + iy; - sc->value = vector_getter(v)(sc, v, index); /* check for normal vector saves in some cases, costs in others */ - unstack(sc); - return(true); - }} - sc->value = vector_ref_1(sc, v, set_plist_2(sc, x, y)); - unstack(sc); - return(true); -} - -static inline bool op_implicit_vector_set_3(s7_scheme *sc) -{ - s7_pointer i1, code = cdr(sc->code); - s7_pointer v = lookup(sc, caar(code)); - if (!is_any_vector(v)) - { - /* this could be improved -- set_pair3 perhaps: pair3 set opt3? but this calls g_vector_set_3 */ - pair_set_syntax_op(sc->code, OP_SET_UNCHECKED); - return(true); - } - i1 = fx_call(sc, cdar(code)); /* gc protect? */ - set_car(sc->t3_3, fx_call(sc, cdr(code))); - set_car(sc->t3_1, v); - set_car(sc->t3_2, i1); - sc->value = g_vector_set_3(sc, sc->t3_1); /* calls vector_setter handling any vector type whereas vector_set_p_ppp wants a normal vector */ - /* sc->value = vector_set_p_ppp(sc, v, i1, fx_call(sc, cdr(code))); */ - return(false); -} - -static bool op_implicit_vector_set_4(s7_scheme *sc) -{ - s7_pointer i1, i2, code = cdr(sc->code); - s7_pointer v = lookup(sc, caar(code)); - if (!is_any_vector(v)) - { - pair_set_syntax_op(sc->code, OP_SET_UNCHECKED); - return(true); - } - i1 = fx_call(sc, cdar(code)); - i2 = fx_call(sc, opt3_pair(sc->code)); /* cddar(code) */ - set_car(sc->t3_3, fx_call(sc, cdr(code))); - set_car(sc->t4_1, v); - set_car(sc->t3_1, i1); - set_car(sc->t3_2, i2); - sc->value = g_vector_set_4(sc, sc->t4_1); - set_car(sc->t4_1, sc->F); - return(false); -} - -static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer vect, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - /* vect is the vector, sc->code is expr without the set!, form is the full expr, args have not been evaluated! */ - s7_pointer index; - s7_int argnum; - - if (!is_pair(inds)) - wrong_number_of_args_error_nr(sc, "no index for implicit vector-set!: ~S", form); - if (is_immutable(vect)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vect)); - - argnum = proper_list_length(inds); - if ((argnum > 1) && - (is_normal_vector(vect)) && - (argnum != vector_rank(vect))) - { - /* this block needs to be first to handle (eg): - * (let ((v (vector (inlet 'a 0)))) (set! (v 0 'a) 32) v): #((inlet 'a 32)) - * sc->code here: ((v 0 'a) 32) - */ - if (vector_rank(vect) == 1) - { - s7_pointer ind = car(inds); - if (is_symbol(ind)) ind = lookup_checked(sc, ind); - if (is_t_integer(ind)) - { - s7_pointer obj; - s7_int index1 = integer(ind); - if ((index1 < 0) || (index1 >= vector_length(vect))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, car(inds), (index1 < 0) ? it_is_negative_string : it_is_too_large_string); - obj = vector_element(vect, index1); - if (!is_applicable(obj)) - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~S) is ~S which can't take arguments", 47), form, vect, car(inds), obj)); - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - }} - push_stack(sc, OP_SET2, cdr(inds), val); - sc->code = list_2(sc, vect, car(inds)); - return(goto_unopt); - } - - if ((argnum > 1) || (vector_rank(vect) > 1)) - { - if ((argnum == 2) && - (cdr(form) == sc->code) && /* form == cdr(sc->code) only on the outer call, thereafter form is the old form for better error messages */ - (is_fxable(sc, car(inds))) && - (is_fxable(sc, cadr(inds))) && - (is_fxable(sc, car(val)))) /* (set! (v fx fx) fx) */ - { - fx_annotate_args(sc, inds, sc->curlet); - fx_annotate_arg(sc, val, sc->curlet); - set_opt3_pair(form, cdr(inds)); - pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_4); - } - if ((argnum == vector_rank(vect)) && - (!is_pair(car(val)))) - { - s7_pointer p; - for (p = inds; is_pair(p); p = cdr(p)) - if (is_pair(car(p))) break; - if (is_null(p)) - { - s7_pointer pa; - s7_pointer args = safe_list_if_possible(sc, argnum + 2); - if (in_heap(args)) gc_protect_via_stack(sc, args); - car(args) = vect; - for (p = inds, pa = cdr(args); is_pair(p); p = cdr(p), pa = cdr(pa)) - { - index = car(p); - if (is_symbol(index)) - index = lookup_checked(sc, index); - if (!s7_is_integer(index)) - { - if (in_heap(args)) unstack(sc); - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), form)); - } - car(pa) = index; - } - car(pa) = car(val); - if (is_symbol(car(pa))) - car(pa) = lookup_checked(sc, car(pa)); - sc->value = g_vector_set(sc, args); - if (in_heap(args)) unstack(sc); - else clear_list_in_use(args); - return(goto_start); - }} - push_op_stack(sc, sc->vector_set_function); /* vector_setter(vect) has wrong args */ - sc->code = (is_null(cdr(inds))) ? val : pair_append(sc, cdr(inds), val); /* i.e. rest(args) + val */ - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, vect), sc->code); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); - } - - /* one index, rank == 1 */ - index = car(inds); - if ((is_symbol(car(sc->code))) && /* not (set! (#(a 0 (3)) 1) 0) -- implicit_vector_set_3 assumes symbol vect ref */ - (cdr(form) == sc->code) && - (is_fxable(sc, index)) && - (is_fxable(sc, car(val)))) - { - fx_annotate_arg(sc, inds, sc->curlet); - fx_annotate_arg(sc, val, sc->curlet); - pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_3); - } - if (!is_pair(index)) - { - s7_int ind; - s7_pointer value; - - if (is_symbol(index)) - index = lookup_checked(sc, index); - if (!s7_is_integer(index)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= vector_length(vect))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - value = car(val); - if (!is_pair(value)) - { - if (is_symbol(value)) - value = lookup_checked(sc, value); - if (is_typed_vector(vect)) - typed_vector_setter(sc, vect, ind, value); - else vector_setter(vect)(sc, vect, ind, value); - sc->value = T_Ext(value); - return(goto_start); - } - push_op_stack(sc, sc->vector_set_function); - sc->args = list_2(sc, index, vect); - sc->code = val; - return(goto_eval_args); - } - /* here the index calc might be trivial -- (+ i 1) or (- j 1) but this branch hardly ever happens */ - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, vect), val); - push_op_stack(sc, sc->vector_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - s7_pointer index; - /* c_obj's set! method needs to provide error checks */ - - if ((!is_pair(inds)) || (!is_null(cdr(inds)))) - { - push_op_stack(sc, sc->c_object_set_function); - if (is_null(inds)) - { - push_stack(sc, OP_EVAL_ARGS1, list_1(sc, c_obj), sc->nil); - sc->code = car(val); - } - else - { - sc->code = pair_append(sc, cdr(inds), val); - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, c_obj), sc->code); - sc->code = car(inds); - } - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); - } - index = car(inds); - if (!is_pair(index)) - { - s7_pointer value = car(val); - if (is_symbol(index)) - index = lookup_checked(sc, index); - if (!is_pair(value)) - { - if (is_symbol(value)) - value = lookup_checked(sc, value); - sc->value = (*(c_object_set(sc, c_obj)))(sc, with_list_t3(c_obj, index, value)); - return(goto_start); - } - push_op_stack(sc, sc->c_object_set_function); - sc->args = list_2(sc, index, c_obj); - sc->code = val; - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, c_obj), val); - push_op_stack(sc, sc->c_object_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static bool op_implicit_string_ref_a(s7_scheme *sc) -{ - s7_int index; - s7_pointer s = lookup_checked(sc, car(sc->code)); - s7_pointer x = fx_call(sc, cdr(sc->code)); - if (!is_string(s)) - { - sc->last_function = s; - return(false); - } - if (!s7_is_integer(x)) - { - sc->value = string_ref_1(sc, s, set_plist_1(sc, x)); - return(true); - } - index = s7_integer_clamped_if_gmp(sc, x); - if ((index < string_length(s)) && (index >= 0)) - { - sc->value = chars[((uint8_t *)string_value(s))[index]]; - return(true); - } - sc->value = string_ref_1(sc, s, x); - return(true); -} - -static goto_t set_implicit_string(s7_scheme *sc, s7_pointer str, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - /* here only one index makes sense and it is required, so (set! ("str") #\a), (set! ("str" . 1) #\a) and (set! ("str" 1 2) #\a) are all errors (but see below!) */ - s7_pointer index; - - if (!is_pair(inds)) - wrong_number_of_args_error_nr(sc, "no index for string set!: ~S", form); - if (!is_null(cdr(inds))) - wrong_number_of_args_error_nr(sc, "too many indices for string set!: ~S", form); - - index = car(inds); - if (!is_pair(index)) - { - s7_int ind; - if (is_symbol(index)) - index = lookup_checked(sc, index); - if (!s7_is_integer(index)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), form)); - ind = s7_integer_clamped_if_gmp(sc, index); - if ((ind < 0) || (ind >= string_length(str))) - out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); - if (is_immutable(str)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, str)); - - val = car(val); - if (!is_pair(val)) - { - if (is_symbol(val)) - val = lookup_checked(sc, val); - if (is_character(val)) - { - string_value(str)[ind] = character(val); - sc->value = val; - return(goto_start); - } - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "value must be a character: ~S", 29), form)); - } - /* maybe op_implicit_string_set_a as in vector someday, but this code isn't (currently) called much */ - push_op_stack(sc, sc->string_set_function); - sc->args = list_2(sc, index, str); - sc->code = cdr(sc->code); - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, str), val); /* args4 not 1 because we know cdr(sc->code) is a pair */ - push_op_stack(sc, sc->string_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer lst, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - s7_pointer index, index_val = NULL, value = car(val); - - if (!is_pair(inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are apparently caught somewhere else */ - wrong_number_of_args_error_nr(sc, "no index for list-set!: ~S", form); - - index = car(inds); - if (!is_pair(index)) - index_val = (is_normal_symbol(index)) ? lookup_checked(sc, index) : index; - - if (!is_null(cdr(inds))) - { - /* split (set! (a b c...) v) into (set! ((a b) c ...) v), eval (a b), return (let ((L (list (list 1 2)))) (set! (L 0 0) 3) L) */ - if (index_val) - { - s7_pointer obj = list_ref_1(sc, lst, index_val); - if (!is_applicable(obj)) - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, lst, index_val, obj)); - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - } - push_stack(sc, OP_SET2, cdr(inds), val); /* (let ((L (list (list 1 2 3)))) (set! (L (- (length L) 1) 2) 0) L) */ - sc->code = list_2(sc, caadr(form), car(inds)); - return(goto_unopt); - } - if (index_val) - { - if (!is_pair(value)) - { - set_car(sc->t2_1, index_val); - set_car(sc->t2_2, (is_symbol(value)) ? lookup_checked(sc, value) : value); - sc->value = g_list_set_1(sc, lst, sc->t2_1, 2); - return(goto_start); - } - push_op_stack(sc, sc->list_set_function); /* because cdr(inds) is nil, we're definitely calling list_set */ - sc->args = list_2(sc, index_val, lst); /* plist unsafe here */ - sc->code = val; - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, lst), val); /* plist unsafe here */ - push_op_stack(sc, sc->list_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - s7_pointer key, keyval = NULL; - - if (!is_pair(inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are apparently caught elsewhere */ - wrong_number_of_args_error_nr(sc, "no key for hash-table-set!: ~S", form); - if (is_immutable(table)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->hash_table_set_symbol, table)); - - key = car(inds); - if (is_pair(key)) - { - if (car(key) == sc->quote_symbol) - keyval = cadr(key); - } - else keyval = (is_normal_symbol(key)) ? lookup_checked(sc, key) : key; - - if (!is_null(cdr(inds))) - { - if (keyval) - { - s7_pointer obj = s7_hash_table_ref(sc, table, keyval); - if (obj == sc->F) /* (let ((h (hash-table 'b 1))) (set! (h 'a 'asdf) 32)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "in ~S, ~$ does not exist in ~S", 30), form, keyval, table)); - else - if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, table, keyval, obj)); - /* (let ((v (hash-table 'a (hash-table 'b 1)))) (set! (v 'a 'b 'b) 32) v) -> - * error: in (set! (v 'a 'b 'b) 32), ((hash-table 'b 1) 'b) is 1 which can't take arguments - * (let ((v (hash-table 'a (list 1 2)))) (set! (v 'a 1) 5)) -> code: (set! ((1 2) 1) 5) -> 5 (v: (hash-table 'a (1 5))) - */ - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - } - push_stack(sc, OP_SET2, cdr(inds), val); /* (let ((L (hash-table 'b (hash-table 'a 1)))) (set! (L (symbol "b") (symbol "a")) 0) L) */ - sc->code = list_2(sc, caadr(form), key); /* plist unsafe */ - return(goto_unopt); - } - if (keyval) - { - s7_pointer value = car(val); - if (is_pair(value)) - { - if (car(value) == sc->quote_symbol) - { - sc->value = s7_hash_table_set(sc, table, keyval, cadr(value)); - return(goto_start); - }} - else - { - sc->value = s7_hash_table_set(sc, table, keyval, (is_normal_symbol(value)) ? lookup_checked(sc, value) : value); - return(goto_start); - } - push_op_stack(sc, sc->hash_table_set_function); /* because cdr(inds) is nil, we're definitely calling hash_table_set */ - sc->args = list_2(sc, keyval, table); /* plist unsafe here */ - sc->code = val; - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, table), val); /* plist unsafe here */ - push_op_stack(sc, sc->hash_table_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_let(s7_scheme *sc, s7_pointer let, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - s7_pointer sym, symval = NULL; - - if (!is_pair(inds)) /* as above, bad val caught elsewhere */ - wrong_number_of_args_error_nr(sc, "no symbol (variable name) for let-set!: ~S", form); - - sym = car(inds); - if (is_pair(sym)) - { - if (car(sym) == sc->quote_symbol) - symval = cadr(sym); - } - else symval = (is_normal_symbol(sym)) ? lookup_checked(sc, sym) : sym; - - if (!is_null(cdr(inds))) - { - if (symval) - { - s7_pointer obj = let_ref(sc, let, symval); - if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, let, symval, obj)); - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - } - push_stack(sc, OP_SET2, cdr(inds), val); - sc->code = list_2(sc, let, car(inds)); - return(goto_unopt); - } - if (symval) - { - s7_pointer value = car(val); - if (!is_pair(value)) - { - if (is_symbol(value)) - value = lookup_checked(sc, value); - sc->value = let_set(sc, let, symval, value); - return(goto_start); - } - push_op_stack(sc, sc->let_set_function); - sc->args = list_2(sc, symval, let); - sc->code = val; - return(goto_eval_args); - } - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, let), val); - push_op_stack(sc, sc->let_set_function); - sc->code = car(inds); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_function(s7_scheme *sc, s7_pointer fnc) /* (let ((lst (list 1 2))) (set! (list-ref lst 0) 2) lst) */ -{ - if (!is_t_procedure(c_function_setter(fnc))) - { - if (!is_any_macro(c_function_setter(fnc))) - no_setter_error_nr(sc, fnc); - sc->args = (is_null(cdar(sc->code))) ? cdr(sc->code) : pair_append(sc, cdar(sc->code), cdr(sc->code)); - sc->code = c_function_setter(fnc); - /* here multiple-values can't happen because we don't eval the new-value argument */ - return(goto_apply); - } - /* here the setter can be anything, so we need to check the needs_copied_args bit. (set! ((dilambda / (let ((x 3)) (lambda (y) (+ x y))))) 3)! */ - - /* TODO: if (is_pair(cadr(sc->code))) we need to protect against values somehow - * (let-temporarily (((setter list) list)) (let () (define (f1) (values 3 4 5)) (set! (list 1 2) (f1)))) - * (let-temporarily (((setter list) list)) (set! (list 1 2) (values 3 4 5))) - * these are errors (too many args to set!) after optimization, but before they go through eval-args and return a list '(1 2 3 4 5)! - * maybe the fix is to accept values in both cases? (it's apparently impossible to catch this error currently) - * currently: - * (let-temporarily (((setter list) list)) (set! (list 1 2) (values 3 4 5))) ;'(1 2 3 4 5) - * (let-temporarily (((setter list) list)) (set! (list 1 2) 3 4 5)) ; error too many arguments to set! - * (let-temporarily (((setter list) list)) (let () (define (f) (set! (list 1 2) (values 3 4 5))) (f))) ;'(1 2 3 4 5) - * (let-temporarily (((setter list) list)) (let () (define (f) (set! (list 1 2) (values 3 4 5))) (f) (f))) ;error: too many values to set! (values 3 4 5) - */ - push_op_stack(sc, c_function_setter(fnc)); - if (is_pair(cdar(sc->code))) - { - sc->value = (is_null(cddar(sc->code))) ? cdr(sc->code) : pair_append(sc, cddar(sc->code), cdr(sc->code)); - push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->value); - sc->code = cadar(sc->code); - } - else - { - push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->nil); - sc->code = cadr(sc->code); /* new value */ - } - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer fnc) -{ - s7_pointer setter = closure_setter(fnc); - if ((setter == sc->F) && (!closure_no_setter(fnc))) /* maybe closure_setter hasn't been set yet: see fset3 in s7test.scm */ - setter = setter_p_pp(sc, fnc, sc->curlet); - if (is_t_procedure(setter)) - { - /* (set! (o g) ...), here fnc = o, sc->code = ((o g) ...) */ - push_op_stack(sc, setter); - if (is_null(cdar(sc->code))) - { - push_stack(sc, OP_EVAL_ARGS1, sc->nil, cddr(sc->code)); - sc->code = cadr(sc->code); - } - else - { - if (is_null(cddar(sc->code))) - push_stack(sc, OP_EVAL_ARGS1, sc->nil, cdr(sc->code)); - else - { - sc->value = pair_append(sc, cddar(sc->code), cdr(sc->code)); - push_stack(sc, OP_EVAL_ARGS4, sc->nil, sc->value); - } - sc->code = cadar(sc->code); - }} - else - { - if (!is_any_macro(setter)) - no_setter_error_nr(sc, fnc); - sc->args = (is_null(cdar(sc->code))) ? cdr(sc->code) : pair_append(sc, cdar(sc->code), cdr(sc->code)); - sc->code = setter; - return(goto_apply); - } - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t set_implicit_iterator(s7_scheme *sc, s7_pointer iter) -{ - s7_pointer setter = iterator_sequence(iter); - - if ((is_any_closure(setter)) || (is_any_macro(setter))) - setter = closure_setter(iterator_sequence(iter)); - else no_setter_error_nr(sc, iter); - - if (!is_null(cdar(sc->code))) /* (set! (iter ...) val) but iter is a thunk */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S (an iterator): too many arguments: ~S", 40), iter, sc->code)); - - if (is_procedure(setter)) - { - push_op_stack(sc, setter); - push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->nil); - sc->code = cadr(sc->code); /* the (as yet unevaluated) value, incoming code was ((obj) val) */ - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); - } - sc->args = cdr(sc->code); - sc->code = setter; - return(goto_apply); -} - -static goto_t set_implicit_syntax(s7_scheme *sc, s7_pointer wlet) -{ - if (wlet != global_value(sc->with_let_symbol)) - no_setter_error_nr(sc, wlet); - - /* (set! (with-let a b) x), wlet = with-let, sc->code = ((with-let a b) x) - * a and x are in the current let, b is in a, we need to evaluate a and x, then - * call (with-let a-value (set! b x-value)) - */ - sc->args = cdar(sc->code); - sc->code = cadr(sc->code); - push_stack_direct(sc, OP_SET_WITH_LET_1); - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); -} - -static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form) -{ - /* these depend on sc->code making sense given obj as the sequence being set */ - switch (type(obj)) - { - case T_STRING: return(set_implicit_string(sc, obj, inds, val, form)); - case T_PAIR: return(set_implicit_pair(sc, obj, inds, val, form)); - case T_HASH_TABLE: return(set_implicit_hash_table(sc, obj, inds, val, form)); - case T_LET: return(set_implicit_let(sc, obj, inds, val, form)); - case T_C_OBJECT: return(set_implicit_c_object(sc, obj, inds, val, form)); - case T_ITERATOR: return(set_implicit_iterator(sc, obj)); /* not sure this makes sense */ - case T_SYNTAX: return(set_implicit_syntax(sc, obj)); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - return(set_implicit_vector(sc, obj, inds, val, form)); - - case T_C_MACRO: case T_C_FUNCTION_STAR: - case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: - return(set_implicit_function(sc, obj)); /* (set! (setter...) ...) also comes here */ - - case T_MACRO: case T_MACRO_STAR: case T_BACRO: case T_BACRO_STAR: - case T_CLOSURE: case T_CLOSURE_STAR: - return(set_implicit_closure(sc, obj)); - - default: /* (set! (1 2) 3) */ - if (is_applicable(obj)) - no_setter_error_nr(sc, obj); /* this is reachable if obj is a goto or continuation: (set! (go 1) 2) in s7test.scm */ - error_nr(sc, sc->no_setter_symbol, - list_3(sc, wrap_string(sc, "in ~S, ~S has no setter", 23), - cons_unchecked(sc, sc->set_symbol, /* copy_tree(sc, form) also works but copies too much: we want to copy the ulists */ - cons(sc, copy_proper_list(sc, cadr(form)), cddr(form))), - obj)); - } - return(goto_top_no_pop); -} - -static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) ...) */ -{ - s7_pointer caar_code, obj, form = sc->code; - sc->code = cdr(sc->code); - caar_code = caar(sc->code); - if (is_symbol(caar_code)) - { - obj = lookup_slot_from(caar_code, sc->curlet); - obj = (is_slot(obj)) ? slot_value(obj) : unbound_variable(sc, caar_code); - } - else - if (!is_pair(caar_code)) - obj = caar_code; - else - { - push_stack(sc, OP_SET2, cdar(sc->code), T_Pair(cdr(sc->code))); - sc->code = caar_code; - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); - } - /* code here is the setter and the value without the "set!": ((window-width) 800), (set! (hi 0) (* 2 3)) -> ((hi 0) (* 2 3)) */ - /* for gmp case, indices need to be decoded via s7_integer, not just integer */ - return(call_set_implicit(sc, obj, cdar(sc->code), cdr(sc->code), form)); -} - -static goto_t op_set2(s7_scheme *sc) -{ - if (is_pair(sc->value)) - { - /* (let ((L '((1 2 3)))) (set! ((L 0) 1) 32) L), (let ((L '(((1 2 3))))) (set! ((L 0) 0 1) 32) L) - * any deeper nesting was handled already by the first eval - * set! looks at its first argument, if it's a symbol, it sets the associated value, - * if it's a list, it looks at the car of that list to decide which setter to call, - * if it's a list of lists, it passes the embedded lists to eval, then looks at the - * car of the result. This means that we can do crazy things like: - * (let ((x '(1)) (y '(2))) (set! ((if #t x y) 0) 32) x) - * the other args need to be evaluated (but not the list as if it were code): - * (let ((L '((1 2 3))) (index 1)) (set! ((L 0) index) 32) L) - */ - if (!s7_is_proper_list(sc, sc->args)) /* (set! ('(1 2) 1 . 2) 1) */ - syntax_error_nr(sc, "set! target arguments are an improper list: ~A", 46, sc->args); - if (is_multiple_value(sc->value)) /* this has to be at least 2 args, sc->args and sc->code make 2 more, so... */ - syntax_error_nr(sc, "set!: too many arguments: ~S", 28, - set_ulist_1(sc, sc->set_symbol, pair_append(sc, multiple_value(sc->value), pair_append(sc, sc->args, sc->code)))); - if (sc->args == sc->nil) - syntax_error_nr(sc, "list set!: not enough arguments: ~S", 35, sc->code); - push_op_stack(sc, sc->list_set_function); - if (!is_null(cdr(sc->args))) sc->code = pair_append(sc, cdr(sc->args), sc->code); - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value), T_Pair(sc->code)); - sc->code = car(sc->args); - return(goto_eval); - } - if ((is_any_vector(sc->value)) && - (vector_rank(sc->value) == proper_list_length(sc->args))) /* sc->code == new value? */ - { - /* (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1) 0) 32) L) - * bad case when args is nil: (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1)) 32) L) - */ - if (sc->args == sc->nil) - syntax_error_nr(sc, "vector set!: not enough arguments: ~S", 37, sc->code); - push_op_stack(sc, sc->vector_set_function); - if (!is_null(cdr(sc->args))) sc->code = pair_append(sc, cdr(sc->args), sc->code); - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value), T_Pair(sc->code)); - sc->code = car(sc->args); - return(goto_eval); - } - sc->code = cons_unchecked(sc, sc->set_symbol, cons(sc, set_ulist_1(sc, sc->value, sc->args), sc->code)); /* (let ((x 32)) (set! ((curlet) 'x) 3) x) */ - /* TODO: make a version of set_implicit that doesn't need all these conses! expand set_implicit and clear out pointless stuff - * we have: obj=sc->value [not pair], inds=sc->args, newval=sc->code, but we need the form for errors, and newval needs to be in a list? - * probably need to break out other cases: let|hash|string|c-obj, but all these pair_appends are also stupid - */ - return(set_implicit(sc)); -} - - -/* -------------------------------- do -------------------------------- */ -static bool safe_stepper_expr(s7_pointer expr, s7_pointer var) -{ - /* for now, just look for stepper as last element of any list - * any embedded set is handled by do_is_safe, so we don't need to descend into the depths - */ - s7_pointer p; - if (cadr(expr) == var) return(false); - for (p = cdr(expr); is_pair(cdr(p)); p = cdr(p)); - if (is_pair(p)) - { - if ((is_optimized(p)) && - (op_has_hop(p)) && - (is_safe_c_op(optimize_op(p)))) - return(true); - if (car(p) == var) return(false); - } - else - if (p == var) return(false); - return(true); -} - -static bool tree_match(s7_pointer tree) -{ - if (is_symbol(tree)) - return(is_matched_symbol(tree)); - return((is_pair(tree)) && - ((tree_match(car(tree))) || (tree_match(cdr(tree))))); -} - -static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, bool *has_set) -{ - /* here any (unsafe?) closure or jumping-op (call/cc) or shadowed variable is trouble - * we can free var_list if return(false) not after (!do_is_safe...), but it seems to make no difference, or be slightly slower - */ - /* sc->code is the complete do form (do ...) */ - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - { - s7_pointer expr = car(p); - if (is_pair(expr)) - { - s7_pointer x = car(expr); - - if ((!is_symbol(x)) && (!is_safe_c_function(x))) - return(false); - /* car(expr) ("x") is not a symbol: ((mus-data loc) chan) for example, but that's actually safe since it's - * just in effect vector-ref, there are several examples in dlocsig: ((group-speakers group) i) etc - */ - - if (is_symbol_and_syntactic(x)) - { - s7_pointer func = global_value(x), vars, cp; - opcode_t op = syntax_opcode(func); - switch (op) - { - case OP_MACROEXPAND: - return(false); - - case OP_QUOTE: - if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (quote . 1) or (quote 1 2) etc */ - return(false); - break; - - case OP_LET: case OP_LET_STAR: - case OP_LETREC: case OP_LETREC_STAR: - if ((!is_pair(cdr(expr))) || - (!is_list(cadr(expr))) || - (!is_pair(cddr(expr)))) - return(false); - cp = var_list; - for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) - { - s7_pointer var; - if (!is_pair(car(vars))) return(false); - var = caar(vars); - if (direct_memq(var, ((op == OP_LET) || (op == OP_LETREC)) ? cp : var_list)) return(false); - if ((!is_symbol(var)) || (is_keyword(var))) return(false); - cp = cons(sc, var, cp); - sc->x = cp; - } - sc->x = sc->unused; - if (!do_is_safe(sc, cddr(expr), stepper, cp, has_set)) return(false); - break; - - case OP_DO: - if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */ - return(false); - cp = var_list; - for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) - { - s7_pointer var; - if (!is_pair(car(vars))) return(false); - var = caar(vars); - if ((direct_memq(var, cp)) || (var == stepper)) return(false); - cp = cons(sc, var, cp); - sc->x = cp; - if ((is_pair(cdar(vars))) && - (!do_is_safe(sc, cdar(vars), stepper, cp, has_set))) - { - sc->x = sc->unused; - return(false); - }} - sc->x = sc->unused; - if (!do_is_safe(sc, caddr(expr), stepper, cp, has_set)) return(false); - if ((is_pair(cdddr(expr))) && - (!do_is_safe(sc, cdddr(expr), stepper, cp, has_set))) - return(false); - break; - - case OP_SET: - { - s7_pointer settee; - if (!is_pair(cdr(expr))) /* (set!) */ - return(false); - settee = cadr(expr); - if (!is_symbol(settee)) /* (set! (...) ...) which is tricky due to setter functions/macros */ - { - s7_pointer setv; - if ((!is_pair(settee)) || (!is_symbol(car(settee)))) - return(false); - setv = lookup_unexamined(sc, car(settee)); - if (!((setv) && - ((is_sequence(setv)) || - ((is_c_function(setv)) && - (is_safe_procedure(c_function_setter(setv))))))) - return(false); - if (has_set) (*has_set) = true; - } - else - { - if ((is_pair(caddr(sc->code))) && /* sc->code = do-form (formerly (cdr(do-form)) causing a bug here) */ - (is_pair(caaddr(sc->code)))) - { - bool res; - set_match_symbol(settee); - res = tree_match(caaddr(sc->code)); /* (set! end ...) in some fashion */ - clear_match_symbol(settee); - if (res) return(false); - } - if ((has_set) && (!direct_memq(cadr(expr), var_list))) /* is some non-local variable being set? */ - (*has_set) = true; - } - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) return(false); - if (!safe_stepper_expr(expr, stepper)) /* is step var's value used as the stored value by set!? */ - return(false); - } - break; - - case OP_LET_TEMPORARILY: - if ((!is_pair(cdr(expr))) || - (!is_pair(cadr(expr))) || - (!is_pair(cddr(expr)))) - return(false); - for (cp = cadr(expr); is_pair(cp); cp = cdr(cp)) - if ((!is_pair(car(cp))) || - (!is_pair(cdar(cp))) || - (!do_is_safe(sc, cdar(cp), stepper, var_list, has_set))) - return(false); - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) return(false); - break; - - case OP_COND: - for (cp = cdr(expr); is_pair(cp); cp = cdr(cp)) - if (!do_is_safe(sc, car(cp), stepper, var_list, has_set)) - return(false); - break; - - case OP_CASE: - if ((!is_pair(cdr(expr))) || - (!do_is_safe(sc, cadr(expr), stepper, var_list, has_set))) - return(false); - for (cp = cddr(expr); is_pair(cp); cp = cdr(cp)) - if ((!is_pair(car(cp))) || /* (case x #(123)...) */ - (!do_is_safe(sc, cdar(cp), stepper, var_list, has_set))) - return(false); - break; - - case OP_IF: case OP_WHEN: case OP_UNLESS: - case OP_AND: case OP_OR: case OP_BEGIN: - case OP_WITH_BAFFLE: - if (!do_is_safe(sc, cdr(expr), stepper, var_list, has_set)) - return(false); - break; - - case OP_WITH_LET: - return(true); /* ?? did I mean false here?? */ - - default: - return(false); - }} /* is_syntax(x=car(expr)) */ - else - { - /* if a macro, we'll eventually expand it (if *_optimize), but that requires a symbol lookup here and macroexpand */ - if ((!is_optimized(expr)) || - (optimize_op(expr) == OP_UNKNOWN_NP) || - (!do_is_safe(sc, cdr(expr), stepper, var_list, has_set))) - return(false); - - if ((is_symbol(x)) && (is_setter(x))) /* "setter" includes stuff like cons and vector -- x is a symbol */ - { - /* (hash-table-set! ht i 0) -- caddr is being saved, so this is not safe - * similarly (vector-set! v 0 i) etc - */ - if (is_null(cdr(expr))) /* (vector) for example */ - return((x == sc->vector_symbol) || (x == sc->list_symbol) || (x == sc->string_symbol)); - - if ((has_set) && - (!direct_memq(cadr(expr), var_list)) && /* non-local is being changed */ - ((cadr(expr) == stepper) || /* stepper is being set? */ - (!is_pair(cddr(expr))) || - (!is_pair(cdddr(expr))) || - (is_pair(cddddr(expr))) || - ((x == sc->hash_table_set_symbol) && (caddr(expr) == stepper)) || - (cadddr(expr) == stepper) || /* used to check is_symbol here and above but that's unnecessary */ - ((is_pair(cadddr(expr))) && (s7_tree_memq(sc, stepper, cadddr(expr)))))) - (*has_set) = true; - - if (!do_is_safe(sc, cddr(expr), stepper, var_list, has_set)) - return(false); - if (!safe_stepper_expr(expr, stepper)) - return(false); - }}}} - return(true); -} - -static bool preserves_type(s7_scheme *sc, uint32_t x) -{ - return((x == sc->add_class) || - (x == sc->subtract_class) || - (x == sc->multiply_class)); -} - -static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer v) -{ - if ((is_proper_list_3(sc, v)) && - (is_fxable(sc, cadr(v)))) - { - s7_pointer step_expr = caddr(v); - if ((is_optimized(step_expr)) && - (((optimize_op(step_expr) == HOP_SAFE_C_SC) && (car(v) == cadr(step_expr))) || - ((is_h_safe_c_nc(step_expr)) && /* replace with is_fxable? */ - (is_pair(cdr(step_expr))) && /* ((v 0 (+))) */ - (car(v) == cadr(step_expr)) && - ((opt1_cfunc(step_expr) == sc->add_x1) || (opt1_cfunc(step_expr) == sc->subtract_x1))) || - ((optimize_op(step_expr) == HOP_SAFE_C_CS) && (car(v) == caddr(step_expr))))) - return(step_expr); - } - return(NULL); -} - -static bool is_simple_end(s7_scheme *sc, s7_pointer end) -{ - return((is_optimized(end)) && - (is_safe_c_op(optimize_op(end))) && - (is_pair(cddr(end))) && /* end: (zero? n) */ - (cadr(end) != caddr(end)) && - ((opt1_cfunc(end) == sc->num_eq_xi) || - (optimize_op(end) == HOP_SAFE_C_SS) || (optimize_op(end) == HOP_SAFE_C_SC))); -} - -static s7_pointer fxify_step_exprs(s7_scheme *sc, s7_pointer code) -{ - s7_pointer vars = car(code); - s7_pointer e = collect_variables(sc, vars, sc->nil); /* only valid in step exprs, not in inits */ - - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_function callee = NULL; - s7_pointer expr = cdar(p); /* init */ - if (is_pair(expr)) - { - callee = fx_choose(sc, expr, sc->nil, do_symbol_is_safe); /* not vars -- they aren't defined yet */ - if (callee) set_fx(expr, callee); - } - expr = cddar(p); /* step */ - if (is_pair(expr)) - { - if ((is_pair(car(expr))) && - (!is_checked(car(expr)))) - optimize_expression(sc, car(expr), 0, e, false); - callee = fx_choose(sc, expr, vars, do_symbol_is_safe); /* fx_proc can be nil! */ - if (callee) set_fx(expr, callee); - }} - if ((is_pair(cdr(code))) && - (is_pair(cadr(code)))) - { - s7_pointer result = cdadr(code); - if ((is_pair(result)) && - (is_fxable(sc, car(result)))) - set_fx_direct(result, fx_choose(sc, result, vars, do_symbol_is_safe)); - } - return(code); -} - -static bool do_vector_has_definers(s7_scheme *sc, s7_pointer v) -{ - s7_int len = vector_length(v); - s7_pointer *els = vector_elements(v); - for (s7_int i = 0; i < len; i++) - if ((is_pair(els[i])) && - (is_symbol(car(els[i]))) && - (is_definer(car(els[i])))) /* this is a desperate kludge */ - return(true); - return(false); -} - -static /* inline */ bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree) -{ - /* we can't be very fancy here because quote gloms up everything: (cond '(define x 0) ...) etc, and the tree here can - * be arbitrarily messed up, and we need to be reasonably fast. So we accept some false positives: (case ((define)...)...) or '(define...) - * but what about ((f...)...) where (f...) returns a macro that defines something? Or (for-each or ...) where for-each and or might be - * obfuscated and the args might contain a definer? - */ - for (s7_pointer p = tree; is_pair(p); p = cdr(p)) - { - s7_pointer pp = car(p); - if (is_symbol(pp)) - { - if (is_definer(pp)) - { - if (pp == sc->varlet_symbol) /* tlet case (varlet e1 ...) */ - { - if ((is_pair(cdr(p))) && (is_symbol(cadr(p))) && (!symbol_is_in_list(sc, cadr(p)))) - return(true); - } - else - if (pp == sc->apply_symbol) - { - s7_pointer val; - if ((!is_pair(cdr(p))) || (!is_symbol(cadr(p)))) return(true); - val = lookup_unexamined(sc, cadr(p)); - if ((!val) || (!is_c_function(val))) return(true); - } - else return(true); - }} - else - if (is_pair(pp)) - { - if (do_tree_has_definers(sc, pp)) - return(true); - } - else - if ((is_applicable(pp)) && - (((is_normal_vector(pp)) && (do_vector_has_definers(sc, pp))) || - ((is_c_function(pp)) && (is_func_definer(pp))) || - ((is_syntax(pp)) && (is_syntax_definer(pp))))) - return(true); - } - return(false); -} - -static void check_do_for_obvious_errors(s7_scheme *sc, s7_pointer form) -{ - s7_pointer x, code = cdr(form); - - if ((!is_pair(code)) || /* (do . 1) */ - ((!is_pair(car(code))) && /* (do 123) */ - (is_not_null(car(code))))) /* (do () ...) is ok */ - syntax_error_nr(sc, "do: variable list is not a list: ~S", 35, form); - - if (!is_pair(cdr(code))) /* (do () . 1) */ - syntax_error_nr(sc, "do body is messed up: ~A", 24, form); - - if ((!is_pair(cadr(code))) && /* (do ((i 0)) 123) */ - (is_not_null(cadr(code)))) /* no end-test? */ - syntax_error_nr(sc, "do: end-test and end-value list is not a list: ~A", 49, form); - - if (is_pair(car(code))) - { - clear_symbol_list(sc); - for (x = car(code); is_pair(x); x = cdr(x)) - { - s7_pointer y = car(x); - if (!(is_pair(y))) /* (do (4) (= 3)) */ - syntax_error_nr(sc, "do: variable name missing? ~A", 29, form); - - if (!is_symbol(car(y))) /* (do ((3 2)) ()) */ - syntax_error_nr(sc, "do step variable: ~S is not a symbol?", 37, y); - - if (is_constant_symbol(sc, car(y))) /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */ - syntax_error_nr(sc, "do step variable: ~S is immutable", 33, y); - - if (!is_pair(cdr(y))) - syntax_error_nr(sc, "do: step variable has no initial value: ~A", 42, x); - if (!is_pair(cddr(y))) - { - if (is_not_null(cddr(y))) /* (do ((i 0 . 1)) ...) */ - syntax_error_nr(sc, "do: step variable info is an improper list?: ~A", 47, x); - } - else - if (is_not_null(cdddr(y))) /* (do ((i 0 1 (+ i 1))) ...) */ - syntax_error_nr(sc, "do: step variable info has extra stuff after the increment: ~A", 62, x); - set_local(car(y)); - - if (symbol_is_in_list(sc, car(y))) /* (do ((i 0 (+ i 1)) (i 2))...) */ - syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, x); - add_symbol_to_list(sc, car(y)); - } - if (is_not_null(x)) /* (do ((i 0 i) . 1) ((= i 1))) */ - syntax_error_nr(sc, "do: list of variables is improper: ~A", 37, form); - } - if (is_pair(cadr(code))) - { - for (x = cadr(code); is_pair(x); x = cdr(x)); - if (is_not_null(x)) /* (do ((i 0 (+ i 1))) ((= i 2) . 3) */ - syntax_error_nr(sc, "stray dot in do end section? ~A", 31, form); - } - for (x = cddr(code); is_pair(x); x = cdr(x)); - if (is_not_null(x)) - syntax_error_nr(sc, "stray dot in do body? ~A", 24, form); -} - -static s7_pointer do_end_bad(s7_scheme *sc, s7_pointer form) -{ - s7_pointer code = cdr(form); - if (is_null(cddr(code))) - { - s7_pointer p; - /* no body, end not fxable (if eval car(end) might be unopt) */ - for (p = car(code); is_pair(p); p = cdr(p)) /* gather var names */ - { - s7_pointer var = car(p); - if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */ - set_match_symbol(car(var)); - } - for (p = car(code); is_pair(p); p = cdr(p)) /* look for stuff like (do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i)) */ - { - s7_pointer var = car(p); - s7_pointer val = cddr(var); - if (is_pair(val)) - { - clear_match_symbol(car(var)); /* ignore current var */ - if (tree_match(car(val))) - { - for (s7_pointer q = car(code); is_pair(q); q = cdr(q)) - clear_match_symbol(caar(q)); - return(code); - }} - set_match_symbol(car(var)); - } - for (p = car(code); is_pair(p); p = cdr(p)) /* clear var names */ - clear_match_symbol(caar(p)); - - if (is_null(p)) - { - if ((is_null(cadr(code))) && /* (do () ()) or (do (fxable vars) ()) */ - (is_null(cddr(code)))) - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: infinite do loop: %s\n", __func__, display(form)); - return(code); - } - fxify_step_exprs(sc, code); - for (p = car(code); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((!has_fx(cdr(var))) || - ((is_pair(cddr(var))) && (!has_fx(cddr(var))))) - return(code); - } - pair_set_syntax_op(form, OP_DO_NO_BODY_NA_VARS); - return(sc->nil); - }} - return(fxify_step_exprs(sc, code)); -} - -static s7_pointer check_do(s7_scheme *sc) -{ - /* returns nil if optimizable */ - s7_pointer form = sc->code, code, vars, end, body, p; - - check_do_for_obvious_errors(sc, form); - pair_set_syntax_op(form, OP_DO_UNCHECKED); - code = cdr(form); - end = cadr(code); - - if ((!is_pair(end)) || (!is_fxable(sc, car(end)))) - return(do_end_bad(sc, form)); - - /* sc->curlet is the outer environment, local vars are in the symbol_list via check_do_for_obvious_error, and it's only needed for fx_unsafe_s */ - set_fx_direct(end, fx_choose(sc, end, sc->curlet, let_symbol_is_safe_or_listed)); - if ((is_pair(cdr(end))) && - (is_fxable(sc, cadr(end)))) - set_fx_direct(cdr(end), fx_choose(sc, cdr(end), sc->curlet, let_symbol_is_safe_or_listed)); - - vars = car(code); - if (is_null(vars)) - { - pair_set_syntax_op(form, OP_DO_NO_VARS); - if (is_fx_treeable(end)) - { - if ((is_pair(car(end))) && /* this code is repeated below */ - (has_fx(end)) && - (!(is_syntax(caar(end)))) && - (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) - { - s7_pointer v1 = NULL, v2 = NULL, v3 = NULL; - bool more_vs = false; - if (tis_slot(let_slots(sc->curlet))) /* outer vars */ - { - p = let_slots(sc->curlet); - v1 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - v2 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - v3 = slot_symbol(p); - more_vs = tis_slot(next_slot(p)); - }}} - if (v1) fx_tree_outer(sc, end, v1, v2, v3, more_vs); - }} - return(sc->nil); - } - if (do_tree_has_definers(sc, form)) /* we don't want definers in body, vars, or end test */ - return(fxify_step_exprs(sc, code)); - - body = cddr(code); - if ((is_pair(end)) && (is_pair(car(end))) && /* end test is a pair */ - (is_pair(vars)) && (is_null(cdr(vars))) && /* one stepper */ - (is_pair(body)) && (is_pair(car(body))) && /* body is normal-looking */ - ((is_symbol(caar(body))) || (is_safe_c_function(caar(body))))) - { - /* loop has one step variable, and normal-looking end test */ - s7_pointer v = car(vars), step_expr; - - fx_tree(sc, end, car(v), NULL, NULL, false); - if (is_fx_treeable(body)) /* this is thwarted by gotos */ - fx_tree(sc, body, car(v), NULL, NULL, false); - - step_expr = simple_stepper(sc, v); - if (step_expr) - { - s7_pointer orig_end = end; - set_fx(cdr(v), fx_choose(sc, cdr(v), vars, do_symbol_is_safe)); /* v is (i 0 (+ i 1)) or the like */ - - /* step var is (var const|symbol (op var const)|(op const var)) */ - end = car(end); - if ((is_simple_end(sc, end)) && - (car(v) == cadr(end))) - { - /* end var is (op var const|symbol) using same var as step so at least we can use SIMPLE_DO */ - bool has_set = false; - bool one_line = ((is_null(cdr(body))) && (is_pair(car(body)))); - if ((car(end) == sc->num_eq_symbol) && (is_symbol(cadr(end))) && (is_t_integer(caddr(end)))) - { - set_c_function(end, sc->num_eq_2); - set_opt2_con(cdr(end), caddr(end)); - set_fx_direct(orig_end, (integer(caddr(end)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); - } - set_opt1_any(code, caddr(end)); /* symbol or int(?) */ - set_opt2_pair(code, step_expr); /* caddr(caar(code)) */ - pair_set_syntax_op(form, OP_SIMPLE_DO); /* simple_do: 1 var easy step/end */ - - if ((c_function_class(opt1_cfunc(step_expr)) == sc->add_class) && /* we check above that (car(v) == cadr(step_expr)) and (car(v) == cadr(end)) */ - ((c_function_class(opt1_cfunc(end)) == sc->num_eq_class) || - (opt1_cfunc(end) == sc->geq_2))) - { - if ((one_line) && - ((!is_optimized(car(body))) || (op_no_hop(car(body)) != OP_SAFE_C_NC)) && /* this does happen: (if (= i 3) (vector-set! j 0 i)) */ - (is_symbol_and_syntactic(caar(body))) && - (s7_is_integer(caddr(step_expr))) && /* this currently blocks s7_optimize of float steppers */ - (s7_integer_clamped_if_gmp(sc, caddr(step_expr)) == 1)) - { - pair_set_syntax_op(car(body), symbol_syntax_op_checked(car(body))); - pair_set_syntax_op(form, OP_DOTIMES_P); /* dotimes_p: simple + syntax body + 1 expr */ - } - - if (((caddr(step_expr) == int_one) || (cadr(step_expr) == int_one)) && - (do_is_safe(sc, body, car(v), sc->nil, &has_set))) - { - pair_set_syntax_op(form, OP_SAFE_DO); /* safe_do: body is safe, step by 1 */ - /* no semipermanent let here because apparently do_is_safe accepts recursive calls? */ - if ((!has_set) && - (c_function_class(opt1_cfunc(end)) == sc->num_eq_class)) - { - pair_set_syntax_op(form, OP_SAFE_DOTIMES); /* safe_dotimes: end is = */ - if (is_fxable(sc, car(body))) - fx_annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); - } - fx_tree(sc, body, car(v), NULL, NULL, false); - /* an experiment (this never works...) */ - if (stack_op(sc->stack, current_stack_top(sc) - 1) == OP_SAFE_DO_STEP) - fx_tree_outer(sc, body, caaar(stack_code(sc->stack, (current_stack_top(sc) - 1))), NULL, NULL, true); - }} - return(sc->nil); - }}} - - /* we get here if there is more than one local var or anything "non-simple" about the rest */ - for (p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((!is_fxable(sc, cadr(var))) || - ((is_pair(cddr(var))) && (!is_fxable(sc, caddr(var)))) || - ((is_symbol(cadr(var))) && (is_definer_or_binder(cadr(var))))) - { - for (s7_pointer q = vars; q != p; q = cdr(q)) - clear_match_symbol(caar(q)); - return(fxify_step_exprs(sc, code)); - } - if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */ - set_match_symbol(car(var)); - } - - { - s7_pointer stepper0 = NULL, stepper1 = NULL, stepper2 = NULL, stepper3 = NULL; - bool got_pending = false, outer_shadowed = false; - - for (p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - s7_pointer val = cddr(var); - stepper3 = stepper2; - stepper2 = stepper1; - stepper1 = stepper0; - stepper0 = car(var); - if (is_pair(val)) - { - var = car(var); - clear_match_symbol(var); /* ignore current var */ - if (tree_match(car(val))) - { - for (s7_pointer q = vars; is_pair(q); q = cdr(q)) - clear_match_symbol(caar(q)); - if (is_null(body)) - got_pending = true; - else return(fxify_step_exprs(sc, code)); - } - set_match_symbol(var); - }} - - for (p = vars; is_pair(p); p = cdr(p)) - set_match_symbol(caar(p)); - for (p = let_slots(sc->curlet); tis_slot(p); p = next_slot(p)) - if (is_matched_symbol(slot_symbol(p))) - { - outer_shadowed = true; - break; - } - for (p = vars; is_pair(p); p = cdr(p)) - clear_match_symbol(caar(p)); - - /* end and steps look ok! */ - for (p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - set_fx_direct(cdr(var), fx_choose(sc, cdr(var), sc->curlet, let_symbol_is_safe)); /* init val */ - if (is_pair(cddr(var))) - { - s7_pointer step_expr = caddr(var); - set_fx_direct(cddr(var), fx_choose(sc, cddr(var), vars, do_symbol_is_safe)); /* sets opt2(cddr(var)), not opt1 */ - if (!is_pair(step_expr)) /* (i 0 0) */ - { - if (cadr(var) == caddr(var)) /* not types match: (i x y) etc */ - set_safe_stepper_expr(cddr(var)); - } - else - { - s7_pointer endp = car(end); - s7_pointer var1 = car(var); - if ((car(step_expr) != sc->quote_symbol) && /* opt1_cfunc(==opt1) might not be set in this case (sigh) */ - (is_safe_c_op(optimize_op(step_expr))) && - ((preserves_type(sc, c_function_class(opt1_cfunc(step_expr)))) || /* add etc */ - (car(step_expr) == sc->cdr_symbol) || - (car(step_expr) == sc->cddr_symbol) || - ((is_pair(cadr(var))) && - (is_pair(c_function_signature(c_function_base(opt1_cfunc(step_expr))))) && - (car(c_function_signature(c_function_base(opt1_cfunc(step_expr)))) != sc->T) && - (caadr(var) == car(step_expr))))) /* i.e. accept char-position as init/step, but not iterate */ - set_safe_stepper_expr(cddr(var)); - - if ((is_proper_list_3(sc, endp)) && (is_proper_list_3(sc, step_expr)) && - ((car(endp) == sc->num_eq_symbol) || (car(endp) == sc->geq_symbol)) && - (is_symbol(cadr(endp))) && - ((is_t_integer(caddr(endp))) || (is_symbol(caddr(endp)))) && - (car(step_expr) == sc->add_symbol) && - (var1 == cadr(endp)) && (var1 == cadr(step_expr)) && - ((car(endp) != sc->num_eq_symbol) || ((caddr(step_expr) == int_one)))) - set_step_end_ok(end); - }}} - pair_set_syntax_op(form, (got_pending) ? OP_DOX_PENDING_NO_BODY : OP_DOX); - /* there are only a couple of cases in snd-test where a multi-statement do body is completely fx-able */ - - if ((is_null(body)) && - (is_null(cdr(vars))) && - (is_pair(cdr(end))) && - (is_null(cddr(end))) && - (has_fx(cdr(end))) && - (is_pair(cdar(vars))) && - (is_pair(cddar(vars)))) - { - s7_pointer var = caar(vars); - s7_pointer step = cddar(vars); - set_opt3_any(code, (in_heap(code)) ? sc->F : make_semipermanent_let(sc, vars)); - if (!got_pending) - pair_set_syntax_op(form, OP_DOX_NO_BODY); - if (is_safe_stepper_expr(step)) - { - step = car(step); - if ((is_pair(step)) && (is_proper_list_3(sc, step))) - { - if ((car(step) == sc->add_symbol) && - (((cadr(step) == var) && (caddr(step) == int_one)) || - (caddr(step) == var)) && (cadr(step) == int_one)) - set_opt2_con(code, int_one); - else - if ((car(step) == sc->subtract_symbol) && - (cadr(step) == var) && - (caddr(step) == int_one)) - set_opt2_con(code, minus_one); - else set_opt2_con(code, int_zero); - } - else set_opt2_con(code, int_zero); - } - else set_opt2_con(code, int_zero); - } - - if (do_passes_safety_check(sc, body, sc->nil, NULL)) - { - s7_pointer var1 = NULL, var2 = NULL, var3 = NULL; - bool more_vars = false; - if (tis_slot(let_slots(sc->curlet))) /* outer vars */ - { - p = let_slots(sc->curlet); - var1 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - var2 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - var3 = slot_symbol(p); - more_vars = tis_slot(next_slot(p)); - }}} - - for (p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if (is_pair(cdr(var))) - { - if (var1) fx_tree_in(sc, cdr(var), var1, var2, var3, more_vars); /* init vals, more_vars refers to outer let, stepper3 == local let more_vars */ - if (is_pair(cddr(var))) - { - if (stepper0) fx_tree(sc, cddr(var), stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cddr(var), var1, var2, var3, more_vars); - }}} - - if ((is_pair(cdr(end))) && - (is_null(cddr(end))) && - (has_fx(cdr(end)))) - { - if (!fx_tree_in(sc, cdr(end), stepper0, stepper1, stepper2, stepper3)) - fx_tree(sc, cadr(end), stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cdr(end), var1, var2, var3, more_vars); - } - - if ((is_pair(car(end))) && - (has_fx(end)) && - (!(is_syntax(caar(end)))) && - (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) - { - if (!fx_tree_in(sc, end, stepper0, stepper1, stepper2, stepper3)) /* just the end-test, not the results */ - fx_tree(sc, car(end), stepper0, stepper1, stepper2, stepper3); /* car(end) might be (or ...) */ - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, end, var1, var2, var3, more_vars); - } - - if ((is_pair(body)) && (is_null(cdr(body))) && - (is_fxable(sc, car(body)))) - { - fx_annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); - if (stepper0) fx_tree(sc, body, stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, body, var1, var2, var3, more_vars); - }}} - return(sc->nil); -} - -static bool has_safe_steppers(s7_scheme *sc, s7_pointer let) -{ - for (s7_pointer slot = let_slots(let); tis_slot(slot); slot = next_slot(slot)) - { - s7_pointer val = slot_value(slot); - if (slot_has_expression(slot)) - { - s7_pointer step_expr = T_Pair(slot_expression(slot)); - if (is_safe_stepper_expr(step_expr)) - { - if (is_t_integer(val)) - { - if (is_int_optable(step_expr)) - set_safe_stepper(slot); - else - if (no_int_opt(step_expr)) - clear_safe_stepper(slot); - else - { - sc->pc = 0; - if (int_optimize(sc, step_expr)) - { - set_safe_stepper(slot); - set_is_int_optable(step_expr); - } - else - { - clear_safe_stepper(slot); - set_no_int_opt(step_expr); - }}} - else - if (is_small_real(val)) - { - if (is_float_optable(step_expr)) - set_safe_stepper(slot); - else - if (no_float_opt(step_expr)) - clear_safe_stepper(slot); - else - { - sc->pc = 0; - if (float_optimize(sc, step_expr)) - { - set_safe_stepper(slot); - set_is_float_optable(step_expr); - } - else - { - clear_safe_stepper(slot); - set_no_float_opt(step_expr); - }}} - else set_safe_stepper(slot); /* ?? shouldn't this check types ?? */ - }} - else - { - if (is_t_real(val)) - slot_set_value(slot, s7_make_mutable_real(sc, real(val))); - if (is_t_integer(val)) - slot_set_value(slot, make_mutable_integer(sc, integer(val))); - set_safe_stepper(slot); - } - if (!is_safe_stepper(slot)) - return(false); - } - return(true); -} - -static bool copy_if_end_ok(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7_int i, s7_pointer endp, s7_pointer stepper) -{ - if ((fn_proc(endp) == g_num_eq_2) && (is_symbol(cadr(endp))) && (is_symbol(caddr(endp)))) - { - s7_pointer end_slot = lookup_slot_from((cadr(endp) == slot_symbol(stepper)) ? caddr(endp) : cadr(endp), sc->curlet); - if ((is_slot(end_slot)) && (is_t_integer(slot_value(end_slot)))) - { - copy_to_same_type(sc, dest, source, i, integer(slot_value(end_slot)), i); - return(true); - }} - return(false); -} - -static bool op_dox_init(s7_scheme *sc) -{ - s7_pointer test, code = cdr(sc->code); - s7_pointer let = inline_make_let(sc, sc->curlet); - sc->temp1 = let; - - for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) - { - add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); - if (is_pair(cddar(vars))) - slot_set_expression(let_slots(let), cddar(vars)); - else slot_just_set_expression(let_slots(let), sc->nil); - } - set_curlet(sc, let); - sc->temp1 = sc->unused; - test = cadr(code); - if (is_true(sc, sc->value = fx_call(sc, test))) - { - sc->code = cdr(test); - return(true); /* goto DO_END_CLAUSES */ - } - sc->code = T_Pair(cddr(code)); - push_stack_no_args(sc, (intptr_t)((is_null(cdr(sc->code))) ? OP_DOX_STEP_O : OP_DOX_STEP), code); - return(false); /* goto BEGIN */ -} - -static goto_t op_dox_no_body_1(s7_scheme *sc, s7_pointer slots, s7_pointer end, int32_t steppers, s7_pointer stepper) -{ - s7_function endf = fx_proc(end); - s7_pointer endp = car(end); - if (endf == fx_c_nc) - { - endf = fn_proc(endp); - endp = cdr(endp); - } - if (steppers == 1) - { - s7_function f = fx_proc(slot_expression(stepper)); /* e.g. fx_add_s1 */ - s7_pointer a = car(slot_expression(stepper)); - if (f == fx_c_nc) - { - f = fn_proc(a); - a = cdr(a); - } - if (((f == fx_cdr_s) || (f == fx_cdr_t)) && - (cadr(a) == slot_symbol(stepper))) - { - do {slot_set_value(stepper, cdr(slot_value(stepper)));} while (endf(sc, endp) == sc->F); - sc->value = sc->T; - } - else /* (- n 1) tpeak dup */ - if (((f == fx_add_t1) || (f == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) - { - s7_pointer p = make_mutable_integer(sc, integer(slot_value(stepper))); - slot_set_value(stepper, p); - if (!no_bool_opt(end)) - { - sc->pc = 0; - if (bool_optimize(sc, end)) /* in dup.scm this costs more than the fb(o) below saves (search is short) */ - { /* but tc is much slower (and bool|int_optimize dominates) */ - opt_info *o = sc->opts[0]; - bool (*fb)(opt_info *o) = o->v[0].fb; - do {integer(p)++;} while (!fb(o)); /* do {integer(p)++;} while ((sc->value = optf(sc, endp)) == sc->F); */ - clear_mutable_integer(p); - sc->value = sc->T; - sc->code = cdr(end); - return(goto_do_end_clauses); - } - set_no_bool_opt(end); - } - do {integer(p)++;} while ((sc->value = endf(sc, endp)) == sc->F); - clear_mutable_integer(p); - } - else do {slot_set_value(stepper, f(sc, a));} while ((sc->value = endf(sc, endp)) == sc->F); - - sc->code = cdr(end); - return(goto_do_end_clauses); - } - if ((steppers == 2) && - (!tis_slot(next_slot(next_slot(slots))))) - { - s7_pointer step1 = slots; - s7_pointer expr1 = slot_expression(step1); - s7_pointer step2 = next_slot(step1); - s7_pointer expr2 = slot_expression(step2); /* presetting fx_proc/car(expr) is not faster */ - if ((fx_proc(expr2) == fx_subtract_u1) && - (is_t_integer(slot_value(step2))) && - (endf == fx_num_eq_ui)) - { - s7_int lim = integer(caddr(endp)); - for (s7_int i = integer(slot_value(step2)) - 1; i >= lim; i--) - slot_set_value(step1, fx_call(sc, expr1)); - } - else - do { - slot_set_value(step1, fx_call(sc, expr1)); - slot_set_value(step2, fx_call(sc, expr2)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - if (!is_symbol(car(sc->code))) - return(goto_do_end_clauses); - step1 = lookup_slot_from(car(sc->code), sc->curlet); - sc->value = slot_value(step1); - if (is_t_real(sc->value)) - clear_mutable_number(sc->value); - return(goto_start); - } - do { - s7_pointer slt = slots; - do { - if (slot_has_expression(slt)) - slot_set_value(slt, fx_call(sc, slot_expression(slt))); - slt = next_slot(slt); - } while (tis_slot(slt)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); -} - -static goto_t op_dox(s7_scheme *sc) -{ - /* any number of steppers using dox exprs, end also dox, body and end result arbitrary. - * since all these exprs are local, we don't need to jump until the body - */ - int64_t id, steppers = 0; - s7_pointer code, end, endp, stepper = NULL, form = sc->code, slots; - s7_function endf; -#if WITH_GMP - bool got_bignum = false; -#endif - s7_pointer let = inline_make_let(sc, sc->curlet); /* new let is not tied into the symbol lookup process yet */ - sc->temp1 = let; - sc->code = cdr(sc->code); - for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) - { - s7_pointer expr = cdar(vars), slot; - s7_pointer val = fx_call(sc, expr); - s7_pointer stp = cdr(expr); /* cddar(vars) */ -#if WITH_GMP - if (!got_bignum) got_bignum = is_big_number(val); -#endif - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, caar(vars), val); - if (is_pair(stp)) - { - steppers++; - stepper = slot; - slot_set_expression(slot, stp); - } - else slot_just_set_expression(slot, sc->nil); - slot_set_next(slot, let_slots(let)); - let_set_slots(let, slot); - } - set_curlet(sc, let); - slots = let_slots(sc->curlet); - sc->temp1 = sc->unused; - id = let_id(let); - - /* the fn_calls above could have redefined a previous stepper, so that its symbol_id is > let let_id when we get here, - * so we use symbol_set_local_slot_unchecked below to sidestep the debugger (see zauto.scm: i is a stepper, but then mock-vector-ref uses i as its index) - */ - for (s7_pointer slot = slots; tis_slot(slot); slot = next_slot(slot)) - symbol_set_local_slot_unchecked_and_unincremented(slot_symbol(slot), id, slot); - - end = cadr(sc->code); - endp = car(end); - endf = fx_proc(end); - - /* an experiment */ - if ((step_end_ok(end)) && (steppers == 1) && - (is_t_integer(slot_value(stepper)))) - { - s7_pointer stop_slot = (is_symbol(caddr(endp))) ? opt_integer_symbol(sc, caddr(endp)) : sc->nil; - if (stop_slot) /* sc->nil -> it's an integer */ - { - set_step_end(stepper); - set_do_loop_end(slot_value(stepper), (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : integer(caddr(endp))); - }} - - if (is_true(sc, sc->value = endf(sc, endp))) - { - sc->code = cdr(end); - return(goto_do_end_clauses); - } - code = cddr(sc->code); - if (is_null(code)) /* no body -- how does this happen? */ - return(op_dox_no_body_1(sc, slots, end, steppers, stepper)); - - if ((is_null(cdr(code))) && /* 1 expr, code is cdddr(form) here */ - (is_pair(car(code)))) - { - s7_pointer body = car(code); - s7_pfunc bodyf = NULL; - if ((!no_cell_opt(code)) && -#if WITH_GMP - (!got_bignum) && -#endif - (has_safe_steppers(sc, sc->curlet))) - bodyf = s7_optimize_nv(sc, code); - - if ((!bodyf) && - (is_fxable(sc, body)) && /* happens very rarely, #_* as car etc */ - (is_c_function(car(body)))) - bodyf = s7_optimize_nv(sc, set_dlist_1(sc, set_ulist_1(sc, c_function_name_to_symbol(sc, car(body)), cdr(body)))); - - if (bodyf) - { - if (steppers == 1) /* one expr body, 1 stepper */ - { - s7_pointer stepa = car(slot_expression(stepper)); - s7_function stepf = fx_proc(slot_expression(stepper)); - if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) - { - s7_int i = integer(slot_value(stepper)); - opt_info *o = sc->opts[0]; - if (bodyf == opt_cell_any_nv) - { - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - /* a laborious experiment... */ - if (!((fp == opt_p_pip_sso) && (o->v[2].p == o->v[4].p) && - (((o->v[5].p_pip_f == string_set_p_pip_unchecked) && (o->v[6].p_pi_f == string_ref_p_pi_unchecked)) || - ((o->v[5].p_pip_f == string_set_p_pip_direct) && (o->v[6].p_pi_f == string_ref_p_pi_direct)) || - ((o->v[5].p_pip_f == vector_set_p_pip_unchecked) && (o->v[6].p_pi_f == normal_vector_ref_p_pi_unchecked)) || - ((o->v[5].p_pip_f == normal_vector_set_p_pip_direct) && (o->v[6].p_pi_f == normal_vector_ref_p_pi_direct)) || - ((o->v[5].p_pip_f == list_set_p_pip_unchecked) && (o->v[6].p_pi_f == list_ref_p_pi_unchecked))) && - (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[3].p), i, endp, stepper)))) - { - if (is_step_end(stepper)) - { - s7_int lim = do_loop_end(slot_value(stepper)); - if ((i >= 0) && (lim < NUM_SMALL_INTS)) - do {fp(o); slot_set_value(stepper, small_int(++i));} while (i < lim); - else do {fp(o); slot_set_value(stepper, make_integer(sc, ++i));} while (i < lim); - sc->value = sc->T; - } - else - do { - fp(o); - slot_set_value(stepper, make_integer(sc, ++i)); - } while ((sc->value = endf(sc, endp)) == sc->F); - }} - else - if (!(((bodyf == opt_float_any_nv) && (o->v[0].fd == opt_d_7pid_ss_ss) && - (o->v[2].p == o->v[6].p) && - ((o->v[4].d_7pid_f == float_vector_set_d_7pid) || (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct)) && - (o->v[3].d_7pi_f == float_vector_ref_d_7pi) && - (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[5].p), i, endp, stepper))) || - - ((bodyf == opt_int_any_nv) && ((o->v[0].fi == opt_i_7pii_ssf) || (o->v[0].fi == opt_i_7pii_ssf_vset)) && - (o->v[2].p == o->v[4].o1->v[2].p) && - (((o->v[3].i_7pii_f == int_vector_set_i_7pii) && (o->v[4].o1->v[3].i_7pi_f == int_vector_ref_i_7pi)) || - ((o->v[3].i_7pii_f == int_vector_set_i_7pii_direct) && (o->v[4].o1->v[3].i_7pi_f == int_vector_ref_i_7pi_direct))) && - (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[4].o1->v[1].p), i, endp, stepper))))) - /* here the is_step_end business doesn't happen much */ - do { - bodyf(sc); - slot_set_value(stepper, make_integer(sc, ++i)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - do { - bodyf(sc); - slot_set_value(stepper, stepf(sc, stepa)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - - if ((steppers == 2) && - (!tis_slot(next_slot(next_slot(slots))))) - { - s7_pointer s1 = slots, s2 = next_slot(slots); - s7_function f1 = fx_proc(slot_expression(s1)); - s7_function f2 = fx_proc(slot_expression(s2)); - s7_pointer p1 = car(slot_expression(s1)); - s7_pointer p2 = car(slot_expression(s2)); - /* split out opt_float_any_nv gained nothing (see tmp), same for opt_cell_any_nv */ - if (bodyf == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - /* maybe this can be generalized (thash:79) -- explicit integer stepper, but there must be a simpler way */ - if ((f2 == fx_add_u1) && (is_t_integer(slot_value(s2))) && (endf == fx_num_eq_ui) && - (is_symbol(cadr(endp))) && (cadr(endp) == slot_symbol(s2)) && - (is_t_integer(caddr(endp))) && (!s7_tree_memq(sc, cadr(endp), body))) - { - s7_int i = integer(slot_value(s2)), endi = integer(caddr(endp)); - do { - fp(o); - slot_set_value(s1, f1(sc, p1)); - i++; - } while (i < endi); - } - else - do { - fp(o); - slot_set_value(s1, f1(sc, p1)); - slot_set_value(s2, f2(sc, p2)); - } while ((sc->value = endf(sc, endp)) == sc->F); - } - else - do { - bodyf(sc); - slot_set_value(s1, f1(sc, p1)); - slot_set_value(s2, f2(sc, p2)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - if (bodyf == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - do { - s7_pointer slot1 = slots; - fp(o); - do { - if (slot_has_expression(slot1)) - slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); - slot1 = next_slot(slot1); - } while (tis_slot(slot1)); - } while ((sc->value = endf(sc, endp)) == sc->F); - } - else - do { - s7_pointer slot1 = slots; - bodyf(sc); - do { - if (slot_has_expression(slot1)) - slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); - slot1 = next_slot(slot1); - } while (tis_slot(slot1)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - - if ((steppers == 1) && - (car(body) == sc->set_symbol) && - (is_pair(cdr(body))) && - (is_symbol(cadr(body))) && - (is_pair(cddr(body))) && - ((has_fx(cddr(body))) || (is_fxable(sc, caddr(body)))) && - (is_null(cdddr(body)))) - { - s7_pointer val = cddr(body), stepa; - s7_function stepf, valf; - s7_pointer slot = lookup_slot_from(cadr(body), sc->curlet); - if (!has_fx(val)) - set_fx(val, fx_choose(sc, val, sc->curlet, let_symbol_is_safe)); - valf = fx_proc(val); - val = car(val); - if (slot == sc->undefined) - unbound_variable_error_nr(sc, cadr(body)); - stepf = fx_proc(slot_expression(stepper)); - stepa = car(slot_expression(stepper)); - do { - slot_set_value(slot, valf(sc, val)); - slot_set_value(stepper, stepf(sc, stepa)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - - /* not fxable body (bodyf nil) but body might be gxable here: is_gxable(body) */ - if ((has_gx(body)) || (gx_annotate_arg(sc, code, sc->curlet))) - { - s7_function f = fx_proc_unchecked(code); - do { - s7_pointer slot1 = slots; - f(sc, body); - do { - if (slot_has_expression(slot1)) - slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); - slot1 = next_slot(slot1); - } while (tis_slot(slot1)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - }} - else /* more than one expr */ - { - s7_pointer p = code; - bool use_opts = false; - int32_t body_len = 0; - opt_info *body[32]; - #define MAX_OPT_BODY_SIZE 32 - - if ((!no_cell_opt(code)) && -#if WITH_GMP - (!got_bignum) && -#endif - (has_safe_steppers(sc, sc->curlet))) - { - sc->pc = 0; - for (int32_t k = 0; (is_pair(p)) && (k < MAX_OPT_BODY_SIZE); k++, p = cdr(p), body_len++) - { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - { - set_no_cell_opt(code); - p = code; - break; - } - oo_idp_nr_fixup(start); - body[k] = start; - } - use_opts = is_null(p); - } - - if (p == code) - for (; is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - - if (is_null(p)) - { - s7_pointer stepa = NULL; - s7_function stepf = NULL; - if (!use_opts) - fx_annotate_args(sc, code, sc->curlet); - - if (stepper) - { - stepf = fx_proc(slot_expression(stepper)); - stepa = car(slot_expression(stepper)); - } - while (true) - { - if (use_opts) - for (int32_t i = 0; i < body_len; i++) - body[i]->v[0].fp(body[i]); - else - for (p = code; is_pair(p); p = cdr(p)) - fx_call(sc, p); - - if (steppers == 1) - slot_set_value(stepper, stepf(sc, stepa)); - else - { - s7_pointer slot = slots; - do { - if (slot_has_expression(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - slot = next_slot(slot); - } while (tis_slot(slot)); - } - if (is_true(sc, sc->value = endf(sc, endp))) - { - sc->code = cdr(end); - return(goto_do_end_clauses); - }}}} - if ((is_null(cdr(code))) && /* one expr */ - (is_pair(car(code)))) - { - code = car(code); - if ((is_syntactic_pair(code)) || - (is_symbol_and_syntactic(car(code)))) - { - push_stack_no_args_direct(sc, OP_DOX_STEP_O); - if (is_syntactic_pair(code)) - sc->cur_op = (opcode_t)optimize_op(code); - else - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); - pair_set_syntax_op(code, sc->cur_op); - } - sc->code = code; - return(goto_top_no_pop); - }} - pair_set_syntax_op(form, OP_DOX_INIT); - sc->code = T_Pair(cddr(sc->code)); - push_stack_no_args(sc, (intptr_t)((is_null(cdr(sc->code))) ? OP_DOX_STEP_O : OP_DOX_STEP), cdr(form)); - return(goto_begin); -} - -static inline bool op_dox_step_1(s7_scheme *sc) -{ - s7_pointer slot = let_slots(sc->curlet); - do { /* every dox case has vars (else op_do_no_vars) */ - if (slot_has_expression(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - slot = next_slot(slot); - } while (tis_slot(slot)); - sc->value = fx_call(sc, cadr(sc->code)); - if (is_true(sc, sc->value)) - { - sc->code = cdadr(sc->code); - return(true); - } - return(false); -} - -static void op_dox_step(s7_scheme *sc) -{ - push_stack_no_args_direct(sc, OP_DOX_STEP); - sc->code = T_Pair(cddr(sc->code)); -} - -static void op_dox_step_o(s7_scheme *sc) -{ - push_stack_no_args_direct(sc, OP_DOX_STEP_O); - sc->code = caddr(sc->code); -} - -static void op_dox_no_body(s7_scheme *sc) -{ - s7_pointer slot, var, test, result; - s7_function testf; - - sc->code = cdr(sc->code); - var = caar(sc->code); - testf = fx_proc(cadr(sc->code)); - test = caadr(sc->code); - result = cdadr(sc->code); - - if ((!in_heap(sc->code)) && - (is_let(opt3_any(sc->code)))) /* (*repl* 'keymap) anything -> segfault because opt3_any here is #f. (see line 80517) */ - { - s7_pointer let = update_let_with_slot(sc, opt3_any(sc->code), fx_call(sc, cdr(var))); - let_set_outlet(let, sc->curlet); - set_curlet(sc, let); - } - else sc->curlet = make_let_with_slot(sc, sc->curlet, car(var), fx_call(sc, cdr(var))); - - slot = let_slots(sc->curlet); - if ((is_t_integer(slot_value(slot))) && - ((integer(opt2_con(sc->code))) != 0)) - { - s7_int incr = integer(opt2_con(sc->code)); - s7_pointer istep = make_mutable_integer(sc, integer(slot_value(slot))); - /* this can cause unexpected, but correct behavior: (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (memq x '(0)))) -> #f - * because (eq? 0 x) here is false -- memv will return '(0). tree-count is similar. - */ - slot_set_value(slot, istep); - if (testf == fx_or_2a) - { - s7_pointer t1 = cadr(test); - s7_pointer t2 = caddr(test); - s7_function f1 = fx_proc(cdr(test)); - s7_function f2 = fx_proc(cddr(test)); - while ((f1(sc, t1) == sc->F) && (f2(sc, t2) == sc->F)) - integer(istep) += incr; - } - else while (testf(sc, test) == sc->F) {integer(istep) += incr;} - if (is_small_int(integer(istep))) - slot_set_value(slot, small_int(integer(istep))); - else clear_mutable_integer(istep); - sc->value = fx_call(sc, result); - } - else - { - s7_function stepf = fx_proc(cddr(var)); - s7_pointer step = caddr(var); - if (testf == fx_or_and_2a) - { - s7_pointer f1_arg = cadr(test), p = opt3_pair(test); /* cdadr(p) */ - s7_function f1 = fx_proc(cdr(test)); - s7_pointer f2_arg = car(p); - s7_pointer f3_arg = cadr(p); - s7_function f2 = fx_proc(p); - s7_function f3 = fx_proc(cdr(p)); - if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(slot)))) - { - s7_pointer ip = make_mutable_integer(sc, integer(slot_value(slot))); - slot_set_value(slot, ip); - while ((f1(sc, f1_arg) == sc->F) && - ((f2(sc, f2_arg) == sc->F) || (f3(sc, f3_arg) == sc->F))) - integer(ip)++; - clear_mutable_integer(ip); - } - else - while ((f1(sc, f1_arg) == sc->F) && - ((f2(sc, f2_arg) == sc->F) || (f3(sc, f3_arg) == sc->F))) - slot_set_value(slot, stepf(sc, step)); - } - else while (testf(sc, test) == sc->F) {slot_set_value(slot, stepf(sc, step));} - sc->value = fx_call(sc, result); - } -} - -static void op_dox_pending_no_body(s7_scheme *sc) -{ - s7_pointer test, slots; - bool all_steps = true; - s7_pointer let = inline_make_let(sc, sc->curlet); - sc->temp1 = let; - sc->code = cdr(sc->code); - for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) - { - add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); - if (is_pair(cddar(vars))) - slot_set_expression(let_slots(let), cddar(vars)); - else - { - all_steps = false; - slot_just_set_expression(let_slots(let), sc->nil); - }} - slots = let_slots(let); - set_curlet(sc, let); - sc->temp1 = sc->unused; - test = cadr(sc->code); - - let_set_has_pending_value(sc->curlet); - if ((all_steps) && - (!tis_slot(next_slot(next_slot(slots)))) && - (is_pair(cdr(test)))) - { - s7_pointer slot1 = slots; - s7_pointer expr1 = slot_expression(slot1); - s7_pointer slot2 = next_slot(slot1); - s7_pointer expr2 = slot_expression(slot2); - while (fx_call(sc, test) == sc->F) - { - slot_simply_set_pending_value(slot1, fx_call(sc, expr1)); /* use pending_value for GC protection */ - slot_set_value(slot2, fx_call(sc, expr2)); - slot_set_value(slot1, slot_pending_value(slot1)); - } - sc->code = cdr(test); - let_clear_has_pending_value(sc->curlet); - return; - } - while ((sc->value = fx_call(sc, test)) == sc->F) - { - s7_pointer slt = slots; - do { - if (slot_has_expression(slt)) - slot_simply_set_pending_value(slt, fx_call(sc, slot_expression(slt))); - slt = next_slot(slt); - } while (tis_slot(slt)); - slt = slots; - do { - if (slot_has_expression(slt)) - slot_set_value(slt, slot_pending_value(slt)); - slt = next_slot(slt); - } while (tis_slot(slt)); - } - sc->code = cdr(test); - let_clear_has_pending_value(sc->curlet); -} - -static bool op_do_no_vars(s7_scheme *sc) -{ - s7_pointer p, form = sc->code; - int32_t i; - opt_info *body[32]; - sc->code = cdr(sc->code); - sc->pc = 0; - - for (i = 0, p = cddr(sc->code); (is_pair(p)) && (i < 32); i++, p = cdr(p)) - { - body[i] = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (is_null(p)) - { - s7_pointer end = cadr(sc->code); - sc->curlet = inline_make_let(sc, sc->curlet); - if (i == 1) - { - while ((sc->value = fx_call(sc, end)) == sc->F) body[0]->v[0].fp(body[0]); - sc->code = cdr(end); - return(true); - } - if (i == 0) /* null body! */ - { - s7_function endf = fx_proc(end); - s7_pointer endp = car(end); - while (!is_true(sc, sc->value = endf(sc, endp))); /* the assignment is (normally) in the noise */ - sc->code = cdr(end); - return(true); - } - while ((sc->value = fx_call(sc, end)) == sc->F) - for (int32_t k = 0; k < i; k++) - body[k]->v[0].fp(body[k]); - sc->code = cdr(end); - return(true); - } - /* back out */ - pair_set_syntax_op(form, OP_DO_NO_VARS_NO_OPT); - sc->curlet = make_let(sc, sc->curlet); - sc->value = fx_call(sc, cadr(sc->code)); - if (is_true(sc, sc->value)) - { - sc->code = cdadr(sc->code); - return(true); - } - push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1); - sc->code = T_Pair(cddr(sc->code)); - return(false); -} - -static void op_do_no_vars_no_opt(s7_scheme *sc) -{ - sc->code = cdr(sc->code); - sc->curlet = inline_make_let(sc, sc->curlet); -} - -static bool op_do_no_vars_no_opt_1(s7_scheme *sc) -{ - sc->value = fx_call(sc, cadr(sc->code)); - if (is_true(sc, sc->value)) - { - sc->code = cdadr(sc->code); - return(true); - } - push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1); - sc->code = T_Pair(cddr(sc->code)); - return(false); -} - -static void op_do_no_body_na_vars(s7_scheme *sc) /* vars fxable, end-test not */ -{ - s7_pointer stepper = NULL; - s7_int steppers = 0; - s7_pointer let = inline_make_let(sc, sc->curlet); - sc->temp1 = let; - sc->code = cdr(sc->code); - for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) - { - add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); - if (is_pair(cddar(vars))) - { - slot_set_expression(let_slots(let), cddar(vars)); - steppers++; - stepper = let_slots(let); - } - else slot_just_set_expression(let_slots(let), sc->nil); - } - if (steppers == 1) let_set_dox_slot1(let, stepper); - set_curlet(sc, let); - sc->temp1 = sc->unused; - push_stack_no_args_direct(sc, (intptr_t)((steppers == 1) ? OP_DO_NO_BODY_NA_VARS_STEP_1 : OP_DO_NO_BODY_NA_VARS_STEP)); - sc->code = caadr(sc->code); -} - -static bool op_do_no_body_na_vars_step(s7_scheme *sc) -{ - if (sc->value != sc->F) - { - sc->code = cdadr(sc->code); - return(true); - } - for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) - if (slot_has_expression(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - push_stack_no_args_direct(sc, OP_DO_NO_BODY_NA_VARS_STEP); - sc->code = caadr(sc->code); - return(false); -} - -static bool op_do_no_body_na_vars_step_1(s7_scheme *sc) -{ - if (sc->value != sc->F) - { - sc->code = cdadr(sc->code); - return(true); - } - slot_set_value(let_dox_slot1(sc->curlet), fx_call(sc, slot_expression(let_dox_slot1(sc->curlet)))); - push_stack_no_args_direct(sc, OP_DO_NO_BODY_NA_VARS_STEP_1); - sc->code = caadr(sc->code); - return(false); -} - -static bool do_step1(s7_scheme *sc) -{ - while (true) - { - s7_pointer code; - if (is_null(sc->args)) /* after getting the new values, transfer them into the slot_values */ - { - for (s7_pointer x = sc->code; is_pair(x); x = cdr(x)) /* sc->code here is the original sc->args list */ - { - slot_set_value(car(x), slot_pending_value(car(x))); - slot_clear_has_pending_value(car(x)); - } - pop_stack_no_op(sc); - return(true); - } - code = T_Pair(slot_expression(car(sc->args))); /* get the next stepper new value */ - if (has_fx(code)) - { - sc->value = fx_call(sc, code); - slot_set_pending_value(car(sc->args), sc->value); /* consistently slower if slot_simply_set... here? */ - sc->args = cdr(sc->args); /* go to next step var */ - } - else - { - push_stack_direct(sc, OP_DO_STEP2); - sc->code = car(code); - return(false); - }} -} - -static bool op_do_step2(s7_scheme *sc) -{ - if (is_multiple_value(sc->value)) - syntax_error_nr(sc, "do: variable step value can't be ~S", 35, set_ulist_1(sc, sc->values_symbol, sc->value)); - slot_set_pending_value(car(sc->args), sc->value); /* save current value */ - sc->args = cdr(sc->args); /* go to next step var */ - return(do_step1(sc)); -} - -static bool op_do_step(s7_scheme *sc) -{ - /* increment all vars, return to endtest - * these are also updated in parallel at the end, so we gather all the incremented values first - * here we know car(sc->args) is not null, args is the list of steppable vars, - * any unstepped vars in the do var section are not in this list, so - * (do ((i 0 (+ i 1)) (j 2)) ...) arrives here with sc->args: '(slot<((+ i 1)=expr, 0=pending_value>)) - */ - push_stack_direct(sc, OP_DO_END); - sc->args = car(sc->args); /* the var data lists */ - sc->code = sc->args; /* save the top of the list */ - return(do_step1(sc)); -} - -static goto_t do_end_code(s7_scheme *sc) -{ - if (is_pair(cdr(sc->code))) - { - if (is_undefined_feed_to(sc, car(sc->code))) - return(goto_feed_to); - /* never has_fx(sc->code) here (first of a body) */ - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - sc->code = car(sc->code); - return(goto_eval); - } - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - return(goto_start); - } - sc->code = T_Pair(car(sc->code)); - return(goto_eval); -} - -static bool do_end_clauses(s7_scheme *sc) -{ - if (!is_null(sc->code)) - return(false); - if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(true); -} - -static bool opt_do_copy(s7_scheme *sc, opt_info *o, s7_int start, s7_int stop) -{ - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; /* o->v[6].p_pi_f is getter, o->v[5].p_pip_f is setter */ - if (start >= stop) return(true); - if ((fp == opt_p_pip_sso) && - (type(slot_value(o->v[1].p)) == type(slot_value(o->v[3].p))) && - (o->v[2].p == o->v[4].p)) - { - s7_pointer caller = NULL; - s7_pointer dest = slot_value(o->v[1].p); - s7_pointer source = slot_value(o->v[3].p); - if ((is_normal_vector(dest)) && - (((o->v[5].p_pip_f == vector_set_p_pip_unchecked) || - (o->v[5].p_pip_f == normal_vector_set_p_pip_direct)) && - ((o->v[6].p_pi_f == normal_vector_ref_p_pi_unchecked) || - (o->v[6].p_pi_f == vector_ref_p_pi_unchecked) || - (o->v[6].p_pi_f == normal_vector_ref_p_pi_direct)))) - caller = sc->vector_set_symbol; - else - if ((is_string(dest)) && - (((o->v[5].p_pip_f == string_set_p_pip_unchecked) || (o->v[5].p_pip_f == string_set_p_pip_direct)) && - ((o->v[6].p_pi_f == string_ref_p_pi_unchecked) || (o->v[6].p_pi_f == string_ref_p_pi_direct)))) - caller = sc->string_set_symbol; - else - if ((is_pair(dest)) && - ((o->v[5].p_pip_f == list_set_p_pip_unchecked) && (o->v[6].p_pi_f == list_ref_p_pi_unchecked))) - caller = sc->list_set_symbol; - else return(false); - if (start < 0) - out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, start), it_is_negative_string); - if ((stop > integer(s7_length(sc, source))) || (stop > integer(s7_length(sc, dest)))) - out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, stop), it_is_too_large_string); - if ((caller) && (copy_to_same_type(sc, dest, source, start, stop, start))) - return(true); - } - return(false); -} - -static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) -{ - s7_pointer step_expr, step_var, ctr_slot, end_slot; - s7_function stepf, endf; - s7_pfunc func; - - if (no_cell_opt(cddr(code))) - return(false); - func = s7_optimize_nv(sc, cddr(code)); - if (!func) - { - set_no_cell_opt(cddr(code)); - return(false); - } - /* func must be set */ - step_expr = opt2_pair(code); /* caddr(caar(code)) */ - stepf = fn_proc(step_expr); - endf = fn_proc(caadr(code)); - ctr_slot = let_dox_slot1(sc->curlet); - end_slot = let_dox_slot2(sc->curlet); - step_var = caddr(step_expr); - /* use g* funcs (not fx) because we're passing the actual values, not the expressions */ - - if ((stepf == g_add_x1) && - (is_t_integer(slot_value(ctr_slot))) && - ((endf == g_num_eq_2) || (endf == g_num_eq_xi) || (endf == g_geq_2)) && - (is_t_integer(slot_value(end_slot)))) - { - s7_int i; - s7_int start = integer(slot_value(ctr_slot)); - s7_int stop = integer(slot_value(end_slot)); - - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if ((fp == opt_p_ppp_sss) || (fp == opt_p_ppp_sss_mul) || (fp == opt_p_ppp_sss_hset)) - { - s7_p_ppp_t fpt = o->v[4].p_ppp_f; - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fpt(sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)); - }} - else - if (fp == opt_p_ppp_sfs) - { - s7_p_ppp_t fpt = o->v[3].p_ppp_f; - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)); - }} - else - if ((fp == opt_p_pip_sss_vset) && (start >= 0) && (stop <= vector_length(slot_value(o->v[1].p)))) - { - s7_pointer *vels = vector_elements(slot_value(o->v[1].p)); /* better in callgrind, possibly slightly slower in time */ - check_free_heap_size(sc, stop - start); - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer_unchecked(sc, i)); - vels[integer(slot_value(o->v[2].p))] = slot_value(o->v[3].p); - }} - else - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }} - else - /* splitting out opt_float_any_nv here saves almost nothing */ - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - } - sc->value = sc->T; - sc->code = cdadr(code); - return(true); - } - if ((stepf == g_subtract_x1) && - (is_t_integer(slot_value(ctr_slot))) && - ((endf == g_less_x0) || (endf == g_less_2) || (endf == g_less_xi)) && - (is_t_integer(slot_value(end_slot)))) - { - s7_int i, start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)); - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - if (!opt_do_copy(sc, o, stop, start + 1)) - { - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - for (i = start; i >= stop; i--) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }}} - else - for (i = start; i >= stop; i--) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - } - sc->value = sc->T; - sc->code = cdadr(code); - return(true); - } - if ((stepf == g_add_2_xi) && - (is_t_integer(slot_value(ctr_slot))) && - ((endf == g_num_eq_2) || (endf == g_num_eq_xi) || (endf == g_geq_2)) && - (is_t_integer(slot_value(end_slot)))) - { - s7_int i, start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)), incr = integer(caddr(step_expr)); - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - for (i = start; i < stop; i += incr) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }} - else - for (i = start; i < stop; i += incr) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - } - sc->value = sc->T; - sc->code = cdadr(code); - return(true); - } - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if ((stepf == g_add_x1) && (is_t_integer(slot_value(ctr_slot))) && - (endf == g_greater_2) && (is_t_integer(slot_value(end_slot)))) - { - s7_int start = integer(slot_value(ctr_slot)); - s7_int stop = integer(slot_value(end_slot)); - if (fp == opt_cond_1b) - { - s7_pointer (*test_fp)(opt_info *o) = o->v[4].o1->v[O_WRAP].fp; - opt_info *test_o1 = o->v[4].o1; - opt_info *o2 = o->v[6].o1; - for (s7_int i = start; i <= stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - if (test_fp(test_o1) != sc->F) cond_value(o2); - }} - else - for (s7_int i = start; i <= stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }} - else - do { - fp(o); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, step_var); - slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, slot_value(end_slot)); - } while ((sc->value = endf(sc, sc->t2_1)) == sc->F); - } - else - do { - func(sc); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, step_var); - slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, slot_value(end_slot)); - } while ((sc->value = endf(sc, sc->t2_1)) == sc->F); - - sc->code = cdadr(code); - return(true); -} - -static bool op_simple_do(s7_scheme *sc) -{ - /* body might not be safe in this case, but the step and end exprs are easy */ - s7_pointer code = cdr(sc->code); - s7_pointer end = opt1_any(code); /* caddr(caadr(code)) */ - s7_pointer body = cddr(code); - - sc->curlet = make_let(sc, sc->curlet); - sc->value = fx_call(sc, cdaar(code)); - let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), sc->value)); - - if (is_symbol(end)) - let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); - else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); - set_car(sc->t2_1, let_dox1_value(sc->curlet)); - set_car(sc->t2_2, let_dox2_value(sc->curlet)); - sc->value = fn_proc(caadr(code))(sc, sc->t2_1); - if (is_true(sc, sc->value)) - { - sc->code = cdadr(code); - return(true); /* goto DO_END_CLAUSES */ - } - if ((is_null(cdr(body))) && /* one expr in body */ - (is_pair(car(body))) && /* and it is a pair */ - (is_symbol(cadr(opt2_pair(code)))) && /* caddr(caar(code)), caar=(i 0 (+ i 1)), caddr=(+ i 1), so this checks that stepf is reasonable? */ - (is_t_integer(caddr(opt2_pair(code)))) && - (op_simple_do_1(sc, cdr(sc->code)))) - return(true); /* goto DO_END_CLAUSES */ - - push_stack_no_args(sc, OP_SIMPLE_DO_STEP, code); - sc->code = body; - return(false); /* goto BEGIN */ -} - -static bool op_simple_do_step(s7_scheme *sc) -{ - s7_pointer ctr = let_dox_slot1(sc->curlet); - s7_pointer end = let_dox_slot2(sc->curlet); - s7_pointer code = sc->code; - s7_pointer step = opt2_pair(code); /* caddr(caar(code)) */ - if (is_symbol(cadr(step))) - { - set_car(sc->t2_1, slot_value(ctr)); - set_car(sc->t2_2, caddr(step)); - } - else /* is_symbol(caddr(step)) I think: (+ 1 x) vs (+ x 1) */ - { - set_car(sc->t2_2, slot_value(ctr)); - set_car(sc->t2_1, cadr(step)); - } - slot_set_value(ctr, fn_proc(step)(sc, sc->t2_1)); - set_car(sc->t2_1, slot_value(ctr)); - set_car(sc->t2_2, slot_value(end)); - end = cadr(code); - sc->value = fn_proc(car(end))(sc, sc->t2_1); - if (is_true(sc, sc->value)) - { - sc->code = cdr(end); - return(true); - } - push_stack_direct(sc, OP_SIMPLE_DO_STEP); - sc->code = T_Pair(cddr(code)); - return(false); -} - -static bool op_safe_do_step(s7_scheme *sc) -{ - s7_int end = integer(let_dox2_value(sc->curlet)); - s7_pointer slot = let_dox_slot1(sc->curlet); - s7_int step = integer(slot_value(slot)) + 1; - slot_set_value(slot, make_integer(sc, step)); - if ((step == end) || - ((step > end) && (opt1_cfunc(caadr(sc->code)) == sc->geq_2))) - { - sc->value = sc->T; - sc->code = cdadr(sc->code); - return(true); - } - push_stack_direct(sc, OP_SAFE_DO_STEP); - sc->code = T_Pair(opt2_pair(sc->code)); - return(false); -} - -static bool op_safe_dotimes_step(s7_scheme *sc) -{ - s7_pointer arg = slot_value(sc->args); - numerator(arg)++; - if (numerator(arg) == do_loop_end(arg)) - { - sc->value = sc->T; - sc->code = cdadr(sc->code); - return(true); - } - push_stack_direct(sc, OP_SAFE_DOTIMES_STEP); - sc->code = opt2_pair(sc->code); /* here we know the body has more than one form */ - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); - return(false); -} - -static bool op_safe_dotimes_step_o(s7_scheme *sc) -{ - s7_pointer arg = slot_value(sc->args); - numerator(arg)++; - if (numerator(arg) == do_loop_end(arg)) - { - sc->value = sc->T; - sc->code = cdadr(sc->code); - return(true); - } - push_stack_direct(sc, OP_SAFE_DOTIMES_STEP_O); - sc->code = opt2_pair(sc->code); - return(false); -} - -static /* inline */ bool op_dotimes_step_o(s7_scheme *sc) /* called once in eval, mat(10+6), num(7+1) */ -{ - s7_pointer ctr = let_dox_slot1(sc->curlet); - s7_pointer end = let_dox2_value(sc->curlet); - s7_pointer now = slot_value(ctr); - s7_pointer code = sc->code; - s7_pointer end_test = opt2_pair(code); - - if (is_t_integer(now)) - { - slot_set_value(ctr, make_integer(sc, integer(now) + 1)); - now = slot_value(ctr); - if (is_t_integer(end)) - { - if ((integer(now) == integer(end)) || - ((integer(now) > integer(end)) && (opt1_cfunc(end_test) == sc->geq_2))) - { - sc->value = sc->T; - sc->code = cdadr(code); - return(true); - }} - else - { - set_car(sc->t2_1, now); - set_car(sc->t2_2, end); - end = cadr(code); - sc->value = fn_proc(car(end))(sc, sc->t2_1); - if (is_true(sc, sc->value)) - { - sc->code = cdr(end); - return(true); - }}} - else - { - slot_set_value(ctr, g_add_x1(sc, with_list_t1(now))); - /* (define (hi) (let ((x 0.0) (y 1.0)) (do ((i y (+ i 1))) ((= i 6)) (do ((i i (+ i 1))) ((>= i 7)) (set! x (+ x i)))) x)) */ - set_car(sc->t2_1, slot_value(ctr)); - set_car(sc->t2_2, end); - end = cadr(code); - sc->value = fn_proc(car(end))(sc, sc->t2_1); - if (is_true(sc, sc->value)) - { - sc->code = cdr(end); - return(true); - }} - push_stack_direct(sc, OP_DOTIMES_STEP_O); - sc->code = caddr(code); - return(false); -} - -static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool safe_step) -{ - if (safe_step) /* I think safe_step means the stepper is completely unproblematic */ - set_safe_stepper(sc->args); - else set_safe_stepper(let_dox_slot1(sc->curlet)); - - if (is_null(cdr(code))) - { - s7_pfunc func; - if (no_cell_opt(code)) return(false); - func = s7_optimize_nv(sc, code); - if (!func) - { - set_no_cell_opt(code); - return(false); - } - if (safe_step) - { - s7_int end = do_loop_end(slot_value(sc->args)); - s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); - slot_set_value(sc->args, stepper); - if ((func == opt_float_any_nv) || - (func == opt_cell_any_nv)) - { - opt_info *o = sc->opts[0]; - if (func == opt_float_any_nv) - { - s7_double (*fd)(opt_info *o) = o->v[0].fd; - if ((fd == opt_d_id_sf) && /* by far the most common case in clm: (outa i ...) etc */ - (is_slot(o->v[1].p)) && - (stepper == slot_value(o->v[1].p))) - { - opt_info *o1 = sc->opts[1]; - s7_int end8 = end - 8; - s7_d_id_t f0 = o->v[3].d_id_f; - fd = o1->v[0].fd; - while (integer(stepper) < end8) - LOOP_8(f0(integer(stepper), fd(o1)); integer(stepper)++); - while (integer(stepper) < end) - { - f0(integer(stepper), fd(o1)); - integer(stepper)++; - }} - else - if ((o->v[0].fd == opt_d_7pid_ss_ss) && (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct) && - (o->v[3].d_7pi_f == float_vector_ref_d_7pi) && (o->v[2].p == o->v[6].p)) - copy_to_same_type(sc, slot_value(o->v[1].p), slot_value(o->v[5].p), integer(stepper), end, integer(stepper)); - else - if ((o->v[0].fd == opt_d_7pid_ssc) && - (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct) && - (stepper == slot_value(o->v[2].p))) - s7_fill(sc, set_elist_4(sc, slot_value(o->v[1].p), make_real(sc, o->v[3].x), stepper, make_integer(sc, end))); - else - { - s7_int end4 = end - 4; - while (integer(stepper) < end4) - LOOP_4(fd(o); integer(stepper)++); - for (; integer(stepper) < end; integer(stepper)++) - fd(o); - }} - else - { - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if ((fp == opt_p_pip_ssc) && - (stepper == slot_value(o->v[2].p)) && /* i.e. index by do counter */ - ((o->v[3].p_pip_f == string_set_p_pip_direct) || - (o->v[3].p_pip_f == normal_vector_set_p_pip_direct) || - (o->v[3].p_pip_f == list_set_p_pip_unchecked))) - s7_fill(sc, set_elist_4(sc, slot_value(o->v[1].p), o->v[4].p, stepper, make_integer(sc, end))); - else - if (fp == opt_if_bp) - { - for (; integer(stepper) < end; integer(stepper)++) - if (o->v[3].fb(o->v[2].o1)) o->v[5].fp(o->v[4].o1); - } - else - if (fp == opt_if_nbp_fs) - { - for (; integer(stepper) < end; integer(stepper)++) - if (!(o->v[2].b_pi_f(sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) o->v[11].fp(o->v[10].o1); - } - else - if (fp == opt_unless_p_1) - { - for (; integer(stepper) < end; integer(stepper)++) - if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1); - } - else for (; integer(stepper) < end; integer(stepper)++) fp(o); - }} - else - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - if ((fi == opt_i_7pii_ssc) && (stepper == slot_value(o->v[2].p)) && (o->v[3].i_7pii_f == int_vector_set_i_7pii_direct)) - s7_fill(sc, set_elist_4(sc, slot_value(o->v[1].p), make_integer(sc, o->v[4].i), stepper, make_integer(sc, end))); - else - if ((o->v[3].i_7pii_f == int_vector_set_i_7pii_direct) && (o->v[5].fi == opt_7pi_ss_ivref) && (o->v[2].p == o->v[4].o1->v[2].p)) - copy_to_same_type(sc, slot_value(o->v[1].p), slot_value(o->v[4].o1->v[1].p), integer(stepper), end, integer(stepper)); - else - for (; integer(stepper) < end; integer(stepper)++) - fi(o); - } - else /* (((i 0 (+ i 1))) ((= i 1)) (char-alphabetic? (string-ref #u(0 1) 1))) or (logbit? i -1): kinda nutty */ - for (; integer(stepper) < end; integer(stepper)++) - func(sc); - - clear_mutable_integer(stepper); - } - else /* not safe_step */ - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - s7_pointer end_slot = let_dox_slot2(sc->curlet); - s7_int step = integer(slot_value(step_slot)); - s7_int stop = integer(slot_value(end_slot)); - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if (!opt_do_copy(sc, o, step, stop)) - { - if ((step >= 0) && (stop < NUM_SMALL_INTS)) - { - if (fp == opt_when_p_2) - { - while (step < stop) - { - slot_set_value(step_slot, small_int(step)); - if (o->v[4].fb(o->v[3].o1)) - { - o->v[6].fp(o->v[5].o1); - o->v[8].fp(o->v[7].o1); - } - step = integer(slot_value(step_slot)) + 1; - }} - else - while (step < stop) - { - slot_set_value(step_slot, small_int(step)); - fp(o); - step = integer(slot_value(step_slot)) + 1; - }} - else - while (step < stop) - { - slot_set_value(step_slot, make_integer(sc, step)); - fp(o); - step = integer(slot_value(step_slot)) + 1; - }}} - else - if ((step >= 0) && (stop < NUM_SMALL_INTS)) - while (step < stop) - { - slot_set_value(step_slot, small_int(step)); - func(sc); - step = integer(slot_value(step_slot)) + 1; - } - else - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - while (step < stop) - { - slot_set_value(step_slot, make_integer(sc, step)); - fi(o); - step = integer(slot_value(step_slot)) + 1; - }} - else - while (step < stop) - { - slot_set_value(step_slot, make_integer(sc, step)); - func(sc); - step = integer(slot_value(step_slot)) + 1; - }} - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); - } - { - s7_pointer p; - s7_int body_len = s7_list_length(sc, code); - opt_info *body[32]; - int32_t k; - - sc->pc = 0; - if (body_len >= 32) return(false); - - if (!no_float_opt(code)) - { - for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) - { - body[k] = sc->opts[sc->pc]; - if (!float_optimize(sc, p)) - break; - } - if (is_pair(p)) - { - pc_fallback(sc, 0); - set_no_float_opt(code); - } - else - { - s7_int end = do_loop_end(slot_value(sc->args)); - if (safe_step) - { - s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); - slot_set_value(sc->args, stepper); - for (; integer(stepper) < end; integer(stepper)++) - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); - clear_mutable_integer(stepper); - } - else - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - s7_pointer end_slot = let_dox_slot2(sc->curlet); - s7_int stop = integer(slot_value(end_slot)); - for (s7_int step = integer(slot_value(step_slot)); step < stop; step = integer(slot_value(step_slot)) + 1) - { - slot_set_value(step_slot, make_integer(sc, step)); - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); - }} - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); - }} - - /* not float opt */ - sc->pc = 0; - for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) - { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - oo_idp_nr_fixup(start); - body[k] = start; - } - if (is_null(p)) - { - s7_int end = do_loop_end(slot_value(sc->args)); - if (safe_step) - { - s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); - slot_set_value(sc->args, stepper); - if ((body_len & 0x3) == 0) - for (; integer(stepper) < end; integer(stepper)++) - for (int32_t i = 0; i < body_len; ) - LOOP_4(body[i]->v[0].fp(body[i]); i++); - else - for (; integer(stepper) < end; integer(stepper)++) - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fp(body[i]); - clear_mutable_integer(stepper); - } - else - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - s7_pointer end_slot = let_dox_slot2(sc->curlet); - s7_int stop = integer(slot_value(end_slot)); - for (s7_int step = integer(slot_value(step_slot)); step < stop; step = integer(slot_value(step_slot)) + 1) - { - slot_set_value(step_slot, make_integer(sc, step)); - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fp(body[i]); - }} - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); - }} - return(false); -} - -static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) -{ - s7_pointer let_body, p = NULL, let_vars, let_code = caddr(scc), ip; - bool let_star; - s7_pointer old_e, stepper; - s7_int body_len, var_len, k, end; - #define O_SIZE 32 - opt_info *body[O_SIZE], *vars[O_SIZE]; - memclr((void *)body, O_SIZE * sizeof(opt_info *)); /* placate the damned compiler */ - memclr((void *)vars, O_SIZE * sizeof(opt_info *)); - - /* do_let with non-float vars doesn't get many fixable hits */ - if ((!is_pair(cdr(let_code))) || (!is_list(cadr(let_code)))) /* (do ((j 0 (+ j 1))) ((= j 1)) (let name 123)) */ - return(false); - let_body = cddr(let_code); - body_len = s7_list_length(sc, let_body); - if ((body_len <= 0) || (body_len >= 32)) return(false); - let_star = (symbol_syntax_op_checked(let_code) == OP_LET_STAR); - let_vars = cadr(let_code); - set_safe_stepper(step_slot); - stepper = slot_value(step_slot); - old_e = sc->curlet; - sc->curlet = make_let(sc, sc->curlet); - - sc->pc = 0; - for (var_len = 0, p = let_vars; (is_pair(p)) && (var_len < 32); var_len++, p = cdr(p)) - { - if ((!is_pair(car(p))) || - (!is_normal_symbol(caar(p))) || - (!is_pair(cdar(p)))) - return(false); - vars[var_len] = sc->opts[sc->pc]; - if (!float_optimize(sc, cdar(p))) /* each of these needs to set the associated variable */ - { - set_curlet(sc, old_e); - return(false); - } - if (let_star) - add_slot_checked(sc, sc->curlet, caar(p), s7_make_mutable_real(sc, 1.5)); - } - - if (!let_star) - for (p = let_vars; is_pair(p); p = cdr(p)) - add_slot_checked(sc, sc->curlet, caar(p), s7_make_mutable_real(sc, 1.5)); - - for (k = 0, p = let_body; is_pair(p); k++, p = cdr(p)) - { - body[k] = sc->opts[sc->pc]; - if (!float_optimize(sc, p)) - { - set_curlet(sc, old_e); - return(false); - }} - if (!is_null(p)) /* no hits in s7test or snd-test */ - { - set_curlet(sc, old_e); - return(false); - } - end = do_loop_end(stepper); - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - ip = slot_value(step_slot); - - if (body_len == 1) - { - if (var_len == 1) - { - opt_info *first = sc->opts[0]; - opt_info *o = body[0]; - s7_pointer xp = t_lookup(sc, caar(let_vars), let_vars); - s7_double (*f1)(opt_info *o) = first->v[0].fd; - s7_double (*f2)(opt_info *o) = o->v[0].fd; - integer(ip) = numerator(stepper); - set_real(xp, f1(first)); - f2(o); - if ((f2 == opt_fmv) && - (f1 == opt_d_dd_ff_o2) && - (first->v[3].d_dd_f == add_d_dd) && - (slot_symbol(step_slot) == slot_symbol(o->v[2].p))) - { - opt_info *o1 = o->v[12].o1; - opt_info *o2 = o->v[13].o1; - opt_info *o3 = o->v[14].o1; - s7_d_vid_t vf7 = o->v[4].d_vid_f; - s7_d_v_t vf1 = first->v[4].d_v_f; - s7_d_v_t vf2 = first->v[5].d_v_f; - s7_d_v_t vf3 = o1->v[2].d_v_f; - s7_d_v_t vf4 = o3->v[5].d_v_f; - s7_d_vd_t vf5 = o2->v[3].d_vd_f; - s7_d_vd_t vf6 = o3->v[6].d_vd_f; - void *obj1 = first->v[1].obj; - void *obj2 = first->v[2].obj; - void *obj3 = o1->v[1].obj; - void *obj4 = o3->v[1].obj; - void *obj5 = o->v[5].obj; - void *obj6 = o2->v[5].obj; - void *obj7 = o3->v[2].obj; - for (k = numerator(stepper) + 1; k < end; k++) - { - s7_double vib = vf1(obj1) + vf2(obj2); - s7_double amp_env = vf3(obj3); - vf7(obj5, k, amp_env * vf5(obj6, vib + (vf4(obj4) * vf6(obj7, vib)))); - }} - else - for (k = numerator(stepper) + 1; k < end; k++) - { - integer(ip) = k; - set_real(xp, f1(first)); - f2(o); - }} /* body_len == 1 and var_len == 1 */ - else - { - if (var_len == 2) - { - s7_pointer s1 = let_slots(sc->curlet); - s7_pointer s2 = next_slot(s1); - for (k = numerator(stepper); k < end; k++) - { - integer(ip) = k; - set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); - set_real(slot_value(s2), vars[1]->v[0].fd(vars[1])); - body[0]->v[0].fd(body[0]); - }} /* body_len == 1 and var_len == 2 */ - else - for (k = numerator(stepper); k < end; k++) - { - integer(ip) = k; - p = let_slots(sc->curlet); - for (int32_t n = 0; tis_slot(p); n++, p = next_slot(p)) - set_real(slot_value(p), vars[n]->v[0].fd(vars[n])); - body[0]->v[0].fd(body[0]); - }}} /* end body_len == 1 */ - else - if ((body_len == 2) && (var_len == 1)) - { - s7_pointer s1 = let_slots(sc->curlet); - for (k = numerator(stepper); k < end; k++) - { - integer(ip) = k; - set_real(slot_value(s1), vars[0]->v[0].fd(vars[0])); - body[0]->v[0].fd(body[0]); - body[1]->v[0].fd(body[1]); - }} - else - for (k = numerator(stepper); k < end; k++) - { - int32_t i; - integer(ip) = k; - for (i = 0, p = let_slots(sc->curlet); tis_slot(p); i++, p = next_slot(p)) - set_real(slot_value(p), vars[i]->v[0].fd(vars[i])); - for (i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); - } - set_curlet(sc, old_e); - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); -} - -static bool dotimes(s7_scheme *sc, s7_pointer code, bool safe_case) -{ - s7_pointer body = caddr(code); /* here we assume one expr in body */ - if (((is_syntactic_pair(body)) || - (is_symbol_and_syntactic(car(body)))) && - ((symbol_syntax_op_checked(body) == OP_LET) || - (symbol_syntax_op(car(body)) == OP_LET_STAR))) - return(do_let(sc, sc->args, code)); - return(opt_dotimes(sc, cddr(code), code, safe_case)); -} - -static goto_t op_safe_dotimes(s7_scheme *sc) -{ - s7_pointer init_val, form = sc->code; - sc->code = cdr(sc->code); - - init_val = fx_call(sc, cdaar(sc->code)); - if (s7_is_integer(init_val)) - { - s7_pointer end_expr = caadr(sc->code); - s7_pointer code = sc->code; - s7_pointer end_val = caddr(end_expr); - if (is_symbol(end_val)) - end_val = lookup_checked(sc, end_val); - - if (s7_is_integer(end_val)) - { - sc->code = cddr(code); - sc->curlet = make_let(sc, sc->curlet); - sc->args = add_slot_checked(sc, sc->curlet, caaar(code), make_mutable_integer(sc, s7_integer_clamped_if_gmp(sc, init_val))); - set_do_loop_end(slot_value(sc->args), s7_integer_clamped_if_gmp(sc, end_val)); - set_step_end(sc->args); /* safe_dotimes step is by 1 */ - - /* (define (hi) (do ((i 1 (+ 1 i))) ((= i 1) i))) -- we need the let even if the loop is not evaluated */ - - /* safe_dotimes: (car(body) is known to be a pair here) - * if 1-expr body look for syntactic case, if let(*) goto do_let, else opt_dotimes - * if they are unhappy, got safe_dotimes_step_o - * else goto opt_dotimes then safe_dotimes_step_o - * if multi-line body, check opt_dotimes, then safe_dotimes_step - */ - if (s7_integer_clamped_if_gmp(sc, init_val) == s7_integer_clamped_if_gmp(sc, end_val)) - { - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - } - if ((is_null(cdr(sc->code))) && - (is_pair(car(sc->code)))) - { - sc->code = car(sc->code); - set_opt2_pair(code, sc->code); /* is_pair above */ - if ((is_syntactic_pair(sc->code)) || - (is_symbol_and_syntactic(car(sc->code)))) - { - if (!is_unsafe_do(code)) - { - if (dotimes(sc, code, true)) - return(goto_safe_do_end_clauses); - set_unsafe_do(code); - } - push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); - if (is_syntactic_pair(sc->code)) - sc->cur_op = (opcode_t)optimize_op(sc->code); - else - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); - pair_set_syntax_op(sc->code, sc->cur_op); - } - return(goto_top_no_pop); - } - /* car not syntactic? */ - if ((!is_unsafe_do(code)) && - (opt_dotimes(sc, cddr(code), code, true))) - return(goto_safe_do_end_clauses); - set_unsafe_do(code); - - if (has_fx(cddr(code))) /* this almost never happens and the func case below is only in timing tests */ - { - s7_int end = s7_integer_clamped_if_gmp(sc, end_val); - s7_pointer body = cddr(code), stepper = slot_value(sc->args); - for (; integer(stepper) < end; integer(stepper)++) - fx_call(sc, body); - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - } - push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); /* arg is local step var slot, code is do form - do, sc->code is the body */ - return(goto_eval); - } - /* multi-line body */ - if ((!is_unsafe_do(code)) && - (opt_dotimes(sc, sc->code, code, true))) - return(goto_safe_do_end_clauses); - set_unsafe_do(code); - set_opt2_pair(code, sc->code); - push_stack(sc, OP_SAFE_DOTIMES_STEP, sc->args, code); - return(goto_begin); - }} - pair_set_syntax_op(form, OP_SIMPLE_DO); - sc->code = form; - if (op_simple_do(sc)) return(goto_do_end_clauses); - return(goto_begin); -} - -static goto_t op_safe_do(s7_scheme *sc) -{ - /* body is safe, step = +1, end is = or >=, but stepper and end might be set (or at least indirectly exported) in the body: - * (let ((lst ())) (do ((i 0 (+ i 1))) ((= i 10)) (let ((j (min i 100))) (set! lst (cons j lst)))) lst) - * however, we're very restrictive about this in check_do and do_is_safe; even this is considered trouble: - * (let ((x 0)) (do ((i i (+ i 1))) ((= i 7)) (set! x (+ x i))) x) - * but end might not be an integer -- need to catch this earlier. - */ - s7_pointer end, init_val, end_val, code, form = sc->code; - - /* inits, if not >= opt_dotimes else safe_do_step */ - sc->code = cdr(sc->code); - code = sc->code; - init_val = fx_call(sc, cdaar(code)); - end = opt1_any(code); /* caddr(caadr(code)) */ - end_val = (is_symbol(end)) ? lookup_checked(sc, end) : end; - - if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) /* this almost never happens */ - { - pair_set_syntax_op(form, OP_DO_UNCHECKED); - return(goto_do_unchecked); - } - - /* (let ((sum 0)) (define (hi) (do ((i 10 (+ i 1))) ((= i 10) i) (set! sum (+ sum i)))) (hi)) */ - sc->curlet = make_let(sc, sc->curlet); - let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), init_val)); /* define the step var -- might be needed in the end clauses */ - - if ((s7_integer_clamped_if_gmp(sc, init_val) == s7_integer_clamped_if_gmp(sc, end_val)) || - ((s7_integer_clamped_if_gmp(sc, init_val) > s7_integer_clamped_if_gmp(sc, end_val)) && - (opt1_cfunc(caadr(code)) == sc->geq_2))) - { - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - } - - if (is_symbol(end)) - let_set_dox_slot2(sc->curlet, lookup_slot_from(end, sc->curlet)); - else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end)); - sc->args = let_dox_slot2(sc->curlet); /* the various safe steps assume sc->args is the end slot */ - - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - set_step_end(step_slot); - slot_set_value(step_slot, make_mutable_integer(sc, integer(slot_value(step_slot)))); - set_do_loop_end(slot_value(step_slot), s7_integer_clamped_if_gmp(sc, end_val)); - } - - if (!is_unsafe_do(sc->code)) - { - s7_pointer old_let = sc->curlet; - sc->temp7 = old_let; - if (opt_dotimes(sc, cddr(sc->code), sc->code, false)) - return(goto_safe_do_end_clauses); - set_curlet(sc, old_let); /* apparently s7_optimize can step on sc->curlet? */ - sc->temp7 = sc->unused; - } - if (is_null(cdddr(sc->code))) - { - s7_pointer body = caddr(sc->code); - if ((car(body) == sc->set_symbol) && - (is_pair(cdr(body))) && - (is_symbol(cadr(body))) && - (is_pair(cddr(body))) && - (has_fx(cddr(body))) && - (is_null(cdddr(body)))) - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - if (slot_symbol(step_slot) != cadr(body)) - { - s7_int endi = integer(let_dox2_value(sc->curlet)); - s7_pointer fx_p = cddr(body); - s7_pointer val_slot = lookup_slot_from(cadr(body), sc->curlet); - s7_int step = integer(slot_value(step_slot)); - s7_pointer step_val = make_mutable_integer(sc, step); - slot_set_value(step_slot, step_val); - do { - slot_set_value(val_slot, fx_call(sc, fx_p)); - integer(step_val) = ++step; - } while (step != endi); /* geq not needed here -- we're leq endi and stepping by +1 all ints */ - clear_mutable_integer(step_val); - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - }}} - sc->code = cddr(code); - set_unsafe_do(sc->code); - set_opt2_pair(code, sc->code); - push_stack_no_args(sc, OP_SAFE_DO_STEP, code); /* (do ((i 0 (+ i 1))) ((= i 2)) (set! (str i) #\a)) */ - return(goto_begin); -} - -static goto_t op_dotimes_p(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code), end_val, slot, old_e; - s7_pointer end = opt1_any(code); /* caddr(opt2_pair(code)) */ - /* (do ... (set! args ...)) -- one line, syntactic */ - - s7_pointer init_val = fx_call(sc, cdaar(code)); - sc->value = init_val; - set_opt2_pair(code, caadr(code)); - if (is_symbol(end)) - { - slot = lookup_slot_from(end, sc->curlet); - end_val = slot_value(slot); - } - else - { - slot = make_slot(sc, make_symbol(sc, "___end___", 9), end); /* name is ignored, but needs to be > 8 chars for gcc's benefit (version 10.2.1)! */ - end_val = end; - } - if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) - { - pair_set_syntax_op(sc->code, OP_DO_UNCHECKED); - sc->code = cdr(sc->code); - return(goto_do_unchecked); - } - - old_e = sc->curlet; - sc->curlet = make_let(sc, sc->curlet); - let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), init_val)); - let_set_dox_slot2(sc->curlet, slot); - - set_car(sc->t2_1, let_dox1_value(sc->curlet)); - set_car(sc->t2_2, let_dox2_value(sc->curlet)); - if (is_true(sc, sc->value = fn_proc(caadr(code))(sc, sc->t2_1))) - { - sc->code = cdadr(code); - return(goto_do_end_clauses); - } - if ((!is_unsafe_do(code)) && - (opt1_cfunc(caadr(code)) != sc->geq_2)) - { - s7_pointer old_args = sc->args; - s7_pointer old_init = let_dox1_value(sc->curlet); - sc->args = T_Slt(let_dox_slot1(sc->curlet)); /* used in opt_dotimes */ - slot_set_value(sc->args, make_mutable_integer(sc, integer(let_dox1_value(sc->curlet)))); - set_do_loop_end(slot_value(sc->args), integer(let_dox2_value(sc->curlet))); - set_step_end(sc->args); /* dotimes step is by 1 */ - sc->code = cdr(sc->code); - if (dotimes(sc, code, false)) - return(goto_do_end_clauses); /* not safe_do here */ - slot_set_value(sc->args, old_init); - set_curlet(sc, old_e); /* free_cell(sc, sc->curlet) beforehand is not safe */ - sc->args = old_args; - set_unsafe_do(code); - return(goto_do_unchecked); - } - push_stack_no_args(sc, OP_DOTIMES_STEP_O, code); - sc->code = caddr(code); - return(goto_eval); -} - -static bool op_do_init_1(s7_scheme *sc) -{ - s7_pointer y, z; - while (true) /* at start, first value is the loop (for GC protection?), returning sc->value is the next value */ - { - s7_pointer init; - sc->args = cons(sc, sc->value, sc->args); /* code will be last element (first after reverse), these cons's will be used below for the new let/slots */ - if (!is_pair(sc->code)) break; - /* here sc->code is a list like: ((i 0 (+ i 1)) ...) so cadar gets the init value */ - init = cdar(sc->code); - if (has_fx(init)) - sc->value = fx_call(sc, init); - else - { - init = car(init); - if (is_pair(init)) - { - push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */ - sc->code = init; - return(true); /* goto eval */ - } - sc->value = (is_symbol(init)) ? lookup_checked(sc, init) : init; - } - sc->code = cdr(sc->code); - } - /* all the initial values are now in the args list */ - sc->args = proper_list_reverse_in_place(sc, sc->args); - sc->code = car(sc->args); /* saved at the start */ - z = sc->args; - sc->args = cdr(sc->args); /* init values */ - - /* sc->args was cons'd above, so it should be safe to reuse it as the new let */ - set_curlet(sc, reuse_as_let(sc, z, sc->curlet)); /* sc->curlet = make_let(sc, sc->curlet); */ - - /* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->curlet, also reuse sc->args as the new let slots */ - sc->value = sc->nil; - y = sc->args; - for (s7_pointer x = car(sc->code); is_not_null(y); x = cdr(x)) - { - s7_pointer sym = caar(x), args = cdr(y); - reuse_as_slot(sc, y, sym, unchecked_car(y)); - slot_set_next(y, let_slots(sc->curlet)); - let_set_slots(sc->curlet, y); - symbol_set_local_slot(sym, let_id(sc->curlet), y); - if (is_pair(cddar(x))) /* else no incr expr, so ignore it henceforth */ - { - slot_set_expression(y, cddar(x)); - sc->value = cons_unchecked(sc, y, sc->value); - } - y = args; - } - sc->args = cons(sc, sc->value = proper_list_reverse_in_place(sc, sc->value), cadr(sc->code)); - sc->code = cddr(sc->code); - return(false); /* fall through */ -} - -static bool op_do_init(s7_scheme *sc) -{ - if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "do: variable initial value can't be ~S", 38), - set_ulist_1(sc, sc->values_symbol, sc->value))); - return(!op_do_init_1(sc)); -} - -static void op_do_unchecked(s7_scheme *sc) -{ - push_stack_no_code(sc, OP_GC_PROTECT, sc->code); - sc->code = cdr(sc->code); -} - -static bool do_unchecked(s7_scheme *sc) -{ - if (is_null(car(sc->code))) /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */ - { - sc->curlet = make_let(sc, sc->curlet); - sc->args = cons_unchecked(sc, sc->nil, cadr(sc->code)); - sc->code = cddr(sc->code); - return(false); - } - /* eval each init value, then set up the new let (like let, not let*) */ - sc->args = sc->nil; /* the evaluated var-data */ - sc->value = sc->code; /* protect it */ - sc->code = car(sc->code); /* the vars */ - return(op_do_init_1(sc)); -} - -static bool op_do_end(s7_scheme *sc) -{ - /* car(sc->args) here is the var list used by do_end2 */ - if (is_pair(cdr(sc->args))) - { - if (!has_fx(cdr(sc->args))) - { - push_stack_direct(sc, OP_DO_END1); - sc->code = cadr(sc->args); /* evaluate the end expr */ - return(true); - } - sc->value = fx_call(sc, cdr(sc->args)); - } - else sc->value = sc->F; /* goto "if (is_pair(sc->code))..." below */ - return(false); -} - -static goto_t op_do_end_false(s7_scheme *sc) -{ - if (!is_pair(sc->code)) - return((is_null(car(sc->args))) ? /* no steppers */ goto_do_end : fall_through); - if (is_null(car(sc->args))) - push_stack_direct(sc, OP_DO_END); - else push_stack_direct(sc, OP_DO_STEP); - return(goto_begin); -} - -static goto_t op_do_end_true(s7_scheme *sc) -{ - /* we're done -- deal with result exprs, if there isn't an end test, there also isn't a result (they're in the same list) - * multiple-value end-test result is ok - */ - sc->code = T_Lst(cddr(sc->args)); /* result expr (a list -- implicit begin) */ - free_cell(sc, sc->args); - sc->args = sc->nil; - if (is_null(sc->code)) - { - if (is_multiple_value(sc->value)) /* (define (f) (+ 1 (do ((i 2 (+ i 1))) ((values i (+ i 1)))))) -> 6 */ - sc->value = splice_in_values(sc, multiple_value(sc->value)); - /* similarly, if the result is a multiple value: (define (f) (+ 1 (do ((i 2 (+ i 1))) ((= i 3) (values i (+ i 1)))))) -> 8 */ - return(goto_start); - } - /* might be => here as in cond and case */ - if (is_null(cdr(sc->code))) - { - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - return(goto_start); - } - sc->code = car(sc->code); - return(goto_eval); - } - if (is_undefined_feed_to(sc, car(sc->code))) - return(goto_feed_to); - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - sc->code = car(sc->code); - return(goto_eval); -} - - -/* -------------------------------- apply functions -------------------------------- */ -static inline s7_pointer apply_c_function(s7_scheme *sc, s7_pointer func, s7_pointer args) /* -------- C-based function -------- */ -{ - s7_int len = proper_list_length(args); - if (len < c_function_min_args(func)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), func, func, args)); - if (c_function_max_args(func) < len) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, args)); - /* fprintf(stderr, "%s %s %s\n", __func__, display(func), display(args)); */ - return(c_function_call(func)(sc, args)); - /* just by chance, this code is identical to macroexpand_c_macro's code (after macro expansion)! So, - * gcc -O2 uses the macroexpand code, but then valgrind shows us calling macros all the time, and - * gdb with break apply_c_function breaks at macroexpand -- confusing! - */ -} - -static void apply_c_rst_no_req_function(s7_scheme *sc) /* -------- C-based function that can take any number of arguments -------- */ -{ - sc->value = c_function_call(sc->code)(sc, sc->args); -} - -static void apply_c_macro(s7_scheme *sc) /* -------- C-based macro -------- */ -{ - s7_int len = proper_list_length(sc->args); - if (len < c_macro_min_args(sc->code)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); - if (c_macro_max_args(sc->code) < len) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); - sc->code = c_macro_call(sc->code)(sc, sc->args); -} - -static void apply_syntax(s7_scheme *sc) /* -------- syntactic keyword as applicable object -------- */ -{ /* current reader-cond macro uses this via (map quote ...) */ - s7_int len; /* ((apply lambda '((x) (+ x 1))) 4) */ - if (is_pair(sc->args)) /* this is ((pars) . body) */ - { - len = s7_list_length(sc, sc->args); - if (len == 0) - syntax_error_nr(sc, "attempt to evaluate a circular list: ~S", 39, sc->args); - if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, sc->args))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "apply ~S: body is circular: ~S", 30), sc->code, sc->args)); - } - else len = 0; - - if (len < syntax_min_args(sc->code)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); - if ((syntax_max_args(sc->code) < len) && - (syntax_max_args(sc->code) != -1)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); - sc->cur_op = syntax_opcode(sc->code); /* (apply begin '((define x 3) (+ x 2))) */ - /* I had elaborate checks here for embedded circular lists, but now I think that is the caller's problem */ - sc->code = cons(sc, sc->code, sc->args); - set_current_code(sc, sc->code); - pair_set_syntax_op(sc->code, sc->cur_op); -} - -static void apply_vector(s7_scheme *sc) /* -------- vector as applicable object -------- */ -{ - /* sc->code is the vector, sc->args is the list of indices */ - if (is_null(sc->args)) /* (#2d((1 2) (3 4))) */ - wrong_number_of_args_error_nr(sc, "vector ref: no index: (~A)", sc->code); - if ((is_null(cdr(sc->args))) && - (s7_is_integer(car(sc->args))) && - (vector_rank(sc->code) == 1)) - { - s7_int index = s7_integer_clamped_if_gmp(sc, car(sc->args)); - if ((index >= 0) && - (index < vector_length(sc->code))) - sc->value = vector_getter(sc->code)(sc, sc->code, index); - else out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, car(sc->args), (index < 0) ? it_is_negative_string : it_is_too_large_string); - } - else sc->value = vector_ref_1(sc, sc->code, sc->args); -} - -static void apply_string(s7_scheme *sc) /* -------- string as applicable object -------- */ -{ - if (!is_pair(sc->args)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "string ref: no index: (~S~{~^ ~S~})", 35), sc->code, sc->args)); - if (!is_null(cdr(sc->args))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "string ref: too many indices: (~S~{~^ ~S~})", 43), sc->code, sc->args)); - - if (s7_is_integer(car(sc->args))) - { - s7_int index = s7_integer_clamped_if_gmp(sc, car(sc->args)); - if ((index >= 0) && - (index < string_length(sc->code))) - { - sc->value = chars[((uint8_t *)string_value(sc->code))[index]]; - return; - }} - sc->value = string_ref_1(sc, sc->code, car(sc->args)); -} - -static bool apply_pair(s7_scheme *sc) /* -------- list as applicable object -------- */ -{ - if (is_multiple_value(sc->code)) /* ((values + 2 3) 4) */ - { - /* car of values can be anything, so conjure up a new expression, and apply again */ - sc->args = pair_append(sc, cdr(sc->code), sc->args); - sc->code = car(sc->code); - return(false); - } - if (is_null(sc->args)) - wrong_number_of_args_error_nr(sc, "list ref: no index: (~S)", sc->code); - sc->value = list_ref_1(sc, sc->code, car(sc->args)); /* (L 1) */ - if (!is_null(cdr(sc->args))) - sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args); - return(true); -} - -static void apply_hash_table(s7_scheme *sc) /* -------- hash-table as applicable object -------- */ -{ - if (is_null(sc->args)) - wrong_number_of_args_error_nr(sc, "hash-table ref: no key: (~S)", sc->code); - sc->value = s7_hash_table_ref(sc, sc->code, car(sc->args)); - if (!is_null(cdr(sc->args))) - sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args); -} - -static void apply_let(s7_scheme *sc) /* -------- environment as applicable object -------- */ -{ - if (is_null(sc->args)) - wrong_number_of_args_error_nr(sc, "let ref: no field: (~S)", sc->code); - sc->value = let_ref(sc, sc->code, car(sc->args)); - if (is_pair(cdr(sc->args))) - sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args); - /* (let ((v #(1 2 3))) (let ((e (curlet))) ((e 'v) 1))) -> 2 - * so (let ((v #(1 2 3))) (let ((e (curlet))) (e 'v 1))) -> 2 - */ -} - -static void apply_iterator(s7_scheme *sc) /* -------- iterator as applicable object -------- */ -{ - if (!is_null(sc->args)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "iterator takes no arguments: (~A~{~^ ~S~})", 42), sc->code, sc->args)); - sc->value = s7_iterate(sc, sc->code); -} - -static Inline void inline_apply_lambda(s7_scheme *sc) /* -------- normal function (lambda), or macro --------, called once in eval */ -{ /* load up the current args into the ((args) (lambda)) layout [via the current environment] */ - s7_pointer x, z, e = sc->curlet, slot, last_slot = slot_end(sc); - uint64_t id = let_id(sc->curlet); - - for (x = closure_args(sc->code), z = T_Lst(sc->args); is_pair(x); x = cdr(x), z = cdr(z)) /* closure_args can be a symbol, for example */ - { - s7_pointer sym = car(x); - if (is_null(z)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_5(sc, wrap_string(sc, "~S: not enough arguments: ((~S ~S ...)~{~^ ~S~})", 48), - closure_name(sc, sc->code), - (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), - closure_args(sc->code), sc->args)); - slot = make_slot(sc, sym, T_Ext(unchecked_car(z))); - symbol_set_local_slot(sym, id, slot); - if (tis_slot(last_slot)) - slot_set_next(last_slot, slot); - else let_set_slots(e, slot); - last_slot = slot; - slot_set_next(slot, slot_end(sc)); - } - if (is_null(x)) - { - if (is_not_null(z)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_5(sc, wrap_string(sc, "~S: too many arguments: ((~S ~S ...)~{~^ ~S~})", 46), - closure_name(sc, sc->code), - (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), - closure_args(sc->code), sc->args)); - } - else - { - slot = make_slot(sc, x, z); - symbol_set_local_slot(x, id, slot); - if (tis_slot(last_slot)) - slot_set_next(last_slot, slot); - else let_set_slots(e, slot); - slot_set_next(slot, slot_end(sc)); - } - sc->code = closure_body(sc->code); -} - -static void op_f(s7_scheme *sc) /* sc->code: ((lambda () 32)) -> (let () 32) */ -{ - sc->curlet = make_let(sc, sc->curlet); - sc->code = opt3_pair(sc->code); /* cddar */ -} - -static void op_f_a(s7_scheme *sc) /* sc->code: ((lambda (x) (+ x 1)) i) -> (let ((x i)) (+ x 1)) */ -{ - /* if caddar(sc->code) is fxable [(+ x 1) above], this could call fx and return to the top */ - sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt3_sym(cdr(sc->code)), fx_call(sc, cdr(sc->code))); - sc->code = opt3_pair(sc->code); -} - -static void op_f_aa(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) i j) -> (let ((x i) (y j)) (+ x y)) */ -{ - gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); - sc->curlet = make_let_with_two_slots(sc, sc->curlet, opt3_sym(cdr(sc->code)), stack_protected1(sc), cadadr(car(sc->code)), fx_call(sc, cddr(sc->code))); - unstack(sc); - sc->code = opt3_pair(sc->code); -} - -static void op_f_np(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) (values i j)) -> (let ((x i) (y j)) (+ x y)) after splice */ -{ - s7_pointer pars = cadar(sc->code); - s7_pointer e = make_let(sc, sc->curlet); - if (is_pair(pars)) - { - s7_pointer last_slot; - if (is_null(cdr(sc->code))) /* ((lambda (x) 21)) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar(sc->code), cdr(sc->code))); - if (is_constant(sc, car(pars))) - error_nr(sc, sc->syntax_error_symbol, /* (lambda (a) 1) where 'a is immutable (locally perhaps) */ - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: ((lambda ~S ...)~{~^ ~S~})", 61), - car(pars), cadar(sc->code), cdr(sc->code))); - - add_slot_unchecked_no_local(sc, e, car(pars), sc->undefined); - last_slot = let_slots(e); - for (pars = cdr(pars); is_pair(pars); pars = cdr(pars)) - last_slot = add_slot_at_end_no_local(sc, last_slot, car(pars), sc->undefined); - /* last par might be rest par (dotted) */ - if (!is_null(pars)) - { - last_slot = add_slot_at_end_no_local(sc, last_slot, pars, sc->undefined); - set_is_rest_slot(last_slot); - }} - /* check_stack_size(sc); */ - if ((sc->stack_end + 4) >= sc->stack_resize_trigger) resize_stack(sc); - push_stack(sc, OP_GC_PROTECT, let_slots(e), cddr(sc->code)); /* not for gc-protection, but as implicit loop vars */ - push_stack(sc, OP_F_NP_1, e, sc->code); - sc->code = cadr(sc->code); -} - -static bool op_f_np_1(s7_scheme *sc) -{ - s7_pointer e, slot = stack_protected1(sc), arg = stack_protected2(sc); - if (is_multiple_value(sc->value)) - { - s7_pointer p, oslot = slot; - for (p = sc->value; (is_pair(p)) && (tis_slot(slot)); p = cdr(p), oslot = slot, slot = next_slot(slot)) - if (is_rest_slot(slot)) - { - if (slot_value(slot) == sc->undefined) - slot_set_value(slot, copy_proper_list(sc, p)); - else slot_set_value(slot, pair_append(sc, slot_value(slot), copy_proper_list(sc, p))); - p = sc->nil; - break; - } - else slot_set_value(slot, car(p)); - if (is_pair(p)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar(sc->code), cdr(sc->code))); - slot = oslot; /* snd-test 22 grani */ - } - else /* not mv */ - if (!is_rest_slot(slot)) - slot_set_value(slot, sc->value); - else - if (slot_value(slot) == sc->undefined) - slot_set_value(slot, list_1(sc, sc->value)); - else slot_set_value(slot, pair_append(sc, slot_value(slot), list_1(sc, sc->value))); - - if (is_pair(arg)) - { - if ((!tis_slot(next_slot(slot))) && (!is_rest_slot(slot))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "too many arguments: ((lambda ~S ...)~{~^ ~S~})", 46), - cadar(sc->code), cdr(sc->code))); - set_stack_protected1(sc, (is_rest_slot(slot)) ? slot : next_slot(slot)); - set_stack_protected2(sc, cdr(arg)); - push_stack_direct(sc, OP_F_NP_1); /* sc->args=e, sc->code from start */ - sc->code = car(arg); - return(true); - } - if (tis_slot(next_slot(slot))) - { - if (!is_rest_slot(next_slot(slot))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar(sc->code), cdr(sc->code))); - if (slot_value(next_slot(slot)) == sc->undefined) - slot_set_value(next_slot(slot), sc->nil); - } - e = sc->args; - let_set_id(e, ++sc->let_number); - set_curlet(sc, e); - update_symbol_ids(sc, e); - sc->code = cddar(sc->code); - unstack(sc); - return(false); -} - -static void op_lambda_star(s7_scheme *sc) -{ - check_lambda_star(sc); - if (!is_pair(car(sc->code))) - sc->value = make_closure(sc, car(sc->code), cdr(sc->code), - (is_symbol(car(sc->code))) ? (T_CLOSURE | T_COPY_ARGS) : T_CLOSURE, - CLOSURE_ARITY_NOT_SET); - else sc->value = make_closure(sc, car(sc->code), cdr(sc->code), - (!arglist_has_rest(sc, car(sc->code))) ? T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), - CLOSURE_ARITY_NOT_SET); -} - -static void op_lambda_star_unchecked(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - if (!is_pair(car(code))) - sc->value = make_closure(sc, car(code), cdr(code), - (is_symbol(car(code))) ? (T_CLOSURE | T_COPY_ARGS) : T_CLOSURE, - CLOSURE_ARITY_NOT_SET); - else sc->value = make_closure(sc, car(code), cdr(code), - (!arglist_has_rest(sc, car(code))) ? T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), - CLOSURE_ARITY_NOT_SET); -} - -static s7_pointer star_set(s7_scheme *sc, s7_pointer slot, s7_pointer val, bool check_rest) -{ - if (is_checked_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); - if ((check_rest) && (is_rest_slot(slot))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), slot_symbol(slot), val)); - set_checked_slot(slot); - slot_set_value(slot, val); - return(val); -} - -static s7_pointer lambda_star_argument_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val, s7_pointer slot, bool check_rest) -{ - if (val == sc->no_value) val = sc->unspecified; - if (sym == slot_symbol(slot)) - return(star_set(sc, slot, val, check_rest)); - for (s7_pointer x = let_slots(sc->curlet) /* presumably the arglist */; tis_slot(x); x = next_slot(x)) - if (slot_symbol(x) == sym) - return(star_set(sc, x, val, check_rest)); - return(sc->no_value); -} - -static s7_pointer lambda_star_set_args(s7_scheme *sc) -{ - s7_pointer arg_vals = sc->args, rest_key = sc->nil, code = sc->code, args = sc->args; - s7_pointer slot = let_slots(sc->curlet); - s7_pointer pars = closure_args(code); - bool allow_other_keys = ((is_pair(pars)) && (allows_other_keys(pars))); - - while ((is_pair(pars)) && - (is_pair(arg_vals))) - { - if (car(pars) == sc->rest_keyword) /* the rest arg: a default is not allowed here (see check_lambda_star_args) */ - { - /* next arg is bound to trailing args from this point as a list */ - pars = cdr(pars); - if ((is_symbol_and_keyword(car(arg_vals))) && - (is_pair(cdr(arg_vals))) && - (keyword_symbol(car(arg_vals)) == car(pars))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), - car(pars), cadr(arg_vals))); - lambda_star_argument_set_value(sc, car(pars), (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals), slot, false); /* sym5 :rest bug */ - rest_key = sc->rest_keyword; - arg_vals = cdr(arg_vals); - pars = cdr(pars); - slot = next_slot(slot); - } - else - { - s7_pointer arg_val = car(arg_vals); - if (is_symbol_and_keyword(arg_val)) - { - if (!is_pair(cdr(arg_vals))) - { - if (!sc->accept_all_keyword_arguments) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, keyword_value_missing_string, closure_name(sc, code), arg_vals, args)); - slot_set_value(slot, arg_val); - set_checked_slot(slot); - arg_vals = cdr(arg_vals); - } - else - { - s7_pointer sym = keyword_symbol(arg_val); - if (lambda_star_argument_set_value(sc, sym, cadr(arg_vals), slot, true) == sc->no_value) - { - /* if default value is a key, go ahead and use this value. - * (define* (f (a :b)) a) (f :c) - * this has become much trickier than I anticipated... - */ - if (allow_other_keys) - /* in CL: (defun hi (&key (a 1) &allow-other-keys) a) (hi :b :a :a 3) -> 3 - * in s7: (define* (hi (a 1) :allow-other-keys) a) (hi :b :a :a 3) -> 3 - */ - arg_vals = cddr(arg_vals); - else - { - if (!sc->accept_all_keyword_arguments) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: unknown key: ~S in ~S", 25), closure_name(sc, code), arg_vals, args)); - slot_set_value(slot, arg_val); - set_checked_slot(slot); - arg_vals = cdr(arg_vals); - pars = cdr(pars); - slot = next_slot(slot); - } - continue; - } - arg_vals = cddr(arg_vals); - } - slot = next_slot(slot); - } - else /* not a key/value pair */ - { - if (is_checked_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); - set_checked_slot(slot); - slot_set_value(slot, car(arg_vals)); - slot = next_slot(slot); - arg_vals = cdr(arg_vals); - } - pars = cdr(pars); - }} - /* (let () (define* (hi (a 1) :allow-other-keys) a) (hi :a 2 32)) -> 'error */ - /* (let () (define* (f (a :b)) a) (list (f) (f 1) (f :c) (f :a :c) (f :a 1) (f))) -> 'error */ - - /* check for trailing args with no :rest arg */ - if (is_not_null(arg_vals)) - { - if ((is_not_null(pars)) || - (rest_key == sc->rest_keyword)) - { - if (is_symbol(pars)) - { - if ((is_symbol_and_keyword(car(arg_vals))) && - (is_pair(cdr(arg_vals))) && - (keyword_symbol(car(arg_vals)) == pars)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), pars, cadr(arg_vals))); - slot_set_value(slot, (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals)); /* sym5 :rest bug */ - }} - else - { - if (!allow_other_keys) /* ((lambda* (a) a) :a 1 2) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "too many arguments: (~S ~S ...)~{~^ ~S~})", 41), - (is_closure_star(code)) ? sc->lambda_star_symbol : ((is_bacro_star(sc->code)) ? sc->bacro_star_symbol : sc->macro_star_symbol), - closure_args(code), args)); - /* check trailing args for repeated keys or keys with no values or values with no keys */ - while (is_pair(arg_vals)) - { - if ((!is_symbol_and_keyword(car(arg_vals))) || /* ((lambda* (a :allow-other-keys) a) :a 1 :b 2 3) */ - (!is_pair(cdr(arg_vals)))) /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: not a key/value pair: ~S", 28), closure_name(sc, code), arg_vals)); - slot = symbol_to_local_slot(sc, keyword_symbol(car(arg_vals)), sc->curlet); - if ((is_slot(slot)) && - (is_checked_slot(slot))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); - arg_vals = cddr(arg_vals); - }}} - return(sc->nil); -} - -static inline bool lambda_star_default(s7_scheme *sc) -{ - for (s7_pointer z = sc->args; tis_slot(z); z = next_slot(z)) - { - if ((slot_value(z) == sc->undefined) && /* trouble: (lambda* ((e #))...) */ - (slot_has_expression(z)) && /* if default val is not a pair or a symbol, this is false */ - (!is_checked_slot(z))) - { - s7_pointer val = slot_expression(z); - if (is_symbol(val)) - { - slot_set_value(z, lookup_checked(sc, val)); - if (slot_value(z) == sc->undefined) - { - /* the current environment here contains the function parameters which defaulted to # - * (or maybe #?) earlier in apply_*_closure_star_1, so (define (f f) (define* (f (f f)) f) (f)) (f 0) - * looks for the default f, finds itself currently undefined, and raises an error! So, before - * claiming it is unbound, we need to check outlet as well. But in the case above, the inner - * define* shadows the caller's parameter before checking the default arg values, so the default f - * refers to the define* -- I'm not sure this is a bug. It means that (define* (f (a f)) a) - * returns f: (equal? f (f)) -> #t, so any outer f needs an extra let and endless outlets: - * (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3 - * We want the shadowing once the define* is done, so the current mess is simplest. - */ - slot_set_value(z, s7_symbol_local_value(sc, val, let_outlet(sc->curlet))); - if (slot_value(z) == sc->undefined) - syntax_error_nr(sc, "lambda* defaults: ~A is unbound", 31, slot_symbol(z)); - }} - else - if (!is_pair(val)) - slot_set_value(z, val); - else - if (car(val) == sc->quote_symbol) - { - if ((!is_pair(cdr(val))) || /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */ - (is_pair(cddr(val)))) - syntax_error_nr(sc, "lambda* default: ~A is messed up", 32, val); - slot_set_value(z, cadr(val)); - } - else - { - push_stack(sc, OP_LAMBDA_STAR_DEFAULT, z, sc->code); - sc->code = val; - return(true); /* goto eval */ - }}} - return(false); -} - -static bool op_lambda_star_default(s7_scheme *sc) -{ - /* sc->args is the current let slots position, sc->value is the default expression's value */ - if (is_multiple_value(sc->value)) - syntax_error_nr(sc, "lambda*: argument default value can't be ~S", 43, set_ulist_1(sc, sc->values_symbol, sc->value)); - slot_set_value(sc->args, sc->value); - sc->args = next_slot(sc->args); - if (lambda_star_default(sc)) return(true); - pop_stack_no_op(sc); - sc->code = T_Pair(closure_body(sc->code)); - return(false); -} - -static inline bool set_star_args(s7_scheme *sc, s7_pointer top) -{ - lambda_star_set_args(sc); /* load up current arg vals */ - sc->args = top; - if (is_slot(sc->args)) - { - /* get default values, which may involve evaluation -- see also OP_LAMBDA_STAR_DEFAULT */ - push_stack_direct(sc, OP_GC_PROTECT); - if (lambda_star_default(sc)) return(true); /* else fall_through */ - pop_stack_no_op(sc); /* get original args and code back */ - } - sc->code = closure_body(sc->code); - return(false); -} - -static inline bool apply_safe_closure_star_1(s7_scheme *sc) /* -------- define* (lambda*) -------- */ -{ - /* slots are in "reverse order" -- in the same order as the args, despite let printout (which reverses the order!) */ - set_curlet(sc, closure_let(sc->code)); - if (has_no_defaults(sc->code)) - { - for (s7_pointer z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z)) - { - clear_checked_slot(z); - slot_set_value(z, sc->F); - } - if (!is_null(sc->args)) - lambda_star_set_args(sc); /* load up current arg vals */ - sc->code = closure_body(sc->code); - return(false); /* goto BEGIN */ - } - for (s7_pointer z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z)) - { - clear_checked_slot(z); - slot_set_value(z, (slot_defaults(z)) ? sc->undefined : slot_expression(z)); - } - return(set_star_args(sc, slot_pending_value(let_slots(sc->curlet)))); -} - -static bool apply_unsafe_closure_star_1(s7_scheme *sc) -{ - s7_pointer z, top = sc->nil; - for (z = closure_args(sc->code); is_pair(z); z = cdr(z)) - { - s7_pointer car_z = car(z); - if (is_pair(car_z)) /* arg has a default value */ - { - s7_pointer slot, val = cadr(car_z); - if ((!is_pair(val)) && - (!is_symbol(val))) - slot = add_slot_checked(sc, sc->curlet, car(car_z), val); - else - { - add_slot(sc, sc->curlet, car(car_z), sc->undefined); - slot = let_slots(sc->curlet); - slot_set_expression(slot, val); - } - if (is_null(top)) - top = slot; - } - else - if (!is_keyword(car_z)) - add_slot(sc, sc->curlet, car_z, sc->F); - else - if (car_z == sc->rest_keyword) /* else it's :allow-other-keys? */ - { - set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(z), sc->nil)); - z = cdr(z); - }} - if (is_symbol(z)) - set_is_rest_slot(add_slot_checked(sc, sc->curlet, z, sc->nil)); /* set up rest arg */ - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - return(set_star_args(sc, top)); -} - -static void apply_macro_star_1(s7_scheme *sc) -{ - /* here the defaults (if any) are not evalled, and there is not an existing let */ - s7_pointer p; - for (p = closure_args(sc->code); is_pair(p); p = cdr(p)) - { - s7_pointer par = car(p); - if (is_pair(par)) - add_slot_checked(sc, sc->curlet, car(par), cadr(par)); - else - if (!is_keyword(par)) - add_slot_checked(sc, sc->curlet, par, sc->F); - else - if (par == sc->rest_keyword) - { - set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(p), sc->nil)); - p = cdr(p); - }} - if (is_symbol(p)) - set_is_rest_slot(add_slot_checked(sc, sc->curlet, p, sc->nil)); - let_set_slots(sc->curlet, reverse_slots(sc, let_slots(sc->curlet))); - lambda_star_set_args(sc); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void clear_absolutely_all_optimizations(s7_pointer p) -{ - if ((is_pair(p)) && (!is_matched_pair(p))) - { - clear_has_fx(p); - clear_optimized(p); - clear_optimize_op(p); - set_match_pair(p); - clear_absolutely_all_optimizations(cdr(p)); - clear_absolutely_all_optimizations(car(p)); - } -} - -static void clear_matches(s7_pointer p) -{ - if ((is_pair(p)) && (is_matched_pair(p))) - { - clear_match_pair(p); - clear_matches(car(p)); - clear_matches(cdr(p)); - } -} - -static void apply_macro(s7_scheme *sc) /* this is not from the reader, so treat expansions here as normal macros */ -{ - check_stack_size(sc); - if (closure_arity_to_int(sc, sc->code) < 0) - { - clear_absolutely_all_optimizations(sc->args); /* desperation... */ - clear_matches(sc->args); - } - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = inline_make_let(sc, closure_let(sc->code)); /* closure_let -> sc->curlet, sc->code is the macro */ - transfer_macro_info(sc, sc->code); -} - -static void apply_bacro(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = make_let(sc, sc->curlet); /* like let* -- we'll be adding macro args, so might as well sequester things here */ - transfer_macro_info(sc, sc->code); -} - -static void apply_macro_star(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = make_let(sc, closure_let(sc->code)); - transfer_macro_info(sc, sc->code); - apply_macro_star_1(sc); -} - -static void apply_bacro_star(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_op_let(sc, OP_EVAL_MACRO); - sc->curlet = make_let(sc, sc->curlet); - transfer_macro_info(sc, sc->code); - apply_macro_star_1(sc); -} - -static void apply_closure(s7_scheme *sc) -{ - /* we can get safe_closures here, but can't easily determine whether we have the expected saved funclet */ - check_stack_size(sc); - sc->curlet = inline_make_let(sc, closure_let(sc->code)); -} - -static bool apply_closure_star(s7_scheme *sc) -{ - if (is_safe_closure(sc->code)) - return(apply_safe_closure_star_1(sc)); - check_stack_size(sc); - sc->curlet = make_let(sc, closure_let(sc->code)); - return(apply_unsafe_closure_star_1(sc)); -} - -static inline s7_pointer op_safe_closure_star_a1(s7_scheme *sc, s7_pointer code) /* called in eval and below, tlamb */ -{ - s7_pointer func = opt1_lambda(code); - s7_pointer val = fx_call(sc, cdr(code)); - if ((is_symbol_and_keyword(val)) && - (!sc->accept_all_keyword_arguments)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, keyword_value_missing_string, closure_name(sc, func), val, sc->args)); - sc->curlet = update_let_with_slot(sc, closure_let(func), val); - sc->code = T_Pair(closure_body(func)); - return(func); -} - -static void op_safe_closure_star_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer func = op_safe_closure_star_a1(sc, code); - s7_pointer p = cdr(closure_args(func)); - if (is_pair(p)) - for (s7_pointer x = next_slot(let_slots(closure_let(func))); is_pair(p); p = cdr(p), x = next_slot(x)) - { - if (is_pair(car(p))) - { - s7_pointer defval = cadar(p); - slot_set_value(x, (is_pair(defval)) ? cadr(defval) : defval); - } - else slot_set_value(x, sc->F); - symbol_set_local_slot(slot_symbol(x), let_id(sc->curlet), x); - } -} - -static void op_safe_closure_star_ka(s7_scheme *sc, s7_pointer code) /* two args, but k=arg key, key has been checked. no trailing pars */ -{ - s7_pointer func = opt1_lambda(code); - sc->curlet = update_let_with_slot(sc, closure_let(func), fx_call(sc, cddr(code))); - sc->code = T_Pair(closure_body(func)); -} - -static void op_safe_closure_star_aa(s7_scheme *sc, s7_pointer code) -{ - /* here closure_arity == 2 and we have 2 args and those args' defaults are simple (no eval or lookup needed) */ - s7_pointer arg2, func = opt1_lambda(code); - s7_pointer arg1 = fx_call(sc, cdr(code)); - sc->w = arg1; /* weak GC protection */ - arg2 = fx_call(sc, cddr(code)); - - if (is_symbol_and_keyword(arg1)) - { - if (keyword_symbol(arg1) == slot_symbol(let_slots(closure_let(func)))) - { - arg1 = arg2; - arg2 = cadr(closure_args(func)); - if (is_pair(arg2)) arg2 = (is_pair(cadr(arg2))) ? cadadr(arg2) : cadr(arg2); else arg2 = sc->F; - } - else - if (keyword_symbol(arg1) == slot_symbol(next_slot(let_slots(closure_let(func))))) - { - arg1 = car(closure_args(func)); - if (is_pair(arg1)) arg1 = (is_pair(cadr(arg1))) ? cadadr(arg1) : cadr(arg1); else arg1 = sc->F; - } - else - if (!sc->accept_all_keyword_arguments) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: unknown keyword argument: ~S in ~S", 38), - closure_name(sc, func), arg1, code)); /* arg1 is already the value */ - } - else - if ((is_symbol_and_keyword(arg2)) && - (!sc->accept_all_keyword_arguments)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, keyword_value_missing_string, closure_name(sc, func), arg2, code)); - sc->curlet = update_let_with_two_slots(sc, closure_let(func), arg1, arg2); - sc->code = T_Pair(closure_body(func)); -} - -static bool call_lambda_star(s7_scheme *sc, s7_pointer code, s7_pointer arglist) -{ - bool target; - sc->code = opt1_lambda(code); - target = apply_safe_closure_star_1(sc); - clear_list_in_use(arglist); - return(target); -} - -static bool op_safe_closure_star_aaa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arg2, arg3, func = opt1_lambda(code); - s7_pointer arg1 = fx_call(sc, cdr(code)); - gc_protect_via_stack(sc, arg1); - arg2 = fx_call(sc, cddr(code)); - set_stack_protected2(sc, arg2); - arg3 = fx_call(sc, cdddr(code)); - if ((is_symbol_and_keyword(arg1)) || (is_symbol_and_keyword(arg2)) || (is_symbol_and_keyword(arg3))) - { - s7_pointer arglist = make_safe_list(sc, 3); - sc->args = arglist; - set_car(arglist, arg1); - set_cadr(arglist, arg2); - set_caddr(arglist, arg3); - unstack(sc); - return(call_lambda_star(sc, code, arglist)); /* this clears list_in_use */ - } - sc->curlet = update_let_with_three_slots(sc, closure_let(func), arg1, arg2, arg3); - unstack(sc); - sc->code = T_Pair(closure_body(func)); - if_pair_set_up_begin_unchecked(sc); - return(true); -} - -static bool op_safe_closure_star_na_0(s7_scheme *sc, s7_pointer code) -{ - sc->args = sc->nil; - sc->code = opt1_lambda(code); - return(apply_safe_closure_star_1(sc)); -} - -static bool op_safe_closure_star_na_1(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arglist = safe_list_1(sc); - sc->args = arglist; - set_car(arglist, fx_call(sc, cdr(code))); - return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */ -} - -static bool op_safe_closure_star_na_2(s7_scheme *sc, s7_pointer code) -{ - s7_pointer arglist = safe_list_2(sc); - sc->args = arglist; - set_car(arglist, fx_call(sc, cdr(code))); - set_cadr(arglist, fx_call(sc, cddr(code))); - return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */ -} - -static inline bool op_safe_closure_star_na(s7_scheme *sc, s7_pointer code) /* called once in eval, clo */ -{ - s7_pointer arglist = safe_list_if_possible(sc, opt3_arglen(cdr(code))); - sc->args = arglist; - for (s7_pointer p = arglist, old_args = cdr(code); is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - if ((S7_DEBUGGING) && (sc->args != arglist)) fprintf(stderr, "%s[%d]: lost gc\n", __func__, __LINE__); - return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */ -} - -static void op_closure_star_ka(s7_scheme *sc, s7_pointer code) -{ - s7_pointer func = opt1_lambda(code); - s7_pointer p = car(closure_args(func)); - sc->value = fx_call(sc, cddr(code)); - sc->curlet = inline_make_let_with_slot(sc, closure_let(func), (is_pair(p)) ? car(p) : p, sc->value); - sc->code = T_Pair(closure_body(func)); -} - -static void op_closure_star_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer p, func = opt1_lambda(code); - sc->value = fx_call(sc, cdr(code)); - if ((is_symbol_and_keyword(sc->value)) && - (!sc->accept_all_keyword_arguments)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, keyword_value_missing_string, closure_name(sc, opt1_lambda(code)), sc->value, code)); - p = car(closure_args(func)); - sc->curlet = make_let_with_slot(sc, closure_let(func), (is_pair(p)) ? car(p) : p, sc->value); - if (closure_star_arity_to_int(sc, func) > 1) - { - s7_pointer last_slot = let_slots(sc->curlet); - s7_int id = let_id(sc->curlet); - for (p = cdr(closure_args(func)); is_pair(p); p = cdr(p)) - { - s7_pointer par = car(p); - if (is_pair(par)) - last_slot = add_slot_at_end(sc, id, last_slot, car(par), (is_pair(cadr(par))) ? cadadr(par) : cadr(par)); /* possible quoted list as default value */ - else last_slot = add_slot_at_end(sc, id, last_slot, par, sc->F); - }} - sc->code = T_Pair(closure_body(func)); -} - -static inline bool op_closure_star_na(s7_scheme *sc, s7_pointer code) -{ - /* check_stack_size(sc); */ - if (is_pair(cdr(code))) - { - sc->w = cdr(code); /* args aren't evaluated yet */ - sc->args = make_list(sc, opt3_arglen(cdr(code)), sc->unused); - for (s7_pointer p = sc->args, old_args = sc->w; is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - sc->w = sc->unused; - } - else sc->args = sc->nil; - sc->code = opt1_lambda(code); - sc->curlet = inline_make_let(sc, closure_let(sc->code)); - return(apply_unsafe_closure_star_1(sc)); -} - -static s7_pointer define1_caller(s7_scheme *sc) -{ - /* we can jump to op_define1, so this is not fool-proof */ - if (sc->cur_op == OP_DEFINE_CONSTANT) return(sc->define_constant_symbol); - if ((sc->cur_op == OP_DEFINE_STAR) || (sc->cur_op == OP_DEFINE_STAR_UNCHECKED)) return(sc->define_star_symbol); - return(sc->define_symbol); -} - -static bool op_define1(s7_scheme *sc) -{ - /* sc->code is the symbol being defined, sc->value is its value - * if sc->value is a closure, car is of the form ((args...) body...) - * it's not possible to expand and replace macros at this point without evaluating - * the body. Just as examples, say we have a macro "mac", - * (define (hi) (call/cc (lambda (mac) (mac 1)))) - * (define (hi) (quote (mac 1))) or macroexpand etc - * (define (hi mac) (mac 1)) assuming mac here is a function passed as an arg, etc... - * the immutable constant check needs to wait until we have the actual new value because - * we want to ignore the rebinding (not raise an error) if it is the existing value. - * This happens when we reload a file that calls define-constant. But we want a - * warning if we got define (as opposed to the original define-constant). - */ - s7_pointer x; - if (is_multiple_value(sc->value)) /* (define x (values 1 2)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_5(sc, wrap_string(sc, "~A: more than one value: (~A ~A ~S)", 35), - define1_caller(sc), define1_caller(sc), sc->code, sc->value)); - if (is_constant_symbol(sc, sc->code)) /* (define pi 3) or (define (pi a) a) */ - { - x = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : lookup_slot_from(sc->code, sc->curlet); - /* local_slot can be free even if sc->code is immutable (local constant now defunct) */ - - if (!((is_slot(x)) && - (type(sc->value) == unchecked_type(slot_value(x))) && - (s7_is_equivalent(sc, sc->value, slot_value(x))))) /* if value is unchanged, just ignore this (re)definition */ - syntax_error_with_caller_nr(sc, "~A: ~S is immutable", 19, define1_caller(sc), sc->code); /* can't use s7_is_equal because value might be NaN, etc */ - - if ((sc->safety > 0) && /* (define-constant x 3) (define x 3)... */ - (sc->cur_op == OP_DEFINE)) - s7_warn(sc, 256, "(define %s %s), but %s is a constant\n", display(sc->code), display(sc->value), display(sc->code)); - } - else x = lookup_slot_from(sc->code, sc->curlet); - if ((is_slot(x)) && (slot_has_setter(x))) - { - sc->value = bind_symbol_with_setter(sc, OP_DEFINE_WITH_SETTER, sc->code, sc->value); - if (sc->value == sc->no_value) - return(true); /* goto apply, if all goes well, OP_DEFINE_WITH_SETTER will jump to DEFINE2 */ - } - return(false); /* fall through */ -} - -static void set_let_file_and_line(s7_scheme *sc, s7_pointer new_let, s7_pointer new_func) -{ - if (port_file(current_input_port(sc)) != stdin) - { - if ((is_pair(closure_args(new_func))) && - (has_location(closure_args(new_func)))) - { - let_set_file(new_let, pair_file_number(closure_args(new_func))); - let_set_line(new_let, pair_line_number(closure_args(new_func))); - } - else - if (has_location(closure_body(new_func))) - { - let_set_file(new_let, pair_file_number(closure_body(new_func))); - let_set_line(new_let, pair_line_number(closure_body(new_func))); - } - else - { - s7_pointer p; - for (p = cdr(closure_body(new_func)); is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && (has_location(car(p)))) - break; - let_set_file(new_let, (is_pair(p)) ? pair_file_number(car(p)) : port_file_number(current_input_port(sc))); - let_set_line(new_let, (is_pair(p)) ? pair_line_number(car(p)) : port_line_number(current_input_port(sc))); - } - set_has_let_file(new_let); - } - else - { - let_set_file(new_let, 0); - let_set_line(new_let, 0); - clear_has_let_file(new_let); - } -} - -static void op_define_with_setter(s7_scheme *sc) -{ - s7_pointer code = sc->code; - if ((is_immutable(sc->curlet)) && - (is_let(sc->curlet))) /* not () */ - error_nr(sc, sc->immutable_error_symbol, - set_elist_2(sc, wrap_string(sc, "can't define ~S: curlet is immutable", 36), code)); - - if ((is_any_closure(sc->value)) && - ((!(is_let(closure_let(sc->value)))) || - (!(is_funclet(closure_let(sc->value)))))) /* otherwise it's (define f2 f1) or something similar */ - { - s7_pointer new_func = sc->value, new_let; - if (is_safe_closure_body(closure_body(new_func))) - { - set_safe_closure(new_func); - if (is_very_safe_closure_body(closure_body(new_func))) - set_very_safe_closure(new_func); - } - new_let = make_funclet(sc, new_func, code, closure_let(new_func)); - - /* this should happen only if the closure* default values do not refer in any way to - * the enclosing environment (else we can accidentally shadow something that happens - * to share an argument name that is being used as a default value -- kinda dumb!). - * I think I'll check this before setting the safe_closure bit. - */ - set_let_file_and_line(sc, new_let, new_func); - /* add the newly defined thing to the current environment */ - if (is_let(sc->curlet)) - { - if (let_id(sc->curlet) <= symbol_id(code)) /* we're adding a later-bound symbol to an old let (?) */ - { /* was < 16-Aug-22: (let ((a 3)) (define (a) 4) (curlet)) */ - s7_pointer slot; - sc->let_number++; /* dummy let, force symbol lookup */ - for (slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) - if (slot_symbol(slot) == code) - { - if (is_immutable(slot)) - syntax_error_nr(sc, "define ~S, but it is immutable", 30, code); /* someday give the location of the immutable definition or setting */ - slot_set_value(slot, new_func); - symbol_set_local_slot(code, sc->let_number, slot); - set_local(code); - sc->value = new_func; /* probably not needed? */ - return; - } - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, code, new_func); - symbol_set_local_slot(code, sc->let_number, slot); - slot_set_next(slot, let_slots(sc->curlet)); - let_set_slots(sc->curlet, slot); - } - else add_slot(sc, sc->curlet, code, new_func); - set_local(code); - } - else - { - if ((is_slot(global_slot(code))) && - (is_immutable(global_slot(code)))) - { - s7_pointer old_symbol = code, old_value = global_value(code); - if ((type(old_value) != type(new_func)) || - (!s7_is_equivalent(sc, old_value, new_func))) /* if value is unchanged, just ignore this (re)definition */ - syntax_error_nr(sc, "define ~S, but it is immutable", 30, old_symbol); - } - s7_make_slot(sc, sc->curlet, code, new_func); - } - sc->value = new_func; /* 25-Jul-14 so define returns the value not the name */ - } - else - { - s7_pointer slot = symbol_to_local_slot(sc, code, sc->curlet); /* add the newly defined thing to the current environment */ - if (is_slot(slot)) - { - if (is_immutable(slot)) - { - s7_pointer old_symbol = code, old_value = slot_value(slot); - if ((type(old_value) != type(sc->value)) || - (!s7_is_equivalent(sc, old_value, sc->value))) /* if value is unchanged, just ignore this (re)definition */ - syntax_error_nr(sc, "define ~S, but it is immutable", 30, old_symbol); - } - slot_set_value_with_hook(slot, sc->value); - symbol_increment_ctr(code); - } - else s7_make_slot(sc, sc->curlet, code, sc->value); - if ((is_any_macro(sc->value)) && (!is_c_macro(sc->value))) - { - set_pair_macro(closure_body(sc->value), code); - set_has_pair_macro(sc->value); - }} -} - - -/* -------------------------------- eval -------------------------------- */ -static void check_for_cyclic_code(s7_scheme *sc, s7_pointer code) -{ - if (tree_is_cyclic(sc, code)) - { - sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2))); - syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, code); - } - resize_stack(sc); /* we've already checked that resize_stack is needed */ -} - -static void op_thunk(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = inline_make_let(sc, closure_let(p)); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin(sc); -} - -static void op_thunk_o(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = inline_make_let(sc, closure_let(p)); - sc->code = car(closure_body(p)); -} - -static void op_safe_thunk(s7_scheme *sc) /* no let needed */ -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = closure_let(p); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin_unchecked(sc); -} - -static s7_pointer op_safe_thunk_a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer f = opt1_lambda(code); - set_curlet(sc, closure_let(f)); - return(fx_call(sc, closure_body(f))); -} - -static void op_thunk_any(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = make_let_with_slot(sc, closure_let(p), closure_args(p), sc->nil); - sc->code = closure_body(p); -} - -static void op_safe_thunk_any(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = closure_let(p); - slot_set_value(let_slots(sc->curlet), sc->nil); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_closure_s(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - check_stack_size(sc); - sc->curlet = inline_make_let_with_slot(sc, closure_let(p), car(closure_args(p)), lookup(sc, opt2_sym(sc->code))); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin_unchecked(sc); -} - -static inline void op_closure_s_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = inline_make_let_with_slot(sc, closure_let(f), car(closure_args(f)), lookup(sc, opt2_sym(sc->code))); - sc->code = car(closure_body(f)); -} - -static void op_safe_closure_s(s7_scheme *sc) -{ - s7_pointer p = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(p), lookup(sc, opt2_sym(sc->code))); - sc->code = T_Pair(closure_body(p)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_s_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(f), lookup(sc, opt2_sym(sc->code))); - sc->code = car(closure_body(f)); -} - -static void op_safe_closure_p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args(sc, OP_SAFE_CLOSURE_P_1, opt1_lambda(sc->code)); - sc->code = cadr(sc->code); -} - -static void op_safe_closure_p_1(s7_scheme *sc) -{ - sc->curlet = update_let_with_slot(sc, closure_let(sc->code), sc->value); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_safe_closure_p_a(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_CLOSURE_P_A_1); - sc->code = cadr(sc->code); -} - -static void op_safe_closure_p_a_1(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(f), sc->value); - sc->value = fx_call(sc, closure_body(f)); -} - -static Inline void inline_op_closure_a(s7_scheme *sc) /* called twice in eval */ -{ - s7_pointer f = opt1_lambda(sc->code); - sc->value = fx_call(sc, cdr(sc->code)); - sc->curlet = inline_make_let_with_slot(sc, closure_let(f), car(closure_args(f)), sc->value); - sc->code = T_Pair(closure_body(f)); -} - -static void op_safe_closure_3s(s7_scheme *sc) -{ - s7_pointer args = cddr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_three_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), lookup(sc, car(args)), lookup(sc, cadr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_ssa(s7_scheme *sc) /* possibly inline b */ -{ /* ssa_a is hit once, but is only about 3/4% faster -- there's the fx overhead, etc */ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_three_slots(sc, closure_let(f), lookup(sc, car(args)), lookup(sc, cadr(args)), fx_call(sc, cddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_saa(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - s7_pointer args = cddr(sc->code); - s7_pointer arg2 = lookup(sc, cadr(sc->code)); /* I don't see fx_t|u here? */ - sc->code = fx_call(sc, args); - sc->curlet = update_let_with_three_slots(sc, closure_let(f), arg2, sc->code, fx_call(sc, cdr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_agg(s7_scheme *sc) /* possibly inline tleft */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_three_slots(sc, closure_let(f), fx_call(sc, args), fx_call(sc, cdr(args)), fx_call(sc, cddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_closure_p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args(sc, OP_CLOSURE_P_1, opt1_lambda(sc->code)); - sc->code = cadr(sc->code); -} - -static void op_closure_p_1(s7_scheme *sc) -{ - sc->curlet = inline_make_let_with_slot(sc, closure_let(sc->code), car(closure_args(sc->code)), sc->value); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_safe_closure_a(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(f), fx_call(sc, cdr(sc->code))); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static void op_safe_closure_a_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_slot(sc, closure_let(f), fx_call(sc, cdr(sc->code))); - sc->code = car(closure_body(f)); -} - -static void op_closure_ap(s7_scheme *sc) -{ - s7_pointer code = sc->code; - sc->args = fx_call(sc, cdr(code)); - /* (hook-push (undo-hook ind 0) (lambda (hook) (set! u0 #t))) -> # - * g_undo_hook calls s7_eval_c_string so it obviously should be declared unsafe! - */ - push_stack(sc, OP_CLOSURE_AP_1, opt1_lambda(sc->code), sc->args); - sc->code = caddr(code); -} - -static void op_closure_ap_1(s7_scheme *sc) -{ - /* sc->value is presumably the "P" argument value, "A" is sc->args->sc->code above (sc->args here is opt1_lambda(original sc->code)) */ - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(sc->args), car(closure_args(sc->args)), sc->code, cadr(closure_args(sc->args)), sc->value); - sc->code = T_Pair(closure_body(sc->args)); -} - -static void op_closure_pa(s7_scheme *sc) -{ - s7_pointer code = sc->code; - sc->args = fx_call(sc, cddr(code)); - check_stack_size(sc); - push_stack(sc, OP_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code)); /* "p" can be self-call changing func locally! so pass opt1_lambda(sc->code), not sc->code */ - sc->code = cadr(code); -} - -static void op_closure_pa_1(s7_scheme *sc) -{ - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(sc->code), car(closure_args(sc->code)), sc->value, cadr(closure_args(sc->code)), sc->args); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_closure_pp(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack(sc, OP_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code); - sc->code = cadr(sc->code); -} - -static void op_closure_pp_1(s7_scheme *sc) -{ - push_stack(sc, OP_CLOSURE_AP_1, sc->args, sc->value); - sc->code = caddr(sc->code); -} - -static void op_safe_closure_ap(s7_scheme *sc) -{ - check_stack_size(sc); - sc->args = fx_call(sc, cdr(sc->code)); - push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->args, opt1_lambda(sc->code)); - sc->code = caddr(sc->code); -} - -static void op_safe_closure_ap_1(s7_scheme *sc) -{ - sc->curlet = update_let_with_two_slots(sc, closure_let(sc->code), sc->args, sc->value); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_safe_closure_pa(s7_scheme *sc) -{ - check_stack_size(sc); - sc->args = fx_call(sc, cddr(sc->code)); - push_stack(sc, OP_SAFE_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code)); - sc->code = cadr(sc->code); -} - -static void op_safe_closure_pa_1(s7_scheme *sc) -{ - sc->curlet = update_let_with_two_slots(sc, closure_let(sc->code), sc->value, sc->args); - sc->code = T_Pair(closure_body(sc->code)); -} - -static void op_safe_closure_pp(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack(sc, OP_SAFE_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code); - sc->code = cadr(sc->code); -} - -static void op_safe_closure_pp_1(s7_scheme *sc) -{ - push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->args); - sc->code = caddr(sc->code); -} - -static void op_any_closure_3p(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - if (has_fx(p)) - { - sc->args = fx_call(sc, p); - p = cdr(p); - if (has_fx(p)) - { - sc->stack_end[0] = sc->code; /* push_stack_direct(sc, OP_ANY_CLOSURE_3P_3) here but trying to be too clever? */ - sc->stack_end[2] = sc->args; /* stack[args] == arg1 to closure) */ - sc->stack_end[3] = (s7_pointer)(OP_ANY_CLOSURE_3P_3); - sc->stack_end += 4; - set_stack_protected3_with(sc, fx_call(sc, p), OP_ANY_CLOSURE_3P_3); - /* (i.e. stack[curlet] == arg2 of closure), fx_call might push_stack gc_protect etc, so push_stack via +4 before it */ - sc->code = cadr(p); - } - else - { - push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */ - sc->code = car(p); - }} - else - { - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_3P_1); - sc->code = car(p); - } -} - -static bool closure_3p_end(s7_scheme *sc, s7_pointer p) -{ - if (has_fx(p)) - { - s7_pointer func = opt1_lambda(sc->code); - gc_protect_2_via_stack(sc, sc->args, sc->value); /* sc->args == arg1, sc->value == arg2 */ - set_stack_protected3(sc, fx_call(sc, p)); - if (is_safe_closure(func)) - sc->curlet = update_let_with_three_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc)); - else make_let_with_three_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc)); - unstack(sc); - sc->code = T_Pair(closure_body(func)); - return(true); - } - push_stack_direct(sc, OP_ANY_CLOSURE_3P_3); - set_stack_protected3_with(sc, sc->value, OP_ANY_CLOSURE_3P_3); /* arg2 == curlet stack loc */ - sc->code = car(p); - return(false); -} - -static bool op_any_closure_3p_1(s7_scheme *sc) -{ - s7_pointer p = cddr(sc->code); - sc->args = sc->value; /* (arg1 of closure) sc->value can be clobbered by fx_call? */ - if (has_fx(p)) - { - sc->value = fx_call(sc, p); - return(closure_3p_end(sc, cdr(p))); - } - push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); - sc->code = car(p); - return(false); -} - -static bool op_any_closure_3p_2(s7_scheme *sc) {return(closure_3p_end(sc, cdddr(sc->code)));} - -static void op_any_closure_3p_3(s7_scheme *sc) -{ - /* display(obj) will not work here because sc->curlet is being used as arg2 of the closure3 */ - s7_pointer func = opt1_lambda(sc->code); /* incoming args (from pop_stack): sc->args, sc->curlet, and sc->value from last evaluation */ - if (is_safe_closure(func)) - sc->curlet = update_let_with_three_slots(sc, closure_let(func), sc->args, sc->curlet, sc->value); - else make_let_with_three_slots(sc, func, sc->args, sc->curlet, sc->value); - sc->code = T_Pair(closure_body(func)); -} - -static void op_any_closure_4p(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - check_stack_size(sc); - if (has_fx(p)) - { - gc_protect_via_stack(sc, fx_call(sc, p)); - p = cdr(p); - if (has_fx(p)) - { - set_stack_protected2(sc, fx_call(sc, p)); - p = cdr(p); - if (has_fx(p)) - { - set_stack_protected3(sc, fx_call(sc, p)); - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); - sc->code = cadr(p); - } - else - { - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); - sc->code = car(p); - }} - else - { - sc->stack_end[2] = sc->unused; /* copy_stack dangling pair */ - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); - sc->code = car(p); - }} - else - { - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_1); - sc->code = car(p); - } -} - -static bool closure_4p_end(s7_scheme *sc, s7_pointer p) -{ - if (has_fx(p)) - { - s7_pointer func = opt1_lambda(sc->code); - sc->args = fx_call(sc, p); - if (is_safe_closure(func)) - sc->curlet = update_let_with_four_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->args); - else make_let_with_four_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->args); - sc->code = T_Pair(closure_body(func)); - unstack(sc); - return(true); - } - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); - sc->code = car(p); - return(false); -} - -static bool op_any_closure_4p_1(s7_scheme *sc) -{ - s7_pointer p = cddr(sc->code); - gc_protect_via_stack(sc, sc->value); - if (has_fx(p)) - { - set_stack_protected2(sc, fx_call(sc, p)); - p = cdr(p); - if (has_fx(p)) - { - set_stack_protected3(sc, fx_call(sc, p)); - return(closure_4p_end(sc, cdr(p))); - } - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); - sc->code = car(p); - } - else - { - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); - sc->code = car(p); - } - return(false); -} - -static bool op_any_closure_4p_2(s7_scheme *sc) -{ - s7_pointer p = cdddr(sc->code); - set_stack_protected2(sc, sc->value); - if (has_fx(p)) - { - set_stack_protected3(sc, fx_call(sc, p)); - return(closure_4p_end(sc, cdr(p))); - } - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); - sc->code = car(p); - return(false); -} - -static bool op_any_closure_4p_3(s7_scheme *sc) -{ - set_stack_protected3(sc, sc->value); - return(closure_4p_end(sc, cddddr(sc->code))); -} - -static inline void op_any_closure_4p_4(s7_scheme *sc) -{ - s7_pointer func = opt1_lambda(sc->code); - if (is_safe_closure(func)) - sc->curlet = update_let_with_four_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->value); - else make_let_with_four_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->value); - sc->code = T_Pair(closure_body(func)); - unstack(sc); -} - -static void op_safe_closure_ss(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(sc->code))); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static void op_safe_closure_ss_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(sc->code))); - sc->code = car(closure_body(f)); -} - -static inline void op_closure_ss(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - check_stack_size(sc); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), - car(closure_args(f)), lookup(sc, cadr(sc->code)), - cadr(closure_args(f)), lookup(sc, opt2_sym(sc->code))); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static inline void op_closure_ss_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), - car(closure_args(f)), lookup(sc, cadr(sc->code)), - cadr(closure_args(f)), lookup(sc, opt2_sym(sc->code))); - sc->code = car(closure_body(f)); -} - -static void op_safe_closure_sc(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), opt2_con(sc->code)); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static void op_safe_closure_sc_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), opt2_con(sc->code)); - sc->code = car(closure_body(f)); -} - -static void op_closure_sc(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - check_stack_size(sc); - sc->curlet = make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), lookup(sc, cadr(sc->code)), cadr(closure_args(f)), opt2_con(sc->code)); - sc->code = T_Pair(closure_body(f)); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); -} - -static inline void op_closure_sc_o(s7_scheme *sc) -{ - s7_pointer f = opt1_lambda(sc->code); - check_stack_size(sc); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), lookup(sc, cadr(sc->code)), cadr(closure_args(f)), opt2_con(sc->code)); - sc->code = car(closure_body(f)); -} - -static void op_closure_3s(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer v1 = lookup(sc, car(args)); - s7_pointer f = opt1_lambda(sc->code); - args = cdr(args); - make_let_with_three_slots(sc, f, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static inline void op_closure_3s_o(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer v1 = lookup(sc, car(args)); - s7_pointer f = opt1_lambda(sc->code); - args = cdr(args); - make_let_with_three_slots(sc, f, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ - sc->code = car(closure_body(f)); -} - -static void op_closure_4s(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer v1 = lookup(sc, car(args)); - s7_pointer v2 = lookup(sc, cadr(args)); - s7_pointer f = opt1_lambda(sc->code); - args = cddr(args); - make_let_with_four_slots(sc, f, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static inline void op_closure_4s_o(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer v1 = lookup(sc, car(args)); - s7_pointer v2 = lookup(sc, cadr(args)); - s7_pointer f = opt1_lambda(sc->code); - args = cddr(args); - make_let_with_four_slots(sc, f, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ - sc->code = car(closure_body(f)); -} - -static void op_safe_closure_aa(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */ - sc->curlet = update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), sc->code); - p = T_Pair(closure_body(f)); - /* check_stack_size(sc); */ /* pretty-print if cycles=#f? */ - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p))); - sc->code = car(p); -} - -static inline void op_safe_closure_aa_o(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); - sc->curlet = update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), sc->code); - sc->code = car(closure_body(f)); -} - -static void op_closure_aa(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); - sc->value = fx_call(sc, p); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), sc->value, cadr(closure_args(f)), sc->code); - p = T_Pair(closure_body(f)); - check_stack_size(sc); - push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p))); - sc->code = car(p); -} - -static Inline void inline_op_closure_aa_o(s7_scheme *sc) /* called once in eval, b cb left lg list */ -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); - sc->value = fx_call(sc, p); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), sc->value, cadr(closure_args(f)), sc->code); - sc->code = car(closure_body(f)); -} - -static inline void op_closure_fa(s7_scheme *sc) -{ - s7_pointer new_clo, code = sc->code; - s7_pointer farg = opt2_pair(code); /* cdadr(code); */ - s7_pointer aarg = fx_call(sc, cddr(code)); - s7_pointer func = opt1_lambda(code); /* outer func */ - s7_pointer func_args = closure_args(func); - sc->value = inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), sc->F, cadr(func_args), aarg); - new_clo = make_closure_unchecked(sc, car(farg), cdr(farg), T_CLOSURE | ((is_symbol(car(farg))) ? T_COPY_ARGS : 0), CLOSURE_ARITY_NOT_SET); - slot_set_value(let_slots(sc->value), new_clo); /* this order allows us to use make_closure_unchecked */ - sc->curlet = sc->value; - sc->code = car(closure_body(func)); -} - -static void op_safe_closure_ns(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - s7_pointer let = closure_let(f); - uint64_t id = ++sc->let_number; - let_set_id(let, id); - for (s7_pointer x = let_slots(let); tis_slot(x); x = next_slot(x), args = cdr(args)) - { - slot_set_value(x, lookup(sc, car(args))); - symbol_set_local_slot(slot_symbol(x), id, x); - } - set_curlet(sc, let); - sc->code = closure_body(f); - if_pair_set_up_begin_unchecked(sc); -} - -static inline void op_safe_closure_3a(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */ - sc->args = fx_call(sc, cddr(p)); /* is sc->args safe here? */ - sc->curlet = update_let_with_three_slots(sc, closure_let(f), fx_call(sc, p), sc->code, sc->args); - sc->code = closure_body(f); - if_pair_set_up_begin_unchecked(sc); -} - -static void op_safe_closure_na(s7_scheme *sc) -{ - s7_pointer let; - uint64_t id; - - sc->args = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code))); - for (s7_pointer args = cdr(sc->code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - sc->code = opt1_lambda(sc->code); - id = ++sc->let_number; - let = closure_let(sc->code); - let_set_id(let, id); - for (s7_pointer x = let_slots(let), z = sc->args; tis_slot(x); x = next_slot(x), z = cdr(z)) - { - slot_set_value(x, car(z)); - symbol_set_local_slot(slot_symbol(x), id, x); - } - clear_list_in_use(sc->args); - set_curlet(sc, let); - sc->code = closure_body(sc->code); - if_pair_set_up_begin_unchecked(sc); -} - -static /* inline */ void op_closure_ns(s7_scheme *sc) /* called once in eval, lg? */ -{ - /* in this case, we have just lambda (not lambda*), and no dotted arglist, - * and no accessed symbols in the arglist, and we know the arglist matches the parameter list. - */ - s7_pointer args = cdr(sc->code), last_slot; - s7_pointer f = opt1_lambda(sc->code); - s7_pointer p = closure_args(f); - s7_pointer e = inline_make_let(sc, closure_let(f)); - s7_int id = let_id(e); - sc->z = e; - add_slot_unchecked(sc, e, car(p), lookup(sc, car(args)), id); - last_slot = let_slots(e); - for (p = cdr(p), args = cdr(args); is_pair(p); p = cdr(p), args = cdr(args)) - last_slot = inline_add_slot_at_end(sc, id, last_slot, car(p), lookup(sc, car(args))); /* main such call in lt (fx_s is 1/2, this is 1/5 of all calls) */ - set_curlet(sc, e); - sc->z = sc->unused; - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_ass(s7_scheme *sc) /* possibly inline b */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - make_let_with_three_slots(sc, f, fx_call(sc, args), lookup(sc, cadr(args)), lookup(sc, caddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_aas(s7_scheme *sc) /* possibly inline b */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->z = fx_call(sc, args); - make_let_with_three_slots(sc, f, sc->z, fx_call(sc, cdr(args)), lookup(sc, caddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_saa(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->z = fx_call(sc, cdr(args)); - make_let_with_three_slots(sc, f, lookup(sc, car(args)), sc->z, fx_call(sc, cddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_asa(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - sc->z = fx_call(sc, args); - make_let_with_three_slots(sc, f, sc->z, lookup(sc, cadr(args)), fx_call(sc, cddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_sas(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - make_let_with_three_slots(sc, f, lookup(sc, car(args)), fx_call(sc, cdr(args)), lookup(sc, caddr(args))); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static inline void op_closure_3a(s7_scheme *sc) /* if inlined, tlist -60 */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cdr(args))); - make_let_with_three_slots(sc, f, stack_protected1(sc), stack_protected2(sc), fx_call(sc, cddr(args))); - unstack(sc); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_4a(s7_scheme *sc) /* sass */ -{ - s7_pointer args = cdr(sc->code); - s7_pointer f = opt1_lambda(sc->code); - gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cddr(args))); - args = cdr(args); - set_stack_protected3(sc, fx_call(sc, args)); /* [-3]=second */ - make_let_with_four_slots(sc, f, stack_protected1(sc), stack_protected3(sc), stack_protected2(sc), fx_call(sc, cddr(args))); - unstack(sc); - sc->code = T_Pair(closure_body(f)); - if_pair_set_up_begin(sc); -} - -static void op_closure_na(s7_scheme *sc) -{ - s7_pointer exprs = cdr(sc->code); - s7_pointer func = opt1_lambda(sc->code), slot, last_slot; - s7_int id; - s7_pointer pars = closure_args(func); - s7_pointer e = inline_make_let(sc, closure_let(func)); - sc->z = e; - sc->value = fx_call(sc, exprs); - new_cell_no_check(sc, last_slot, T_SLOT); - slot_set_symbol_and_value(last_slot, car(pars), sc->value); - slot_set_next(last_slot, let_slots(e)); /* i.e. slot_end */ - let_set_slots(e, last_slot); - for (pars = cdr(pars), exprs = cdr(exprs); is_pair(pars); pars = cdr(pars), exprs = cdr(exprs)) - { - sc->value = fx_call(sc, exprs); /* before new_cell since it might call the GC */ - new_cell(sc, slot, T_SLOT); /* args < GC_TRIGGER checked in optimizer, but we're calling fx_call? */ - slot_set_symbol_and_value(slot, car(pars), sc->value); - /* setting up the let might use unrelated-but-same-name symbols, so wait to set the symbol ids */ - slot_set_next(slot, slot_end(sc)); - slot_set_next(last_slot, slot); - last_slot = slot; - } - set_curlet(sc, e); - sc->z = sc->unused; - let_set_id(e, ++sc->let_number); - for (id = let_id(e), slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) - { - symbol_set_local_slot(slot_symbol(slot), id, slot); - set_local(slot_symbol(slot)); - } - sc->code = T_Pair(closure_body(func)); - if_pair_set_up_begin(sc); -} - -static bool check_closure_sym(s7_scheme *sc, int32_t args) -{ - /* can't use closure_is_fine -- (lambda args 1) and (lambda (name . args) 1) are both arity -1 for the internal arity checkers! */ - if ((symbol_ctr(car(sc->code)) != 1) || - (unchecked_local_value(car(sc->code)) != opt1_lambda_unchecked(sc->code))) - { - s7_pointer f = lookup_unexamined(sc, car(sc->code)); - if ((f != opt1_lambda_unchecked(sc->code)) && - ((!f) || - ((typesflag(f) & (TYPE_MASK | T_SAFE_CLOSURE)) != T_CLOSURE) || - (((args == 1) && (!is_symbol(closure_args(f)))) || - ((args == 2) && ((!is_pair(closure_args(f))) || (!is_symbol(cdr(closure_args(f))))))))) - { - sc->last_function = f; - return(false); - } - set_opt1_lambda(sc->code, f); - } - return(true); -} - -static void op_any_closure_sym(s7_scheme *sc) /* for (lambda a ...) */ -{ - s7_pointer func = opt1_lambda(sc->code), old_args = cdr(sc->code); /* args aren't evaluated yet */ - s7_int num_args = opt3_arglen(old_args); - - if (num_args == 1) - sc->curlet = inline_make_let_with_slot(sc, closure_let(func), closure_args(func), - ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? - set_plist_1(sc, fx_call(sc, old_args)) : list_1(sc, sc->value = fx_call(sc, old_args))); - else - if (num_args == 2) - { - gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ - sc->args = fx_call(sc, cdr(old_args)); - sc->curlet = inline_make_let_with_slot(sc, closure_let(func), closure_args(func), - ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? - set_plist_2(sc, stack_protected1(sc), sc->args) : list_2(sc, stack_protected1(sc), sc->args)); - unstack(sc); - } - else - if (num_args == 0) - sc->curlet = inline_make_let_with_slot(sc, closure_let(func), closure_args(func), sc->nil); - else - { - sc->args = make_list(sc, num_args, sc->unused); - for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - sc->curlet = make_let_with_slot(sc, closure_let(func), closure_args(func), sc->args); - } - sc->code = T_Pair(closure_body(func)); -} - -static void op_any_closure_a_sym(s7_scheme *sc) /* for (lambda (a . b) ...) */ -{ - s7_pointer func = opt1_lambda(sc->code), old_args = cdr(sc->code); - s7_int num_args = opt3_arglen(old_args); - s7_pointer func_args = closure_args(func); - - if (num_args == 1) - sc->curlet = make_let_with_two_slots(sc, closure_let(func), car(func_args), sc->value = fx_call(sc, old_args), cdr(func_args), sc->nil); - else - { - gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ - if (num_args == 2) - { - sc->args = fx_call(sc, cdr(old_args)); - sc->curlet = inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), list_1(sc, sc->args)); - } - else - { - sc->args = make_list(sc, num_args - 1, sc->unused); - old_args = cdr(old_args); - for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - sc->curlet = make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), sc->args); - } - unstack(sc); - } - sc->code = T_Pair(closure_body(func)); -} - - -/* -------- */ -#if S7_DEBUGGING -#define TC_REC_SIZE NUM_OPS -#define TC_REC_LOW_OP OP_TC_AND_A_OR_A_LA - -static void init_tc_rec(s7_scheme *sc) -{ - sc->tc_rec_calls = (int *)Calloc(TC_REC_SIZE, sizeof(int)); - add_saved_pointer(sc, sc->tc_rec_calls); -} - -static s7_pointer g_report_missed_calls(s7_scheme *sc, s7_pointer args) -{ - for (int32_t i = TC_REC_LOW_OP; i < NUM_OPS; i++) - if (sc->tc_rec_calls[i] == 0) - fprintf(stderr, "%s missed\n", op_names[i]); - return(sc->F); -} - -static void tick_tc(s7_scheme *sc, int32_t op) -{ - sc->tc_rec_calls[op]++; -} -#else -#define tick_tc(Sc, Op) -#endif - -static bool op_tc_case_la(s7_scheme *sc, s7_pointer code) -{ - /* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ - s7_pointer clauses = cddr(code), la_slot = let_slots(sc->curlet), endp, selp = cdr(code); - s7_int len = opt3_arglen(cdr(code)); - if (len == 3) - { - while (true) - { - s7_pointer selector = fx_call(sc, selp); - if (selector == opt1_any(clauses)) - endp = opt2_any(clauses); - else - { - s7_pointer p = cdr(clauses); - endp = (selector == opt1_any(p)) ? opt2_any(p) : opt2_any(cdr(p)); - } - if (has_tc(endp)) - slot_set_value(la_slot, fx_call(sc, cdr(endp))); - else break; - }} - else - while (true) - { - s7_pointer p, selector = fx_call(sc, selp); - for (p = clauses; is_pair(cdr(p)); p = cdr(p)) - if (selector == opt1_any(p)) {endp = opt2_any(p); goto CASE_ALA_END;} - endp = opt2_any(p); - CASE_ALA_END: - if (has_tc(endp)) - slot_set_value(la_slot, fx_call(sc, cdr(endp))); - else break; - } - if (has_fx(endp)) - { - sc->value = fx_call(sc, endp); - return(true); /* continue */ - } - sc->code = endp; - return(false); /* goto BEGIN (not like op_tc_z below) */ -} - -static s7_pointer fx_tc_case_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_CASE_LA); - op_tc_case_la(sc, arg); - return(sc->value); -} - -static bool op_tc_z(s7_scheme *sc, s7_pointer expr) -{ - if (has_fx(expr)) - { - sc->value = fx_call(sc, expr); - return(true); - } - sc->code = car(expr); - return(false); -} - -static void op_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or = cdadr(fx_and); - s7_pointer fx_la = cdadr(fx_or); - /* cell_optimize here is slower! */ - while (true) - { - s7_pointer p; - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_OR_A_LA); - op_tc_and_a_or_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and = cdadr(fx_or); - s7_pointer fx_la = cdadr(fx_and); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_LA); - op_tc_or_a_and_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or1 = cdadr(fx_and); - s7_pointer fx_or2 = cdr(fx_or1); - s7_pointer fx_la = cdadr(fx_or2); - while (true) - { - s7_pointer p; - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - p = fx_call(sc, fx_or1); - if (p != sc->F) {sc->value = p; return;} - p = fx_call(sc, fx_or2); - if (p != sc->F) {sc->value = p; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_OR_A_A_LA); - op_tc_and_a_or_a_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and1 = cdadr(fx_or); - s7_pointer fx_and2 = cdr(fx_and1); - s7_pointer fx_la = cdadr(fx_and2); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if ((fx_call(sc, fx_and1) == sc->F) || - (fx_call(sc, fx_and2) == sc->F)) - {sc->value = sc->F; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_A_LA); - op_tc_or_a_and_a_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or1 = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or2 = cdr(fx_or1); - s7_pointer fx_and1 = cdadr(fx_or2); - s7_pointer fx_and2 = cdr(fx_and1); - s7_pointer fx_la = cdadr(fx_and2); - while (true) - { - s7_pointer p = fx_call(sc, fx_or1); - if (p != sc->F) {sc->value = p; return;} - p = fx_call(sc, fx_or2); - if (p != sc->F) {sc->value = p; return;} - if (fx_call(sc, fx_and1) == sc->F) {sc->value = sc->F; return;} - if (fx_call(sc, fx_and2) == sc->F) {sc->value = sc->F; return;} - slot_set_value(la_slot, fx_call(sc, fx_la)); - } -} - -static s7_pointer fx_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_A_AND_A_A_LA); - op_tc_or_a_a_and_a_a_la(sc, arg); - return(sc->value); -} - -static void op_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or = cdadr(fx_and); - s7_pointer fx_la = cdadr(fx_or); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer laa_slot = next_slot(la_slot); - - if ((fx_proc(fx_and) == fx_not_is_null_u) && (fx_proc(fx_or) == fx_is_null_t) && - (fx_proc(fx_la) == fx_cdr_t) && (fx_proc(fx_laa) == fx_cdr_u)) - { - s7_pointer la_val = slot_value(la_slot), laa_val = slot_value(laa_slot); - while (true) - { - if (is_null(laa_val)) {sc->value = sc->F; return;} - if (is_null(la_val)) {sc->value = sc->T; return;} - la_val = cdr(la_val); - laa_val = cdr(laa_val); - }} - while (true) - { - s7_pointer p; - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - sc->rec_p1 = fx_call(sc, fx_la); - slot_set_value(laa_slot, fx_call(sc, fx_laa)); - slot_set_value(la_slot, sc->rec_p1); - } -} - -static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_OR_A_LAA); - op_tc_and_a_or_a_laa(sc, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static void op_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and = cdadr(fx_or); - s7_pointer fx_la = cdadr(fx_and); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer laa_slot = next_slot(la_slot); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - sc->rec_p1 = fx_call(sc, fx_la); - slot_set_value(laa_slot, fx_call(sc, fx_laa)); - slot_set_value(la_slot, sc->rec_p1); - } -} - -static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_LAA); - op_tc_or_a_and_a_laa(sc, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static void op_tc_and_a_or_a_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_or = cdadr(fx_and); - s7_pointer fx_la = cdadr(fx_or); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer fx_l3a = cdr(fx_laa); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer l3a_slot = next_slot(laa_slot); - while (true) - { - s7_pointer p; - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - sc->rec_p1 = fx_call(sc, fx_la); - sc->rec_p2 = fx_call(sc, fx_laa); - slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } -} - -static s7_pointer fx_tc_and_a_or_a_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_OR_A_L3A); - op_tc_and_a_or_a_l3a(sc, arg); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static void op_tc_or_a_and_a_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and = cdadr(fx_or); - s7_pointer fx_la = cdadr(fx_and); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer fx_l3a = cdr(fx_laa); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer l3a_slot = next_slot(laa_slot); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;} - sc->rec_p1 = fx_call(sc, fx_la); - sc->rec_p2 = fx_call(sc, fx_laa); - slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } -} - -static s7_pointer fx_tc_or_a_and_a_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_L3A); - op_tc_or_a_and_a_l3a(sc, arg); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static void op_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer fx_and1 = opt3_pair(fx_or); /* (or_case) ? cdadr(fx_or) : cdaddr(fx_or); */ - s7_pointer fx_and2 = cdr(fx_and1); - s7_pointer fx_la = cdadr(fx_and2); - s7_pointer fx_laa = cdr(fx_la); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer fx_l3a = cdr(fx_laa); - s7_pointer l3a_slot = next_slot(laa_slot); - if ((fx_proc(fx_and1) == fx_not_a) && (fx_proc(fx_and2) == fx_not_a)) - { - fx_and1 = cdar(fx_and1); - fx_and2 = cdar(fx_and2); - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if ((fx_call(sc, fx_and1) != sc->F) || (fx_call(sc, fx_and2) != sc->F)) {sc->value = sc->F; return;} - sc->rec_p1 = fx_call(sc, fx_la); - sc->rec_p2 = fx_call(sc, fx_laa); - slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); - slot_set_value(la_slot, sc->rec_p1); - slot_set_value(laa_slot, sc->rec_p2); - }} - while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if ((fx_call(sc, fx_and1) == sc->F) || (fx_call(sc, fx_and2) == sc->F)) {sc->value = sc->F; return;} - sc->rec_p1 = fx_call(sc, fx_la); - sc->rec_p2 = fx_call(sc, fx_laa); - slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); - slot_set_value(la_slot, sc->rec_p1); - slot_set_value(laa_slot, sc->rec_p2); - } -} - -static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_OR_A_AND_A_A_L3A); - op_tc_or_a_and_a_a_l3a(sc, arg); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code, bool cond) -{ - s7_pointer la_slot = let_slots(sc->curlet); - s7_pointer if_test = (cond) ? cadr(code) : cdr(code); - s7_pointer if_true = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test); - s7_pointer la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test); - if (is_t_integer(slot_value(la_slot))) - { - sc->pc = 0; - if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); - slot_set_value(la_slot, val); - while (!(o->v[0].fb(o))){integer(val) = o1->v[0].fi(o1);} - return(op_tc_z(sc, if_true)); - }}} - while (fx_call(sc, if_test) == sc->F) {slot_set_value(la_slot, fx_call(sc, la));} - return(op_tc_z(sc, if_true)); -} - -static s7_pointer fx_tc_if_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_LA); - op_tc_if_a_z_la(sc, arg, false); - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_LA); - op_tc_if_a_z_la(sc, arg, true); - return(sc->value); -} - -static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code, bool cond) -{ - s7_pointer la_slot = let_slots(sc->curlet); - s7_pointer if_test = (cond) ? cadr(code) : cdr(code); - s7_pointer if_false = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test); - s7_pointer la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test); - if (is_t_integer(slot_value(la_slot))) - { - sc->pc = 0; - if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); - slot_set_value(la_slot, val); - while (o->v[0].fb(o)) {integer(val) = o1->v[0].fi(o1);} - return(op_tc_z(sc, if_false)); - }}} - while (fx_call(sc, if_test) != sc->F) {slot_set_value(la_slot, fx_call(sc, la));} - return(op_tc_z(sc, if_false)); -} - -static s7_pointer fx_tc_if_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_LA_Z); - op_tc_if_a_la_z(sc, arg, false); - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_LA_Z); - op_tc_if_a_la_z(sc, arg, true); - return(sc->value); -} - -typedef enum {TC_IF, TC_COND, TC_AND} tc_choice_t; - -static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first, tc_choice_t cond) -{ - s7_pointer if_test, if_z, la, laa, laa_slot, la_slot = let_slots(sc->curlet); - s7_function tf; - if (cond == TC_IF) - { - if_test = cdr(code); - if_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */ - la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */ - } - else - { - if_test = cadr(code); - if_z = opt1_pair(cdr(code)); /* if_z = (z_first) ? cdr(if_test) : cdr(caddr(code)) */ - la = opt3_pair(cdr(code)); /* la = (z_first) ? cdr(cadaddr(code)) : cdadr(if_test) */ - } - laa = cdr(la); - laa_slot = next_slot(la_slot); -#if (!WITH_GMP) - if (!no_bool_opt(code)) - { - sc->pc = 0; - if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc], *o2; - int32_t start_pc = sc->pc; - if ((is_t_integer(slot_value(la_slot))) && - (is_t_integer(slot_value(laa_slot)))) - { - if (int_optimize(sc, la)) - { - o2 = sc->opts[sc->pc]; - if (int_optimize(sc, laa)) - { - s7_int (*fi1)(opt_info *o) = o1->v[0].fi; - s7_int (*fi2)(opt_info *o) = o2->v[0].fi; - bool (*fb)(opt_info *o) = o->v[0].fb; - s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); - s7_pointer val2; - slot_set_value(la_slot, val1); - slot_set_value(laa_slot, val2 = make_mutable_integer(sc, integer(slot_value(laa_slot)))); - if ((z_first) && - ((fb == opt_b_ii_sc_lt) || (fb == opt_b_ii_sc_lt_0)) && - (fi1 == opt_i_ii_sc_sub)) - { - s7_int lim = o->v[2].i, m = o1->v[2].i; - s7_pointer slot1 = o->v[1].p, slot2 = o1->v[1].p; - while (integer(slot_value(slot1)) >= lim) - { - s7_int i1 = integer(slot_value(slot2)) - m; - integer(val2) = fi2(o2); - integer(val1) = i1; - }} - else - while (fb(o) != z_first) - { - s7_int i1 = fi1(o1); - integer(val2) = fi2(o2); - integer(val1) = i1; - } - return(op_tc_z(sc, if_z)); - }}} - - if ((is_t_real(slot_value(la_slot))) && - (is_t_real(slot_value(laa_slot)))) - { - sc->pc = start_pc; - if (float_optimize(sc, la)) - { - o2 = sc->opts[sc->pc]; - if (float_optimize(sc, laa)) - { - s7_double (*fd1)(opt_info *o) = o1->v[0].fd; - s7_double (*fd2)(opt_info *o) = o2->v[0].fd; - bool (*fb)(opt_info *o) = o->v[0].fb; - s7_pointer val1 = s7_make_mutable_real(sc, real(slot_value(la_slot))); - s7_pointer val2 = s7_make_mutable_real(sc, real(slot_value(laa_slot))); - slot_set_value(la_slot, val1); - slot_set_value(laa_slot, val2); - if ((z_first) && - (fb == opt_b_dd_sc_lt) && - (fd1 == opt_d_dd_sc_sub)) - { - s7_double lim = o->v[2].x; - s7_double m = o1->v[2].x; - s7_pointer slot1 = o->v[1].p; - s7_pointer slot2 = o1->v[1].p; - while (real(slot_value(slot1)) >= lim) - { - s7_double x1 = real(slot_value(slot2)) - m; - real(val2) = fd2(o2); - real(val1) = x1; - }} - else - while (fb(o) != z_first) - { - s7_double x1 = fd1(o1); - real(val2) = fd2(o2); - real(val1) = x1; - } - return(op_tc_z(sc, if_z)); - }}}} - set_no_bool_opt(code); - } -#endif - tf = fx_proc(if_test); - if_test = car(if_test); - if (z_first) - { - if ((fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_subtract_u1) && - (fn_proc(if_test) == g_num_eq_xi) && /* was also (fx_proc(if_test) == fx_num_eq_ui) but we cloberred if_test above */ - (is_pair(slot_value(la_slot))) && (is_t_integer(slot_value(laa_slot)))) - { /* list-tail ferchrissake */ - s7_int end = integer(caddr(if_test)); - s7_pointer lst = slot_value(la_slot); - for (s7_int start = integer(slot_value(laa_slot)); start > end; start--) - lst = cdr(lst); - slot_set_value(la_slot, lst); - } - else - while (tf(sc, if_test) == sc->F) - { - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - }} - else - while (tf(sc, if_test) != sc->F) - { - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, if_z)); -} - -static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_LAA); - op_tc_if_a_z_laa(sc, arg, true, TC_IF); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_LAA); - op_tc_if_a_z_laa(sc, arg, true, TC_COND); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_LAA_Z); - op_tc_if_a_z_laa(sc, arg, false, TC_IF); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_laa_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_LAA_Z); - op_tc_if_a_z_laa(sc, arg, false, TC_COND); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static void op_tc_when_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if_test = cadr(code), body = cddr(code), la_call, la, la_slot = let_slots(sc->curlet); - s7_function tf = fx_proc(cdr(code)); - for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); - la = cdar(la_call); - while (tf(sc, if_test) != sc->F) - { - for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); - slot_set_value(la_slot, fx_call(sc, la)); - } - sc->value = sc->unspecified; -} - -static void op_tc_when_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if_test = cadr(code), body = cddr(code), la, laa, laa_slot, la_call, la_slot = let_slots(sc->curlet); - s7_function tf = fx_proc(cdr(code)); - for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); - la = cdar(la_call); - laa = cdr(la); - laa_slot = next_slot(la_slot); - while (tf(sc, if_test) != sc->F) - { - for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - } - sc->rec_p1 = sc->unused; - sc->value = sc->unspecified; -} - -static void op_tc_when_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if_test = cadr(code), body = cddr(code), la, laa, l3a, laa_slot, l3a_slot, la_call, la_slot = let_slots(sc->curlet); - s7_function tf = fx_proc(cdr(code)); - for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); - la = cdar(la_call); - laa = cdr(la); - l3a = cdr(laa); - laa_slot = next_slot(la_slot); - l3a_slot = next_slot(laa_slot); - while (tf(sc, if_test) != sc->F) - { - for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); - sc->rec_p1 = fx_call(sc, la); - sc->rec_p2 = fx_call(sc, laa); - slot_set_value(l3a_slot, fx_call(sc, l3a)); - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } - sc->rec_p1 = sc->unused; - sc->value = sc->unspecified; -} - -static bool op_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer code, bool z_first) -{ - s7_pointer if_test = cdr(code), la_slot = let_slots(sc->curlet); - s7_pointer f_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */ - s7_pointer la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */ - s7_pointer laa = cdr(la); - s7_pointer l3a = cdr(laa); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer l3a_slot = next_slot(laa_slot); - s7_function tf = fx_proc(if_test); - if_test = car(if_test); - while ((tf(sc, if_test) == sc->F) == z_first) - { - sc->rec_p1 = fx_call(sc, la); - sc->rec_p2 = fx_call(sc, laa); - slot_set_value(l3a_slot, fx_call(sc, l3a)); - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, f_z)); -} - -static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_L3A); - op_tc_if_a_z_l3a(sc, arg, true); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_if_a_l3a_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_L3A_Z); - op_tc_if_a_z_l3a(sc, arg, false); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first, tc_choice_t cond) -{ - s7_pointer if_test, if_true, if_false, f_test, f_z, la, endp, la_slot = let_slots(sc->curlet); - bool tc_and = (cond == TC_AND); - if (cond != TC_COND) - { - if_test = cdr(code); - if_true = (!tc_and) ? cdr(if_test) : sc->F; - if_false = (!tc_and) ? cadr(if_true) : cadr(if_test); - f_test = cdr(if_false); - f_z = (z_first) ? cdr(f_test) : cddr(f_test); - la = (z_first) ? cdaddr(f_test) : cdadr(f_test); - } - else - { - if_test = cadr(code); /* code: (cond (a1 z1) (a2 z2|la) (else la|z2)) */ - if_true = cdr(if_test); - if_false = caddr(code); /* (a2 z2|la) */ - f_test = if_false; - f_z = (z_first) ? cdr(f_test) : cdr(cadddr(code)); - la = (z_first) ? cdadr(cadddr(code)) : cdadr(caddr(code)); - } -#if (!WITH_GMP) - if (is_t_integer(slot_value(la_slot))) - { - opt_info *o = sc->opts[0]; - sc->pc = 0; - if (bool_optimize_nw(sc, if_test)) - { - opt_info *o1 = sc->opts[sc->pc]; - if (bool_optimize_nw(sc, f_test)) - { - opt_info *o2 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); - slot_set_value(la_slot, val); - if (tc_and) - while (true) - { - if (!o->v[0].fb(o)) {sc->value = sc->F; return(true);} - if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} - integer(val) = o2->v[0].fi(o2); - } - else - while (true) - { - if (o->v[0].fb(o)) {endp = if_true; break;} - if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} - integer(val) = o2->v[0].fi(o2); - } - return(op_tc_z(sc, endp)); - }}}} -#endif - while (true) - { - if ((fx_call(sc, if_test) == sc->F) == tc_and) {if (tc_and) {sc->value = sc->F; return(true);} else {endp = if_true; break;}} - if ((fx_call(sc, f_test) == sc->F) != z_first) {endp = f_z; break;} - slot_set_value(la_slot, fx_call(sc, la)); - } - return(op_tc_z(sc, endp)); -} - -static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LA); - op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_IF); - return(sc->value); -} - -static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_LA_Z); - op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_IF); - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_Z_LA); - op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_COND); - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_LA_Z); - op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_COND); - return(sc->value); -} - -static s7_pointer fx_tc_and_a_if_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_IF_A_Z_LA); - op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_AND); - return(sc->value); -} - -static s7_pointer fx_tc_and_a_if_a_la_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_AND_A_IF_A_LA_Z); - op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_AND); - return(sc->value); -} - -static bool op_tc_if_a_z_if_a_z_laa(s7_scheme *sc, bool cond, s7_pointer code) -{ - s7_pointer if_false, f_test, f_true, la, laa, laa_slot, endp, slot1, la_slot = let_slots(sc->curlet); - s7_pointer if_test = (cond) ? cadr(code) : cdr(code); - s7_pointer if_true = cdr(if_test); - if (!cond) if_false = cadr(if_true); - f_test = (cond) ? caddr(code) : cdr(if_false); - f_true = cdr(f_test); - la = (cond) ? opt3_pair(code) : cdadr(f_true); /* cdadr(cadddr(code)) */ - laa = cdr(la); - laa_slot = next_slot(la_slot); - slot1 = (fx_proc(if_test) == fx_is_null_t) ? la_slot : ((fx_proc(if_test) == fx_is_null_u) ? laa_slot : NULL); - if (slot1) - { - if ((slot1 == laa_slot) && (fx_proc(f_test) == fx_is_null_t) && (fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_cdr_u) && - (is_boolean(car(if_true))) && (is_boolean(car(f_true)))) - { - s7_pointer la_val = slot_value(la_slot), laa_val = slot_value(laa_slot); - while (true) - { - if (is_null(laa_val)) {sc->value = car(if_true); return(true);} - if (is_null(la_val)) {sc->value = car(f_true); return(true);} - la_val = cdr(la_val); - laa_val = cdr(laa_val); - }} - while (true) - { - if (is_null(slot_value(slot1))) {endp = if_true; break;} - if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - }} - else - while (true) - { - if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} - if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, endp)); -} - -static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LAA); - op_tc_if_a_z_if_a_z_laa(sc, false, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_Z_LAA); - op_tc_if_a_z_if_a_z_laa(sc, true, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_if_a_laa_z(s7_scheme *sc, bool cond, s7_pointer code) -{ - s7_pointer if_false, f_test, f_true, f_false, la, laa, laa_slot, endp, la_slot = let_slots(sc->curlet); - s7_pointer if_test = (cond) ? cadr(code) : cdr(code); - s7_pointer if_true = cdr(if_test); - if (!cond) if_false = cadr(if_true); - f_test = (cond) ? caddr(code) : cdr(if_false); - f_true = cdr(f_test); - f_false = (cond) ? cdr(cadddr(code)) : cdr(f_true); - la = (cond) ? opt3_pair(code) : cdar(f_true); /* cdadr(caddr(code)) */ - laa = cdr(la); - laa_slot = next_slot(la_slot); - while (true) - { - if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} - if (fx_call(sc, f_test) == sc->F) {endp = f_false; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, endp)); -} - -static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_LAA_Z); - op_tc_if_a_z_if_a_laa_z(sc, false, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_cond_a_z_a_laa_z(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_LAA_Z); - op_tc_if_a_z_if_a_laa_z(sc, true, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if_test = cdr(code); - s7_pointer endp, la_slot = let_slots(sc->curlet); - s7_pointer if_true = cdr(if_test); - s7_pointer if_false = cadr(if_true); - s7_pointer f_test = cdr(if_false); - s7_pointer f_true = cdr(f_test); - s7_pointer f_false = cdr(f_true); - s7_pointer la1 = cdar(f_true); - s7_pointer la2 = cdar(f_false); - s7_pointer laa1 = cdr(la1); - s7_pointer laa2 = cdr(la2); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer l3a1 = cdr(laa1); - s7_pointer l3a2 = cdr(laa2); - s7_pointer l3a_slot = next_slot(laa_slot); - while (true) - { - if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} - if (fx_call(sc, f_test) != sc->F) - { - sc->rec_p1 = fx_call(sc, la1); - sc->rec_p2 = fx_call(sc, laa1); - slot_set_value(l3a_slot, fx_call(sc, l3a1)); - } - else - { - sc->rec_p1 = fx_call(sc, la2); - sc->rec_p2 = fx_call(sc, laa2); - slot_set_value(l3a_slot, fx_call(sc, l3a2)); - } - slot_set_value(laa_slot, sc->rec_p2); - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, endp)); -} - -static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_IF_A_Z_IF_A_L3A_L3A); - op_tc_if_a_z_if_a_l3a_l3a(sc, arg); - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - return(sc->value); -} - -static bool op_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer code) -{ - s7_pointer body = caddr(code); - s7_pointer outer_let = sc->curlet; - s7_pointer la_slot = let_slots(outer_let); - s7_pointer if_test = cdr(body); - s7_pointer if_true = cddr(body); - s7_pointer if_false = cadddr(body); - s7_pointer la = cdr(if_false); - s7_pointer let_var = caadr(code); - s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); - s7_pointer let_slot = let_slots(inner_let); - sc->curlet = inner_let; - s7_gc_protect_via_stack(sc, inner_let); - let_var = cdr(let_var); - - while (fx_call(sc, if_test) == sc->F) - { - slot_set_value(la_slot, fx_call(sc, la)); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - } - unstack(sc); - if (!op_tc_z(sc, if_true)) - return(false); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - return(true); -} - -static s7_pointer fx_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_IF_A_Z_LA); - op_tc_let_if_a_z_la(sc, arg); - return(sc->value); -} - -static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer body = caddr(code); - s7_pointer outer_let = sc->curlet; - s7_pointer la_slot = let_slots(outer_let); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer if_test = cdr(body); - s7_pointer if_true = cddr(body); - s7_pointer if_false = cadddr(body); - s7_pointer la = cdr(if_false); - s7_pointer laa = cddr(if_false); - s7_pointer let_var = caadr(code); - s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); - s7_pointer let_slot = let_slots(inner_let); - sc->curlet = inner_let; - s7_gc_protect_via_stack(sc, inner_let); - let_var = cdr(let_var); -#if (!WITH_GMP) - if (!no_bool_opt(code)) - { - sc->pc = 0; - if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0]; - opt_info *o1 = sc->opts[sc->pc], *o2, *o3; - if ((is_t_integer(slot_value(la_slot))) && - (is_t_integer(slot_value(laa_slot)))) - { - if (int_optimize(sc, la)) - { - o2 = sc->opts[sc->pc]; - if (int_optimize(sc, laa)) - { - o3 = sc->opts[sc->pc]; - set_curlet(sc, outer_let); - if (int_optimize(sc, let_var)) - { - s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); - s7_pointer val2 = make_mutable_integer(sc, integer(slot_value(laa_slot))); - s7_pointer val3 = make_mutable_integer(sc, integer(slot_value(let_slot))); - set_curlet(sc, inner_let); - slot_set_value(la_slot, val1); - slot_set_value(laa_slot, val2); - slot_set_value(let_slot, val3); - while (!(o->v[0].fb(o))) - { - s7_int i1 = o1->v[0].fi(o1); - integer(val2) = o2->v[0].fi(o2); - integer(val1) = i1; - integer(val3) = o3->v[0].fi(o3); - } - unstack(sc); - if (!op_tc_z(sc, if_true)) /* sc->inner_let in effect here since it was the last set above */ - return(false); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - return(true); - }}}}} - set_no_bool_opt(code); - } -#endif - while (fx_call(sc, if_test) == sc->F) - { - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - } - unstack(sc); - if (!op_tc_z(sc, if_true)) - return(false); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - return(true); -} - -static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_IF_A_Z_LAA); - op_tc_let_if_a_z_laa(sc, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static void op_tc_let_when_laa(s7_scheme *sc, bool when, s7_pointer code) -{ - s7_pointer p, body = caddr(code), la, laa, let_var = caadr(code), outer_let = sc->curlet; - s7_pointer if_test = cdr(body); - s7_pointer if_true = cddr(body); - s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); - s7_pointer let_slot = let_slots(inner_let); - sc->curlet = inner_let; - s7_gc_protect_via_stack(sc, inner_let); - let_var = cdr(let_var); - - for (p = if_true; is_pair(cdr(p)); p = cdr(p)); - la = cdar(p); - laa = cddar(p); - if ((car(la) == slot_symbol(let_slots(outer_let))) && - (car(laa) == slot_symbol(next_slot(let_slots(outer_let))))) - { - if ((cdr(if_true) == p) && (!when)) - { - s7_pointer a1 = slot_value(let_slots(outer_let)); - s7_pointer a2 = slot_value(next_slot(let_slots(outer_let))); - if ((is_input_port(a1)) && (is_output_port(a2)) && (is_string_port(a1)) && (is_file_port(a2)) && - (!port_is_closed(a1)) && (!port_is_closed(a2)) && (fx_proc(if_true) == fx_c_tU_direct) && - (fx_proc(let_var) == fx_c_t_direct) && (((s7_p_pp_t)opt3_direct(cdar(if_true))) == write_char_p_pp) && - (((s7_p_p_t)opt2_direct(cdar(let_var))) == read_char_p_p) && (fx_proc(if_test) == fx_is_eof_t)) - { - int32_t c = (int32_t)s7_character(slot_value(let_slots(inner_let))); - a1 = slot_value(let_slots(outer_let)); - a2 = slot_value(next_slot(let_slots(outer_let))); - while (c != EOF) - { - inline_file_write_char(sc, (uint8_t)c, a2); - c = string_read_char(sc, a1); - }} - else - while (fx_call(sc, if_test) == sc->F) - { - fx_call(sc, if_true); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - }} - else - while (true) - { - p = fx_call(sc, if_test); - if (when) {if (p == sc->F) break;} else {if (p != sc->F) break;} - for (p = if_true; is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - }} - else - { - s7_pointer la_slot = let_slots(outer_let); - s7_pointer laa_slot = next_slot(la_slot); - while (true) - { - p = fx_call(sc, if_test); - if (when) {if (p == sc->F) break;} else {if (p != sc->F) break;} - for (p = if_true; is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - }} - unstack(sc); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - sc->value = sc->unspecified; -} - -static s7_pointer fx_tc_let_when_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_WHEN_LAA); - op_tc_let_when_laa(sc, true, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static s7_pointer fx_tc_let_unless_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_WHEN_LAA); - op_tc_let_when_laa(sc, false, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - -static bool op_tc_if_a_z_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer if1_test = cdr(code), endp, outer_let = sc->curlet, slot, var, la_slot = let_slots(sc->curlet); - s7_pointer if1_true = cdr(if1_test); /* cddr(code) */ - s7_pointer let_expr = cadr(if1_true); /* cadddr(code) */ - s7_pointer let_vars = cadr(let_expr); - s7_pointer if2 = caddr(let_expr); - s7_pointer if2_test = cdr(if2); - s7_pointer if2_true = cdr(if2_test); /* cddr(if2) */ - s7_pointer la = cdadr(if2_true); /* cdr(cadddr(if2)) */ - s7_pointer laa = cdr(la); - s7_pointer laa_slot = next_slot(la_slot); - s7_pointer inner_let = inline_make_let(sc, sc->curlet); - - s7_gc_protect_via_stack(sc, inner_let); - slot = make_slot(sc, caar(let_vars), sc->F); - slot_set_next(slot, slot_end(sc)); - let_set_slots(inner_let, slot); - symbol_set_local_slot_unincremented(caar(let_vars), let_id(inner_let), slot); - for (var = cdr(let_vars); is_pair(var); var = cdr(var)) - slot = inline_add_slot_at_end(sc, let_id(inner_let), slot, caar(var), sc->F); - - while (true) - { - if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} - slot = let_slots(inner_let); - slot_set_value(slot, fx_call(sc, cdar(let_vars))); - set_curlet(sc, inner_let); - for (var = cdr(let_vars), slot = next_slot(slot); is_pair(var); var = cdr(var), slot = next_slot(slot)) - slot_set_value(slot, fx_call(sc, cdar(var))); - - if (fx_call(sc, if2_test) != sc->F) {endp = if2_true; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - set_curlet(sc, outer_let); - } - sc->rec_p1 = sc->unused; - unstack(sc); - if (!op_tc_z(sc, endp)) /* might refer to inner_let slots */ - return(false); - free_cell(sc, let_slots(inner_let)); /* true = has_fx, so we should be done with the let */ - free_cell(sc, inner_let); - return(true); -} - -static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) -{ - bool read_case; - s7_pointer result; - s7_pointer outer_let = sc->curlet; - s7_pointer slots = let_slots(outer_let); - s7_pointer cond_body = cdaddr(code); /* code here == body in check_tc */ - s7_pointer let_var = caadr(code); - s7_function letf = fx_proc(cdr(let_var)); - s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); - s7_pointer let_slot = let_slots(inner_let); - sc->curlet = inner_let; - s7_gc_protect_via_stack(sc, inner_let); - let_var = cadr(let_var); - if ((letf == fx_c_s_direct) && /* an experiment */ - (symbol_id(cadr(let_var)) != let_id(outer_let))) /* i.e. not an argument to the recursive function, and not set! (safe closure body) */ - { - letf = (s7_p_p_t)opt2_direct(cdr(let_var)); - let_var = lookup(sc, cadr(let_var)); - } - /* in the named let no-var case slots may contain the let name (it's the funclet) */ - - if (opt3_arglen(cdr(code)) == 0) /* (loop) etc -- no args */ - while (true) - { - for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) - if (fx_call(sc, car(p)) != sc->F) - { - result = cdar(p); - if (!has_tc(result)) - goto TC_LET_COND_DONE; - set_curlet(sc, outer_let); - slot_set_value(let_slot, letf(sc, let_var)); - set_curlet(sc, inner_let); - break; - }} - else - if (opt3_arglen(cdr(code)) == 1) - while (true) - for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) - if (fx_call(sc, car(p)) != sc->F) - { - result = cdar(p); - if (!has_tc(result)) - goto TC_LET_COND_DONE; - slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */ - set_curlet(sc, outer_let); - slot_set_value(let_slot, letf(sc, let_var)); /* inner let var */ - set_curlet(sc, inner_let); - break; - } - - let_set_has_pending_value(outer_let); - read_case = ((letf == read_char_p_p) && (is_input_port(let_var)) && (is_string_port(let_var)) && (!port_is_closed(let_var))); - while (true) - for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) - if (fx_call(sc, car(p)) != sc->F) - { - result = cdar(p); - if (!has_tc(result)) - goto TC_LET_COND_DONE; - for (s7_pointer slot = slots, arg = cdar(result); is_pair(arg); slot = next_slot(slot), arg = cdr(arg)) - slot_simply_set_pending_value(slot, fx_call(sc, arg)); - for (s7_pointer slot = slots; tis_slot(slot); slot = next_slot(slot)) /* using two swapping lets instead is slightly slower */ - slot_set_value(slot, slot_pending_value(slot)); - - if (read_case) - slot_set_value(let_slot, chars[string_read_char(sc, let_var)]); - else - { - set_curlet(sc, outer_let); - slot_set_value(let_slot, letf(sc, let_var)); - set_curlet(sc, inner_let); - } - break; - } - let_clear_has_pending_value(outer_let); - - TC_LET_COND_DONE: - unstack(sc); - if (has_fx(result)) - { - sc->value = fx_call(sc, result); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - return(true); - } - sc->code = car(result); - return(false); -} - -static s7_pointer fx_tc_let_cond(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_LET_COND); - op_tc_let_cond(sc, arg); - return(sc->value); -} - -static bool op_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer c1 = cadr(code), c2 = caddr(code), la_slot = let_slots(sc->curlet); - s7_pointer la1 = cdadr(c2); - s7_pointer laa1 = cddadr(c2); - s7_pointer c3 = opt3_pair(code); /* cadr(cadddr(code)) = cadr(else_clause) */ - s7_pointer la2 = cdr(c3); - s7_pointer laa2 = cddr(c3); - s7_pointer laa_slot = next_slot(la_slot); - while (true) - { - if (fx_call(sc, c1) != sc->F) {c1 = cdr(c1); break;} - if (fx_call(sc, c2) != sc->F) - { - sc->rec_p1 = fx_call(sc, la1); - slot_set_value(laa_slot, fx_call(sc, laa1)); - } - else - { - sc->rec_p1 = fx_call(sc, la2); - slot_set_value(laa_slot, fx_call(sc, laa2)); - } - slot_set_value(la_slot, sc->rec_p1); - } - return(op_tc_z(sc, c1)); -} - -static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_TC_COND_A_Z_A_LAA_LAA); - op_tc_cond_a_z_a_laa_laa(sc, arg); - sc->rec_p1 = sc->unused; - return(sc->value); -} - - -#define RECUR_INITIAL_STACK_SIZE 1024 - -static void recur_resize(s7_scheme *sc) -{ - s7_pointer stack = sc->rec_stack; - block_t *ob, *nb; - vector_length(stack) = sc->rec_len * 2; - ob = vector_block(stack); - nb = reallocate(sc, ob, vector_length(stack) * sizeof(s7_pointer)); - block_info(nb) = NULL; - vector_block(stack) = nb; - vector_elements(stack) = (s7_pointer *)block_data(nb); /* GC looks only at elements within sc->rec_loc */ - sc->rec_len = vector_length(stack); - sc->rec_els = vector_elements(stack); -} - -static inline void recur_push(s7_scheme *sc, s7_pointer value) -{ - if (sc->rec_loc == sc->rec_len) - recur_resize(sc); - sc->rec_els[sc->rec_loc] = value; - sc->rec_loc++; -} - -static inline void recur_push_unchecked(s7_scheme *sc, s7_pointer value) {sc->rec_els[sc->rec_loc++] = value;} -static s7_pointer recur_pop(s7_scheme *sc) {return(sc->rec_els[--sc->rec_loc]);} -static s7_pointer recur_ref(s7_scheme *sc, s7_int loc) {return(sc->rec_els[sc->rec_loc - loc]);} - -static s7_pointer recur_pop2(s7_scheme *sc) -{ - sc->rec_loc -= 2; - return(sc->rec_els[sc->rec_loc + 1]); -} - -static s7_pointer recur_swap(s7_scheme *sc, s7_pointer value) -{ - s7_pointer res = sc->rec_els[sc->rec_loc - 1]; - sc->rec_els[sc->rec_loc - 1] = value; - return(res); -} - -static s7_pointer recur_make_stack(s7_scheme *sc) -{ - if (!sc->rec_stack) - { - sc->rec_stack = make_simple_vector(sc, RECUR_INITIAL_STACK_SIZE); - sc->rec_els = vector_elements(sc->rec_stack); - sc->rec_len = RECUR_INITIAL_STACK_SIZE; - } - sc->rec_loc = 0; - return(sc->rec_stack); -} - -static void rec_set_test(s7_scheme *sc, s7_pointer p) -{ - sc->rec_testp = p; - sc->rec_testf = fx_proc(sc->rec_testp); - sc->rec_testp = car(sc->rec_testp); -} - -static void rec_set_res(s7_scheme *sc, s7_pointer p) -{ - sc->rec_resp = p; - sc->rec_resf = fx_proc(sc->rec_resp); - sc->rec_resp = car(sc->rec_resp); -} - -static void rec_set_f1(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f1p = p; - sc->rec_f1f = fx_proc(sc->rec_f1p); - sc->rec_f1p = car(sc->rec_f1p); -} - -static void rec_set_f2(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f2p = p; - sc->rec_f2f = fx_proc(sc->rec_f2p); - sc->rec_f2p = car(sc->rec_f2p); -} - -static void rec_set_f3(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f3p = p; - sc->rec_f3f = fx_proc(sc->rec_f3p); - sc->rec_f3p = car(sc->rec_f3p); -} - -static void rec_set_f4(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f4p = p; - sc->rec_f4f = fx_proc(sc->rec_f4p); - sc->rec_f4p = car(sc->rec_f4p); -} - -static void rec_set_f5(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f5p = p; - sc->rec_f5f = fx_proc(sc->rec_f5p); - sc->rec_f5p = car(sc->rec_f5p); -} - -static void rec_set_f6(s7_scheme *sc, s7_pointer p) -{ - sc->rec_f6p = p; - sc->rec_f6f = fx_proc(sc->rec_f6p); - sc->rec_f6p = car(sc->rec_f6p); -} - -/* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */ -typedef enum {OPT_PTR, OPT_INT, OPT_DBL, OPT_INT_0} opt_pid_t; - -static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op, s7_pointer code) -{ - s7_pointer caller = opt3_pair(code); /* false_p in check_recur */ -#if (!WITH_GMP) - s7_pointer c_op = car(caller); - if ((is_symbol(c_op)) && - ((is_global(c_op)) || - ((is_slot(global_slot(c_op))) && - (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) - { - s7_pointer s_func = global_value(c_op), slot = let_slots(sc->curlet); - if (is_c_function(s_func)) - { - sc->pc = 0; - sc->rec_test_o = sc->opts[0]; - if (bool_optimize(sc, cdr(code))) - { - int32_t start_pc = sc->pc; - sc->rec_result_o = sc->opts[start_pc]; - if (is_t_integer(slot_value(slot))) - { - sc->rec_i_ii_f = s7_i_ii_function(s_func); - if ((sc->rec_i_ii_f) && - (int_optimize(sc, (a_op) ? cddr(code) : cdddr(code)))) - { - sc->rec_a1_o = sc->opts[sc->pc]; - if (int_optimize(sc, (la_op) ? cdr(caller) : cddr(caller))) /* cdadr? */ - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(opt3_pair(caller)))) - { - sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); - slot_set_value(slot, sc->rec_val1); - return(OPT_INT); - }}}}}}} -#endif - rec_set_test(sc, cdr(code)); - rec_set_res(sc, (a_op) ? cddr(code) : cdddr(code)); - rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); - rec_set_f2(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); - return(OPT_PTR); -} - -static s7_int oprec_i_if_a_a_opa_laq(s7_scheme *sc) -{ - s7_int i1; - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - return(sc->rec_i_ii_f(i1, oprec_i_if_a_a_opa_laq(sc))); -} - -static s7_int oprec_i_if_a_opa_laq_a(s7_scheme *sc) -{ - s7_int i1; - if (!sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - return(sc->rec_i_ii_f(i1, oprec_i_if_a_opa_laq_a(sc))); -} - -static s7_pointer oprec_if_a_a_opa_laq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - { - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - set_car(sc->t2_2, oprec_if_a_a_opa_laq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer oprec_if_a_a_opla_aq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - set_car(sc->t2_1, oprec_if_a_a_opla_aq(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer oprec_if_a_opa_laq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - { - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - set_car(sc->t2_2, oprec_if_a_opa_laq_a(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer oprec_if_a_opla_aq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - set_car(sc->t2_1, oprec_if_a_opla_aq_a(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static void wrap_recur_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op) -{ - opt_pid_t choice = opinit_if_a_a_opa_laq(sc, a_op, la_op, sc->code); - tick_tc(sc, sc->cur_op); - if (choice == OPT_INT) - sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opa_laq(sc) : oprec_i_if_a_opa_laq_a(sc)); - else - { - sc->rec_stack = recur_make_stack(sc); - if (a_op) - sc->value = (la_op) ? oprec_if_a_a_opa_laq(sc) : oprec_if_a_a_opla_aq(sc); - else sc->value = (la_op) ? oprec_if_a_opa_laq_a(sc) : oprec_if_a_opla_aq_a(sc); - sc->rec_loc = 0; - } -} - -static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_IF_A_A_opA_LAq); - if (opinit_if_a_a_opa_laq(sc, true, true, arg) == OPT_INT) - sc->value = make_integer(sc, oprec_i_if_a_a_opa_laq(sc)); - else - { - sc->rec_stack = recur_make_stack(sc); - sc->value = oprec_if_a_a_opa_laq(sc); - sc->rec_loc = 0; - } - return(sc->value); -} - -static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_IF_A_opA_LAq_A); - if (opinit_if_a_a_opa_laq(sc, false, true, arg) == OPT_INT) - sc->value = make_integer(sc, oprec_i_if_a_opa_laq_a(sc)); - else - { - sc->rec_stack = recur_make_stack(sc); - sc->value = oprec_if_a_opa_laq_a(sc); - sc->rec_loc = 0; - } - return(sc->value); -} - -/* -------- cond_a_a_opa_laq -------- */ -static void opinit_cond_a_a_opa_laq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, cadr(sc->code)); - rec_set_res(sc, cdadr(sc->code)); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer op_recur_cond_a_a_opa_laq(s7_scheme *sc) -{ - opinit_cond_a_a_opa_laq(sc); - return(oprec_if_a_a_opa_laq(sc)); -} - -/* -------- if_a_a_opa_laaq and if_a_opa_laaq_a and cond_a_a_opa_laaq -------- */ -enum {IF1A_LA2, IF2A_LA2, COND2A_LA2}; - -static void opinit_if_a_a_opa_laaq(s7_scheme *sc, int32_t a_op) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, (a_op == COND2A_LA2) ? cadr(sc->code) : cdr(sc->code)); - rec_set_res(sc, (a_op == IF2A_LA2) ? cddr(sc->code) : ((a_op == IF1A_LA2) ? cdddr(sc->code) : cdadr(sc->code))); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, cdr(opt3_pair(caller))); - rec_set_f3(sc, cddr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_if_a_a_opa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - { - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_if_a_a_opa_laaq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer oprec_if_a_opa_laaq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_if_a_opa_laaq_a(sc)); - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_if_a_a_opa_laaq(s7_scheme *sc) -{ - opinit_if_a_a_opa_laaq(sc, IF2A_LA2); - return(oprec_if_a_a_opa_laaq(sc)); -} - -static s7_pointer op_recur_if_a_opa_laaq_a(s7_scheme *sc) -{ - opinit_if_a_a_opa_laaq(sc, IF1A_LA2); - return(oprec_if_a_opa_laaq_a(sc)); -} - -static s7_pointer op_recur_cond_a_a_opa_laaq(s7_scheme *sc) -{ - opinit_if_a_a_opa_laaq(sc, COND2A_LA2); - return(oprec_if_a_a_opa_laaq(sc)); -} - - -/* -------- if_a_a_opa_l3aq -------- */ -static void opinit_if_a_a_opa_l3aq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code), l3a = cdr(opt3_pair(caller)); - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, cddr(sc->code)); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, l3a); - rec_set_f3(sc, cdr(l3a)); - rec_set_f4(sc, cddr(l3a)); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_slot3 = next_slot(sc->rec_slot2); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_if_a_a_opa_l3aq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - { - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_if_a_a_opa_l3aq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme *sc) -{ - opinit_if_a_a_opa_l3aq(sc); - return(oprec_if_a_a_opa_l3aq(sc)); -} - -/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */ -static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) -{ - s7_pointer caller = opt3_pair(sc->code); -#if (!WITH_GMP) - s7_pointer c_op = car(caller); - if ((is_symbol(c_op)) && - ((is_global(c_op)) || - ((is_slot(global_slot(c_op))) && - (lookup_slot_from(c_op, sc->curlet) == global_slot(c_op))))) - { - s7_pointer s_func = global_value(c_op); - s7_pointer slot = let_slots(sc->curlet); - if (is_c_function(s_func)) - { - sc->pc = 0; - sc->rec_test_o = sc->opts[0]; - if (bool_optimize(sc, cdr(sc->code))) - { - int32_t start_pc = sc->pc; - sc->rec_result_o = sc->opts[start_pc]; - if (is_t_integer(slot_value(slot))) - { - sc->rec_i_ii_f = s7_i_ii_function(s_func); - if ((sc->rec_i_ii_f) && - (int_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)))) - { - sc->rec_a1_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdadr(caller))) - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(opt3_pair(caller)))) - { - sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); - slot_set_value(slot, sc->rec_val1); - if (sc->pc != 4) - return(OPT_INT); - sc->rec_fb1 = sc->rec_test_o->v[0].fb; - sc->rec_fi1 = sc->rec_result_o->v[0].fi; - sc->rec_fi2 = sc->rec_a1_o->v[0].fi; - sc->rec_fi3 = sc->rec_a2_o->v[0].fi; - return(OPT_INT_0); - }}}} - if (is_t_real(slot_value(slot))) - { - sc->rec_d_dd_f = s7_d_dd_function(s_func); - if (sc->rec_d_dd_f) - { - sc->pc = start_pc; - sc->rec_result_o = sc->opts[start_pc]; - if (float_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code))) - { - sc->rec_a1_o = sc->opts[sc->pc]; - if (float_optimize(sc, cdadr(caller))) - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(opt3_pair(caller)))) - { - sc->rec_val1 = s7_make_mutable_real(sc, real(slot_value(slot))); - slot_set_value(slot, sc->rec_val1); - return(OPT_DBL); - }}}}}}}} -#endif - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); - rec_set_f1(sc, cdadr(caller)); - rec_set_f2(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); - return(OPT_PTR); -} - -static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc) -{ - s7_int i1, i2; - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) /* if_(A) */ - return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */ - i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); /* save a1 */ - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); /* slot1 = a2 */ - i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */ - integer(sc->rec_val1) = i1; /* slot1 = a1 */ - return(sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq(sc), i2)); /* call op(la1, la2) */ -} - -static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme *sc) -{ - s7_int i1, i2; - if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); - i1 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - if (sc->rec_fb1(sc->rec_test_o)) - i2 = sc->rec_fi1(sc->rec_result_o); - else - { - s7_int i3; - i2 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - i3 = oprec_i_if_a_a_opla_laq_0(sc); - integer(sc->rec_val1) = i2; - i2 = sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i3); - } - integer(sc->rec_val1) = i1; - return(sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i2)); -} - -static s7_double oprec_d_if_a_a_opla_laq(s7_scheme *sc) -{ - s7_double x1, x2; - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); - x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) - x2 = sc->rec_result_o->v[0].fd(sc->rec_result_o); - else - { - s7_double x3; - x2 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); - x3 = oprec_d_if_a_a_opla_laq(sc); - real(sc->rec_val1) = x2; - x2 = sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x3); - } - real(sc->rec_val1) = x1; - return(sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x2)); -} - -static s7_pointer oprec_if_a_a_opla_laq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_a_opla_laq(sc))); - set_car(sc->t2_1, oprec_if_a_a_opla_laq(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc) -{ - s7_int i1, i2; - if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - i2 = oprec_i_if_a_opla_laq_a(sc); - integer(sc->rec_val1) = i1; - return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a(sc), i2)); -} - -static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme *sc) -{ - s7_int i1, i2; - if (!sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); - i1 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - if (!sc->rec_fb1(sc->rec_test_o)) - i2 = sc->rec_fi1(sc->rec_result_o); - else - { - s7_int i3; - i2 = sc->rec_fi2(sc->rec_a1_o); - integer(sc->rec_val1) = sc->rec_fi3(sc->rec_a2_o); - i3 = oprec_i_if_a_opla_laq_a_0(sc); - integer(sc->rec_val1) = i2; - i2 = sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i3); - } - integer(sc->rec_val1) = i1; - return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i2)); -} - -static s7_double oprec_d_if_a_opla_laq_a(s7_scheme *sc) -{ - s7_double x1, x2; - if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) return(sc->rec_result_o->v[0].fd(sc->rec_result_o)); - x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o); - real(sc->rec_val1) = sc->rec_a2_o->v[0].fd(sc->rec_a2_o); - x2 = oprec_d_if_a_opla_laq_a(sc); - real(sc->rec_val1) = x1; - return(sc->rec_d_dd_f(oprec_d_if_a_opla_laq_a(sc), x2)); -} - -static s7_pointer oprec_if_a_opla_laq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_opla_laq_a(sc))); - set_car(sc->t2_1, oprec_if_a_opla_laq_a(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static void wrap_recur_if_a_a_opla_laq(s7_scheme *sc, bool a_op) -{ - opt_pid_t choice = opinit_if_a_a_opla_laq(sc, a_op); - tick_tc(sc, sc->cur_op); - if ((choice == OPT_INT) || (choice == OPT_INT_0)) - { - if (choice == OPT_INT_0) - sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq_0(sc) : oprec_i_if_a_opla_laq_a_0(sc)); - else sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq(sc) : oprec_i_if_a_opla_laq_a(sc)); - } - else - if (choice == OPT_PTR) - { - sc->rec_stack = recur_make_stack(sc); - sc->value = (a_op) ? oprec_if_a_a_opla_laq(sc) : oprec_if_a_opla_laq_a(sc); - sc->rec_loc = 0; - } - else sc->value = make_real(sc, (a_op) ? oprec_d_if_a_a_opla_laq(sc) : oprec_d_if_a_opla_laq_a(sc)); -} - - -/* -------- if_a_a_opa_la_laq and if_a_opa_la_laq_a -------- */ -static void opinit_if_a_a_opa_la_laq(s7_scheme *sc, bool a_op) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, cdaddr(caller)); - rec_set_f3(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_if_a_a_opa_la_laq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_a_opa_la_laq(sc))); - set_car(sc->t3_2, oprec_if_a_a_opa_la_laq(sc)); - set_car(sc->t3_3, recur_pop(sc)); - set_car(sc->t3_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t3_1)); -} - -static s7_pointer oprec_if_a_opa_la_laq_a(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_opa_la_laq_a(sc))); - set_car(sc->t3_2, oprec_if_a_opa_la_laq_a(sc)); - set_car(sc->t3_3, recur_pop(sc)); - set_car(sc->t3_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t3_1)); -} - -static s7_pointer op_recur_if_a_a_opa_la_laq(s7_scheme *sc) -{ - opinit_if_a_a_opa_la_laq(sc, true); - return(oprec_if_a_a_opa_la_laq(sc)); -} - -static s7_pointer op_recur_if_a_opa_la_laq_a(s7_scheme *sc) -{ - opinit_if_a_a_opa_la_laq(sc, false); - return(oprec_if_a_opa_la_laq_a(sc)); -} - -/* -------- if_a_a_opla_la_laq -------- */ -static void opinit_if_a_a_opla_la_laq(s7_scheme *sc, bool a_op) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); - rec_set_f1(sc, cdadr(caller)); - rec_set_f2(sc, cdaddr(caller)); - rec_set_f3(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_if_a_a_opla_la_laq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_a_opla_la_laq(sc))); - recur_push(sc, oprec_if_a_a_opla_la_laq(sc)); - slot_set_value(sc->rec_slot1, recur_ref(sc, 3)); - set_car(sc->t3_1, oprec_if_a_a_opla_la_laq(sc)); - set_car(sc->t3_2, recur_pop(sc)); - set_car(sc->t3_3, recur_pop2(sc)); - return(sc->rec_fn(sc, sc->t3_1)); -} - -static s7_pointer op_recur_if_a_a_opla_la_laq(s7_scheme *sc) -{ - opinit_if_a_a_opla_la_laq(sc, true); - return(oprec_if_a_a_opla_la_laq(sc)); -} - -/* -------- if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) -------- - * esteemed reader, please ignore this nonsense! - * The opt_info version was not a lot faster -- ~/old/tak-st.c: say 10% faster. The current fx-based - * version has immediate lookups, and since the data is (ahem) simple, the GC is not a factor. - * The opt version has its own overheads, and has to do the same amount of stack manipulations. - */ -static s7_pointer rec_x(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot1));} -static s7_pointer rec_y(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot2));} -static s7_pointer rec_z(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot3));} -static s7_pointer rec_sub_z1(s7_scheme *sc, s7_pointer code) -{ - s7_pointer x = slot_value(sc->rec_slot3); - return((is_t_integer(x)) ? make_integer(sc, integer(x) - 1) : minus_c1(sc, x)); -} - -static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code); - s7_pointer la1 = cadr(caller); - s7_pointer la2 = caddr(caller); - s7_pointer la3 = opt3_pair(caller); - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, cddr(sc->code)); - rec_set_f1(sc, cdr(la1)); - rec_set_f2(sc, cddr(la1)); - if (sc->rec_f2f == fx_u) sc->rec_f2f = rec_y; - rec_set_f3(sc, cdddr(la1)); - rec_set_f4(sc, cdr(la2)); - rec_set_f5(sc, cddr(la2)); - rec_set_f6(sc, cdddr(la2)); - if (sc->rec_f6f == fx_t) sc->rec_f6f = rec_x; - - sc->rec_f7p = cdr(la3); - sc->rec_f7f = fx_proc(sc->rec_f7p); - sc->rec_f7p = car(sc->rec_f7p); - - sc->rec_f8p = cddr(la3); - sc->rec_f8f = fx_proc(sc->rec_f8p); - if (sc->rec_f8f == fx_t) sc->rec_f8f = rec_x; - sc->rec_f8p = car(sc->rec_f8p); - - sc->rec_f9p = cdddr(la3); - sc->rec_f9f = fx_proc(sc->rec_f9p); - if (sc->rec_f9f == fx_u) sc->rec_f9f = rec_y; - sc->rec_f9p = car(sc->rec_f9p); - - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_slot3 = next_slot(sc->rec_slot2); - if (cadddr(la1) == slot_symbol(sc->rec_slot3)) sc->rec_f3f = rec_z; - if (caddr(la2) == slot_symbol(sc->rec_slot3)) sc->rec_f5f = rec_z; - if ((sc->rec_f7f == fx_subtract_s1) && (cadadr(la3) == slot_symbol(sc->rec_slot3))) sc->rec_f7f = rec_sub_z1; -} - -static s7_pointer oprec_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - recur_push(sc, sc->rec_f6f(sc, sc->rec_f6p)); - recur_push(sc, sc->rec_f7f(sc, sc->rec_f7p)); - recur_push(sc, sc->rec_f8f(sc, sc->rec_f8p)); - slot_set_value(sc->rec_slot3, sc->rec_f9f(sc, sc->rec_f9p)); - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc)); - slot_set_value(sc->rec_slot3, recur_ref(sc, 2)); - slot_set_value(sc->rec_slot2, recur_ref(sc, 3)); - slot_set_value(sc->rec_slot1, recur_ref(sc, 4)); - recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc)); - slot_set_value(sc->rec_slot3, recur_ref(sc, 6)); - slot_set_value(sc->rec_slot2, recur_ref(sc, 7)); - slot_set_value(sc->rec_slot1, recur_ref(sc, 8)); - slot_set_value(sc->rec_slot1, oprec_if_a_a_lopl3a_l3a_l3aq(sc)); - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot3, recur_pop(sc)); - sc->rec_loc -= 6; - return(oprec_if_a_a_lopl3a_l3a_l3aq(sc)); -} - -static s7_pointer op_recur_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) -{ - opinit_if_a_a_lopl3a_l3a_l3aq(sc); - return(oprec_if_a_a_lopl3a_l3a_l3aq(sc)); -} - -/* -------- if_a_a_and_a_laa_laa -------- */ -static void opinit_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer caller = opt3_pair(code); - s7_pointer la1 = caddr(caller); - s7_pointer la2 = cadddr(caller); - rec_set_test(sc, cdr(code)); - rec_set_res(sc, cddr(code)); - rec_set_f1(sc, cdr(caller)); - rec_set_f2(sc, cdr(la1)); - rec_set_f3(sc, cddr(la1)); - rec_set_f4(sc, cdr(la2)); - rec_set_f5(sc, cddr(la2)); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); -} - -static s7_pointer oprec_if_a_a_and_a_laa_laa(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) == sc->F) return(sc->F); - recur_push(sc, slot_value(sc->rec_slot1)); - recur_push(sc, slot_value(sc->rec_slot2)); - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - if (oprec_if_a_a_and_a_laa_laa(sc) == sc->F) - { - sc->rec_loc -= 2; - return(sc->F); - } - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_if_a_a_and_a_laa_laa(sc)); -} - -static s7_pointer op_recur_if_a_a_and_a_laa_laa(s7_scheme *sc) -{ - opinit_if_a_a_and_a_laa_laa(sc, sc->code); - return(oprec_if_a_a_and_a_laa_laa(sc)); -} - -static s7_pointer fx_recur_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_IF_A_A_AND_A_LAA_LAA); - /* sc->curlet is set already and will be restored by the caller */ - sc->rec_stack = recur_make_stack(sc); - opinit_if_a_a_and_a_laa_laa(sc, arg); - sc->value = oprec_if_a_a_and_a_laa_laa(sc); - sc->rec_loc = 0; - return(sc->value); -} - -/* -------- cond_a_a_a_a_opla_laq -------- */ -static void opinit_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer code, bool cond_case) -{ - s7_pointer caller = opt3_pair(code); - if (cond_case) - { - rec_set_test(sc, cadr(code)); - rec_set_res(sc, cdadr(code)); - rec_set_f1(sc, caddr(code)); - rec_set_f2(sc, cdaddr(code)); - } - else - { - rec_set_test(sc, cdr(code)); - rec_set_res(sc, cddr(code)); /* (if a b...) */ - rec_set_f1(sc, opt1_pair(code)); /* cdr(cadddr(code)), (if a b (if c d...)) */ - rec_set_f2(sc, cdr(opt1_pair(code))); - } - rec_set_f3(sc, cdadr(caller)); - rec_set_f4(sc, opt3_pair(caller)); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_fn = fn_proc(caller); -} - -static inline s7_pointer oprec_cond_a_a_a_a_opla_laq(s7_scheme *sc) /* inline = 27 in trec */ -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_cond_a_a_a_a_opla_laq(sc))); - set_car(sc->t2_1, oprec_cond_a_a_a_a_opla_laq(sc)); - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_opla_laq(sc, sc->code, true); - return(oprec_cond_a_a_a_a_opla_laq(sc)); -} - -static s7_pointer op_recur_if_a_a_if_a_a_opla_laq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_opla_laq(sc, sc->code, false); - return(oprec_cond_a_a_a_a_opla_laq(sc)); -} - -static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_COND_A_A_A_A_opLA_LAq); - sc->rec_stack = recur_make_stack(sc); - opinit_cond_a_a_a_a_opla_laq(sc, arg, true); - sc->value = oprec_cond_a_a_a_a_opla_laq(sc); - sc->rec_loc = 0; - return(sc->value); -} - - -/* -------- cond_a_a_a_a_oplaa_laaq -------- */ -static void opinit_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc, bool cond_case) -{ - s7_pointer caller = opt3_pair(sc->code); /* cadr(cadddr(sc->code)) = (cfunc laa laa) */ - if (cond_case) - { - rec_set_test(sc, cadr(sc->code)); - rec_set_res(sc, cdadr(sc->code)); - rec_set_f1(sc, caddr(sc->code)); - rec_set_f2(sc, cdaddr(sc->code)); - } - else - { - rec_set_test(sc, cdr(sc->code)); - rec_set_res(sc, cddr(sc->code)); /* (if a b...) */ - rec_set_f1(sc, opt1_pair(sc->code)); /* cdr(cadddr(sc->code)), (if a b (if c d...)) */ - rec_set_f2(sc, cdr(opt1_pair(sc->code))); - } - sc->rec_f3p = cdadr(caller); - rec_set_f4(sc, cdr(sc->rec_f3p)); - sc->rec_f3f = fx_proc(sc->rec_f3p); - sc->rec_f3p = car(sc->rec_f3p); - sc->rec_f5p = opt3_pair(caller); - rec_set_f6(sc, cdr(sc->rec_f5p)); - sc->rec_f5f = fx_proc(sc->rec_f5p); - sc->rec_f5p = car(sc->rec_f5p); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - sc->value = oprec_cond_a_a_a_a_oplaa_laaq(sc); /* second laa arg */ - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - recur_push_unchecked(sc, sc->value); - set_car(sc->t2_1, oprec_cond_a_a_a_a_oplaa_laaq(sc)); /* first laa arg */ - set_car(sc->t2_2, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_oplaa_laaq(sc, true); - return(oprec_cond_a_a_a_a_oplaa_laaq(sc)); -} - -static s7_pointer op_recur_if_a_a_if_a_a_oplaa_laaq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_oplaa_laaq(sc, false); - return(oprec_cond_a_a_a_a_oplaa_laaq(sc)); -} - - -/* -------- cond_a_a_a_a_opa_laaq -------- */ -static void opinit_cond_a_a_a_a_opa_laaq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code); - rec_set_test(sc, cadr(sc->code)); - rec_set_res(sc, cdadr(sc->code)); - sc->rec_f1p = caddr(sc->code); - rec_set_f2(sc, cdr(sc->rec_f1p)); - sc->rec_f1f = fx_proc(sc->rec_f1p); - sc->rec_f1p = car(sc->rec_f1p); - rec_set_f3(sc, cdr(caller)); - rec_set_f4(sc, opt3_pair(caller)); - rec_set_f5(sc, cdr(opt3_pair(caller))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - sc->rec_fn = fn_proc(caller); -} - -static s7_pointer oprec_cond_a_a_a_a_opa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_cond_a_a_a_a_opa_laaq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_cond_a_a_a_a_opa_laaq(s7_scheme *sc) -{ - opinit_cond_a_a_a_a_opa_laaq(sc); - return(oprec_cond_a_a_a_a_opa_laaq(sc)); -} - - -/* -------- cond_a_a_a_laa_opa_laaq -------- */ -static void opinit_cond_a_a_a_laa_opa_laaq(s7_scheme *sc, bool cond) -{ - s7_pointer caller = opt3_pair(sc->code); /* opA_LAA */ - rec_set_test(sc, (cond) ? cadr(sc->code) : cdr(sc->code)); - rec_set_res(sc, (cond) ? cdadr(sc->code) : cddr(sc->code)); - sc->rec_f1p = (cond) ? caddr(sc->code) : cdr(cadddr(sc->code)); - sc->rec_f2p = cdadr(sc->rec_f1p); - rec_set_f3(sc, cdr(sc->rec_f2p)); - sc->rec_f1f = fx_proc(sc->rec_f1p); - sc->rec_f1p = car(sc->rec_f1p); - sc->rec_f2f = fx_proc(sc->rec_f2p); - sc->rec_f2p = car(sc->rec_f2p); - rec_set_f4(sc, cdr(caller)); - sc->rec_f5p = cdr(opt3_pair(caller)); /* (L)AA */ - rec_set_f6(sc, cdr(sc->rec_f5p)); - sc->rec_f5f = fx_proc(sc->rec_f5p); - sc->rec_f5p = car(sc->rec_f5p); - sc->rec_fn = fn_proc(caller); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); -} - -static s7_pointer oprec_cond_a_a_a_laa_opa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) - { - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */ - } - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) - set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp)); - else - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) - { - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */ - } - else - { - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); - } - set_car(sc->t2_1, recur_pop(sc)); - return(sc->rec_fn(sc, sc->t2_1)); -} - -static s7_pointer op_recur_cond_a_a_a_laa_opa_laaq(s7_scheme *sc) -{ - opinit_cond_a_a_a_laa_opa_laaq(sc, true); - return(oprec_cond_a_a_a_laa_opa_laaq(sc)); -} - -static s7_pointer op_recur_if_a_a_if_a_laa_opa_laaq(s7_scheme *sc) /* if version, same logic as cond above */ -{ - opinit_cond_a_a_a_laa_opa_laaq(sc, false); - return(oprec_cond_a_a_a_laa_opa_laaq(sc)); -} - -/* -------- cond_a_a_a_laa_lopa_laaq -------- */ - -static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) -{ - s7_pointer caller = opt3_pair(sc->code); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); - -#if (!WITH_GMP) - if ((is_t_integer(slot_value(sc->rec_slot1))) && - (is_t_integer(slot_value(sc->rec_slot2)))) - { - sc->pc = 0; - sc->rec_test_o = sc->opts[0]; - if (bool_optimize(sc, cadr(sc->code))) - { - sc->rec_result_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdadr(sc->code))) - { - s7_pointer laa1 = caddr(sc->code); - sc->rec_a1_o = sc->opts[sc->pc]; - if (bool_optimize(sc, laa1)) - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdadr(laa1))) - { - sc->rec_a3_o = sc->opts[sc->pc]; - if (int_optimize(sc, cddadr(laa1))) - { - s7_pointer laa2 = cadr(cadddr(sc->code)), laa3 = caddr(laa2); - sc->rec_a4_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(laa2))) - { - sc->rec_a5_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(laa3))) - { - sc->rec_a6_o = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(laa3))) - { - sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot1))); - slot_set_value(sc->rec_slot1, sc->rec_val1); - sc->rec_val2 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot2))); - slot_set_value(sc->rec_slot2, sc->rec_val2); - if (sc->pc != 8) - return(OPT_INT); - sc->rec_fb1 = sc->rec_test_o->v[0].fb; - sc->rec_fb2 = sc->rec_a1_o->v[0].fb; - sc->rec_fi1 = sc->rec_result_o->v[0].fi; - sc->rec_fi2 = sc->rec_a2_o->v[0].fi; - sc->rec_fi3 = sc->rec_a3_o->v[0].fi; - sc->rec_fi4 = sc->rec_a4_o->v[0].fi; - sc->rec_fi5 = sc->rec_a5_o->v[0].fi; - sc->rec_fi6 = sc->rec_a6_o->v[0].fi; - return(OPT_INT_0); - }}}}}}}}} -#endif - rec_set_test(sc, cadr(sc->code)); - rec_set_res(sc, cdadr(sc->code)); - sc->rec_f1p = caddr(sc->code); - sc->rec_f2p = cdadr(sc->rec_f1p); - rec_set_f3(sc, cdr(sc->rec_f2p)); - sc->rec_f1f = fx_proc(sc->rec_f1p); - sc->rec_f1p = car(sc->rec_f1p); - sc->rec_f2f = fx_proc(sc->rec_f2p); - sc->rec_f2p = car(sc->rec_f2p); - rec_set_f4(sc, cdr(caller)); - sc->rec_f5p = opt3_pair(caller); - rec_set_f6(sc, cdr(sc->rec_f5p)); - sc->rec_f5f = fx_proc(sc->rec_f5p); - sc->rec_f5p = car(sc->rec_f5p); - return(OPT_PTR); -} - -static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) -{ - s7_int i1, i2; - if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); - if (sc->rec_a1_o->v[0].fb(sc->rec_a1_o)) - { - i1 = sc->rec_a2_o->v[0].fi(sc->rec_a2_o); - integer(sc->rec_val2) = sc->rec_a3_o->v[0].fi(sc->rec_a3_o); - integer(sc->rec_val1) = i1; - return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); - } - i1 = sc->rec_a4_o->v[0].fi(sc->rec_a4_o); - i2 = sc->rec_a5_o->v[0].fi(sc->rec_a5_o); - integer(sc->rec_val2) = sc->rec_a6_o->v[0].fi(sc->rec_a6_o); - integer(sc->rec_val1) = i2; - integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq(sc); - integer(sc->rec_val1) = i1; - return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc)); -} - -static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq_0(s7_scheme *sc) -{ - s7_int i1, i2; - if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o)); - if (sc->rec_fb2(sc->rec_a1_o)) - { - i1 = sc->rec_fi2(sc->rec_a2_o); - integer(sc->rec_val2) = sc->rec_fi3(sc->rec_a3_o); - integer(sc->rec_val1) = i1; - return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); - } - i1 = sc->rec_fi4(sc->rec_a4_o); - i2 = sc->rec_fi5(sc->rec_a5_o); - integer(sc->rec_val2) = sc->rec_fi6(sc->rec_a6_o); - integer(sc->rec_val1) = i2; - integer(sc->rec_val2) = oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc); - integer(sc->rec_val1) = i1; - return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); -} - -static s7_pointer oprec_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) -{ - if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp)); - if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) - { - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_cond_a_a_a_laa_lopa_laaq(sc)); - } - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - slot_set_value(sc->rec_slot2, oprec_cond_a_a_a_laa_lopa_laaq(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_cond_a_a_a_laa_lopa_laaq(sc)); -} - -static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) -{ - opt_pid_t choice = opinit_cond_a_a_a_laa_lopa_laaq(sc); - tick_tc(sc, sc->cur_op); - if (choice != OPT_PTR) - sc->value = make_integer(sc, (choice == OPT_INT) ? oprec_i_cond_a_a_a_laa_lopa_laaq(sc) : oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc)); - else - { - sc->rec_stack = recur_make_stack(sc); - sc->value = oprec_cond_a_a_a_laa_lopa_laaq(sc); - sc->rec_loc = 0; - } -} - -/* -------- and_a_or_a_laa_laa -------- */ -static void opinit_and_a_or_a_laa_laa(s7_scheme *sc, s7_pointer code) -{ - s7_pointer orp = cdr(opt3_pair(code)); - rec_set_test(sc, cdr(code)); - rec_set_res(sc, orp); - rec_set_f1(sc, cdr(cadr(orp))); - rec_set_f2(sc, cddr(cadr(orp))); - rec_set_f3(sc, cdr(caddr(orp))); - rec_set_f4(sc, cddr(caddr(orp))); - sc->rec_slot1 = let_slots(sc->curlet); - sc->rec_slot2 = next_slot(sc->rec_slot1); -} - -static s7_pointer oprec_and_a_or_a_laa_laa(s7_scheme *sc) -{ - s7_pointer p; - if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->F); - p = sc->rec_resf(sc, sc->rec_resp); - if (p != sc->F) return(p); - recur_push(sc, slot_value(sc->rec_slot1)); - recur_push(sc, slot_value(sc->rec_slot2)); - recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p)); - slot_set_value(sc->rec_slot2, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - p = oprec_and_a_or_a_laa_laa(sc); - if (p != sc->F) - { - sc->rec_loc -= 2; - return(p); - } - slot_set_value(sc->rec_slot2, recur_pop(sc)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot2, sc->rec_f4f(sc, sc->rec_f4p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - return(oprec_and_a_or_a_laa_laa(sc)); -} - -static s7_pointer op_recur_and_a_or_a_laa_laa(s7_scheme *sc) -{ - opinit_and_a_or_a_laa_laa(sc, sc->code); - return(oprec_and_a_or_a_laa_laa(sc)); -} - -static s7_pointer fx_recur_and_a_or_a_laa_laa(s7_scheme *sc, s7_pointer arg) -{ - tick_tc(sc, OP_RECUR_AND_A_OR_A_LAA_LAA); - sc->rec_stack = recur_make_stack(sc); - opinit_and_a_or_a_laa_laa(sc, arg); - sc->value = oprec_and_a_or_a_laa_laa(sc); - sc->rec_loc = 0; - return(sc->value); -} - -static void wrap_recur(s7_scheme *sc, s7_pointer (*recur)(s7_scheme *sc)) -{ - tick_tc(sc, sc->cur_op); - sc->rec_stack = recur_make_stack(sc); - sc->value = recur(sc); - sc->rec_loc = 0; -} - - -/* -------------------------------- */ -static void op_safe_c_p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_C_P_1); - sc->code = T_Pair(cadr(sc->code)); -} - -static void op_safe_c_p_1(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t1(sc->value));} - -static void op_safe_c_ssp(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_C_SSP_1); - sc->code = opt3_pair(sc->code); -} - -static void op_safe_c_ssp_1(s7_scheme *sc) -{ - set_car(sc->t3_3, sc->value); - set_car(sc->t3_1, lookup(sc, cadr(sc->code))); - set_car(sc->t3_2, lookup(sc, caddr(sc->code))); - sc->value = fn_proc(sc->code)(sc, sc->t3_1); -} - -static void op_safe_c_ssp_mv(s7_scheme *sc) -{ - sc->args = cons_unchecked(sc, lookup(sc, cadr(sc->code)), cons(sc, lookup(sc, caddr(sc->code)), sc->value)); /* not ulist here */ - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_s(s7_scheme *sc) -{ - sc->code = lookup(sc, car(sc->code)); - if (!is_applicable(sc->code)) - apply_error_nr(sc, sc->code, sc->nil); - sc->args = sc->nil; /* op_s -> apply, so we'll apply sc->code to sc->args */ -} - -static bool op_s_g(s7_scheme *sc) -{ - s7_pointer code = sc->code; - sc->code = lookup_checked(sc, car(code)); - if ((is_c_function(sc->code)) && - (c_function_min_args(sc->code) == 1) && - (!needs_copied_args(sc->code))) - { - sc->value = c_function_call(sc->code)(sc, with_list_t1((is_symbol(cadr(code))) ? lookup_checked(sc, cadr(code)) : cadr(code))); - return(true); /* continue */ - } - if (!is_applicable(sc->code)) - apply_error_nr(sc, sc->code, cdr(code)); - if (dont_eval_args(sc->code)) - sc->args = cdr(code); - else - { - s7_pointer val = (is_symbol(cadr(code))) ? lookup_checked(sc, cadr(code)) : cadr(code); - sc->args = (needs_copied_args(sc->code)) ? list_1(sc, val) : set_plist_1(sc, val); - } - return(false); -} - -static bool op_x_a(s7_scheme *sc, s7_pointer f) -{ - if ((((type(f) == T_C_FUNCTION) && - (c_function_is_aritable(f, 1))) || - ((type(f) == T_C_RST_NO_REQ_FUNCTION) && - (c_function_max_args(f) >= 1) && - (f != initial_value(sc->hash_table_symbol)) && - (f != initial_value(sc->weak_hash_table_symbol)))) && - (!needs_copied_args(f))) - { - sc->value = c_function_call(f)(sc, with_list_t1(fx_call(sc, cdr(sc->code)))); - return(true); - } - if (is_any_vector(f)) - { - sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); - sc->code = f; - apply_vector(sc); - return(true); - } - if (!is_applicable(f)) - apply_error_nr(sc, f, cdr(sc->code)); - if (dont_eval_args(f)) - sc->args = cdr(sc->code); /* list_1(sc, cadr(sc->code)); */ - else - if (!needs_copied_args(f)) - sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); - else - { - sc->args = fx_call(sc, cdr(sc->code)); - sc->args = list_1(sc, sc->args); - } - sc->code = f; - return(false); /* goto APPLY */ -} - -static void op_x_aa(s7_scheme *sc, s7_pointer f) -{ - s7_pointer code = sc->code; - if (!is_applicable(f)) - apply_error_nr(sc, f, cdr(code)); - if (dont_eval_args(f)) - sc->args = list_2(sc, cadr(code), caddr(code)); - else - { - sc->args = fx_call(sc, cddr(code)); - if (!needs_copied_args(f)) - sc->args = set_plist_2(sc, fx_call(sc, cdr(code)), sc->args); - else sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args); - } - sc->code = f; -} - -static void op_p_s_1(s7_scheme *sc) -{ - /* we get multiple values here (from op calc = "p" not "s") but don't need to handle it ourselves: - * let v be #(#_abs), so ((v 0) -2), (v 0 -2), ((values v 0) -2), and (((values v 0)) -2) are all 2 - * or: (define (f1) (values vector-ref (vector 1 2 3))) (define arg 1) (define (f2) ((f1) arg)) (f2) (f2) - * so apply calls apply_pair which handles multiple values explicitly. - */ - if (dont_eval_args(sc->value)) - sc->args = cdr(sc->code); - else - { - sc->args = lookup_checked(sc, cadr(sc->code)); - sc->args = (needs_copied_args(sc->value)) ? list_1(sc, sc->args) : set_plist_1(sc, sc->args); - } - sc->code = sc->value; /* goto APPLY */ -} - -static void op_safe_c_star_na(s7_scheme *sc) -{ - sc->args = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code))); - for (s7_pointer args = cdr(sc->code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - sc->code = opt1_cfunc(sc->code); - apply_c_function_star(sc); - clear_list_in_use(sc->args); -} - -static void op_safe_c_star(s7_scheme *sc) -{ - sc->code = opt1_cfunc(sc->code); - apply_c_function_star_fill_defaults(sc, 0); -} - -static void op_safe_c_star_a(s7_scheme *sc) -{ - sc->args = fx_call(sc, cdr(sc->code)); - if (is_symbol_and_keyword(sc->args)) /* (blocks3 (car (list :asdf))) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: keyword ~S, but no value: ~S", 32), car(sc->code), sc->args, sc->code)); - /* scheme-level define* here also gives "not a parameter name" */ - sc->args = list_1(sc, sc->args); - sc->code = opt1_cfunc(sc->code); - /* one arg, so it's not a keyword; all we need to do is fill in the defaults */ - apply_c_function_star_fill_defaults(sc, 1); -} - -static void op_safe_c_star_aa(s7_scheme *sc) -{ - sc->args = fx_call(sc, cdr(sc->code)); - set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t2_1, sc->args); - sc->args = sc->t2_1; - sc->code = opt1_cfunc(sc->code); - apply_c_function_star(sc); -} - - -static void op_safe_c_ps(s7_scheme *sc) -{ - push_stack_no_args_direct(sc, OP_SAFE_C_PS_1); /* got to wait in this case */ - sc->code = cadr(sc->code); -} - -static void op_safe_c_ps_1(s7_scheme *sc) -{ - set_car(sc->t2_2, lookup(sc, caddr(sc->code))); - set_car(sc->t2_1, sc->value); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); -} - -static void op_safe_c_ps_mv(s7_scheme *sc) /* (define (hi a) (+ (values 1 2) a)) from safe_c_ps_1 */ -{ - sc->args = pair_append(sc, sc->value, list_1(sc, lookup(sc, caddr(sc->code)))); /* don't assume sc->value can be used as sc->args here! */ - sc->code = c_function_base(opt1_cfunc(sc->code)); - /* we know it's a c function here, but there are 3 choices (c_function, c_function_star, no_rst_no_req_function) - * sc->value = fn_proc(sc->code)(sc, sc->args) might not check argnum - */ -} - -static void op_safe_c_sp(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - check_stack_size(sc); - push_stack(sc, (opcode_t)opt1_any(args), lookup(sc, car(args)), sc->code); - sc->code = cadr(args); -} - -static void op_safe_c_sp_1(s7_scheme *sc) -{ - /* we get here from many places (op_safe_c_sp for example), but all are safe */ - sc->value = fn_proc(sc->code)(sc, with_list_t2(sc->args, sc->value)); -} - -static void op_safe_c_sp_mv(s7_scheme *sc) -{ - sc->args = cons(sc, sc->args, sc->value); /* not ulist */ - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_safe_add_sp_1(s7_scheme *sc) -{ - if ((is_t_integer(sc->args)) && (is_t_integer(sc->value))) - sc->value = add_if_overflow_to_real_or_big_integer(sc, integer(sc->args), integer(sc->value)); - else sc->value = add_p_pp(sc, sc->args, sc->value); -} - -static void op_safe_multiply_sp_1(s7_scheme *sc) -{ - if ((is_t_real(sc->args)) && (is_t_real(sc->value))) - sc->value = make_real(sc, real(sc->args) * real(sc->value)); - else sc->value = multiply_p_pp(sc, sc->args, sc->value); -} - -static void op_safe_c_pc(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - check_stack_size(sc); /* b dyn */ - push_stack(sc, OP_SAFE_C_PC_1, opt3_con(args), sc->code); - sc->code = car(args); -} - -static void op_safe_c_pc_mv(s7_scheme *sc) -{ - sc->args = pair_append(sc, sc->value, list_1(sc, sc->args)); /* not plist! sc->value is not reusable */ - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_safe_c_pc_1(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t2(sc->value, sc->args));} - -static void op_safe_c_cp(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - /* it's possible in a case like this to overflow the stack -- s7test has a deeply - * nested expression involving (+ c (+ c (+ ... ))) all opt'd as safe_c_cp -- if we're close - * to the stack end at the start, it runs off the end. Normally the stack increase in - * the reader protects us, but a call/cc can replace the original stack with a much smaller one. - */ - check_stack_size(sc); - push_stack(sc, (opcode_t)opt1_any(args), opt3_any(args), sc->code); /* to safe_add_sp_1 for example */ - sc->code = cadr(args); -} - -static Inline void inline_op_safe_c_s(s7_scheme *sc) /* called twice in eval c/cl_s many hits */ -{ - sc->value = fn_proc(sc->code)(sc, with_list_t1(lookup(sc, cadr(sc->code)))); -} -/* if op_safe_c_t added and set in fx_tree_in, we get a few hits, but nothing significant. - * if that had worked, it would be interesting to set opt1(cdr) to the fx_tree fx_proc, (init to fx_c_s), then call that here. - * opt1(cdr) is not used here, opt3_byte happens a few times, but opt2_direct clobbers opt2_fx sometimes - * (also need fx_annotate cdr(expr) in optimize_c_function_one_arg) - */ - -static Inline void inline_op_safe_c_ss(s7_scheme *sc) /* called twice in eval c/cl_ss many hits */ -{ - sc->value = fn_proc(sc->code)(sc, with_list_t2(lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(cdr(sc->code))))); -} - -static void op_safe_c_sc(s7_scheme *sc) -{ - sc->value = fn_proc(sc->code)(sc, with_list_t2(lookup(sc, cadr(sc->code)), opt2_con(cdr(sc->code)))); -} - -static void op_cl_a(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t1(fx_call(sc, cdr(sc->code))));} - -static inline void op_cl_aa(s7_scheme *sc) -{ - gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); - set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t2_1, T_Ext(stack_protected1(sc))); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); -} - -static void op_cl_fa(s7_scheme *sc) -{ - s7_pointer code = cdadr(sc->code); - set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t2_1, make_closure_gc_checked(sc, car(code), cdr(code), T_CLOSURE | ((is_symbol(car(code))) ? T_COPY_ARGS : 0), CLOSURE_ARITY_NOT_SET)); - /* arg1 lambda can be any arity, but it must be applicable to one arg (the "a" above) */ - sc->value = fn_proc(sc->code)(sc, sc->t2_1); -} - -static inline void op_map_for_each_fa(s7_scheme *sc) -{ - s7_pointer f = cddr(sc->code), code = sc->code; - sc->value = fx_call(sc, f); - if (is_null(sc->value)) - sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; - else - { - sc->code = opt3_pair(code); /* cdadr(code); */ - f = make_closure_gc_checked(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 1); /* arity=1 checked in optimizer */ - sc->value = (fn_proc_unchecked(code)) ? g_for_each_closure(sc, f, sc->value) : g_map_closure(sc, f, sc->value); - } -} - -static void op_map_for_each_faa(s7_scheme *sc) -{ - s7_pointer f = cddr(sc->code), code = sc->code; - sc->value = fx_call(sc, f); - sc->args = fx_call(sc, cdr(f)); - if ((is_null(sc->value)) || (is_null(sc->args))) - sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; - else - { - sc->code = opt3_pair(code); /* cdadr(code); */ - f = make_closure_gc_checked(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 2); /* arity=2 checked in optimizer */ - sc->value = (fn_proc_unchecked(code)) ? g_for_each_closure_2(sc, f, sc->value, sc->args) : g_map_closure_2(sc, f, sc->value, sc->args); - } -} - -static void op_cl_na(s7_scheme *sc) -{ - s7_pointer val = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code))); - if (in_heap(val)) gc_protect_via_stack(sc, val); - for (s7_pointer args = cdr(sc->code), p = val; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - sc->value = fn_proc(sc->code)(sc, val); - if (!in_heap(val)) - clear_list_in_use(val); - else - /* the fn_proc call might push its own op (e.g. for-each/map) so we have to check for that */ - if (main_stack_op(sc) == OP_GC_PROTECT) - unstack(sc); -} - -static void op_cl_sas(s7_scheme *sc) -{ - set_car(sc->t3_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t3_1, lookup(sc, cadr(sc->code))); - set_car(sc->t3_3, lookup(sc, cadddr(sc->code))); - sc->value = fn_proc(sc->code)(sc, sc->t3_1); -} - -static inline void op_safe_c_pp(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - check_stack_size(sc); - /* has_fx check here is slower, we assume car(args) below is a pair (else cp/sp/ap?) */ - if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) - { - sc->args = fx_proc_unchecked(args)(sc, car(args)); - push_stack_direct(sc, (opcode_t)opt1_any(args)); /* args = first value, func(args, value) if no mv */ - sc->code = cadr(args); - } - else - { - push_stack_no_args_direct(sc, OP_SAFE_C_PP_1); /* first arg = p, if mv -> op_safe_c_pp_3 */ - sc->code = car(args); - } -} - -static void op_safe_c_pp_1(s7_scheme *sc) -{ - /* it is much slower to check has_gx here! */ - push_stack(sc, (opcode_t)opt1_any(cdr(sc->code)), sc->value, sc->code); /* args[i.e. sc->value] = first value, func(args, value) if no mv */ - sc->code = caddr(sc->code); -} - -static void op_safe_c_pp_3_mv(s7_scheme *sc) -{ - /* we get here if the first arg returned multiple values */ - push_stack(sc, OP_SAFE_C_PP_5, copy_proper_list(sc, sc->value), sc->code); /* copy is needed here */ - sc->code = caddr(sc->code); -} - -static void op_safe_c_pp_5(s7_scheme *sc) -{ - /* 1 mv, 2 normal (else mv->6), sc->args was copied above (and this is a safe c function so its args are in no danger) */ - if (is_null(sc->args)) - sc->args = list_1(sc, sc->value); /* plist here and below, but this is almost never called */ - else - { - s7_pointer p; - for (p = sc->args; is_pair(cdr(p)); p = cdr(p)); - set_cdr(p, list_1(sc, sc->value)); - } - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_safe_c_pp_6_mv(s7_scheme *sc) /* both args mv */ -{ - s7_pointer p; - for (p = cdr(sc->args); is_pair(cdr(p)); p = cdr(p)); /* we used to copy here: sc->args = pair_append(sc, sc->args, sc->value); */ - set_cdr(p, sc->value); - /* fn_proc(sc->code) here is g_add_2, but we have any number of args from a values call - * the original (unoptimized) function is c_function_base(opt1_cfunc(sc->code)) - * (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10 - */ - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_safe_c_3p(s7_scheme *sc) -{ - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_C_3P_1); - sc->code = cadr(sc->code); -} - -static void op_safe_c_3p_1(s7_scheme *sc) -{ - sc->args = sc->value; /* possibly fx/gx? and below */ - push_stack_direct(sc, OP_SAFE_C_3P_2); - sc->code = caddr(sc->code); -} - -static void op_safe_c_3p_1_mv(s7_scheme *sc) /* here only if sc->value is mv */ -{ - sc->args = sc->value; - push_stack_direct(sc, OP_SAFE_C_3P_2_MV); - sc->code = caddr(sc->code); -} - -static void op_safe_c_3p_2(s7_scheme *sc) -{ - gc_protect_via_stack(sc, sc->value); - check_stack_size(sc); - push_stack_direct(sc, OP_SAFE_C_3P_3); - sc->code = cadddr(sc->code); -} - -static void op_safe_c_3p_2_mv(s7_scheme *sc) /* here from 1 + 2mv, or 1_mv with 2 or 2mv */ -{ - gc_protect_via_stack(sc, sc->value); - push_stack_direct(sc, OP_SAFE_C_3P_3_MV); - sc->code = cadddr(sc->code); -} - -static void op_safe_c_3p_3(s7_scheme *sc) -{ - set_car(sc->t3_3, sc->value); - set_car(sc->t3_1, sc->args); - set_car(sc->t3_2, stack_protected1(sc)); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, sc->t3_1); -} - -static void op_safe_c_3p_3_mv(s7_scheme *sc) -{ - s7_pointer p; - s7_pointer p1 = ((is_pair(sc->args)) && (car(sc->args) == sc->unused)) ? cdr(sc->args) : list_1(sc, sc->args); - s7_pointer ps1 = stack_protected1(sc); - s7_pointer p2 = ((is_pair(ps1)) && (car(ps1) == sc->unused)) ? cdr(ps1) : list_1(sc, ps1); - s7_pointer p3 = ((is_pair(sc->value)) && (car(sc->value) == sc->unused)) ? cdr(sc->value) : list_1(sc, sc->value); - unstack(sc); - for (p = p1; is_pair(cdr(p)); p = cdr(p)); - set_cdr(p, p2); - for (p = cdr(p); is_pair(cdr(p)); p = cdr(p)); - set_cdr(p, p3); - sc->args = p1; - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static Inline bool inline_collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer args) /* called (all hits:)op_any_c_np_1/mv and eval, tlet (cb/set) */ -{ - sc->args = args; - for (s7_pointer p = sc->code; is_pair(p); p = cdr(p)) - if (has_fx(p)) - sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ - else - if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) - sc->args = cons(sc, sc->value = fx_proc_unchecked(p)(sc, car(p)), sc->args); - else - { - push_stack(sc, op, sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); - } - return(false); -} - -static bool collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer args) {return(inline_collect_np_args(sc, op, args));} - -static /* inline */ bool op_any_c_np(s7_scheme *sc) /* code: (func . args) where at least one arg is not fxable */ -{ - sc->args = sc->nil; - for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p)) - if (has_fx(p)) - sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ - else - if ((has_gx(p)) && (symbol_ctr(caar(p)) == 1)) - sc->args = cons(sc, sc->value = fx_proc_unchecked(p)(sc, car(p)), sc->args); - else - { - if (sc->op_stack_now >= sc->op_stack_end) - resize_op_stack(sc); - push_op_stack(sc, sc->code); - check_stack_size(sc); - push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); - } - /* here fx/gx got all the args */ - sc->args = proper_list_reverse_in_place(sc, sc->args); - sc->value = fn_proc(sc->code)(sc, sc->args); - return(false); -} - -static Inline bool inline_op_any_c_np_1(s7_scheme *sc) /* called once in eval, tlet (cb/set) */ -{ - /* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is on op-stack */ - if (inline_collect_np_args(sc, OP_ANY_C_NP_1, cons(sc, sc->value, sc->args))) - return(true); - sc->args = proper_list_reverse_in_place(sc, sc->args); - sc->code = pop_op_stack(sc); - sc->value = fn_proc(sc->code)(sc, sc->args); - return(false); -} - -static void op_any_c_np_2(s7_scheme *sc) -{ - sc->args = proper_list_reverse_in_place(sc, sc->args = cons(sc, sc->value, sc->args)); - sc->code = pop_op_stack(sc); - sc->value = fn_proc(sc->code)(sc, sc->args); -} - -static bool op_any_c_np_mv(s7_scheme *sc) -{ - /* we're looping through fp cases here, so sc->value can be non-mv after the first */ - if (collect_np_args(sc, OP_ANY_C_NP_MV, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args))) - return(true); - sc->args = proper_list_reverse_in_place(sc, sc->args); - sc->code = pop_op_stack(sc); - sc->code = c_function_base(opt1_cfunc(sc->code)); - return(false); -} - -static void op_any_closure_np(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - check_stack_size(sc); - if (sc->op_stack_now >= sc->op_stack_end) - resize_op_stack(sc); - push_op_stack(sc, sc->code); - if (has_fx(p)) - { - sc->args = fx_call(sc, p); - sc->args = list_1(sc, sc->args); - for (p = cdr(p); (is_pair(p)) && (has_fx(p)); p = cdr(p)) - sc->args = cons_unchecked(sc, fx_call(sc, p), sc->args); - } - else sc->args = sc->nil; - push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_ANY_CLOSURE_NP_1 : OP_ANY_CLOSURE_NP_2)), sc->args, cdr(p)); - sc->code = T_Pair(car(p)); -} - -static void op_any_closure_np_end(s7_scheme *sc) -{ - s7_pointer x, z, f; - uint64_t id; - - sc->args = proper_list_reverse_in_place(sc, sc->args); /* needed in either case -- closure_args(f) is not reversed */ - sc->code = pop_op_stack(sc); - f = opt1_lambda(sc->code); - - if (is_safe_closure(f)) - { - id = ++sc->let_number; - set_curlet(sc, closure_let(f)); - let_set_id(sc->curlet, id); - for (x = let_slots(sc->curlet), z = sc->args; tis_slot(x); x = next_slot(x), z = cdr(z)) - { - slot_set_value(x, car(z)); - symbol_set_local_slot(slot_symbol(x), id, x); - /* don't free sc->args -- it might be needed in the error below */ - } - if (tis_slot(x)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); - } - else - { - s7_pointer p = closure_args(f), last_slot; - s7_pointer e = inline_make_let(sc, closure_let(f)); - sc->z = e; - id = let_id(e); - last_slot = make_slot(sc, car(p), car(sc->args)); - slot_set_next(last_slot, slot_end(sc)); - let_set_slots(e, last_slot); - symbol_set_local_slot(car(p), id, last_slot); - for (p = cdr(p), z = cdr(sc->args); is_pair(p); p = cdr(p), z = cdr(z)) - last_slot = inline_add_slot_at_end(sc, id, last_slot, car(p), car(z)); /* sets last_slot, don't free sc->args -- used below */ - set_curlet(sc, e); - sc->z = sc->unused; - if (is_pair(p)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); - } - if (is_pair(z)) /* these checks are needed because multiple-values might evade earlier arg num checks */ - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); - - sc->code = closure_body(f); - if_pair_set_up_begin(sc); -} - -static bool op_safe_c_ap(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - s7_pointer val = cdr(code); - if ((has_gx(val)) && (symbol_ctr(caar(val)) == 1)) - { - val = fx_proc_unchecked(val)(sc, car(val)); - gc_protect_via_stack(sc, val); - set_car(sc->t2_1, fx_call(sc, code)); - set_car(sc->t2_2, val); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); - return(false); - } - check_stack_size(sc); - sc->args = fx_call(sc, code); - push_stack_direct(sc, (opcode_t)opt1_any(code)); /* safe_c_sp cases, mv->safe_c_sp_mv */ - sc->code = car(val); - return(true); -} - -static bool op_safe_c_pa(s7_scheme *sc) -{ - s7_pointer args = cdr(sc->code); - if ((has_gx(args)) && (symbol_ctr(caar(args)) == 1)) - { - gc_protect_via_stack(sc, fx_proc_unchecked(args)(sc, car(args))); - set_car(sc->t2_2, fx_call(sc, cdr(args))); - set_car(sc->t2_1, stack_protected1(sc)); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); - return(false); - } - check_stack_size(sc); - push_stack_no_args_direct(sc, OP_SAFE_C_PA_1); - sc->code = car(args); - return(true); -} - -static void op_safe_c_pa_1(s7_scheme *sc) -{ - sc->args = sc->value; /* fx* might change sc->value?? */ - set_car(sc->t2_2, fx_call(sc, cddr(sc->code))); - set_car(sc->t2_1, sc->args); - sc->value = fn_proc(sc->code)(sc, sc->t2_1); -} - -static void op_safe_c_pa_mv(s7_scheme *sc) -{ - s7_pointer p, val = copy_proper_list(sc, sc->value); /* this is necessary since the fx_proc below can clobber sc->value */ - gc_protect_via_stack(sc, val); - for (p = val; is_pair(cdr(p)); p = cdr(p)); /* must be more than 1 member of list or it's not mv */ - sc->args = fx_call(sc, cddr(sc->code)); - cdr(p) = set_plist_1(sc, sc->args); /* do we need to copy sc->args if it is immutable (i.e. plist)? */ - sc->args = val; - unstack(sc); - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_c_na(s7_scheme *sc) /* (set-cdr! lst ()) */ -{ - s7_pointer new_args = make_list(sc, opt3_arglen(cdr(sc->code)), sc->unused); - gc_protect_via_stack(sc, new_args); - for (s7_pointer args = cdr(sc->code), p = new_args; is_pair(args); args = cdr(args), p = cdr(p)) - set_car(p, fx_call(sc, args)); - unstack(sc); - sc->value = fn_proc(sc->code)(sc, new_args); -} - -static void op_c_a(s7_scheme *sc) -{ - sc->value = fx_call(sc, cdr(sc->code)); /* gc protect result before list_1 */ - sc->args = list_1(sc, sc->value); - sc->value = fn_proc(sc->code)(sc, sc->args); -} - -static void op_c_p(s7_scheme *sc) -{ - push_stack_no_args_direct(sc, OP_C_P_1); - sc->code = T_Pair(cadr(sc->code)); -} - -static void op_c_p_mv(s7_scheme *sc) /* op_c_p_1 -> mv case: (define (hi) (format (values #f "~A ~D" 1 2))) */ -{ - sc->code = c_function_base(opt1_cfunc(sc->code)); /* see comment above */ - sc->args = copy_proper_list(sc, sc->value); -} - -static inline void op_c_ss(s7_scheme *sc) -{ - sc->args = list_2(sc, lookup(sc, cadr(sc->code)), lookup(sc, caddr(sc->code))); - sc->value = fn_proc(sc->code)(sc, sc->args); -} - -static void op_c_ap(s7_scheme *sc) -{ - sc->args = fx_call(sc, cdr(sc->code)); - push_stack_direct(sc, OP_C_AP_1); /* op_c_ap_1 sends us to apply which calls check_stack_size I think */ - sc->code = caddr(sc->code); -} - -static void op_c_ap_mv(s7_scheme *sc) -{ - clear_multiple_value(sc->value); - sc->args = cons(sc, sc->args, sc->value); - sc->code = c_function_base(opt1_cfunc(sc->code)); -} - -static void op_c_aa(s7_scheme *sc) -{ - gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code))); - set_stack_protected2(sc, fx_call(sc, cddr(sc->code))); - sc->value = list_2(sc, stack_protected1(sc), stack_protected2(sc)); - unstack(sc); /* fn_proc here is unsafe so clear stack first */ - sc->value = fn_proc(sc->code)(sc, sc->value); -} - -static inline void op_c_s(s7_scheme *sc) -{ - sc->args = list_1(sc, lookup(sc, cadr(sc->code))); - sc->value = fn_proc(sc->code)(sc, sc->args); -} - -static Inline void inline_op_apply_ss(s7_scheme *sc) /* called once in eval, sg: all time spent in proper_list check */ -{ - sc->args = lookup(sc, opt2_sym(sc->code)); - if (!s7_is_proper_list(sc, sc->args)) - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "apply: improper list of arguments: ~S", 37), sc->args)); - sc->code = lookup(sc, cadr(sc->code)); /* global search here was slower (e.g. tauto) */ - if (needs_copied_args(sc->code)) - sc->args = copy_proper_list(sc, sc->args); -} - -static void op_apply_sa(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - sc->args = fx_call(sc, cdr(p)); - if (!s7_is_proper_list(sc, sc->args)) - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "apply: improper list of arguments: ~S", 37), sc->args)); - sc->code = lookup_global(sc, car(p)); - if (needs_copied_args(sc->code)) - sc->args = copy_proper_list(sc, sc->args); -} - -static void op_apply_sl(s7_scheme *sc) -{ - s7_pointer p = cdr(sc->code); - sc->args = fx_call(sc, cdr(p)); - sc->code = lookup_global(sc, car(p)); -} - -static bool op_pair_pair(s7_scheme *sc) -{ - if (!is_pair(car(sc->code))) - { - clear_optimize_op(sc->code); - return(false); - } - if (sc->stack_end >= (sc->stack_resize_trigger - 8)) - check_for_cyclic_code(sc, sc->code); /* calls resize_stack */ - push_stack_no_args_direct(sc, OP_EVAL_ARGS); /* eval args goes immediately to cdr(sc->code) */ - /* don't put check_stack_size here! */ - push_stack_no_args(sc, OP_EVAL_ARGS, car(sc->code)); - sc->code = caar(sc->code); - return(true); -} - -static bool op_pair_sym(s7_scheme *sc) -{ - if (!is_symbol(car(sc->code))) - { - clear_optimize_op(sc->code); - return(false); - } - sc->value = lookup_global(sc, car(sc->code)); - return(true); -} - -static void op_eval_args2(s7_scheme *sc) -{ - sc->code = pop_op_stack(sc); - sc->args = (is_null(sc->args)) ? list_1(sc, sc->value) : proper_list_reverse_in_place(sc, cons(sc, sc->value, sc->args)); -} - -static void op_eval_args3(s7_scheme *sc) -{ - s7_pointer val = sc->code; - if (is_symbol(val)) - val = lookup_checked(sc, val); - sc->args = proper_list_reverse_in_place(sc, cons_unchecked(sc, val, cons(sc, sc->value, sc->args))); - sc->code = pop_op_stack(sc); -} - -static void op_eval_args5(s7_scheme *sc) /* sc->value is the last arg, sc->code is the previous */ -{ - sc->args = proper_list_reverse_in_place(sc, cons_unchecked(sc, sc->value, cons(sc, sc->code, sc->args))); - sc->code = pop_op_stack(sc); -} - -static bool eval_args_no_eval_args(s7_scheme *sc) -{ - if (is_any_macro(sc->value)) - { - if (!s7_is_proper_list(sc, cdr(sc->code))) - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "improper list of arguments: ~S", 30), sc->code)); - sc->args = cdr(sc->code); - if (is_symbol(car(sc->code))) /* not ((f p) args...) where (f p) has returned a macro, op_macro_d assumes car is a symbol */ - { - if (is_macro(sc->value)) - set_optimize_op(sc->code, fixup_macro_d(sc, OP_MACRO_D, sc->value)); - else - if (is_macro_star(sc->value)) - set_optimize_op(sc->code, fixup_macro_d(sc, OP_MACRO_STAR_D, sc->value)); - } - sc->code = sc->value; - return(true); - } - if (is_syntactic_pair(sc->code)) /* (define progn begin) (progn (display "hi") (+ 1 23)) */ - sc->cur_op = optimize_op(sc->code); - else - { - sc->cur_op = syntax_opcode(sc->value); - if ((is_symbol(car(sc->code))) && /* don't opt pair to syntax op if sc->value is actually an arg not the op! ((write and)) should not be op_and */ - ((car(sc->code) == syntax_symbol(sc->value)) || (lookup_global(sc, car(sc->code)) == sc->value))) - pair_set_syntax_op(sc->code, sc->cur_op); - /* weird that sc->cur_op setting above seems ok, but OP_PAIR_PAIR hangs?? */ - } - return(false); -} - - -static inline void eval_last_arg(s7_scheme *sc, s7_pointer car_code) -{ - /* here we've reached the last arg (sc->code == nil), it is not a pair */ - if (!is_null(cdr(sc->code))) - improper_arglist_error_nr(sc); - sc->code = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : car_code; /* this has to precede the set_type below */ - sc->args = (is_null(sc->args)) ? list_1(sc, sc->code) : proper_list_reverse_in_place(sc, cons(sc, sc->code, sc->args)); - sc->code = pop_op_stack(sc); -} - -static inline void eval_args_pair_car(s7_scheme *sc) -{ - s7_pointer code = cdr(sc->code); - if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code(sc, sc->code); /* calls resize_stack */ - if (is_null(code)) - push_stack_no_code(sc, OP_EVAL_ARGS2, sc->args); - else - { - if (!is_pair(code)) /* (= 0 '(1 . 2) . 3) */ - improper_arglist_error_nr(sc); - if ((is_null(cdr(code))) && - (!is_pair(car(code)))) - push_stack(sc, OP_EVAL_ARGS3, sc->args, car(code)); - else push_stack(sc, OP_EVAL_ARGS4, sc->args, code); - } - sc->code = car(sc->code); -} - -static bool eval_car_pair(s7_scheme *sc) -{ - s7_pointer code = sc->code, carc = car(sc->code); - - /* evaluate the inner list but that list can be circular: carc: #1=(#1# #1#)! and the cycle can be well-hidden -- #1=((#1 2) . 2) and other such stuff */ - if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code(sc, code); - - if (is_symbol_and_syntactic(car(carc))) - /* was checking for is_syntactic (pair or symbol) here but that can be confused by successive optimizer passes: (define (hi) (((lambda () list)) 1 2 3)) etc */ - { - if (!no_int_opt(code)) - { - if ((car(carc) == sc->lambda_symbol) && /* ((lambda ...) expr) */ - (is_pair(cddr(carc))) && (s7_is_proper_list(sc, cddr(carc)))) /* not dotted! */ - { - set_opt3_pair(code, cddr(carc)); - if ((is_null(cadr(carc))) && (is_null(cdr(code)))) - { - set_optimize_op(code, OP_F); /* ((lambda () ...)) */ - return(false); - } - if (is_pair(cadr(carc))) - { - if ((is_normal_symbol(caadr(carc))) && (!is_constant(sc, caadr(carc))) && - (is_pair(cdr(code))) && (is_fxable(sc, cadr(code)))) - { - set_opt3_sym(cdr(code), caadr(carc)); - if ((is_null(cdadr(carc))) && (is_null(cddr(code)))) - { - fx_annotate_args(sc, cdr(code), sc->curlet); /* ((lambda (x) ...) expr) */ - set_optimize_op(code, OP_F_A); - return(false); - } - if ((is_pair(cdadr(carc))) && (is_pair(cddr(code))) && (is_fxable(sc, caddr(code))) && - (is_null(cddadr(carc))) && (is_null(cdddr(code))) && - (is_normal_symbol(cadadr(carc))) && (!is_constant(sc, cadadr(carc))) && (caadr(carc) != cadadr(carc))) - { - fx_annotate_args(sc, cdr(code), sc->curlet); - set_optimize_op(code, OP_F_AA); /* ((lambda (x y) ...) expr exor) */ - return(false); - }} - set_optimize_op(code, OP_F_NP); - }} - set_no_int_opt(code); - } - /* ((if op1 op2) args...) is another somewhat common case */ - if ((car(carc) == sc->quote_symbol) && /* ('and #f) */ - ((!is_pair(cdr(carc))) || /* ((quote . #\h) (2 . #\i)) ! */ - (is_symbol_and_syntactic(cadr(carc))))) /* ('or #f) but not ('#_or #f) */ - apply_error_nr(sc, (is_pair(cdr(carc))) ? cadr(carc) : carc, cdr(code)); - - push_stack_no_args(sc, OP_EVAL_ARGS, code); - sc->code = carc; - if (!no_cell_opt(carc)) - { - if ((car(carc) == sc->if_symbol) && - (is_pair(cdr(code))) && /* check that we got one or two args */ - ((is_null(cddr(code))) || - ((is_pair(cddr(code))) && (is_null(cdddr(code)))))) - { - check_if(sc, carc); - if ((fx_function[optimize_op(carc)]) && - (is_fxable(sc, cadr(code))) && - ((is_null(cddr(code))) || (is_fxable(sc, caddr(code))))) /* checked cdddr above */ - { - fx_annotate_args(sc, cdr(code), sc->curlet); - set_fx_direct(code, fx_function[optimize_op(carc)]); - set_optimize_op(code, (is_null(cddr(code))) ? OP_A_A : OP_A_AA); - return(false); /* goto eval in trailers */ - }} - set_no_cell_opt(carc); - } - sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); - pair_set_syntax_op(sc->code, sc->cur_op); - return(true); - } - push_stack_no_args(sc, OP_EVAL_ARGS, code); - if ((is_pair(cdr(code))) && (is_optimized(carc))) - { - if ((fx_function[optimize_op(carc)]) && - (is_fxable(sc, cadr(code))) && - ((is_null(cddr(code))) || - ((is_fxable(sc, caddr(code))) && (is_null(cdddr(code)))))) - { - fx_annotate_args(sc, cdr(code), sc->curlet); - set_fx_direct(code, fx_function[optimize_op(carc)]); - set_optimize_op(code, (is_null(cddr(code))) ? OP_A_A : OP_A_AA); - sc->code = carc; - return(false); /* goto eval in trailers */ - } - if ((is_null(cddr(code))) && (is_symbol(cadr(code)))) /* ((x 'f82) x) in tstar for example */ - { - set_optimize_op(code, OP_P_S); - set_opt3_sym(code, cadr(code)); - } - /* possible op OP_P_ALL_A runs into opt2 fx overwrites in a case like ((values set!) x 32) */ - else set_optimize_op(code, OP_PAIR_PAIR); - } - else set_optimize_op(code, OP_PAIR_PAIR); - push_stack_no_args(sc, OP_EVAL_ARGS, carc); - sc->code = car(carc); - return(false); -} - -static inline bool eval_args_last_arg(s7_scheme *sc) -{ - s7_pointer car_code = car(sc->code); /* we're at the last arg, sc->value is the previous one, not yet saved in the args list */ - if (is_pair(car_code)) - { - if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code(sc, sc->code); - push_stack(sc, OP_EVAL_ARGS5, sc->args, sc->value); - sc->code = car_code; - return(true); - } - /* get the last arg */ - sc->code = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : car_code; - /* get the current arg, which is not a list */ - sc->args = proper_list_reverse_in_place(sc, cons_unchecked(sc, sc->code, cons(sc, sc->value, sc->args))); - sc->code = pop_op_stack(sc); - return(false); -} - -static goto_t trailers(s7_scheme *sc) -{ - s7_pointer code = sc->code; - set_current_code(sc, code); - if (is_pair(code)) - { - s7_pointer carc = car(code); - if (is_symbol(carc)) - { - /* car is a symbol, sc->code a list */ - if (is_syntactic_symbol(carc)) - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); - pair_set_syntax_op(sc->code, sc->cur_op); - return(goto_top_no_pop); - } - sc->value = lookup_global(sc, carc); - set_optimize_op(code, OP_PAIR_SYM); /* mostly stuff outside functions (unopt) */ - return(goto_eval_args_top); - } - if (is_pair(carc)) /* ((if x y z) a b) etc */ - return((eval_car_pair(sc)) ? goto_top_no_pop : goto_eval); - - /* here we can get syntax objects like quote */ - if (is_syntax(carc)) - { - sc->cur_op = syntax_opcode(carc); - pair_set_syntax_op(sc->code, sc->cur_op); - return(goto_top_no_pop); - } - /* car must be the function to be applied, or (for example) a syntax variable like quote that has been used locally */ - set_optimize_op(code, OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ - sc->value = T_Ext(carc); - return(goto_eval_args_top); - } - if (is_symbol(code)) - { - sc->value = lookup_checked(sc, code); - set_optimize_op(code, (is_keyword(code)) ? OP_CONSTANT : OP_SYMBOL); - } - else - { - sc->value = T_Ext(code); - set_optimize_op(code, OP_CONSTANT); - } - return(goto_start); -} - - -/* ---------------- reader funcs for eval ---------------- */ -static void back_up_stack(s7_scheme *sc) -{ - opcode_t top_op = stack_op(sc->stack, current_stack_top(sc) - 1); - if (top_op == OP_READ_DOT) - { - pop_stack(sc); - top_op = stack_op(sc->stack, current_stack_top(sc) - 1); - } - if ((top_op == OP_READ_VECTOR) || - (top_op == OP_READ_BYTE_VECTOR) || - (top_op == OP_READ_INT_VECTOR) || - (top_op == OP_READ_FLOAT_VECTOR)) - { - pop_stack(sc); - top_op = stack_op(sc->stack, current_stack_top(sc) - 1); - } - if (top_op == OP_READ_QUOTE) - pop_stack(sc); -} - -static token_t read_sharp(s7_scheme *sc, s7_pointer pt) -{ - int32_t c = inchar(pt); /* inchar can return EOF, so it can't be used directly as an index into the digits array */ - switch (c) - { - case EOF: - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "unexpected '#' at end of input", 30))); - break; - - case '(': - sc->w = int_one; - return(TOKEN_VECTOR); - - case 'i': - if (read_sharp(sc, pt) == TOKEN_VECTOR) - return(TOKEN_INT_VECTOR); - backchar('i', pt); - break; - - case 'r': - if (read_sharp(sc, pt) == TOKEN_VECTOR) - return(TOKEN_FLOAT_VECTOR); - backchar('r', pt); - break; - - case 'u': - if (s7_peek_char(sc, pt) == chars[(int32_t)('8')]) /* backwards compatibility: #u8(...) == #u(...) */ - { - int32_t bc = inchar(pt); - if (s7_peek_char(sc, pt) == chars[(int32_t)('(')]) - { - inchar(pt); - sc->w = int_one; - return(TOKEN_BYTE_VECTOR); - } - backchar(bc, pt); - } - if (read_sharp(sc, pt) == TOKEN_VECTOR) - return(TOKEN_BYTE_VECTOR); - backchar('u', pt); - break; - - case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': - { - /* here we can get an overflow: #1231231231231232131D() */ - s7_int dims = digits[c]; - int32_t d = 0, loc = 0; - - sc->strbuf[loc++] = (unsigned char)c; - while (true) - { - s7_int dig; - d = inchar(pt); - if (d == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #n...", 43))); - dig = digits[d]; - if (dig >= 10) break; - dims = dig + (dims * 10); - if (dims <= 0) - { - sc->strbuf[loc++] = (unsigned char)d; - error_nr(sc, sc->read_error_symbol, - set_elist_3(sc, wrap_string(sc, "reading #~A...: ~A must be a positive integer", 45), - wrap_string(sc, sc->strbuf, loc), - wrap_integer(sc, dims))); - } - if (dims > sc->max_vector_dimensions) - { - sc->strbuf[loc++] = (unsigned char)d; - sc->strbuf[loc + 1] = '\0'; - error_nr(sc, sc->read_error_symbol, - set_elist_4(sc, wrap_string(sc, "reading #~A...: ~A is too large, (*s7* 'max-vector-dimensions): ~A", 66), - wrap_string(sc, sc->strbuf, loc), - wrap_integer(sc, dims), - wrap_integer(sc, sc->max_vector_dimensions))); - } - sc->strbuf[loc++] = (unsigned char)d; - } - sc->strbuf[loc++] = d; - if ((d == 'd') || (d == 'i') || (d == 'r') || (d == 'u')) - { - int32_t e = inchar(pt); - if (e == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #n()", 42))); - sc->strbuf[loc++] = (unsigned char)e; - if (e == '(') - { - sc->w = make_integer(sc, dims); - if (d == 'd') return(TOKEN_VECTOR); - if (d == 'r') return(TOKEN_FLOAT_VECTOR); - return((d == 'u') ? TOKEN_BYTE_VECTOR : TOKEN_INT_VECTOR); - }} - /* try to back out */ - for (d = loc - 1; d > 0; d--) - backchar(sc->strbuf[d], pt); - } - break; - - case ':': /* turn #: into : -- this is for compatibility with Guile, sigh. - * I just noticed that Rick is using this -- I'll just leave it alone. - * but that means : readers need to handle this case specially. - * I don't think #! is special anymore -- maybe remove that code? - */ - sc->strbuf[0] = ':'; - return(TOKEN_ATOM); - - /* block comments in #! ... !# */ - /* this is needed when an input file is treated as a script: - #!/home/bil/cl/snd - !# - (format #t "a test~%") - (exit) - * but very often the closing !# is omitted which is too bad - */ - case '!': - { - char last_char = ' '; - /* make it possible to override #! handling */ - for (s7_pointer reader = slot_value(sc->sharp_readers); is_pair(reader); reader = cdr(reader)) - if (s7_character(caar(reader)) == '!') - { - sc->strbuf[0] = (unsigned char)c; - return(TOKEN_SHARP_CONST); /* next stage notices any errors */ - } - /* not #! as block comment (for Guile I guess) */ - while ((c = inchar(pt)) != EOF) - { - if ((c == '#') && - (last_char == '!')) - break; - last_char = c; - } - if (c == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #!", 40))); - return(token(sc)); - } - - /* block comments in #| ... |# - * since we ignore everything until the |#, internal semicolon comments are ignored, - * meaning that ;|# is as effective as |# - */ - case '|': - { - const char *str, *orig_str, *p, *pend; - if (is_file_port(pt)) - { - char last_char = ' '; - while (true) - { - c = fgetc(port_file(pt)); - if (c == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #|", 40))); - if ((c == '#') && - (last_char == '|')) - break; - last_char = c; - if (c == '\n') - port_line_number(pt)++; - } - return(token(sc)); - } - orig_str = (const char *)(port_data(pt) + port_position(pt)); - pend = (const char *)(port_data(pt) + port_data_size(pt)); - str = orig_str; - while (true) - { - p = strchr(str, (int)'|'); - if ((!p) || (p >= pend)) - { - port_position(pt) = port_data_size(pt); - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #|", 40))); - } - if (p[1] == '#') - break; - str = (const char *)(p + 1); - } - port_position(pt) += (p - orig_str + 2); - /* now count newlines inside the comment */ - str = (const char *)orig_str; - pend = p; - while (true) - { - p = strchr(str, (int)'\n'); - if ((p) && (p < pend)) - { - port_line_number(pt)++; - str = (char *)(p + 1); - } - else break; - } - return(token(sc)); - }} - sc->strbuf[0] = (unsigned char)c; - return(TOKEN_SHARP_CONST); /* next stage notices any errors */ -} - -static token_t read_comma(s7_scheme *sc, s7_pointer pt) -{ - /* here we probably should check for symbol names that start with "@": - (define-macro (hi @foo) `(+ ,@foo 1)) -> hi, (hi 2) -> ;foo: unbound variable - but (define-macro (hi .foo) `(+ ,.foo 1)) -> hi, (hi 2) -> 3 - and ambiguous: - (define-macro (hi @foo . foo) `(list ,@foo)) - what about , @foo -- is the space significant? We accept ,@ foo. - */ - int32_t c = inchar(pt); - if (c == '@') - return(TOKEN_AT_MARK); - if (c == EOF) - { - sc->strbuf[0] = ','; /* was '@' which doesn't make any sense */ - return(TOKEN_COMMA); /* was TOKEN_ATOM, which also doesn't seem sensible */ - } - backchar(c, pt); - return(TOKEN_COMMA); -} - -static token_t read_dot(s7_scheme *sc, s7_pointer pt) -{ - int32_t c = inchar(pt); - if (c != EOF) - { - backchar(c, pt); - if ((!char_ok_in_a_name[c]) && (c != 0)) - return(TOKEN_DOT); - } - else - { - sc->strbuf[0] = '.'; - return(TOKEN_DOT); - } - sc->strbuf[0] = '.'; - return(TOKEN_ATOM); /* i.e. something that can start with a dot like a number */ -} - -static token_t token(s7_scheme *sc) /* inline here is slower */ -{ - int32_t c = port_read_white_space(current_input_port(sc))(sc, current_input_port(sc)); - switch (c) - { - case '(': return(TOKEN_LEFT_PAREN); - case ')': return(TOKEN_RIGHT_PAREN); - case '.': return(read_dot(sc, current_input_port(sc))); - case '\'': return(TOKEN_QUOTE); - case ';': return(port_read_semicolon(current_input_port(sc))(sc, current_input_port(sc))); - case '"': return(TOKEN_DOUBLE_QUOTE); - case '`': return(TOKEN_BACK_QUOTE); - case ',': return(read_comma(sc, current_input_port(sc))); - case '#': return(read_sharp(sc, current_input_port(sc))); - case '\0': - case EOF: return(TOKEN_EOF); - default: - sc->strbuf[0] = (unsigned char)c; /* every TOKEN_ATOM return goes to port_read_name, so we save a backchar/inchar shuffle by starting the read here */ - return(TOKEN_ATOM); - } -} - -static int32_t read_x_char(s7_scheme *sc, int32_t i, s7_pointer pt) -{ - /* possible "\xn...;" char (write creates these things, so we have to read them) - * but we could have crazy input like "\x -- with no trailing double quote - */ - for (int32_t c_ctr = 0; ; c_ctr++) - { - int32_t d1, d2, c = inchar(pt); - if (c == '"') /* "\x" -> error, "\x44" or "\x44;" -> #\D */ - { - if (c_ctr == 0) /* "\x" */ - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar(c, pt); /* "\x44" I think -- not sure about this -- Guile is happy but I think it contradicts r7rs.pdf */ - return(i); - } - if (c == ';') - { - if (c_ctr == 0) /* "\x;" */ - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - return(i); /* "\x44;" */ - } - if (c == EOF) /* "\x */ - { - read_error_nr(sc, "# in midst of hex-char"); - return(i); - } - d1 = digits[c]; - if (d1 >= 16) /* "\x4H", also "\x44H" which Guile thinks is ok -- it apparently reads 2 digits and quits? */ - { - if (c_ctr == 0) - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar(c, pt); - return(i); - } - /* perhaps if c_ctr==0 error else backchar + return(i??) */ - - c = inchar(pt); - if (c == '"') /* "\x4" */ - { - sc->strbuf[i++] = (unsigned char)d1; - backchar((char)c, pt); - return(i); - } - if (c == ';') /* "\x4;" */ - { - sc->strbuf[i++] = (unsigned char)d1; - return(i); - } - if (c == EOF) /* "\x4 in midst of hex-char"); - return(i); - } - d2 = digits[c]; - if (d2 >= 16) - { - if (c_ctr == 0) - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar(c, pt); - return(i); - } - sc->strbuf[i++] = (unsigned char)(16 * d1 + d2); - } - return(i); -} - -static s7_pointer unknown_string_constant(s7_scheme *sc, int32_t c) -{ - /* check *read-error-hook* */ - if (hook_has_functions(sc->read_error_hook)) - { - s7_pointer result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->F, chars[(uint8_t)c])); - if (is_character(result)) - return(result); - } - return(sc->T); -} - -static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt) -{ - /* sc->F => error, no check needed here for bad input port and so on */ - s7_int i = 0; - - if (is_string_port(pt)) - { - /* try the most common case first */ - char *s, *end, *start = (char *)(port_data(pt) + port_position(pt)); - if (*start == '"') - { - port_position(pt)++; - return(nil_string); - } - end = (char *)(port_data(pt) + port_data_size(pt)); - s = strpbrk(start, "\"\n\\"); - if ((!s) || (s >= end)) /* can this read a huge string constant from a file? */ - { - if (start == end) - sc->strbuf[0] = '\0'; - else memcpy((void *)(sc->strbuf), (void *)start, (end - start > 8) ? 8 : (end - start)); - sc->strbuf[8] = '\0'; - return(sc->F); - } - if (*s == '"') - { - s7_int len = s - start; - port_position(pt) += (len + 1); - return(make_string_with_length(sc, start, len)); - } - for (; s < end; s++) - { - if (*s == '"') /* switch here no faster */ - { - s7_int len = s - start; - port_position(pt) += (len + 1); - return(make_string_with_length(sc, start, len)); - } - if (*s == '\\') - { - /* all kinds of special cases here (resultant string is not the current string), so drop to loop below (setting "i") */ - s7_int len = (s7_int)(s - start); - if (len > 0) - { - if (len >= sc->strbuf_size) - resize_strbuf(sc, len); - memcpy((void *)(sc->strbuf), (void *)(port_data(pt) + port_position(pt)), len); - port_position(pt) += len; - } - i = len; - break; - } - else - if (*s == '\n') - port_line_number(pt)++; - }} - - while (true) - { - /* splitting this check out and duplicating the loop was slower?!? */ - int32_t c = port_read_character(pt)(sc, pt); - switch (c) - { - case '\n': - port_line_number(pt)++; - sc->strbuf[i++] = (unsigned char)c; - break; - - case EOF: - sc->strbuf[(i > 8) ? 8 : i] = '\0'; - return(sc->F); - - case '"': - return(make_string_with_length(sc, sc->strbuf, i)); - - case '\\': - c = inchar(pt); - switch (c) - { - case EOF: - sc->strbuf[(i > 8) ? 8 : i] = '\0'; - return(sc->F); - - case '\\': case '"': case '|': - sc->strbuf[i++] = (unsigned char)c; - break; - - case 'n': sc->strbuf[i++] = '\n'; break; - case 't': sc->strbuf[i++] = '\t'; break; - case 'r': sc->strbuf[i++] = '\r'; break; - case '/': sc->strbuf[i++] = '/'; break; - case 'b': sc->strbuf[i++] = (unsigned char)8; break; - case 'f': sc->strbuf[i++] = (unsigned char)12; break; - - case 'x': - i = read_x_char(sc, i, pt); - break; - - default: /* if (!is_white_space(c)) */ /* changed 8-Apr-12 */ - if ((c != '\n') && (c != '\r')) /* i.e. line continuation via #\\ at end of line */ - { - s7_pointer result = unknown_string_constant(sc, c); - if (!is_character(result)) return(result); - sc->strbuf[i++] = character(result); - } - /* #f here would give confusing error message "end of input", so return #t=bad backslash. - * this is not optimal. It's easy to forget that backslash needs to be backslashed. - * the white_space business half-implements Scheme's \...... or \...... - * feature -- the characters after \ are flushed if they're all white space and include a newline. - * (string->number "1\ 2") is 12?? Too bizarre. - */ - } - break; - - default: - sc->strbuf[i++] = (unsigned char)c; - break; - } - if (i >= sc->strbuf_size) - resize_strbuf(sc, i); - } -} - -static void read_double_quote(s7_scheme *sc) -{ - sc->value = read_string_constant(sc, current_input_port(sc)); - if (sc->value == sc->F) /* can happen if input code ends in the middle of a string */ - string_read_error_nr(sc, "end of input encountered while in a string"); - if (sc->value == sc->T) - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); -} - -static inline bool read_sharp_const(s7_scheme *sc) -{ - sc->value = port_read_sharp(current_input_port(sc))(sc, current_input_port(sc)); - if (sc->value == sc->no_value) - { - /* (set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*)) - * (+ 1 #;(* 2 3) 4) - * so we need to get the next token, act on it without any assumptions about read list - */ - sc->tok = token(sc); - return(true); - } - return(false); -} - -static noreturn void read_expression_read_error_nr(s7_scheme *sc) -{ - s7_pointer pt = current_input_port(sc); - pop_stack(sc); - if ((is_input_port(pt)) && - (!port_is_closed(pt)) && - (port_data(pt)) && - (port_position(pt) > 0)) - { - s7_pointer p = make_empty_string(sc, 128, '\0'); - char *msg = string_value(p); - s7_int pos = port_position(pt); - s7_int start = pos - 40; - if (start < 0) start = 0; - memcpy((void *)msg, (void *)"at \"...", 7); - memcpy((void *)(msg + 7), (void *)(port_data(pt) + start), pos - start); - memcpy((void *)(msg + 7 + pos - start), (void *)"...", 3); - string_length(p) = 7 + pos - start + 3; - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - read_error_nr(sc, "stray comma before ')'?"); /* '("a" "b",) */ -} - -static s7_pointer read_expression(s7_scheme *sc) -{ - while (true) - { - switch (sc->tok) - { - case TOKEN_EOF: - return(eof_object); - - case TOKEN_BYTE_VECTOR: - push_stack_no_let_no_code(sc, OP_READ_BYTE_VECTOR, sc->w); - sc->tok = TOKEN_LEFT_PAREN; - break; - - case TOKEN_INT_VECTOR: - push_stack_no_let_no_code(sc, OP_READ_INT_VECTOR, sc->w); - sc->tok = TOKEN_LEFT_PAREN; - break; - - case TOKEN_FLOAT_VECTOR: - push_stack_no_let_no_code(sc, OP_READ_FLOAT_VECTOR, sc->w); - sc->tok = TOKEN_LEFT_PAREN; - break; - - case TOKEN_VECTOR: /* already read #( -- TOKEN_VECTOR is triggered by #( */ - push_stack_no_let_no_code(sc, OP_READ_VECTOR, sc->w); /* sc->w is the dimensions */ - /* fall through */ - - case TOKEN_LEFT_PAREN: - sc->tok = token(sc); - if (sc->tok == TOKEN_RIGHT_PAREN) - return(sc->nil); - if (sc->tok == TOKEN_DOT) - { - int32_t c; - back_up_stack(sc); - do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF)); - read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ - } - if (sc->tok == TOKEN_EOF) - missing_close_paren_error_nr(sc); - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); /* here we need to clear args, but code is ignored */ - check_stack_size(sc); /* s7test */ - break; - - case TOKEN_QUOTE: - push_stack_no_let_no_code(sc, OP_READ_QUOTE, sc->nil); - sc->tok = token(sc); - break; - - case TOKEN_BACK_QUOTE: - sc->tok = token(sc); - push_stack_no_let_no_code(sc, OP_READ_QUASIQUOTE, sc->nil); - break; - - case TOKEN_COMMA: - push_stack_no_let_no_code(sc, OP_READ_UNQUOTE, sc->nil); - sc->tok = token(sc); - switch (sc->tok) - { - case TOKEN_EOF: - pop_stack(sc); - read_error_nr(sc, "stray comma at the end of the input?"); - case TOKEN_RIGHT_PAREN: - read_expression_read_error_nr(sc); - default: - break; - } - break; - - case TOKEN_AT_MARK: - push_stack_no_let_no_code(sc, OP_READ_APPLY_VALUES, sc->nil); - sc->tok = token(sc); - break; - - case TOKEN_ATOM: - return(port_read_name(current_input_port(sc))(sc, current_input_port(sc))); - /* If reading list (from lparen), this will finally get us to op_read_list */ - - case TOKEN_DOUBLE_QUOTE: - read_double_quote(sc); - return(sc->value); - - case TOKEN_SHARP_CONST: - return(port_read_sharp(current_input_port(sc))(sc, current_input_port(sc))); - - case TOKEN_DOT: /* (catch #t (lambda () (+ 1 . . )) (lambda args 'hiho)) */ - back_up_stack(sc); - {int32_t c; do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF));} - read_error_nr(sc, "stray dot in list?"); /* (+ 1 . . ) */ - - case TOKEN_RIGHT_PAREN: /* (catch #t (lambda () '(1 2 . )) (lambda args 'hiho)) */ - back_up_stack(sc); - read_error_nr(sc, "unexpected close paren"); /* (+ 1 2)) or (+ 1 . ) */ - }} - /* we never get here */ - return(sc->nil); -} - -static void read_dot_and_expression(s7_scheme *sc) -{ - push_stack_no_let_no_code(sc, OP_READ_DOT, sc->args); - sc->tok = token(sc); - sc->value = read_expression(sc); -} - -static void read_tok_default(s7_scheme *sc) -{ - /* by far the main case here is TOKEN_LEFT_PAREN, but it doesn't save anything to move it to this level */ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - /* check for op_read_list here and explicit pop_stack are slower */ -} - -static int32_t read_atom(s7_scheme *sc, s7_pointer pt) -{ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - /* check_stack_size(sc); */ - sc->value = port_read_name(pt)(sc, pt); - sc->args = list_1(sc, sc->value); - pair_set_current_input_location(sc, sc->args); - return(port_read_white_space(pt)(sc, pt)); -} - -static /* inline */ int32_t read_start_list(s7_scheme *sc, s7_pointer pt, int32_t c) -{ - sc->strbuf[0] = (unsigned char)c; - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - check_stack_size(sc); /* s7test */ - sc->value = port_read_name(pt)(sc, pt); - sc->args = list_1(sc, sc->value); - pair_set_current_input_location(sc, sc->args); - return(port_read_white_space(pt)(sc, pt)); -} - -static void op_read_internal(s7_scheme *sc) -{ - /* if we're loading a file, and in the file we evaluate (at top-level) something like: - * (set-current-input-port (open-input-file "tmp2.r5rs")) - * (close-input-port (current-input-port)) - * ... (with no reset of input port to its original value) - * the load process tries to read the loaded string, but the current-input-port is now closed, - * and the original is inaccessible! So we get a segfault in token. We don't want to put - * a port_is_closed check there because token only rarely is in this danger. I think this - * is the only place where we can be about to call token, and someone has screwed up our port. - */ - if (port_is_closed(current_input_port(sc))) - error_nr(sc, sc->read_error_symbol, /* not read_error here because it paws through the port string which doesn't exist here */ - set_elist_1(sc, wrap_string(sc, (is_loader_port(current_input_port(sc))) ? "load input port is closed!" : "read input port is closed!", 26))); - - sc->tok = token(sc); - switch (sc->tok) - { - case TOKEN_EOF: break; - case TOKEN_RIGHT_PAREN: read_error_nr(sc, "unexpected close paren"); - case TOKEN_COMMA: read_error_nr(sc, "unexpected comma"); - default: - sc->value = read_expression(sc); - sc->current_line = port_line_number(current_input_port(sc)); /* this info is used to track down missing close parens */ - sc->current_file = port_filename(current_input_port(sc)); - break; - } -} - -static void op_read_done(s7_scheme *sc) -{ - pop_input_port(sc); - if (sc->tok == TOKEN_EOF) - sc->value = eof_object; - sc->current_file = NULL; /* this is for error handling */ -} - -static void op_read_s(s7_scheme *sc) -{ - s7_pointer port = lookup(sc, cadr(sc->code)); - if (!is_input_port(port)) /* was also not stdin */ - { - sc->value = g_read(sc, set_plist_1(sc, port)); - return; - } - if (port_is_closed(port)) /* I guess the port_is_closed check is needed because we're going down a level below */ - sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, an_open_input_port_string); - - if (is_function_port(port)) - { - sc->value = (*(port_input_function(port)))(sc, S7_READ, port); - if (is_multiple_value(sc->value)) - { - clear_multiple_value(sc->value); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), sc->value)); - }} - else /* we used to check for string port at end here, but that is rarely true so checking takes up more time than it saves */ - { - push_input_port(sc, port); - push_stack_op(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */ - sc->tok = token(sc); - switch (sc->tok) - { - case TOKEN_EOF: return; - case TOKEN_RIGHT_PAREN: read_error_nr(sc, "unexpected close paren"); - case TOKEN_COMMA: read_error_nr(sc, "unexpected comma"); - default: - sc->value = read_expression(sc); - sc->current_line = port_line_number(current_input_port(sc)); /* this info is used to track down missing close parens */ - sc->current_file = port_filename(current_input_port(sc)); - }} -} - -static bool op_read_quasiquote(s7_scheme *sc) -{ - /* this was pushed when the backquote was seen, then eventually we popped back to it */ - sc->value = g_quasiquote_1(sc, sc->value, false); - /* doing quasiquote at read time means there are minor inconsistencies in various combinations or quote/' and quasiquote/`. - * A quoted ` will expand but quoted quasiquote will not (` can't be redefined, but quasiquote can). see s7test.scm for examples. - */ - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool pop_read_list(s7_scheme *sc) -{ - /* push-stack OP_READ_LIST is always no_code and op is always OP_READ_LIST (and not used), sc->curlet is apparently not needed here */ - unstack_with(sc, OP_READ_LIST); - sc->args = sc->stack_end[2]; - if (!is_null(sc->args)) return(false); /* fall into read_list where sc->args is placed at end of on-going list, sc->value */ - sc->args = list_1(sc, sc->value); - pair_set_current_input_location(sc, sc->args); /* uses port_location */ - return(true); -} - -static bool op_load_return_if_eof(s7_scheme *sc) -{ - if (sc->tok != TOKEN_EOF) - { - push_stack_op_let(sc, OP_LOAD_RETURN_IF_EOF); - push_stack_op_let(sc, OP_READ_INTERNAL); - sc->code = sc->value; - return(true); /* we read an expression, now evaluate it, and return to read the next */ - } - sc->current_file = NULL; - return(false); -} - -static bool op_load_close_and_pop_if_eof(s7_scheme *sc) -{ - /* (load "file") in scheme: read and evaluate all exprs, then upon EOF, close current and pop input port stack */ - if (sc->tok != TOKEN_EOF) - { - push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was push args, code */ - if ((!is_string_port(current_input_port(sc))) || - (port_position(current_input_port(sc)) < port_data_size(current_input_port(sc)))) - push_stack_op_let(sc, OP_READ_INTERNAL); - else sc->tok = TOKEN_EOF; - sc->code = sc->value; - return(true); /* we read an expression, now evaluate it, and return to read the next */ - } - if ((S7_DEBUGGING) && (!is_loader_port(current_input_port(sc)))) fprintf(stderr, "%s not loading?\n", display(current_input_port(sc))); - /* if *#readers* func hits error, clear_loader_port might not be undone? */ - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - sc->current_file = NULL; - if (is_multiple_value(sc->value)) /* (load "file") where "file" is (values 1 2 3) */ - sc->value = splice_in_values(sc, multiple_value(sc->value)); - return(false); -} - -static bool op_read_apply_values(s7_scheme *sc) -{ - sc->value = list_2_unchecked(sc, sc->unquote_symbol, list_2(sc, sc->apply_values_symbol, sc->value)); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static goto_t op_read_dot(s7_scheme *sc) -{ - token_t c = token(sc); - if (c != TOKEN_RIGHT_PAREN) /* '(1 . (2) 3) -> '(1 2 3), Guile says "missing close paren" */ - { - if (is_pair(sc->value)) - { - for (s7_pointer p = sc->value; is_pair(p); p = cdr(p)) - sc->args = cons(sc, car(p), sc->args); - sc->tok = c; - return(goto_read_tok); - } - back_up_stack(sc); - read_error_nr(sc, "stray dot?"); /* (+ 1 . 2 3) or (list . ) */ - } - /* args = previously read stuff, value = thing just after the dot and before the ')': - * (list 1 2 . 3) -> value: 3, args: (2 1 list), '(1 . 2) -> value: 2, args: (1) - * but we also get here in a lambda arg list: (lambda (a b . c) #f) -> value: c, args: (b a) - */ - sc->value = any_list_reverse_in_place(sc, sc->value, sc->args); - return((main_stack_op(sc) == OP_READ_LIST) ? goto_pop_read_list : goto_start); -} - -static bool op_read_quote(s7_scheme *sc) -{ - /* can't check for sc->value = sc->nil here because we want ''() to be different from '() */ - if ((sc->safety > IMMUTABLE_VECTOR_SAFETY) && - ((is_pair(sc->value)) || (is_any_vector(sc->value)) || (is_string(sc->value)))) - set_immutable(sc->value); - sc->value = list_2(sc, sc->quote_symbol, sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool op_read_unquote(s7_scheme *sc) -{ - /* here if sc->value is a constant, the unquote is pointless (should we complain?) - * also currently stray "," can be ignored: (abs , 1) -- scanning the stack for quasiquote or quote seems to be unreliable - */ - if ((is_pair(sc->value)) || - (is_symbol(sc->value))) - sc->value = list_2(sc, sc->unquote_symbol, sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -/* safety check is at read time, so (immutable? (let-temporarily (((*s7* 'safety) 2)) #(1 2 3))) is #f - * but (immutable? (let-temporarily (((*s7* 'safety) 2)) (eval-string "#(1 2 3)"))) is #t - */ -static bool op_read_vector(s7_scheme *sc) -{ - sc->value = (sc->args == int_one) ? g_vector(sc, sc->value) : g_multivector(sc, integer(sc->args), sc->value); /* sc->args was sc->w earlier from read_sharp */ - /* here and below all of the sc->value list can be freed, but my tests showed no speed up even in large cases */ - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool op_read_int_vector(s7_scheme *sc) -{ - sc->value = (sc->args == int_one) ? g_int_vector(sc, sc->value) : g_int_multivector(sc, integer(sc->args), sc->value); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool op_read_float_vector(s7_scheme *sc) -{ - sc->value = (sc->args == int_one) ? g_float_vector(sc, sc->value) : g_float_multivector(sc, integer(sc->args), sc->value); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - -static bool op_read_byte_vector(s7_scheme *sc) -{ - sc->value = (sc->args == int_one) ? g_byte_vector(sc, sc->value) : g_byte_multivector(sc, integer(sc->args), sc->value); - if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value); - return(main_stack_op(sc) != OP_READ_LIST); -} - - -/* ---------------- unknown ops ---------------- */ -static bool fixup_unknown_op(s7_scheme *sc, s7_pointer code, s7_pointer func, opcode_t op) -{ - set_optimize_op(code, op); - if (is_any_closure(func)) - set_opt1_lambda_add(code, func); /* perhaps set_opt1_lambda_add here and throughout op_unknown* */ - return(true); -} - -static bool unknown_unknown(s7_scheme *sc, s7_pointer code, opcode_t op) -{ - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - set_optimize_op(code, op); - return(true); -} - -static bool is_immutable_and_stable(s7_scheme *sc, s7_pointer func) -{ - if (symbol_ctr(func) != 1) /* protect against (define-constant (p) (define-constant (p) ...)) */ - return(false); - if ((is_global(func)) && (is_immutable_slot(global_slot(func)))) - return(true); - for (s7_pointer p = sc->curlet; is_let(p); p = let_outlet(p)) - if ((is_funclet(p)) && (funclet_function(p) != func)) - return(false); - return(is_immutable_slot(lookup_slot_from(func, sc->curlet))); -} - -static bool op_unknown(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - if (!f) /* can be NULL if unbound variable */ - unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s %s\n", __func__, display(f), s7_type_names[type(f)]); - - switch (type(f)) - { - case T_CLOSURE: - case T_CLOSURE_STAR: - if (!has_methods(f)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - if (is_null(closure_args(f))) - { - s7_pointer body = closure_body(f); - bool one_form = is_null(cdr(body)); - bool safe_case = is_safe_closure(f); - set_opt1_lambda_add(code, f); - if (one_form) - { - if ((safe_case) && (is_fxable(sc, car(body)))) - { - set_safe_closure(f); /* safe because no args so no reference to funclet? needed because op_safe_thunk_a will check for it */ - fx_annotate_arg(sc, body, sc->curlet); - set_safe_optimize_op(code, hop + OP_SAFE_THUNK_A); - set_closure_one_form_fx_arg(f); - sc->value = fx_safe_thunk_a(sc, sc->code); - return(false); - } - clear_has_fx(code); - } - set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_THUNK : ((one_form) ? OP_THUNK_O : OP_THUNK))); - return(true); - } - if (is_closure_star(f)) - { - set_safe_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); - set_opt1_lambda_add(code, f); - return(true); - }} - break; - - case T_GOTO: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO)); - case T_ITERATOR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_ITERATE)); - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - default: - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - } - return(fixup_unknown_op(sc, code, f, OP_S)); -} - -static bool fxify_closure_star_g(s7_scheme *sc, s7_pointer f, s7_pointer code) -{ - if ((!has_methods(f)) && - (closure_star_arity_to_int(sc, f) != 0)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool safe_case = is_safe_closure(f); - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_opt3_arglen(cdr(code), 1); - if ((safe_case) && (is_null(cdr(closure_args(f))))) - set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_A1); - else - if (lambda_has_simple_defaults(f)) - { - if (arglist_has_rest(sc, closure_args(f))) - fixup_unknown_op(sc, code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - else fixup_unknown_op(sc, code, f, hop + ((safe_case) ? - ((is_null(cdr(closure_args(f)))) ? OP_SAFE_CLOSURE_STAR_A1 : OP_SAFE_CLOSURE_STAR_A) : OP_CLOSURE_STAR_A)); - return(true); - } - fixup_unknown_op(sc, code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - return(true); - } - return(false); -} - -static bool op_unknown_s(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - if ((S7_DEBUGGING) && (!is_normal_symbol(cadr(code)))) fprintf(stderr, "%s[%d]: not a symbol: %s\n", __func__, __LINE__, display(code)); - if ((!is_any_macro(f)) && /* if f is a macro, its argument can be unbound legitimately */ - (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) - return(unknown_unknown(sc, sc->code, (is_normal_symbol(cadr(sc->code))) ? OP_CLEAR_OPTS : OP_S_G)); - - if ((is_unknopt(code)) && (!is_closure(f))) - return(fixup_unknown_op(sc, code, f, OP_S_G)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, 1))) break; - case T_C_RST_NO_REQ_FUNCTION: - set_c_function(code, f); - if (is_safe_procedure(f)) - { - set_optimize_op(code, OP_SAFE_C_S); - sc->value = fx_c_s(sc, sc->code); - } - else - { - set_optimize_op(code, OP_C_S); - op_c_s(sc); - } - return(false); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == 1)) - { - s7_pointer body = closure_body(f); - bool one_form = is_null(cdr(body)); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - set_opt2_sym(code, cadr(code)); - - /* code here might be (f x) where f is passed elsewhere as a function parameter, - * first time through we look it up, find a safe-closure and optimize as (say) safe_closure_s_a, - * next time it is something else, etc. Rather than keep optimizing it locally, we need to - * back out: safe_closure_s_* -> safe_closure_s -> closure_s -> op_s_g. Ideally we'd know - * this was a parameter or whatever. The tricky case is local letrec(f) calling f which initially - * thinks it is not safe, then later is set safe correctly, now outer func is called again, - * this time f is safe, and we're ok from then on. - */ - if (is_unknopt(code)) - { - switch (op_no_hop(code)) - { - case OP_CLOSURE_S: - set_optimize_op(code, (is_safe_closure(f)) ? ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : OP_S_G); break; - case OP_CLOSURE_S_O: - case OP_SAFE_CLOSURE_S: - set_optimize_op(code, ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); break; - case OP_SAFE_CLOSURE_S_O: - case OP_SAFE_CLOSURE_S_A: - case OP_SAFE_CLOSURE_S_TO_S: - case OP_SAFE_CLOSURE_S_TO_SC: - set_optimize_op(code, (is_safe_closure(f)) ? - ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : - ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); - break; - default: - set_optimize_op(code, OP_S_G); break; - } - set_opt1_lambda_add(code, f); - return(true); - } - if (!is_safe_closure(f)) - set_optimize_op(code, hop + ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); - else - if (!is_null(cdr(body))) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_S); - else - if (is_fxable(sc, car(body))) - fxify_closure_s(sc, f, code, sc->curlet, hop); - else set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_S_O); - /* hop if is_constant(sc, car(code)) is not foolproof here (see t967.scm): - * (define (f) (define-constant (f1) ... (f1))...) where each call on f makes a different f1 - */ - set_is_unknopt(code); - set_opt1_lambda_add(code, f); - return(true); - } - break; - - case T_CLOSURE_STAR: - if (fxify_closure_star_g(sc, f, code)) return(true); - break; - - case T_GOTO: - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_opt3_arglen(cdr(code), 1); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO_A)); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_VECTOR_REF_A)); - - case T_STRING: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_STRING_REF_A)); - - case T_PAIR: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_A)); - - case T_C_OBJECT: - if (s7_is_aritable(sc, f, 1)) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_C_OBJECT_REF_A)); - } - break; - - case T_LET: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_A)); - - case T_HASH_TABLE: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_A)); - - case T_CONTINUATION: - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_CONTINUATION_A)); - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - default: - break; - } - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - return(fixup_unknown_op(sc, code, f, OP_S_G)); -} - -static bool op_unknown_a(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, 1))) break; - case T_C_RST_NO_REQ_FUNCTION: - clear_has_fx(code); - set_c_function(code, f); - if (is_safe_procedure(f)) - { - set_optimize_op(code, OP_SAFE_C_A); - sc->value = fx_c_a(sc, code); - } - else - { - set_optimize_op(code, OP_C_A); - op_c_a(sc); - } - return(false); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == 1)) - { - s7_pointer body = closure_body(f); - bool safe_case = is_safe_closure(f); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(body)); - - fxify_closure_a(sc, f, one_form, safe_case, hop, code, sc->curlet); - set_opt1_lambda_add(code, f); - return(true); - } - break; - - case T_CLOSURE_STAR: - if (fxify_closure_star_g(sc, f, code)) return(true); - break; - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_VECTOR_REF_A)); - - case T_STRING: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_STRING_REF_A)); - case T_PAIR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_A)); - case T_C_OBJECT: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_C_OBJECT_REF_A)); - case T_HASH_TABLE: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_A)); - case T_GOTO: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO_A)); - case T_CONTINUATION: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_CONTINUATION_A)); - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - case T_LET: - { - s7_pointer arg1 = cadr(code); - if ((is_pair(arg1)) && (car(arg1) == sc->quote_symbol)) - { - set_opt3_con(code, cadadr(code)); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_C)); - } - set_opt3_any(code, cadr(code)); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_A)); - } - - default: - break; - } - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - return(fixup_unknown_op(sc, code, f, OP_S_A)); /* closure with methods etc */ -} - -static bool op_unknown_gg(s7_scheme *sc) -{ - bool s1, s2; - s7_pointer code = sc->code, f = sc->last_function; - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - s1 = is_normal_symbol(cadr(code)); - s2 = is_normal_symbol(caddr(code)); - - if ((s1) && - (!is_slot(lookup_slot_from(cadr(code), sc->curlet)))) - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); - if ((s2) && - (!is_slot(lookup_slot_from(caddr(code), sc->curlet)))) - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, 2))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure(f)) - { - if (s1) - { - set_optimize_op(code, (s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC); - if (s2) - set_opt2_sym(cdr(code), caddr(code)); - else set_opt2_con(cdr(code), caddr(code)); - } - else - { - set_optimize_op(code, (s2) ? OP_SAFE_C_CS : OP_SAFE_C_NC); - if (s2) - { - set_opt1_con(cdr(code), (is_pair(cadr(code))) ? cadadr(code) : cadr(code)); - set_opt2_sym(cdr(code), caddr(code)); - }}} - else - { - set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args(sc, cdr(code), sc->curlet); - } - set_opt3_arglen(cdr(code), 2); - set_c_function(code, f); - return(true); - - case T_CLOSURE: - if (has_methods(f)) break; - if (closure_arity_to_int(sc, f) == 2) - { - s7_pointer body = closure_body(f); - bool safe_case = is_safe_closure(f); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(body)); - - if ((s1) && (s2)) - { - set_opt2_sym(code, caddr(code)); - if (!one_form) - set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SS : OP_CLOSURE_SS)); - else - if (!safe_case) - set_optimize_op(code, hop + OP_CLOSURE_SS_O); - else - if (!is_fxable(sc, car(body))) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_O); - else - { - fx_annotate_arg(sc, body, sc->curlet); - fx_tree(sc, body, car(closure_args(f)), cadr(closure_args(f)), NULL, false); - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A); - set_closure_one_form_fx_arg(f); - }} - else - if (s1) - { - set_opt2_con(code, caddr(code)); - if (one_form) - set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); - else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)); - } - else - { - set_opt3_arglen(cdr(code), 2); - fx_annotate_args(sc, cdr(code), sc->curlet); - if (safe_case) - set_safe_optimize_op(code, hop + ((one_form) ? OP_SAFE_CLOSURE_AA_O : OP_SAFE_CLOSURE_AA)); - else set_safe_optimize_op(code, hop + ((one_form) ? OP_CLOSURE_AA_O : OP_CLOSURE_AA)); - } - set_opt1_lambda_add(code, f); - return(true); - } - break; - - case T_CLOSURE_STAR: - if ((closure_star_arity_to_int(sc, f) != 0) && - (closure_star_arity_to_int(sc, f) != 1)) - { - fx_annotate_args(sc, cdr(code), sc->curlet); - if (!has_methods(f)) - { - fixup_closure_star_aa(sc, f, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); - set_opt1_lambda_add(code, f); - } - else set_optimize_op(code, OP_S_AA); - return(true); - } - break; - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_PAIR: - set_opt3_arglen(cdr(code), 2); - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((!is_pair(f)) && (vector_rank(f) != 2)) - return(fixup_unknown_op(sc, code, f, OP_S_AA)); - return(fixup_unknown_op(sc, code, f, (is_pair(f)) ? OP_IMPLICIT_PAIR_REF_AA : OP_IMPLICIT_VECTOR_REF_AA)); - - case T_HASH_TABLE: - fx_annotate_args(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_AA)); - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - default: - break; - } - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - fx_annotate_args(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_S_AA)); -} - -static bool op_unknown_ns(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - int32_t num_args = opt3_arglen(cdr(code)); - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - for (s7_pointer arg = cdr(code); is_pair(arg); arg = cdr(arg)) - if (!is_slot(lookup_slot_from(car(arg), sc->curlet))) - unbound_variable_error_nr(sc, car(arg)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, num_args))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure(f)) - { - if (num_args == 3) - { - set_safe_optimize_op(code, OP_SAFE_C_SSS); - set_opt1_sym(cdr(code), caddr(code)); - set_opt2_sym(cdr(code), cadddr(code)); - } - else set_safe_optimize_op(code, OP_SAFE_C_NS); - } - else - { - set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args(sc, cdr(code), sc->curlet); - } - set_c_function(code, f); - return(true); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == num_args)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(closure_body(f))); - fx_annotate_args(sc, cdr(code), sc->curlet); - if (num_args == 3) - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_3S : ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)))); - if (num_args == 4) - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : ((one_form) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S)))); - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : OP_CLOSURE_NS))); - } - break; - - case T_CLOSURE_STAR: - if ((!has_methods(f)) && - ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((is_safe_closure(f)) && (num_args == 3) && (closure_star_arity_to_int(sc, f) == 3)) - return(fixup_unknown_op(sc, code, f, OP_SAFE_CLOSURE_STAR_3A)); - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); - } - break; - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - /* TODO: perhaps vector, but need op_implicit_vector_ns? */ - default: - break; - } - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); -} - -static bool op_unknown_aa(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s %s\n", __func__, display(f)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, 2))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure(f)) /* why is this different from unknown_a and unknown_na? */ - { - if (!safe_c_aa_to_ag_ga(sc, code, 0)) - { - set_safe_optimize_op(code, OP_SAFE_C_AA); - set_opt3_pair(code, cddr(code)); - }} - else set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - set_c_function(code, f); - return(true); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == 2)) - { - s7_pointer body = closure_body(f); - bool safe_case = is_safe_closure(f); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(body)); - if (!one_form) - set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA)); - else - if (!safe_case) - set_optimize_op(code, hop + OP_CLOSURE_AA_O); - else - if (!is_fxable(sc, car(body))) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_O); - else - { - fx_annotate_arg(sc, body, sc->curlet); - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_A); - set_closure_one_form_fx_arg(f); - } - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); - set_opt1_lambda_add(code, f); - return(true); - } - break; - - case T_CLOSURE_STAR: - if (!has_methods(f)) - { - fixup_closure_star_aa(sc, f, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); - set_opt1_lambda_add(code, f); - } - else set_optimize_op(code, OP_S_AA); - return(true); - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: - if (vector_rank(f) != 2) - return(fixup_unknown_op(sc, code, f, OP_S_AA)); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_VECTOR_REF_AA)); - - case T_PAIR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_AA)); - case T_HASH_TABLE: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_AA)); - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - - default: - break; - } - if ((is_symbol(car(code))) && - (!is_slot(lookup_slot_from(car(code), sc->curlet)))) - unbound_variable_error_nr(sc, car(code)); - return(fixup_unknown_op(sc, code, f, OP_S_AA)); -} - -static bool is_normal_happy_symbol(s7_scheme *sc, s7_pointer sym) -{ - if (!is_normal_symbol(sym)) - return(false); - if (!is_slot(lookup_slot_from(sym, sc->curlet))) - unbound_variable_error_nr(sc, sym); - return(true); -} - -static bool op_unknown_na(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0; - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(f), display(sc->code)); - if (num_args == 0) return(fixup_unknown_op(sc, code, f, OP_S)); /* via op_closure*-fx where original had 0 args, safe case -> op_safe_closure*_0 */ - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, num_args))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (is_safe_procedure(f)) - { - if (num_args == 3) - { - int32_t pairs = 0, symbols = 0, quotes = 0; /* specialize aaa->ssc etc, this makes less difference than I expected */ - for (s7_pointer p = cdr(code); is_pair(p); p = cdr(p)) - { - s7_pointer car_p = car(p); - if (is_normal_happy_symbol(sc, car_p)) - symbols++; - else - if (is_pair(car_p)) - { - pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - }} - if (optimize_safe_c_func_three_args(sc, code, f, 0 /* hop */, pairs, symbols, quotes, sc->curlet) == OPT_T) - return(true); - set_opt3_pair(cdr(code), cdddr(code)); - set_opt3_pair(code, cddr(code)); - set_safe_optimize_op(code, OP_SAFE_C_AAA); - } - else set_safe_optimize_op(code, (num_args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA); - } - else set_safe_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args(sc, cdr(code), sc->curlet); - set_c_function(code, f); - return(true); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == num_args)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); - if (is_safe_closure(f)) - { - if (num_args != 3) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_NA); - else - if (is_normal_happy_symbol(sc, cadr(code))) - set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, caddr(code))) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); - else set_safe_optimize_op(code, hop + (((!is_pair(caddr(code))) && (!is_pair(cadddr(code)))) ? OP_SAFE_CLOSURE_AGG : OP_SAFE_CLOSURE_3A)); - } - else - if (num_args != 3) - set_safe_optimize_op(code, hop + ((num_args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA)); - else - if ((is_normal_happy_symbol(sc, caddr(code))) && (is_normal_happy_symbol(sc, cadddr(code)))) - set_safe_optimize_op(code, hop + OP_CLOSURE_ASS); - else - if (is_normal_happy_symbol(sc, cadr(code))) - set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); - else - if (is_normal_happy_symbol(sc, caddr(code))) - set_safe_optimize_op(code, hop + OP_CLOSURE_ASA); - else set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_AAS : OP_CLOSURE_3A)); - set_opt1_lambda_add(code, f); - return(true); - } - if (is_symbol(closure_args(f))) - { - optimize_closure_sym(sc, code, f, 0, num_args, sc->curlet); - if (optimize_op(code) == OP_ANY_CLOSURE_SYM) return(true); - } - break; - - case T_CLOSURE_STAR: - if ((!has_methods(f)) && - ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - if (num_args > 0) - { - set_opt3_arglen(cdr(code), num_args); - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); - } - if (is_safe_closure(f)) - switch (num_args) - { - case 0: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_0)); - case 1: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_1)); - case 2: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_2)); - case 3: if (closure_star_arity_to_int(sc, f) == 3) return(fixup_unknown_op(sc, code, f, OP_SAFE_CLOSURE_STAR_3A)); - default: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA)); - } - return(fixup_unknown_op(sc, code, f, hop + OP_CLOSURE_STAR_NA)); - } - break; - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - /* implicit vector doesn't happen */ - - default: - break; - } - /* closure happens if wrong-number-of-args passed -- probably no need for op_s_na */ - /* TODO: perhaps vector? */ - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); -} - -static bool op_unknown_np(s7_scheme *sc) -{ - s7_pointer code = sc->code, f = sc->last_function; - int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0; - - if (!f) unbound_variable_error_nr(sc, car(sc->code)); - if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s %s %s\n", __func__, __LINE__, display(f), type_name(sc, f, NO_ARTICLE), display(sc->code)); - - switch (type(f)) - { - case T_C_FUNCTION: - if (!(c_function_is_aritable(f, num_args))) break; - case T_C_RST_NO_REQ_FUNCTION: - if (num_args == 1) - set_any_c_np(sc, f, code, sc->curlet, num_args, (is_safe_procedure(f)) ? OP_SAFE_C_P : OP_C_P); - else - if ((num_args == 2) && (is_safe_procedure(f))) - { - set_any_c_np(sc, f, code, sc->curlet, 2, OP_SAFE_C_PP); - opt_sp_1(sc, c_function_call(f), code); - gx_annotate_args(sc, cdr(code), sc->curlet); - } - else - if ((num_args == 3) && - ((is_safe_procedure(f)) || - ((is_semisafe(f)) && - (((car(code) != sc->assoc_symbol) && (car(code) != sc->member_symbol)) || - (unsafe_is_safe(sc, cadddr(code), sc->curlet)))))) - set_any_c_np(sc, f, code, sc->curlet, 3, OP_SAFE_C_3P); - else set_any_c_np(sc, f, code, sc->curlet, num_args, OP_ANY_C_NP); - return(true); - - case T_CLOSURE: - if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == num_args)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - switch (num_args) - { - case 1: - if (is_safe_closure(f)) - { - s7_pointer body = closure_body(f); - if ((is_null(cdr(body))) && (is_fxable(sc, car(body)))) - { - set_optimize_op(code, hop + OP_SAFE_CLOSURE_P_A); - fx_annotate_arg(sc, body, sc->curlet); - } - else set_optimize_op(code, hop + OP_SAFE_CLOSURE_P); - } - else set_optimize_op(code, hop + OP_CLOSURE_P); - set_opt1_lambda_add(code, f); /* added 8-Jun-22 */ - set_opt3_arglen(cdr(code), 1); - set_unsafely_optimized(code); - break; - - case 2: - if (is_fxable(sc, cadr(code))) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); - } - else - if (is_fxable(sc, caddr(code))) - { - fx_annotate_arg(sc, cddr(code), sc->curlet); - set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); - } - else set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_PP : OP_CLOSURE_PP)); - set_opt1_lambda_add(code, f); /* added 8-Jun-22 */ - set_opt3_arglen(cdr(code), 2); /* for later op_unknown_np */ - set_unsafely_optimized(code); - break; - - case 3: set_any_closure_np(sc, f, code, sc->curlet, 3, hop + OP_ANY_CLOSURE_3P); break; - case 4: set_any_closure_np(sc, f, code, sc->curlet, 4, hop + OP_ANY_CLOSURE_4P); break; - default: set_any_closure_np(sc, f, code, sc->curlet, num_args, hop + OP_ANY_CLOSURE_NP); break; - } - return(true); - } - break; - - case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); - case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f))); - } - return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); -} - -static bool unknown_any(s7_scheme *sc, s7_pointer f, s7_pointer code) -{ - sc->last_function = f; - if (is_null(cdr(code))) return(op_unknown(sc)); - if ((is_null(cddr(code))) && (is_normal_symbol(cadr(code)))) return(op_unknown_s(sc)); - set_opt3_arglen(cdr(code), proper_list_length(cdr(code))); - return(op_unknown_np(sc)); -} - - -/* ---------------- eval type checkers ---------------- */ -#if WITH_GCC -#define h_c_function_is_ok(Sc, P) ({s7_pointer _P_; _P_ = P; ((op_has_hop(_P_)) || (c_function_is_ok(Sc, _P_)));}) -#else -#define h_c_function_is_ok(Sc, P) ((op_has_hop(P)) || (c_function_is_ok(Sc, P))) -#endif - -#define c_function_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P)))) -#define c_function_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, caddr(P)))) - -static bool c_function_is_ok_cadr_caddr(s7_scheme *sc, s7_pointer p) -{ - return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, caddr(p)))); -} - -static bool c_function_is_ok_cadr_cadadr(s7_scheme *sc, s7_pointer p) -{ - return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, opt3_pair(p)))); /* cadadr(P) */ -} - -static bool c_function_is_ok_cadr_caddadr(s7_scheme *sc, s7_pointer p) -{ - return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, opt3_pair(p)))); /* caddadr(p) */ -} - -/* closure_is_ok_1 checks the type and the body length indications - * closure_is_fine_1 just checks the type (safe or unsafe closure) - * closure_is_ok calls _ok_1, closure_is_fine calls _fine_1 - * closure_np_is_ok accepts safe/unsafe etc - */ - -static /* inline */ bool closure_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) -{ - s7_pointer f = lookup_unexamined(sc, car(code)); - if ((f == opt1_lambda_unchecked(code)) || - ((f) && /* this fixup check does save time (e.g. cb) */ - (typesflag(f) == type) && - ((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) && /* 3 type bits to replace this but not hit enough to warrant them */ - (set_opt1_lambda(code, f)))) - return(true); - sc->last_function = f; - return(false); -} - -static /* inline */ bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) -{ - s7_pointer f = lookup_unexamined(sc, car(code)); - if ((f == opt1_lambda_unchecked(code)) || - ((f) && - ((typesflag(f) & (TYPE_MASK | T_SAFE_CLOSURE)) == type) && - ((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) && - (set_opt1_lambda(code, f)))) - return(true); - sc->last_function = f; - return(false); -} - -static bool closure_np_is_ok_1(s7_scheme *sc, s7_pointer code) -{ - s7_pointer f = lookup_unexamined(sc, car(code)); - if ((f == opt1_lambda_unchecked(code)) || - ((f) && - (is_closure(f)) && - (set_opt1_lambda(code, f)))) - return(true); - sc->last_function = f; - return(false); -} - -#define closure_is_ok(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_ok_1(Sc, Code, Type, Args))) -#define closure_np_is_ok(Sc, Code) ((symbol_ctr(car(Code)) == 1) || (closure_np_is_ok_1(Sc, Code))) -#define closure_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_fine_1(Sc, Code, Type, Args))) -#define closure_star_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_star_is_fine_1(Sc, Code, Type, Args))) - -static /* inline */ bool closure_is_eq(s7_scheme *sc) -{ - sc->last_function = lookup_unexamined(sc, car(sc->code)); - return(sc->last_function == opt1_lambda_unchecked(sc->code)); -} - -static bool star_arity_is_ok(s7_scheme *sc, s7_pointer val, int32_t args) -{ - int32_t arity = closure_star_arity_to_int(sc, val); - return((arity < 0) || ((arity * 2) >= args)); -} - -static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) -{ - s7_pointer val = lookup_unexamined(sc, car(code)); - if ((val == opt1_lambda_unchecked(code)) || - ((val) && - ((typesflag(val) & (T_SAFE_CLOSURE | TYPE_MASK)) == type) && - (star_arity_is_ok(sc, val, args)) && - (set_opt1_lambda(code, val)))) - return(true); - sc->last_function = val; - return(false); -} - -/* closure_is_fine: */ -#define FINE_UNSAFE_CLOSURE (T_CLOSURE) -#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE) - -/* closure_star_is_fine: */ -#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR) -#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE) - -/* closure_is_ok: */ -#define OK_UNSAFE_CLOSURE_P (T_CLOSURE | T_ONE_FORM) -#define OK_SAFE_CLOSURE_P (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM) -#define OK_UNSAFE_CLOSURE_M (T_CLOSURE | T_MULTIFORM) -#define OK_SAFE_CLOSURE_M (T_CLOSURE | T_SAFE_CLOSURE | T_MULTIFORM) -#define OK_SAFE_CLOSURE_A (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM_FX_ARG) -/* since T_HAS_METHODS is on if there might be methods, this can protect us from that case */ - - -/* ---------------- eval ---------------- */ -static s7_pointer eval(s7_scheme *sc, opcode_t first_op) -{ - if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "eval[%d]:, %s %s %s\n", __LINE__, op_names[first_op], display_80(sc->code), display_80(sc->args))); - sc->cur_op = first_op; - goto TOP_NO_POP; - - while (true) /* "continue" in this procedure refers to this loop */ - { - pop_stack(sc); - goto TOP_NO_POP; - - BEGIN: - if (is_pair(cdr(sc->code))) - { - set_current_code(sc, sc->code); - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - } - sc->code = car(sc->code); - - EVAL: - sc->cur_op = optimize_op(sc->code); /* sc->code can be anything, optimize_op examines a type field (opt_choice) */ - - TOP_NO_POP: - if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), display_80(sc->code))); - - /* it is only slightly faster to use labels as values (computed gotos) here. In my timing tests (June-2018), the best case speedup was in titer.scm - * callgrind numbers 4808 to 4669; another good case was tread.scm: 2410 to 2386. Most timings were a draw. computed-gotos-s7.c has the code, - * macroized so it will work if such gotos aren't available. I think I'll stick with a switch statement. - * Another idea is to put the function in the tree, not an index to it (the optimize_op business above), - * then the switch below is not needed, and we free up 16 type bits. C does not guarantee tail calls (I think) - * so we'd have each function return the next, and eval would be [while (true) f = f(sc)] but would the function - * call overhead be less expensive than the switch? (We get most functions inlined in the current code). - * with some fake fx_calls for the P cases, many of these could be [sc->value = fx_function[sc->cur_op](sc, sc->code); continue;] - * so the switch statement is unnecessary -- maybe a table eval_functions[cur_op] eventually - */ - switch (sc->cur_op) - { - /* safe c_functions */ - case OP_SAFE_C_NC: if (!c_function_is_ok(sc, sc->code)) break; /* break refers to the switch statement */ - case HOP_SAFE_C_NC: sc->value = fc_call(sc, sc->code); continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */ - - case OP_SAFE_C_S: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_s(sc)) goto EVAL; continue;} /* checking symbol_ctr(car(sc->code)) == 1 just slows us down */ - case HOP_SAFE_C_S: inline_op_safe_c_s(sc); continue; - - case OP_SAFE_C_SS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SS: inline_op_safe_c_ss(sc); continue; - - case OP_SAFE_C_NS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_NS: sc->value = fx_c_ns(sc, sc->code); continue; - - case OP_SAFE_C_SC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SC: op_safe_c_sc(sc); continue; - - case OP_SAFE_C_CS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CS: sc->value = fx_c_cs(sc, sc->code); continue; - - case OP_SAFE_C_CQ: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CQ: sc->value = fx_c_cq(sc, sc->code); continue; - - case OP_SAFE_C_FF: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_C_FF: sc->value = fx_c_ff(sc, sc->code); continue; - - case OP_SAFE_C_P: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_P: op_safe_c_p(sc); goto EVAL; - case OP_SAFE_C_P_1: op_safe_c_p_1(sc); continue; - - case OP_ANY_C_NP: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_C_NP: if (op_any_c_np(sc)) goto EVAL; continue; - case OP_ANY_C_NP_1: if (inline_op_any_c_np_1(sc)) goto EVAL; continue; - case OP_ANY_C_NP_2: op_any_c_np_2(sc); continue; - case OP_ANY_C_NP_MV: if (op_any_c_np_mv(sc)) goto EVAL; goto APPLY; - - case OP_SAFE_C_SSP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSP: op_safe_c_ssp(sc); goto EVAL; - case OP_SAFE_C_SSP_1: op_safe_c_ssp_1(sc); continue; - case OP_SAFE_C_SSP_MV: op_safe_c_ssp_mv(sc); goto APPLY; - - case OP_SAFE_C_A: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_C_A: sc->value = fx_c_a(sc, sc->code); continue; - - case OP_SAFE_C_opAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAq: sc->value = fx_c_opaq(sc, sc->code); continue; - - case OP_SAFE_C_opAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAAq: sc->value = fx_c_opaaq(sc, sc->code); continue; - - case OP_SAFE_C_opAAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAAAq: sc->value = fx_c_opaaaq(sc, sc->code); continue; - - case OP_SAFE_C_S_opAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_opAq: sc->value = fx_c_s_opaq(sc, sc->code); continue; - - case OP_SAFE_C_opAq_S: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAq_S: sc->value = fx_c_opaq_s(sc, sc->code); continue; - - case OP_SAFE_C_S_opAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_opAAq: sc->value = fx_c_s_opaaq(sc, sc->code); continue; - - case OP_SAFE_C_AA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); continue; - - case OP_SAFE_C_SA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_SA: sc->value = fx_c_sa(sc, sc->code); continue; - - case OP_SAFE_C_AS: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_AS: sc->value = fx_c_as(sc, sc->code); continue; - - case OP_SAFE_C_CA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_CA: sc->value = fx_c_ca(sc, sc->code); continue; - - case OP_SAFE_C_AC: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_AC: sc->value = fx_c_ac(sc, sc->code); continue; - - case OP_SAFE_C_AAA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AAA: sc->value = fx_c_aaa(sc, sc->code); continue; - - case OP_SAFE_C_SAA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SAA: sc->value = fx_c_saa(sc, sc->code); continue; - - case OP_SAFE_C_SSA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSA: sc->value = fx_c_ssa(sc, sc->code); continue; - case HOP_HASH_TABLE_INCREMENT: sc->value = fx_hash_table_increment(sc, sc->code); continue; /* a placeholder, almost never called */ - - case OP_SAFE_C_SAS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SAS: sc->value = fx_c_sas(sc, sc->code); continue; - - case OP_SAFE_C_ASS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_ASS: sc->value = fx_c_ass(sc, sc->code); continue; - - case OP_SAFE_C_AGG: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AGG: sc->value = fx_c_agg(sc, sc->code); continue; - - case OP_SAFE_C_CAC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CAC: sc->value = fx_c_cac(sc, sc->code); continue; - - case OP_SAFE_C_CSA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSA: sc->value = fx_c_csa(sc, sc->code); continue; - - case OP_SAFE_C_SCA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCA: sc->value = fx_c_sca(sc, sc->code); continue; - - case OP_SAFE_C_4A: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_4A: sc->value = fx_c_4a(sc, sc->code); continue; - - case OP_SAFE_C_NA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_NA: sc->value = fx_c_na(sc, sc->code); continue; - - case OP_SAFE_C_ALL_CA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_ALL_CA: sc->value = fx_c_all_ca(sc, sc->code); continue; - - case OP_SAFE_C_SCS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCS: sc->value = fx_c_scs(sc, sc->code); continue; - - case OP_SAFE_C_SSC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSC: sc->value = fx_c_ssc(sc, sc->code); continue; - - case OP_SAFE_C_SCC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCC: sc->value = fx_c_scc(sc, sc->code); continue; - - case OP_SAFE_C_CSC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSC: sc->value = fx_c_csc(sc, sc->code); continue; - - case OP_SAFE_C_CCS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CCS: sc->value = fx_c_ccs(sc, sc->code); continue; - - case OP_SAFE_C_CSS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSS: sc->value = fx_c_css(sc, sc->code); continue; - - case OP_SAFE_C_SSS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSS: sc->value = fx_c_sss(sc, sc->code); continue; - - case OP_SAFE_C_opNCq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opNCq: sc->value = fx_c_opncq(sc, sc->code); continue; - - case OP_SAFE_C_opSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq: sc->value = fx_c_opsq(sc, sc->code); continue; - - case OP_SAFE_C_op_opSqq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; - case HOP_SAFE_C_op_opSqq: sc->value = fx_c_op_opsqq(sc, sc->code); continue; /* lg cb (splits to not) */ - - case OP_SAFE_C_op_S_opSqq: if (!c_function_is_ok_cadr_caddadr(sc, sc->code)) break; - case HOP_SAFE_C_op_S_opSqq: sc->value = fx_c_op_s_opsqq(sc, sc->code); continue; /* tlet sg (splits to not) */ - - case OP_SAFE_C_op_opSq_Sq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; - case HOP_SAFE_C_op_opSq_Sq: sc->value = fx_c_op_opsq_sq(sc, sc->code); continue; /* lg cb (splits to not etc) */ - - case OP_SAFE_C_PS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PS: op_safe_c_ps(sc); goto EVAL; - case OP_SAFE_C_PS_1: op_safe_c_ps_1(sc); continue; - case OP_SAFE_C_PS_MV: op_safe_c_ps_mv(sc); goto APPLY; - - case OP_SAFE_C_PC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PC: op_safe_c_pc(sc); goto EVAL; - case OP_SAFE_C_PC_1: op_safe_c_pc_1(sc); continue; - case OP_SAFE_C_PC_MV: op_safe_c_pc_mv(sc); goto APPLY; - - case OP_SAFE_C_SP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SP: op_safe_c_sp(sc); goto EVAL; - case OP_SAFE_C_SP_1: op_safe_c_sp_1(sc); continue; - case OP_SAFE_C_SP_MV: op_safe_c_sp_mv(sc); goto APPLY; - - case OP_SAFE_CONS_SP_1: sc->value = cons(sc, sc->args, sc->value); continue; - case OP_SAFE_ADD_SP_1: op_safe_add_sp_1(sc); continue; - case OP_SAFE_MULTIPLY_SP_1: op_safe_multiply_sp_1(sc); continue; - - case OP_SAFE_C_AP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AP: if (op_safe_c_ap(sc)) goto EVAL; continue; - - case OP_SAFE_C_PA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PA: if (op_safe_c_pa(sc)) goto EVAL; continue; - case OP_SAFE_C_PA_1: op_safe_c_pa_1(sc); continue; - case OP_SAFE_C_PA_MV: op_safe_c_pa_mv(sc); goto APPLY; - - case OP_SAFE_C_CP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CP: op_safe_c_cp(sc); goto EVAL; - - case OP_SAFE_C_PP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PP: op_safe_c_pp(sc); goto EVAL; - case OP_SAFE_C_PP_1: op_safe_c_pp_1(sc); goto EVAL; - case OP_SAFE_C_PP_3_MV: op_safe_c_pp_3_mv(sc); goto EVAL; - case OP_SAFE_C_PP_5: op_safe_c_pp_5(sc); goto APPLY; - case OP_SAFE_C_PP_6_MV: op_safe_c_pp_6_mv(sc); goto APPLY; - - case OP_SAFE_C_3P: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_3P: op_safe_c_3p(sc); goto EVAL; - case OP_SAFE_C_3P_1: op_safe_c_3p_1(sc); goto EVAL; - case OP_SAFE_C_3P_2: op_safe_c_3p_2(sc); goto EVAL; - case OP_SAFE_C_3P_3: op_safe_c_3p_3(sc); continue; - case OP_SAFE_C_3P_1_MV: op_safe_c_3p_1_mv(sc); goto EVAL; - case OP_SAFE_C_3P_2_MV: op_safe_c_3p_2_mv(sc); goto EVAL; - case OP_SAFE_C_3P_3_MV: op_safe_c_3p_3_mv(sc); goto APPLY; - - case OP_SAFE_C_opSSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq: sc->value = fx_c_opssq(sc, sc->code); continue; - - case OP_SAFE_C_opSCq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSCq: sc->value = fx_c_opscq(sc, sc->code); continue; - - case OP_SAFE_C_opCSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq: sc->value = fx_c_opcsq(sc, sc->code); continue; - - case OP_SAFE_C_S_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSq: sc->value = fx_c_s_opsq(sc, sc->code); continue; - - case OP_SAFE_C_C_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSq: sc->value = fx_c_c_opsq(sc, sc->code); continue; - - case OP_SAFE_C_C_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSSq: sc->value = fx_c_c_opssq(sc, sc->code); continue; - - case OP_SAFE_C_opCSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq_C: sc->value = fx_c_opcsq_c(sc, sc->code); continue; - - case OP_SAFE_C_opSSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_C: sc->value = fx_c_opssq_c(sc, sc->code); continue; - - case OP_SAFE_C_opSSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_S: sc->value = fx_c_opssq_s(sc, sc->code); continue; - - case OP_SAFE_C_op_opSSqq_S: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; - case HOP_SAFE_C_op_opSSqq_S: sc->value = fx_c_op_opssqq_s(sc, sc->code); continue; - - case OP_SAFE_C_opSCq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSCq_C: sc->value = fx_c_opscq_c(sc, sc->code); continue; - - case OP_SAFE_C_opCSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq_S: sc->value = fx_c_opcsq_s(sc, sc->code); continue; - - case OP_SAFE_C_S_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSCq: sc->value = fx_c_s_opscq(sc, sc->code); continue; - - case OP_SAFE_C_C_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSCq: sc->value = fx_c_c_opscq(sc, sc->code); continue; - - case OP_SAFE_C_S_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSSq: sc->value = fx_c_s_opssq(sc, sc->code); continue; - - case OP_SAFE_C_S_opCSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opCSq: sc->value = fx_c_s_opcsq(sc, sc->code); continue; - - case OP_SAFE_C_opSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_S: sc->value = fx_c_opsq_s(sc, sc->code); continue; - - case OP_SAFE_C_opSq_CS: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_CS: sc->value = fx_c_opsq_cs(sc, sc->code); continue; - - case OP_SAFE_C_opSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_C: sc->value = fx_c_opsq_c(sc, sc->code); continue; - - case OP_SAFE_C_opSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_opSq: sc->value = fx_c_opsq_opsq(sc, sc->code); continue; - - case OP_SAFE_C_opSSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_opSSq: sc->value = fx_c_opssq_opssq(sc, sc->code); continue; - - case OP_SAFE_C_opSSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_opSq: sc->value = fx_c_opssq_opsq(sc, sc->code); continue; - - case OP_SAFE_C_opSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_opSSq: sc->value = fx_c_opsq_opssq(sc, sc->code); continue; - - - /* semisafe c_functions */ - case OP_CL_S: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_S: inline_op_safe_c_s(sc); continue; - - case OP_CL_SS: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_SS: inline_op_safe_c_ss(sc); continue; /* safe_c case has the code we want */ - - case OP_CL_A: if (!cl_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} - case HOP_CL_A: op_cl_a(sc); continue; - - case OP_CL_AA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_AA: op_cl_aa(sc); continue; - - case OP_CL_SAS: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_SAS: op_cl_sas(sc); continue; - - case OP_CL_NA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_NA: op_cl_na(sc); continue; - - case OP_CL_FA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_FA: op_cl_fa(sc); continue; /* op_c_fs was not faster if fx_s below */ - case OP_MAP_FOR_EACH_FA: op_map_for_each_fa(sc); continue; /* here only if for-each or map + one seq */ - case OP_MAP_FOR_EACH_FAA: op_map_for_each_faa(sc); continue; /* here only if for-each or map + twp seqs */ - - - /* unsafe c_functions */ - case OP_C: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S); goto EVAL;} - case HOP_C: sc->value = fn_proc(sc->code)(sc, sc->nil); continue; - - case OP_C_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} - case HOP_C_S: op_c_s(sc); continue; - - case OP_READ_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} - case HOP_READ_S: op_read_s(sc); continue; - - case OP_C_A: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} - case HOP_C_A: op_c_a(sc); continue; - - case OP_C_P: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_P: op_c_p(sc); goto EVAL; - case OP_C_P_1: sc->value = fn_proc(sc->code)(sc, list_1(sc, sc->value)); continue; - case OP_C_P_MV: op_c_p_mv(sc); goto APPLY; - - case OP_C_SS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_SS: op_c_ss(sc); continue; - - case OP_C_AP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_AP: op_c_ap(sc); goto EVAL; - case OP_C_AP_1: sc->value = fn_proc(sc->code)(sc, sc->args = list_2(sc, sc->args, sc->value)); continue; - case OP_C_AP_MV: op_c_ap_mv(sc); goto APPLY; - - case OP_C_AA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_AA: op_c_aa(sc); continue; - - case OP_C_NA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_NA: op_c_na(sc); continue; - - case OP_APPLY_SS: inline_op_apply_ss(sc); goto APPLY; - case OP_APPLY_SA: op_apply_sa(sc); goto APPLY; - case OP_APPLY_SL: op_apply_sl(sc); goto APPLY; - - case OP_CALL_WITH_EXIT: op_call_with_exit(sc); goto BEGIN; - case OP_CALL_CC: op_call_cc(sc); goto BEGIN; - case OP_CALL_WITH_EXIT_O: op_call_with_exit_o(sc); goto EVAL; - case OP_C_CATCH: op_c_catch(sc); goto BEGIN; - case OP_C_CATCH_ALL: op_c_catch_all(sc); goto BEGIN; - case OP_C_CATCH_ALL_O: op_c_catch_all(sc); goto EVAL; - case OP_C_CATCH_ALL_A: op_c_catch_all_a(sc); continue; - - case OP_WITH_IO: if (op_with_io_op(sc)) goto EVAL; goto BEGIN; - case OP_WITH_IO_1: - if (!is_string(sc->value)) {op_with_io_1_method(sc); continue;} - sc->code = op_with_io_1(sc); - goto BEGIN; - - case OP_WITH_IO_C: sc->value = cadr(sc->code); sc->code = op_with_io_1(sc); goto BEGIN; - case OP_WITH_OUTPUT_TO_STRING: op_with_output_to_string(sc); goto BEGIN; - case OP_CALL_WITH_OUTPUT_STRING: op_call_with_output_string(sc); goto BEGIN; - - - case OP_F: op_f(sc); goto BEGIN; - case OP_F_A: op_f_a(sc); goto BEGIN; - case OP_F_AA: op_f_aa(sc); goto BEGIN; - case OP_F_NP: op_f_np(sc); goto EVAL; - case OP_F_NP_1: if (op_f_np_1(sc)) goto EVAL; goto BEGIN; - - case OP_S: op_s(sc); goto APPLY; - case OP_S_G: if (op_s_g(sc)) continue; goto APPLY; - case OP_S_A: if (op_x_a(sc, lookup_checked(sc, car(sc->code)))) continue; goto APPLY; - case OP_A_A: if (op_x_a(sc, fx_call(sc, sc->code))) continue; goto APPLY; - case OP_S_AA: op_x_aa(sc, lookup_checked(sc, car(sc->code))); goto APPLY; - case OP_A_AA: op_x_aa(sc, fx_call(sc, sc->code)); goto APPLY; - case OP_P_S: push_stack_no_args_direct(sc, OP_P_S_1); sc->code = car(sc->code); goto EVAL; - case OP_P_S_1: op_p_s_1(sc); goto APPLY; - - case OP_SAFE_C_STAR: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR: op_safe_c_star(sc); continue; - - case OP_SAFE_C_STAR_A: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_A: op_safe_c_star_a(sc); continue; - - case OP_SAFE_C_STAR_AA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_AA: op_safe_c_star_aa(sc); continue; - - case OP_SAFE_C_STAR_NA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_NA: op_safe_c_star_na(sc); continue; - - - case OP_THUNK: if (!closure_is_ok(sc, sc->code, FINE_UNSAFE_CLOSURE, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_THUNK: op_thunk(sc); goto EVAL; - - case OP_THUNK_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_THUNK_O: op_thunk_o(sc); goto EVAL; - - case OP_SAFE_THUNK: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_SAFE_THUNK: op_safe_thunk(sc); goto EVAL; - - case OP_THUNK_ANY: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break; /* symbol as arglist */ - case HOP_THUNK_ANY: op_thunk_any(sc); goto BEGIN; - - case OP_SAFE_THUNK_ANY: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break; /* symbol as arglist */ - case HOP_SAFE_THUNK_ANY: op_safe_thunk_any(sc); goto EVAL; - - case OP_SAFE_THUNK_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_SAFE_THUNK_A: sc->value = op_safe_thunk_a(sc, sc->code); continue; - - case OP_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_CLOSURE_S: op_closure_s(sc); goto EVAL; - - case OP_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_CLOSURE_S_O: op_closure_s_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S: op_safe_closure_s(sc); goto EVAL; - - case OP_SAFE_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_O: op_safe_closure_s_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_A: sc->value = op_safe_closure_s_a(sc, sc->code); continue; - - case OP_SAFE_CLOSURE_S_TO_S: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_TO_S: sc->value = fx_safe_closure_s_to_s(sc, sc->code); continue; - - case OP_SAFE_CLOSURE_S_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_TO_SC: sc->value = fx_proc(cdr(sc->code))(sc, sc->code); continue; - - case OP_SAFE_CLOSURE_A_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A_TO_SC: sc->value = fx_proc(sc->code)(sc, sc->code); continue; - - case OP_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_CLOSURE_P: op_closure_p(sc); goto EVAL; - case OP_CLOSURE_P_1: op_closure_p_1(sc); goto BEGIN; - - case OP_SAFE_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_P: op_safe_closure_p(sc); goto EVAL; - case OP_SAFE_CLOSURE_P_1: op_safe_closure_p_1(sc); goto BEGIN; - - case OP_SAFE_CLOSURE_P_A: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_P_A: op_safe_closure_p_a(sc); goto EVAL; - case OP_SAFE_CLOSURE_P_A_1: op_safe_closure_p_a_1(sc); continue; - - case OP_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_CLOSURE_A: inline_op_closure_a(sc); push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); sc->code = car(sc->code); goto EVAL; - - case OP_CLOSURE_A_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_CLOSURE_A_O: inline_op_closure_a(sc); sc->code = car(sc->code); goto EVAL; - - case OP_SAFE_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A: op_safe_closure_a(sc); goto EVAL; - - case OP_SAFE_CLOSURE_A_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A_O: op_safe_closure_a_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_A_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A_A: sc->value = op_safe_closure_a_a(sc, sc->code); continue; - - case OP_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AP: op_closure_ap(sc); goto EVAL; - case OP_CLOSURE_AP_1: op_closure_ap_1(sc); goto BEGIN; - - case OP_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_CLOSURE_PA: op_closure_pa(sc); goto EVAL; - case OP_CLOSURE_PA_1: op_closure_pa_1(sc); goto BEGIN; - - case OP_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_CLOSURE_PP: op_closure_pp(sc); goto EVAL; - case OP_CLOSURE_PP_1: op_closure_pp_1(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AP: op_safe_closure_ap(sc); goto EVAL; - case OP_SAFE_CLOSURE_AP_1: op_safe_closure_ap_1(sc); goto BEGIN; - - case OP_SAFE_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_PA: op_safe_closure_pa(sc); goto EVAL; - case OP_SAFE_CLOSURE_PA_1: op_safe_closure_pa_1(sc); goto BEGIN; - - case OP_SAFE_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_PP: op_safe_closure_pp(sc); goto EVAL; - case OP_SAFE_CLOSURE_PP_1: op_safe_closure_pp_1(sc); goto EVAL; - - case OP_ANY_CLOSURE_3P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_CLOSURE_3P: op_any_closure_3p(sc); goto EVAL; - case OP_ANY_CLOSURE_3P_1: if (!op_any_closure_3p_1(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_3P_2: if (!op_any_closure_3p_2(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_3P_3: op_any_closure_3p_3(sc); goto BEGIN; - - case OP_ANY_CLOSURE_4P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 4)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_CLOSURE_4P: op_any_closure_4p(sc); goto EVAL; - case OP_ANY_CLOSURE_4P_1: if (!op_any_closure_4p_1(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_4P_2: if (!op_any_closure_4p_2(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_4P_3: if (!op_any_closure_4p_3(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_4P_4: op_any_closure_4p_4(sc); goto BEGIN; - - case OP_CLOSURE_FA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) break; - case HOP_CLOSURE_FA: op_closure_fa(sc); goto EVAL; - - case OP_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SS: op_closure_ss(sc); goto EVAL; - - case OP_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SS_O: op_closure_ss_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SS: op_safe_closure_ss(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SS_O: op_safe_closure_ss_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SS_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SS_A: sc->value = op_safe_closure_ss_a(sc, sc->code); continue; - - case OP_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_3S: op_closure_3s(sc); goto EVAL; /* "fine" here means changing func (as arg) does not constantly call op_unknown_ns */ - - case OP_CLOSURE_3S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_3S_O: op_closure_3s_o(sc); goto EVAL; - - case OP_CLOSURE_4S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_4S: op_closure_4s(sc); goto EVAL; - - case OP_CLOSURE_4S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 4)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_4S_O: op_closure_4s_o(sc); goto EVAL; - - case OP_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SC: op_closure_sc(sc); goto EVAL; - - case OP_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SC_O: op_closure_sc_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SC: op_safe_closure_sc(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SC_O: op_safe_closure_sc_o(sc); goto EVAL; - - case OP_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AA: op_closure_aa(sc); goto EVAL; - - case OP_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AA_O: inline_op_closure_aa_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AA: op_safe_closure_aa(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AA_O: op_safe_closure_aa_o(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AA_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AA_A: sc->value = fx_safe_closure_aa_a(sc, sc->code); continue; - - case OP_SAFE_CLOSURE_SSA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SSA: op_safe_closure_ssa(sc); goto EVAL; - - case OP_SAFE_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SAA: op_safe_closure_saa(sc); goto EVAL; - - case OP_SAFE_CLOSURE_AGG: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AGG: op_safe_closure_agg(sc); goto EVAL; - - case OP_SAFE_CLOSURE_3A: if (!closure_is_ok(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_3A: op_safe_closure_3a(sc); goto EVAL; - - case OP_SAFE_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_NS: op_safe_closure_ns(sc); goto EVAL; - - case OP_SAFE_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_NA: op_safe_closure_na(sc); goto EVAL; - - case OP_SAFE_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_3S: op_safe_closure_3s(sc); goto EVAL; - - case OP_SAFE_CLOSURE_3S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_3S_A: sc->value = op_safe_closure_3s_a(sc, sc->code); continue; - - case OP_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_NS: op_closure_ns(sc); goto EVAL; - - case OP_CLOSURE_ASS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_ASS: op_closure_ass(sc); goto EVAL; - - case OP_CLOSURE_AAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AAS: op_closure_aas(sc); goto EVAL; - - case OP_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SAA: op_closure_saa(sc); goto EVAL; - - case OP_CLOSURE_ASA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_ASA: op_closure_asa(sc); goto EVAL; - - case OP_CLOSURE_SAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SAS: op_closure_sas(sc); goto EVAL; - - case OP_CLOSURE_3A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_3A: op_closure_3a(sc); goto EVAL; - - case OP_CLOSURE_4A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_4A: op_closure_4a(sc); goto EVAL; - - case OP_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_NA: op_closure_na(sc); goto EVAL; - - case OP_ANY_CLOSURE_NP: if (!closure_np_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_CLOSURE_NP: op_any_closure_np(sc); goto EVAL; - case OP_ANY_CLOSURE_NP_1: - if (!(inline_collect_np_args(sc, OP_ANY_CLOSURE_NP_1, cons(sc, sc->value, sc->args)))) - op_any_closure_np_end(sc); - goto EVAL; - case OP_ANY_CLOSURE_NP_2: - sc->args = cons(sc, sc->value, sc->args); - op_any_closure_np_end(sc); - goto EVAL; - case OP_ANY_CLOSURE_NP_MV: /* this is an error -- a values call confusing the optimizer's arg count */ - if (!(collect_np_args(sc, OP_ANY_CLOSURE_NP_MV, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args)))) - op_any_closure_np_end(sc); - goto EVAL; - - case OP_ANY_CLOSURE_SYM: if (!check_closure_sym(sc, 1)) break; /* (lambda args ...) */ - case HOP_ANY_CLOSURE_SYM: op_any_closure_sym(sc); goto BEGIN; - case OP_ANY_CLOSURE_A_SYM: if (!check_closure_sym(sc, 2)) break; /* (lambda (a . args) ...) */ - case HOP_ANY_CLOSURE_A_SYM: op_any_closure_a_sym(sc); goto BEGIN; - - - case OP_TC_AND_A_OR_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_la(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_LAA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_laa(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LAA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_laa(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_L3A: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_l3a(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_L3A: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_l3a(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_A_L3A: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_l3a(sc, sc->code); continue; - - case OP_TC_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, false)) continue; goto EVAL; - case OP_TC_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, false)) continue; goto EVAL; - case OP_TC_COND_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, true)) continue; goto EVAL; - case OP_TC_COND_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, true)) continue; goto EVAL; - - case OP_TC_IF_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_IF)) continue; goto EVAL; - case OP_TC_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_IF)) continue; goto EVAL; - case OP_TC_COND_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_COND)) continue; goto EVAL; - case OP_TC_COND_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_COND)) continue; goto EVAL; - case OP_TC_WHEN_LA: tick_tc(sc, sc->cur_op); op_tc_when_la(sc, sc->code); continue; - case OP_TC_WHEN_LAA: tick_tc(sc, sc->cur_op); op_tc_when_laa(sc, sc->code); continue; - case OP_TC_WHEN_L3A: tick_tc(sc, sc->cur_op); op_tc_when_l3a(sc, sc->code); continue; - - case OP_TC_IF_A_Z_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL; - case OP_TC_IF_A_L3A_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, false)) continue; goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_IF)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_IF)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_COND)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_COND))continue; goto EVAL; - case OP_TC_AND_A_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_AND)) continue; goto EVAL; - case OP_TC_AND_A_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_AND)) continue; goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_laa(sc, false, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, false, sc->code)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_laa(sc, true, sc->code)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, true, sc->code)) continue; goto EVAL; - - case OP_TC_LET_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_la(sc, sc->code)) continue; goto EVAL; - case OP_TC_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_LET_WHEN_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, true, sc->code); continue; - case OP_TC_LET_UNLESS_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, false, sc->code); continue; - - case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc(sc, sc->cur_op); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_L3A_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_l3a_l3a(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_CASE_LA: tick_tc(sc, sc->cur_op); if (op_tc_case_la(sc, sc->code)) continue; goto BEGIN; - case OP_TC_LET_COND: tick_tc(sc, sc->cur_op); if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; - - case OP_RECUR_IF_A_A_opA_LAq: wrap_recur_if_a_a_opa_laq(sc, true, true); continue; - case OP_RECUR_IF_A_A_opLA_Aq: wrap_recur_if_a_a_opa_laq(sc, true, false); continue; - case OP_RECUR_IF_A_opA_LAq_A: wrap_recur_if_a_a_opa_laq(sc, false, true); continue; - case OP_RECUR_IF_A_opLA_Aq_A: wrap_recur_if_a_a_opa_laq(sc, false, false); continue; - case OP_RECUR_IF_A_A_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_opa_laaq); continue; - case OP_RECUR_IF_A_A_opA_L3Aq: wrap_recur(sc, op_recur_if_a_a_opa_l3aq); continue; - case OP_RECUR_IF_A_opA_LAAq_A: wrap_recur(sc, op_recur_if_a_opa_laaq_a); continue; - case OP_RECUR_IF_A_A_opLA_LAq: wrap_recur_if_a_a_opla_laq(sc, true); continue; - case OP_RECUR_IF_A_opLA_LAq_A: wrap_recur_if_a_a_opla_laq(sc, false); continue; - case OP_RECUR_IF_A_A_opA_LA_LAq: wrap_recur(sc, op_recur_if_a_a_opa_la_laq); continue; - case OP_RECUR_IF_A_opA_LA_LAq_A: wrap_recur(sc, op_recur_if_a_opa_la_laq_a); continue; - case OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq: wrap_recur(sc, op_recur_if_a_a_lopl3a_l3a_l3aq); continue; - case OP_RECUR_IF_A_A_AND_A_LAA_LAA: wrap_recur(sc, op_recur_if_a_a_and_a_laa_laa); continue; - case OP_RECUR_IF_A_A_opLA_LA_LAq: wrap_recur(sc, op_recur_if_a_a_opla_la_laq); continue; - case OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_if_a_laa_opa_laaq); continue; - case OP_RECUR_IF_A_A_IF_A_A_opLA_LAq: wrap_recur(sc, op_recur_if_a_a_if_a_a_opla_laq); continue; - case OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_if_a_a_if_a_a_oplaa_laaq); continue; - case OP_RECUR_COND_A_A_opA_LAq: wrap_recur(sc, op_recur_cond_a_a_opa_laq); continue; - case OP_RECUR_COND_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_opa_laaq); continue; - case OP_RECUR_COND_A_A_A_A_opLA_LAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opla_laq); continue; - case OP_RECUR_COND_A_A_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opa_laaq); continue; - case OP_RECUR_COND_A_A_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_oplaa_laaq); continue; - case OP_RECUR_COND_A_A_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_laa_opa_laaq); continue; - case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq: wrap_recur_cond_a_a_a_laa_lopa_laaq(sc); continue; - case OP_RECUR_AND_A_OR_A_LAA_LAA: wrap_recur(sc, op_recur_and_a_or_a_laa_laa); continue; - - - case OP_SAFE_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_A: op_safe_closure_star_a(sc, sc->code); goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_A1: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_A1: op_safe_closure_star_a1(sc, sc->code); goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_KA: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_KA: op_safe_closure_star_ka(sc, sc->code); goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_AA: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_AA: op_safe_closure_star_aa(sc, sc->code); goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_AA_O: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_AA_O: op_safe_closure_star_aa(sc, sc->code); sc->code = car(sc->code); goto EVAL; - - case OP_SAFE_CLOSURE_STAR_3A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_3A: if (op_safe_closure_star_aaa(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA: - if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? opt3_arglen(cdr(sc->code)) : 0)) - {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA: if (op_safe_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA_0: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA_0: if (op_safe_closure_star_na_0(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA_1: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA_1: if (op_safe_closure_star_na_1(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA_2: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA_2: if (op_safe_closure_star_na_2(sc, sc->code)) goto EVAL; goto BEGIN; - - - case OP_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_CLOSURE_STAR_A: op_closure_star_a(sc, sc->code); goto BEGIN; - - case OP_CLOSURE_STAR_KA: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_CLOSURE_STAR_KA: op_closure_star_ka(sc, sc->code); goto BEGIN; - - case OP_CLOSURE_STAR_NA: - if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? opt3_arglen(cdr(sc->code)) : 0)) - {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_STAR_NA: if (op_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; - - - case OP_UNKNOWN: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown(sc)) goto EVAL; continue; - case OP_UNKNOWN_NS: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_ns(sc)) goto EVAL; continue; - case OP_UNKNOWN_S: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_s(sc)) goto EVAL; continue; - case OP_UNKNOWN_GG: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_gg(sc)) goto EVAL; continue; - case OP_UNKNOWN_A: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_a(sc)) goto EVAL; continue; - case OP_UNKNOWN_AA: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_aa(sc)) goto EVAL; continue; - case OP_UNKNOWN_NA: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_na(sc)) goto EVAL; continue; - case OP_UNKNOWN_NP: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_np(sc)) goto EVAL; continue; - - - case OP_IMPLICIT_VECTOR_REF_A: if (!inline_op_implicit_vector_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_VECTOR_REF_AA: if (!op_implicit_vector_ref_aa(sc)) {if (op_unknown_aa(sc)) goto EVAL;} continue; - case OP_IMPLICIT_STRING_REF_A: if (!op_implicit_string_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_HASH_TABLE_REF_A: if (!op_implicit_hash_table_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_HASH_TABLE_REF_AA: if (!op_implicit_hash_table_ref_aa(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_CONTINUATION_A: if (!op_implicit_continuation_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_ITERATE: if (!op_implicit_iterate(sc)) {if (op_unknown(sc)) goto EVAL;} continue; - case OP_IMPLICIT_LET_REF_C: if (!op_implicit_let_ref_c(sc)) {if ((has_fx(cdr(sc->code))) && (op_unknown_a(sc))) goto EVAL;} continue; - case OP_IMPLICIT_LET_REF_A: if (!op_implicit_let_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_PAIR_REF_A: if (!op_implicit_pair_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_PAIR_REF_AA: if (!op_implicit_pair_ref_aa(sc)) {if (op_unknown_aa(sc)) goto EVAL;} continue; - case OP_IMPLICIT_C_OBJECT_REF_A: if (!op_implicit_c_object_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_GOTO: if (!op_implicit_goto(sc)) {if (op_unknown(sc)) goto EVAL;} continue; - case OP_IMPLICIT_GOTO_A: if (!op_implicit_goto_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_VECTOR_SET_3: if (op_implicit_vector_set_3(sc)) goto EVAL; continue; - case OP_IMPLICIT_VECTOR_SET_4: if (op_implicit_vector_set_4(sc)) goto EVAL; continue; - case OP_IMPLICIT_S7_STARLET_REF_S: sc->value = s7_starlet(sc, opt3_int(sc->code)); continue; - case OP_IMPLICIT_S7_STARLET_SET: - sc->value = s7_starlet_set_1(sc, opt3_sym(sc->code), fx_call(sc, cddr(sc->code))); - continue; - - case OP_UNOPT: goto UNOPT; - case OP_SYMBOL: sc->value = lookup_checked(sc, sc->code); continue; - case OP_CONSTANT: sc->value = sc->code; continue; - case OP_PAIR_PAIR: if (op_pair_pair(sc)) goto EVAL; continue; /* car is pair ((if x car cadr) ...) */ - case OP_PAIR_ANY: sc->value = car(sc->code); goto EVAL_ARGS_TOP; - case OP_PAIR_SYM: if (op_pair_sym(sc)) goto EVAL_ARGS_TOP; continue; - - case OP_EVAL_ARGS1: sc->args = cons(sc, sc->value, sc->args); goto EVAL_ARGS; - case OP_EVAL_ARGS2: op_eval_args2(sc); goto APPLY; /* sc->value is the last arg, [so if is_null(cdr(sc->code) and current is pair, push args2] */ - case OP_EVAL_ARGS3: op_eval_args3(sc); goto APPLY; /* sc->value is the next-to-last arg, and the last arg is not a list (so values can't mess us up!) */ - case OP_EVAL_ARGS4: sc->args = cons(sc, sc->value, sc->args); goto EVAL_ARGS_PAIR; - case OP_EVAL_ARGS5: op_eval_args5(sc); goto APPLY; - - EVAL_ARGS_TOP: - case OP_EVAL_ARGS: - if (dont_eval_args(sc->value)) - { - if (eval_args_no_eval_args(sc)) goto APPLY; - goto TOP_NO_POP; - } - sc->code = cdr(sc->code); - /* sc->value is the func (but can be anything if the code is messed up: (#\a 3)) - * we don't have to delay lookup of the func because arg evaluation order is not specified, so - * (let ((func +)) (func (let () (set! func -) 3) 2)) - * can return 5. - */ - push_op_stack(sc, sc->value); - if (sc->op_stack_now >= sc->op_stack_end) - resize_op_stack(sc); - sc->args = sc->nil; - - EVAL_ARGS: /* first time, value = op, args = nil, code is args */ - if (is_pair(sc->code)) /* evaluate current arg -- must check for pair here, not sc->nil (improper list as args) */ - { - if ((sc->safety > NO_SAFETY) && - (!is_safety_checked(sc->code))) - { - if (tree_is_cyclic(sc, sc->code)) - syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, sc->code); - set_safety_checked(sc->code); - } - EVAL_ARGS_PAIR: - if (is_pair(car(sc->code))) - { - eval_args_pair_car(sc); - goto EVAL; - } - if (is_pair(cdr(sc->code))) - { - s7_pointer car_code = car(sc->code); /* not a pair */ - sc->code = cdr(sc->code); - sc->value = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : T_Ext(car_code); - /* sc->value is the current arg's value, sc->code is pointing to the next */ - - /* cdr(sc->code) might not be a pair or nil here! (eq? #f . 1) -> sc->code is 1 */ - if (is_null(cdr(sc->code))) - { - if (eval_args_last_arg(sc)) goto EVAL; - /* drop into APPLY */ - } - else - { - /* here we know sc->code is a pair, cdr(sc->code) is not null, sc->value is the previous arg's value */ - sc->args = cons(sc, sc->value, sc->args); - goto EVAL_ARGS_PAIR; - }} - else eval_last_arg(sc, car(sc->code)); - /* drop into APPLY */ - } - else /* got all args -- go to apply */ - { - /* *(--sc->op_stack_now) is the "function" (sc->value perhaps), sc->code is the arglist end, sc->args might be the preceding args reversed? */ - if (is_not_null(sc->code)) - improper_arglist_error_nr(sc); - sc->code = pop_op_stack(sc); - sc->args = proper_list_reverse_in_place(sc, sc->args); - } - /* turning this into a call on an array of functions was not a complete disaster, but tauto.scm was ~1.5% slower. - * the array-index overhead is the same as the current switch statement's, but there was also the boolean+jump overhead, - * and the function-local overhead currently otherwise 0 if inlined. - */ - APPLY: - case OP_APPLY: - if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s[%d]: op_apply %s (%s) to %s\n", __func__, __LINE__, - display_80(sc->code), s7_type_names[type(sc->code)], display_80(sc->args))); - switch (type(sc->code)) - { - case T_C_FUNCTION: sc->value = apply_c_function(sc, sc->code, sc->args); continue; - case T_C_RST_NO_REQ_FUNCTION: apply_c_rst_no_req_function(sc); continue; - case T_C_FUNCTION_STAR: apply_c_function_star(sc); continue; - case T_CONTINUATION: call_with_current_continuation(sc); continue; - case T_GOTO: call_with_exit(sc); continue; - case T_C_OBJECT: apply_c_object(sc); continue; - case T_STRING: apply_string(sc); continue; - case T_HASH_TABLE: apply_hash_table(sc); continue; - case T_ITERATOR: apply_iterator(sc); continue; - case T_LET: apply_let(sc); continue; - case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: - case T_VECTOR: apply_vector(sc); continue; - case T_SYNTAX: apply_syntax(sc); goto TOP_NO_POP; - case T_PAIR: if (apply_pair(sc)) continue; goto APPLY; - case T_CLOSURE: apply_closure(sc); goto APPLY_LAMBDA; - case T_CLOSURE_STAR: if (apply_closure_star(sc)) goto EVAL; goto BEGIN; - case T_C_MACRO: apply_c_macro(sc); goto EVAL; - case T_MACRO: apply_macro(sc); goto APPLY_LAMBDA; - case T_BACRO: apply_bacro(sc); goto APPLY_LAMBDA; - case T_MACRO_STAR: apply_macro_star(sc); goto BEGIN; - case T_BACRO_STAR: apply_bacro_star(sc); goto BEGIN; - default: apply_error_nr(sc, sc->code, sc->args); - } - - case OP_MACRO_STAR_D: if (op_macro_star_d(sc)) goto EVAL_ARGS_TOP; goto BEGIN; - case OP_MACRO_D: if (op_macro_d(sc, T_MACRO)) goto EVAL_ARGS_TOP; /* fall through presumably */ - - APPLY_LAMBDA: - case OP_APPLY_LAMBDA: - inline_apply_lambda(sc); - goto BEGIN; - - case OP_LAMBDA_STAR_DEFAULT: if (op_lambda_star_default(sc)) goto EVAL; goto BEGIN; - - case OP_MACROEXPAND_1: - switch (op_macroexpand_1(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} - case OP_MACROEXPAND: - switch (op_macroexpand(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} - - - HEAPSORT: if (op_heapsort(sc)) continue; if (sc->value != sc->F) goto APPLY; - case OP_SORT1: op_sort1(sc); goto APPLY; - case OP_SORT2: if (op_sort2(sc)) continue; goto HEAPSORT; - case OP_SORT: if (!op_sort(sc)) goto HEAPSORT; - case OP_SORT3: if (op_sort3(sc)) continue; goto HEAPSORT; - case OP_SORT_PAIR_END: sc->value = vector_into_list(sc, sc->value, car(sc->args)); continue; - case OP_SORT_VECTOR_END: sc->value = vector_into_fi_vector(sc->value, car(sc->args)); continue; - case OP_SORT_STRING_END: sc->value = vector_into_string(sc->value, car(sc->args)); continue; - -#if S7_DEBUGGING - case OP_MAP_UNWIND: /* this probably can't happen -- left on stack only if opt succeeds then func called */ - fprintf(stderr, "%s[%d]: op_map_unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); - sc->map_call_ctr--; - if (sc->map_call_ctr < 0) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} - continue; -#endif - case OP_MAP_GATHER: inline_op_map_gather(sc); - case OP_MAP: if (op_map(sc)) continue; goto APPLY; - - case OP_MAP_GATHER_1: inline_op_map_gather(sc); - case OP_MAP_1: if (op_map_1(sc)) continue; goto BEGIN; - - case OP_MAP_GATHER_2: - case OP_MAP_GATHER_3: inline_op_map_gather(sc); - case OP_MAP_2: if (op_map_2(sc)) continue; goto EVAL; - - case OP_FOR_EACH: if (op_for_each(sc)) continue; goto APPLY; - case OP_FOR_EACH_1: if (inline_op_for_each_1(sc)) continue; goto BEGIN; - - case OP_FOR_EACH_2: - case OP_FOR_EACH_3: if (inline_op_for_each_2(sc)) continue; goto EVAL; - - case OP_MEMBER_IF: - case OP_MEMBER_IF1: if (op_member_if(sc)) continue; goto APPLY; - - case OP_ASSOC_IF: - case OP_ASSOC_IF1: if (op_assoc_if(sc)) continue; goto APPLY; - - - case OP_SAFE_DOTIMES: /* gen form */ - SAFE_DOTIMES: /* check_do */ - switch (op_safe_dotimes(sc)) - { - case goto_safe_do_end_clauses: if (is_null(sc->code)) continue; goto DO_END_CODE; - case goto_do_end_clauses: goto DO_END_CLAUSES; - case goto_eval: goto EVAL; - case goto_top_no_pop: goto TOP_NO_POP; - default: goto BEGIN; - } - - case OP_SAFE_DO: - SAFE_DO: /* from check_do */ - switch (op_safe_do(sc)) /* mat */ - { - case goto_safe_do_end_clauses: - if (is_null(sc->code)) continue; /* multiple values (as test result) can't happen -- safe do loops involve counters by 1 to some integer end */ - goto DO_END_CODE; - case goto_do_unchecked: goto DO_UNCHECKED; - default: goto BEGIN; - } - - case OP_DOTIMES_P: - DOTIMES_P: /* from check_do */ - switch (op_dotimes_p(sc)) - { - case goto_do_end_clauses: goto DO_END_CLAUSES; - case goto_do_unchecked: goto DO_UNCHECKED; - default: goto EVAL; - } - - case OP_DOX: - DOX: /* from check_do */ - switch (op_dox(sc)) /* lg fft exit */ - { - case goto_do_end_clauses: goto DO_END_CLAUSES; - case goto_start: continue; - case goto_top_no_pop: goto TOP_NO_POP; /* includes dox_step_o */ - default: goto BEGIN; - } - - DO_NO_BODY: - case OP_DO_NO_BODY_NA_VARS: op_do_no_body_na_vars(sc); goto EVAL; - case OP_DO_NO_BODY_NA_VARS_STEP: if (op_do_no_body_na_vars_step(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_DO_NO_BODY_NA_VARS_STEP_1: if (op_do_no_body_na_vars_step_1(sc)) goto DO_END_CLAUSES; goto EVAL; - - case OP_DO_NO_VARS_NO_OPT: op_do_no_vars_no_opt(sc); /* fall through */ - case OP_DO_NO_VARS_NO_OPT_1: if (op_do_no_vars_no_opt_1(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DO_NO_VARS: if (op_do_no_vars(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_SAFE_DOTIMES_STEP_O: if (op_safe_dotimes_step_o(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_SAFE_DOTIMES_STEP: if (op_safe_dotimes_step(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_SAFE_DO_STEP: if (op_safe_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_SIMPLE_DO: if (op_simple_do(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_SIMPLE_DO_STEP: if (op_simple_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DOTIMES_STEP_O: if (op_dotimes_step_o(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_DOX_INIT: if (op_dox_init(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DOX_STEP: if (op_dox_step_1(sc)) goto DO_END_CLAUSES; op_dox_step(sc); goto BEGIN; - case OP_DOX_STEP_O: if (op_dox_step_1(sc)) goto DO_END_CLAUSES; op_dox_step_o(sc); goto EVAL; - case OP_DOX_NO_BODY: op_dox_no_body(sc); continue; - case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto DO_END_CLAUSES; - - case OP_DO_INIT: if (op_do_init(sc)) goto DO_END; goto EVAL; - - case OP_DO: - if (is_null(check_do(sc))) - switch (optimize_op(sc->code)) - { - case OP_DOX: goto DOX; - case OP_SAFE_DOTIMES: goto SAFE_DOTIMES; - case OP_DOTIMES_P: goto DOTIMES_P; - case OP_SAFE_DO: goto SAFE_DO; - case OP_DO_NO_BODY_NA_VARS: goto DO_NO_BODY; - case OP_DO_NO_VARS: if (op_do_no_vars(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DOX_NO_BODY: op_dox_no_body(sc); continue; - case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto DO_END_CLAUSES; - default: if (op_simple_do(sc)) goto DO_END_CLAUSES; goto BEGIN; - } - - case OP_DO_UNCHECKED: - op_do_unchecked(sc); - DO_UNCHECKED: - if (do_unchecked(sc)) goto EVAL; - - DO_END: - case OP_DO_END: - if (op_do_end(sc)) goto EVAL; - - case OP_DO_END1: - if (is_true(sc, sc->value)) - { - goto_t next = op_do_end_true(sc); - if (next == goto_start) continue; - if (next == goto_eval) goto EVAL; - goto FEED_TO; - } - else - { - goto_t next = op_do_end_false(sc); - if (next == goto_begin) goto BEGIN; - if (next == goto_do_end) goto DO_END; - /* fall through */ - } - - case OP_DO_STEP: if (op_do_step(sc)) goto DO_END; goto EVAL; - case OP_DO_STEP2: if (op_do_step2(sc)) goto DO_END; goto EVAL; - - DO_END_CLAUSES: - if (do_end_clauses(sc)) continue; - DO_END_CODE: - { - goto_t next = do_end_code(sc); - if (next == goto_eval) goto EVAL; - if (next == goto_start) continue; - goto FEED_TO; - } - - - case OP_BEGIN_UNCHECKED: - set_current_code(sc, sc->code); - sc->code = T_Pair(cdr(sc->code)); - goto BEGIN; - - case OP_BEGIN: - if (op_begin(sc, sc->code)) continue; - sc->code = T_Pair(cdr(sc->code)); - - case OP_BEGIN_HOOK: - if (sc->begin_hook) - { - /* call_begin_hook might clobber sc->code? via s7_eval_string probably yes */ - set_current_code(sc, sc->code); - if (call_begin_hook(sc)) - return(sc->F); - } - case OP_BEGIN_NO_HOOK: - goto BEGIN; - - case OP_BEGIN_2_UNCHECKED: - push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); - sc->code = cadr(sc->code); - goto EVAL; - - case OP_BEGIN_AA: sc->value = fx_begin_aa(sc, sc->code); continue; - case OP_BEGIN_NA: sc->value = fx_begin_na(sc, sc->code); continue; - - - case OP_EVAL: goto EVAL; - case OP_EVAL_STRING: op_eval_string(sc); goto EVAL; - - case OP_QUOTE: sc->value = check_quote(sc, sc->code); continue; - case OP_QUOTE_UNCHECKED: sc->value = cadr(sc->code); continue; - - case OP_DEFINE_FUNCHECKED: define_funchecked(sc); continue; - case OP_DEFINE_CONSTANT1: op_define_constant1(sc); continue; - - case OP_DEFINE_CONSTANT_UNCHECKED: - push_stack_no_args(sc, OP_DEFINE_CONSTANT1, cadr(sc->code)); - goto DEFCONS; - - case OP_DEFINE_CONSTANT: - if (op_define_constant(sc)) continue; - - case OP_DEFINE_STAR: case OP_DEFINE: - check_define(sc); - - DEFCONS: - case OP_DEFINE_STAR_UNCHECKED: - case OP_DEFINE_UNCHECKED: - if (op_define_unchecked(sc)) goto TOP_NO_POP; - - case OP_DEFINE1: if (op_define1(sc)) goto APPLY; - case OP_DEFINE_WITH_SETTER: op_define_with_setter(sc); continue; - - case OP_SET_opSq_A: if (op_set_opsq_a(sc)) goto APPLY; continue; - case OP_SET_opSAq_A: if (op_set_opsaq_a(sc)) goto APPLY; continue; - case OP_SET_opSAq_P: if (op_set_opsaq_p(sc)) goto APPLY; goto EVAL; - case OP_SET_opSAq_P_1: if (op_set_opsaq_p_1(sc)) goto APPLY; continue; - case OP_SET_opSAAq_A: if (op_set_opsaaq_a(sc)) goto APPLY; continue; - case OP_SET_opSAAq_P: if (op_set_opsaaq_p(sc)) goto APPLY; goto EVAL; - case OP_SET_opSAAq_P_1: if (op_set_opsaaq_p_1(sc)) goto APPLY; continue; - - case OP_INCREMENT_BY_1: inline_op_increment_by_1(sc); continue; - case OP_DECREMENT_BY_1: op_decrement_by_1(sc); continue; - case OP_INCREMENT_SA: op_increment_sa(sc); continue; - case OP_INCREMENT_SAA: op_increment_saa(sc); continue; - - case OP_SET_S_C: op_set_s_c(sc); continue; - case OP_SET_S_S: op_set_s_s(sc); continue; - case OP_SET_S_A: op_set_s_a(sc); continue; - case OP_SET_S_P: op_set_s_p(sc); goto EVAL; - case OP_SET_CONS: op_set_cons(sc); continue; - case OP_SET_SAFE: op_set_safe(sc); continue; - - case OP_SET_FROM_SETTER: slot_set_value(sc->code, sc->value); continue; /* mv caught in splice_in_values */ - case OP_SET_FROM_LET_TEMP: op_set_from_let_temp(sc); continue; - - case OP_SET2: - switch (op_set2(sc)) /* imp */ - { - case goto_eval: goto EVAL; - case goto_top_no_pop: goto TOP_NO_POP; - case goto_start: continue; - case goto_apply: goto APPLY; - case goto_unopt: goto UNOPT; - default: goto EVAL_ARGS; /* goto_eval_args in funcs called by op_set2, unopt */ - } - - case OP_SET: check_set(sc); - case OP_SET_UNCHECKED: - SET_UNCHECKED: - if (is_pair(cadr(sc->code))) /* has setter */ - switch (set_implicit(sc)) - { - case goto_top_no_pop: goto TOP_NO_POP; - case goto_start: continue; - case goto_apply: goto APPLY; - case goto_unopt: goto UNOPT; - default: goto EVAL_ARGS; /* very common, op_unopt at this point */ - } - case OP_SET_NORMAL: if (op_set_normal(sc)) goto EVAL; - case OP_SET1: if (op_set1(sc)) continue; goto APPLY; - - case OP_SET_WITH_LET_1: if (op_set_with_let_1(sc)) goto TOP_NO_POP; goto SET_WITH_LET; - case OP_SET_WITH_LET_2: if (op_set_with_let_2(sc)) continue; - SET_WITH_LET: - activate_with_let(sc, sc->value); /* this activates sc->value, so the set! will happen in that environment */ - if (is_pair(cadr(sc->code))) - switch (set_implicit(sc)) /* imp misc */ - { - case goto_top_no_pop: goto TOP_NO_POP; - case goto_start: continue; - case goto_apply: goto APPLY; - case goto_unopt: goto UNOPT; - default: goto EVAL_ARGS; /* unopt */ - } - error_nr(sc, sc->no_setter_symbol, - set_elist_3(sc, wrap_string(sc, "can't set ~A in ~S", 18), cadr(sc->code), - list_3(sc, sc->set_symbol, - (is_pair(cadr(sc->code))) ? copy_proper_list(sc, cadr(sc->code)) : cadr(sc->code), - (is_pair(caddr(sc->code))) ? copy_proper_list(sc, caddr(sc->code)) : caddr(sc->code)))); - - - case OP_IF: op_if(sc); goto EVAL; - case OP_IF_UNCHECKED: op_if_unchecked(sc); goto EVAL; - case OP_IF1: if (op_if1(sc)) goto EVAL; continue; - - #define if_a_p(sc) if (is_true(sc, fx_call(sc, cdr(sc->code)))) - #define if_not_a_p(sc) if (is_false(sc, fx_call(sc, opt3_pair(sc->code)))) /* cdadr(sc->code) */ - - case OP_IF_A_C_C: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? opt1_con(sc->code) : opt2_con(sc->code); continue; - case OP_IF_A_A: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; continue; - case OP_IF_S_A_A: sc->value = (is_true(sc, lookup(sc, cadr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_A_A_A: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_A_A_P: if_a_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_A_P_A: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_NOT_A_A: sc->value = (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? fx_call(sc, opt2_pair(sc->code)) : sc->unspecified; continue; - case OP_IF_NOT_A_A_A: sc->value = (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? fx_call(sc, opt2_pair(sc->code)) : fx_call(sc, opt3_pair(sc->code)); continue; - case OP_IF_AND2_S_A: sc->value = fx_if_and2_s_a(sc, sc->code); continue; - - #define call_bfunc(Sc, Expr) ((s7_bfunc)opt3_any(cdr(Sc->code)))(Sc, Expr) - case OP_IF_B_A: sc->value = (call_bfunc(sc, cadr(sc->code))) ? fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; continue; - case OP_IF_B_A_P: if (call_bfunc(sc, cadr(sc->code))) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_B_P_A: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_B_P_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_s_p(sc) if (is_true(sc, lookup(sc, cadr(sc->code)))) - #define if_not_s_p(sc) if (is_false(sc, lookup(sc, opt1_sym(cdr(sc->code))))) /* cadadr(sc->code) */ - - case OP_IF_S_P: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_S_R: if_s_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_S_P_P: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_S_N: if_not_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_S_N_N: if_not_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_S_P_A: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_S_A_P: if_s_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - - case OP_IF_A_P: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_A_R: if_a_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_A_P_P: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_A_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_A_N_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - case OP_IF_B_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_B_R: if (call_bfunc(sc, cadr(sc->code))) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_B_N_N: if (call_bfunc(sc, car(opt3_pair(sc->code)))) {sc->code = opt2_any(sc->code); goto EVAL;} sc->code = opt1_any(sc->code); goto EVAL; - - #define if_is_type_s_p(sc) if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) - #define if_is_not_type_s_p(sc) if (!gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) - - case OP_IF_IS_TYPE_S_P: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_IS_TYPE_S_R: if_is_type_s_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_IS_TYPE_S_P_P: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_IS_TYPE_S_N: if_is_not_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_IS_TYPE_S_N_N: if_is_not_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_IS_TYPE_S_A_A: if_is_type_s_p(sc) sc->value = fx_call(sc, opt1_pair(sc->code)); else sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_IS_TYPE_S_P_A: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_IS_TYPE_S_A_P: if_is_type_s_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_true(sc, fn_proc(cadr(sc->code))(sc, sc->t1_1))) - #define if_not_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_false(sc, fn_proc(opt1_pair(cdr(sc->code)))(sc, sc->t1_1))) /* cadadr */ - - case OP_IF_opSq_P: if_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_opSq_R: if_opsq_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_opSq_P_P: if_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_opSq_N: if_not_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_opSq_N_N: if_not_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_and2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - #define if_not_and2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - - case OP_IF_AND2_P: if_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND2_R: if_and2_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_AND2_P_P: if_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_AND2_N: if_not_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND2_N_N: if_not_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_or2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - #define if_not_or2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - - case OP_IF_OR2_P: if_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_OR2_R: if_or2_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_OR2_P_P: if_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_OR2_N: if_not_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_OR2_N_N: if_not_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_and3_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && \ - (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt1_pair(cdr(sc->code)))))) - #define if_not_and3_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || \ - (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt1_pair(cdr(sc->code)))))) - - case OP_IF_AND3_P: if_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND3_R: if_and3_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_AND3_P_P: if_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_AND3_N: if_not_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND3_N_N: if_not_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_p_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code));} while (0) - case OP_IF_P_P: if_p_push(OP_IF_PP); goto EVAL; - case OP_IF_P_N: if_p_push(OP_IF_PN); goto EVAL; - case OP_IF_P_P_P: if_p_push(OP_IF_PPP); goto EVAL; - case OP_IF_P_R: if_p_push(OP_IF_PR); goto EVAL; - case OP_IF_P_N_N: if_p_push(OP_IF_PRR); goto EVAL; - - #define if_bp_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code));} while (0) - case OP_IF_ANDP_P: if_bp_push(OP_IF_PP); goto AND_P; - case OP_IF_ANDP_R: if_bp_push(OP_IF_PR); goto AND_P; - case OP_IF_ANDP_P_P: if_bp_push(OP_IF_PPP); goto AND_P; - case OP_IF_ANDP_N: if_bp_push(OP_IF_PR); goto AND_P; - case OP_IF_ANDP_N_N: if_bp_push(OP_IF_PRR); goto AND_P; - - case OP_IF_ORP_P: if_bp_push(OP_IF_PP); goto OR_P; - case OP_IF_ORP_R: if_bp_push(OP_IF_PR); goto OR_P; - case OP_IF_ORP_P_P: if_bp_push(OP_IF_PPP); goto OR_P; - case OP_IF_ORP_N: if_bp_push(OP_IF_PR); goto OR_P; - case OP_IF_ORP_N_N: if_bp_push(OP_IF_PRR); goto OR_P; - - case OP_IF_PP: if (sc->value != sc->F) goto EVAL; sc->value = sc->unspecified; continue; - case OP_IF_PN: - case OP_IF_PR: if (sc->value == sc->F) goto EVAL; sc->value = sc->unspecified; continue; - case OP_IF_PPP: sc->code = (sc->value != sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; - case OP_IF_PRR: sc->code = (sc->value == sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; - - case OP_WHEN: check_when(sc); goto EVAL; - case OP_WHEN_S: if (op_when_s(sc)) continue; goto EVAL; - case OP_WHEN_A: if (op_when_a(sc)) continue; goto EVAL; - case OP_WHEN_P: op_when_p(sc); goto EVAL; - case OP_WHEN_AND_2A: if (op_when_and_2a(sc)) continue; goto EVAL; - case OP_WHEN_AND_3A: if (op_when_and_3a(sc)) continue; goto EVAL; - case OP_WHEN_AND_AP: if (op_when_and_ap(sc)) continue; goto EVAL; - case OP_WHEN_PP: if (op_when_pp(sc)) continue; goto EVAL; - - case OP_UNLESS: check_unless(sc); goto EVAL; - case OP_UNLESS_S: if (op_unless_s(sc)) continue; goto EVAL; - case OP_UNLESS_A: if (op_unless_a(sc)) continue; goto EVAL; - case OP_UNLESS_P: op_unless_p(sc); goto EVAL; - case OP_UNLESS_PP: if (op_unless_pp(sc)) continue; goto EVAL; - - - case OP_COND_FEED: if (op_cond_feed(sc)) goto EVAL; /* else fall through */ - case OP_COND_FEED_1: if (is_true(sc, sc->value)) {op_cond_feed_1(sc); goto EVAL;} sc->value = sc->unspecified; continue; - - case OP_COND: check_cond(sc); - case OP_COND_UNCHECKED: if (op_cond_unchecked(sc)) goto EVAL; - case OP_COND1: if (op_cond1(sc)) goto TOP_NO_POP; /* else fall through */ - FEED_TO: - if (feed_to(sc)) goto APPLY; - goto EVAL; - case OP_FEED_TO_1: sc->code = sc->value; goto APPLY; /* sc->args saved in feed_to via push_stack */ - - case OP_COND_SIMPLE: if (op_cond_simple(sc)) goto EVAL; - case OP_COND1_SIMPLE: if (op_cond1_simple(sc)) goto TOP_NO_POP; goto BEGIN; - case OP_COND_SIMPLE_O: if (op_cond_simple_o(sc)) goto EVAL; - case OP_COND1_SIMPLE_O: if (op_cond1_simple_o(sc)) continue; goto EVAL; - - case OP_COND_NA_NA: sc->value = fx_cond_na_na(sc, sc->code); continue; - case OP_COND_NA_NP: if (op_cond_na_np(sc)) continue; goto EVAL; - case OP_COND_NA_NP_1: if (op_cond_na_np_1(sc)) continue; goto EVAL; - case OP_COND_NA_NP_O: if (inline_op_cond_na_np_o(sc)) continue; goto EVAL; - case OP_COND_NA_2E: if (op_cond_na_2e(sc)) continue; goto EVAL; - case OP_COND_NA_3E: if (op_cond_na_3e(sc)) continue; goto EVAL; - - - case OP_AND: - if (check_and(sc, sc->code)) continue; - case OP_AND_P: - sc->code = cdr(sc->code); - AND_P: /* this code (and OR_P below) is ugly, but the pretty version (procedurized) is much slower */ - if (has_fx(sc->code)) /* all fx_proc's are set via fx_choose which can return nil, but it is not cleared when type is */ - { /* so, if (fx_proc(sc->code)) here and in OR_P is not safe */ - sc->value = fx_call(sc, sc->code); - if (is_false(sc, sc->value)) continue; - sc->code = cdr(sc->code); - if (is_null(sc->code)) continue; /* this order of checks appears to be faster than any of the alternatives */ - goto AND_P; - } - if (is_pair(cdr(sc->code))) /* apparently exactly as fast as is_not_null */ - push_stack_no_args(sc, OP_AND_P1, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; - - case OP_AND_P1: - if ((is_false(sc, sc->value)) || - (is_null(sc->code))) - continue; - goto AND_P; - - case OP_AND_AP: if (op_and_ap(sc)) continue; goto EVAL; - case OP_AND_2A: sc->value = fx_and_2a(sc, sc->code); continue; - case OP_AND_3A: sc->value = fx_and_3a(sc, sc->code); continue; - case OP_AND_N: sc->value = fx_and_n(sc, sc->code); continue; - case OP_AND_S_2: sc->value = fx_and_s_2(sc, sc->code); continue; - case OP_AND_PAIR_P: if (op_and_pair_p(sc)) continue; goto EVAL; - case OP_AND_SAFE_P1: op_and_safe_p1(sc); goto EVAL; - case OP_AND_SAFE_P2: if (op_and_safe_p2(sc)) continue; goto EVAL; - case OP_AND_SAFE_P3: if (op_and_safe_p3(sc)) continue; goto EVAL; - case OP_AND_SAFE_P_REST: if (is_true(sc, sc->value)) sc->value = fx_and_n(sc, sc->code); continue; - - - case OP_OR: - if (check_or(sc, sc->code)) continue; - case OP_OR_P: - sc->code = cdr(sc->code); - OR_P: - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - if (is_true(sc, sc->value)) continue; - sc->code = cdr(sc->code); - if (is_null(sc->code)) continue; - goto OR_P; - } - if (is_pair(cdr(sc->code))) - push_stack_no_args(sc, OP_OR_P1, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; - - case OP_OR_P1: - if ((is_true(sc, sc->value)) || - (is_null(sc->code))) - continue; - goto OR_P; - - case OP_OR_AP: if (op_or_ap(sc)) continue; goto EVAL; - case OP_OR_2A: sc->value = fx_or_2a(sc, sc->code); continue; - case OP_OR_S_2: sc->value = fx_or_s_2(sc, sc->code); continue; - case OP_OR_S_TYPE_2: sc->value = fx_or_s_type_2(sc, sc->code); continue; - case OP_OR_3A: sc->value = fx_or_3a(sc, sc->code); continue; - case OP_OR_N: sc->value = fx_or_n(sc, sc->code); continue; - - - case OP_NAMED_LET_NO_VARS: op_named_let_no_vars(sc); goto BEGIN; - case OP_NAMED_LET: if (op_named_let(sc)) goto BEGIN; goto EVAL; - case OP_NAMED_LET_A: op_named_let_a(sc); goto BEGIN; - case OP_NAMED_LET_AA: op_named_let_aa(sc); goto BEGIN; - case OP_NAMED_LET_NA: if (op_named_let_na(sc)) goto BEGIN; goto EVAL; - - case OP_LET: if (op_let(sc)) goto BEGIN; goto EVAL; - case OP_LET_UNCHECKED: if (op_let_unchecked(sc)) goto BEGIN; goto EVAL; - case OP_LET1: if (op_let1(sc)) goto BEGIN; goto EVAL; - case OP_LET_NO_VARS: op_let_no_vars(sc); goto BEGIN; - - case OP_LET_A_A_OLD: op_let_a_a_old(sc); continue; - case OP_LET_A_A_NEW: op_let_a_a_new(sc); continue; - case OP_LET_A_NA_OLD: op_let_a_na_old(sc); continue; - case OP_LET_A_NA_NEW: op_let_a_na_new(sc); continue; - case OP_LET_NA_OLD: op_let_na_old(sc); goto BEGIN; - case OP_LET_NA_NEW: inline_op_let_na_new(sc); goto BEGIN; - case OP_LET_2A_OLD: op_let_2a_old(sc); goto EVAL; - case OP_LET_2A_NEW: op_let_2a_new(sc); goto EVAL; - case OP_LET_3A_OLD: op_let_3a_old(sc); goto EVAL; - case OP_LET_3A_NEW: op_let_3a_new(sc); goto EVAL; - case OP_LET_ONE_OLD: op_let_one_old(sc); goto EVAL; - case OP_LET_ONE_NEW: op_let_one_new(sc); goto EVAL; - case OP_LET_ONE_P_OLD: op_let_one_p_old(sc); goto EVAL; - case OP_LET_ONE_P_NEW: op_let_one_p_new(sc); goto EVAL; - - case OP_LET_A_OLD: op_let_a_old(sc); sc->code = cdr(sc->code); goto BEGIN; - case OP_LET_A_NEW: inline_op_let_a_new(sc); sc->code = cdr(sc->code); goto BEGIN; - case OP_LET_A_OLD_2: inline_op_let_a_old(sc); push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_A_NEW_2: inline_op_let_a_new(sc); push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_A_P_OLD: inline_op_let_a_old(sc); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_A_P_NEW: inline_op_let_a_new(sc); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_ONE_OLD_1: op_let_one_old_1(sc); goto BEGIN; - case OP_LET_ONE_P_OLD_1: op_let_one_p_old_1(sc); goto EVAL; - case OP_LET_ONE_NEW_1: sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value); goto BEGIN; - case OP_LET_ONE_P_NEW_1: sc->curlet = inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value); sc->code = car(sc->code); goto EVAL; - case OP_LET_opaSSq_OLD: op_let_opassq_old(sc); goto BEGIN; - case OP_LET_opaSSq_NEW: op_let_opassq_new(sc); goto BEGIN; - - case OP_LET_STAR_NA: op_let_star_na(sc); goto BEGIN; - case OP_LET_STAR_NA_A: op_let_star_na_a(sc); continue; - - case OP_NAMED_LET_STAR: op_named_let_star(sc); goto EVAL; - case OP_LET_STAR2: op_let_star2(sc); goto EVAL; - case OP_LET_STAR: if (check_let_star(sc)) goto EVAL; goto BEGIN; - case OP_LET_STAR1: if (op_let_star1(sc)) goto EVAL; goto BEGIN; - case OP_LET_STAR_SHADOWED: if (op_let_star_shadowed(sc)) goto EVAL; goto BEGIN; - - case OP_LETREC: check_letrec(sc, true); - case OP_LETREC_UNCHECKED: if (op_letrec_unchecked(sc)) goto EVAL; goto BEGIN; - case OP_LETREC1: if (op_letrec1(sc)) goto EVAL; goto BEGIN; - - case OP_LETREC_STAR: check_letrec(sc, false); - case OP_LETREC_STAR_UNCHECKED: if (op_letrec_star_unchecked(sc)) goto EVAL; goto BEGIN; - case OP_LETREC_STAR1: if (op_letrec_star1(sc)) goto EVAL; goto BEGIN; - - - case OP_LET_TEMPORARILY: check_let_temporarily(sc); - case OP_LET_TEMP_UNCHECKED: op_let_temp_unchecked(sc); goto LET_TEMP_INIT1; - - case OP_LET_TEMP_INIT1: - op_let_temp_init1_1(sc); - LET_TEMP_INIT1: - if (op_let_temp_init1(sc)) goto EVAL; - case OP_LET_TEMP_INIT2: - switch (op_let_temp_init2(sc)) /* let misc obj */ - { - case goto_begin: goto BEGIN; - case goto_eval: goto EVAL; - case goto_set_unchecked: goto SET_UNCHECKED; - case fall_through: - default: break; - } - - case OP_LET_TEMP_DONE: - sc->code = sc->value; - push_stack(sc, OP_GC_PROTECT, sc->args, sc->value); /* save let-temp body val as sc->code */ - case OP_LET_TEMP_DONE1: - if (op_let_temp_done1(sc)) continue; - goto SET_UNCHECKED; - - - case OP_LET_TEMP_S7: if(op_let_temp_s7(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_S7_DIRECT: if (op_let_temp_s7_direct(sc)) goto BEGIN; sc->value = sc->nil; continue; - - case OP_LET_TEMP_NA: if (op_let_temp_na(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_A: if (op_let_temp_a(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_SETTER: if (op_let_temp_setter(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_A_A: sc->value = fx_let_temp_a_a(sc, sc->code); continue; - - case OP_LET_TEMP_UNWIND: op_let_temp_unwind(sc); continue; - case OP_LET_TEMP_S7_UNWIND: op_let_temp_s7_unwind(sc); continue; - case OP_LET_TEMP_S7_DIRECT_UNWIND: op_let_temp_s7_direct_unwind(sc); continue; - case OP_LET_TEMP_SETTER_UNWIND: op_let_temp_setter_unwind(sc); continue; - - - case OP_EVAL_MACRO: op_eval_macro(sc); goto EVAL; - case OP_EVAL_MACRO_MV: if (op_eval_macro_mv(sc)) continue; goto EVAL; - case OP_EXPANSION: op_finish_expansion(sc); continue; - - case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR: - case OP_DEFINE_EXPANSION: case OP_DEFINE_EXPANSION_STAR: - case OP_DEFINE_MACRO: case OP_DEFINE_MACRO_STAR: - op_define_macro(sc); - continue; - - case OP_MACRO: case OP_BACRO: case OP_MACRO_STAR: case OP_BACRO_STAR: - op_macro(sc); - continue; - - case OP_LAMBDA: sc->value = op_lambda(sc, sc->code); continue; - case OP_LAMBDA_UNCHECKED: sc->value = op_lambda_unchecked(sc, sc->code); continue; - case OP_LAMBDA_STAR: op_lambda_star(sc); continue; - case OP_LAMBDA_STAR_UNCHECKED: op_lambda_star_unchecked(sc); continue; - - - case OP_CASE: /* car(sc->code) is the selector */ - /* selector A, key type: E=eq (symbol/char), I=integer, G=any, S=single keys and single bodies */ - if (check_case(sc)) goto EVAL; else goto G_G; /* selector is a symbol or constant, stupid "else" to shut up the compiler */ - - case OP_CASE_A_G_G: sc->value = fx_call(sc, cdr(sc->code)); - G_G: case OP_CASE_G_G: if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; - case OP_CASE_A_E_S: sc->value = fx_call(sc, cdr(sc->code)); - case OP_CASE_E_S: op_case_e_s(sc); goto EVAL; -#if (!WITH_GMP) - case OP_CASE_P_I_S: push_stack_no_args_direct(sc, OP_CASE_I_S); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_A_I_S: sc->value = fx_call(sc, cdr(sc->code)); - case OP_CASE_I_S: if (op_case_i_s(sc)) continue; goto EVAL; -#endif - case OP_CASE_A_G_S: sc->value = fx_call(sc, cdr(sc->code)); /* this almost never happens? */ - case OP_CASE_G_S: op_case_g_s(sc); goto EVAL; - - case OP_CASE_A_E_G: sc->value = fx_call(sc, cdr(sc->code)); - case OP_CASE_E_G: if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) goto TOP_NO_POP; goto FEED_TO; - case OP_CASE_A_S_G: /* splitting this case out matters in lint */ - sc->value = fx_call(sc, cdr(sc->code)); - if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) goto TOP_NO_POP; else goto FEED_TO; - - case OP_CASE_P_G_G: push_stack_no_args_direct(sc, OP_CASE_G_G); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_E_S: push_stack_no_args_direct(sc, OP_CASE_E_S); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_G_S: push_stack_no_args_direct(sc, OP_CASE_G_S); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_P_E_G: push_stack_no_args_direct(sc, OP_CASE_E_G); sc->code = cadr(sc->code); goto EVAL; -#if (!WITH_GMP) - case OP_CASE_A_I_S_A: sc->value = fx_case_a_i_s_a(sc, sc->code); continue; -#endif - case OP_CASE_A_E_S_A: sc->value = fx_case_a_e_s_a(sc, sc->code); continue; - case OP_CASE_A_G_S_A: sc->value = fx_case_a_g_s_a(sc, sc->code); continue; - case OP_CASE_A_S_G_A: sc->value = fx_case_a_s_g_a(sc, sc->code); continue; - - - case OP_ERROR_QUIT: - if (sc->stack_end <= sc->stack_start) stack_reset(sc); /* sets stack_end to stack_start, then pushes op_eval_done */ - return(sc->F); - - case OP_ERROR_HOOK_QUIT: - op_error_hook_quit(sc); - - case OP_EVAL_DONE: - return(sc->F); - - case OP_SPLICE_VALUES: /* if splice_in_values hits eval_done, it needs to continue the splice after returning, so we get here */ - sc->value = splice_in_values(sc, sc->args); - continue; - - case OP_GC_PROTECT: case OP_BARRIER: case OP_NO_VALUES: - case OP_CATCH_ALL: case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: - continue; - - case OP_GET_OUTPUT_STRING: op_get_output_string(sc); /* from call-with-output-string|with-output-to-string; return the port string directly *//* fall through */ - case OP_UNWIND_OUTPUT: op_unwind_output(sc); continue; - case OP_UNWIND_INPUT: op_unwind_input(sc); continue; - case OP_DYNAMIC_UNWIND: dynamic_unwind(sc, sc->code, sc->args); continue; - case OP_PROFILE_IN: g_profile_in(sc, set_plist_2(sc, cadr(sc->code), sc->curlet)); continue; - case OP_DYNAMIC_UNWIND_PROFILE: g_profile_out(sc, set_plist_1(sc, sc->args)); continue; - case OP_DYNAMIC_WIND: if (op_dynamic_wind(sc)) goto APPLY; continue; - case OP_DEACTIVATE_GOTO: call_exit_active(sc->args) = false; continue; /* deactivate the exiter */ - - case OP_WITH_LET_S: sc->value = fx_with_let_s(sc, sc->code); continue; - case OP_WITH_LET: check_with_let(sc); - case OP_WITH_LET_UNCHECKED: if (op_with_let_unchecked(sc)) goto EVAL; - case OP_WITH_LET1: if (sc->value != sc->curlet) activate_with_let(sc, sc->value); goto BEGIN; - - case OP_WITH_BAFFLE: check_with_baffle(sc); - case OP_WITH_BAFFLE_UNCHECKED: if (op_with_baffle_unchecked(sc)) continue; goto BEGIN; - - - case OP_READ_INTERNAL: op_read_internal(sc); continue; - case OP_READ_DONE: op_read_done(sc); continue; - case OP_LOAD_RETURN_IF_EOF: if (op_load_return_if_eof(sc)) goto EVAL; return(sc->F); - case OP_LOAD_CLOSE_AND_POP_IF_EOF: if (op_load_close_and_pop_if_eof(sc)) goto EVAL; continue; - - POP_READ_LIST: - if (pop_read_list(sc)) goto READ_NEXT; - - READ_LIST: - case OP_READ_LIST: /* sc->args is sc->nil at first */ - sc->args = cons(sc, sc->value, sc->args); - - READ_NEXT: - case OP_READ_NEXT: /* this is 75% of the token calls, so expanding it saves lots of time */ - { - int32_t c; - s7_pointer pt = current_input_port(sc); - c = port_read_white_space(pt)(sc, pt); - - READ_C: - switch (c) - { - case '(': - c = port_read_white_space(pt)(sc, pt); /* sc->tok = token(sc) */ - switch (c) - { - case '(': sc->tok = TOKEN_LEFT_PAREN; break; - case ')': sc->value = sc->nil; goto READ_LIST; /* was tok = TOKEN_RIGHT_PAREN */ - case '.': sc->tok = read_dot(sc, pt); break; - case '\'': sc->tok = TOKEN_QUOTE; break; - case ';': sc->tok = port_read_semicolon(pt)(sc, pt); break; - case '"': sc->tok = TOKEN_DOUBLE_QUOTE; break; - case '`': sc->tok = TOKEN_BACK_QUOTE; break; - case ',': sc->tok = read_comma(sc, pt); break; - case '#': sc->tok = read_sharp(sc, pt); break; - case '\0': case EOF: sc->tok = TOKEN_EOF; break; - - default: /* read first element of list (ignore callgrind confusion -- this happens a lot) */ - c = read_start_list(sc, pt, c); - goto READ_C; - } - if (sc->tok == TOKEN_ATOM) - { - c = read_atom(sc, pt); - goto READ_C; - } - if (sc->tok == TOKEN_RIGHT_PAREN) - { - sc->value = sc->nil; - goto READ_LIST; - } - if (sc->tok == TOKEN_DOT) - { - do {c = inchar(pt);} while ((c != ')') && (c != EOF)); - read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ - } - if (sc->tok == TOKEN_EOF) - missing_close_paren_error_nr(sc); - - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); - /* check_stack_size(sc); */ - sc->value = read_expression(sc); - if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case ')': - sc->tok = TOKEN_RIGHT_PAREN; - break; - - case '.': - sc->tok = read_dot(sc, pt); /* dot or atom */ - break; - - case '\'': - sc->tok = TOKEN_QUOTE; - /* might need check_stack_size(sc) here */ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - continue; - - case ';': - sc->tok = port_read_semicolon(pt)(sc, pt); - break; - - case '"': - sc->tok = TOKEN_DOUBLE_QUOTE; - read_double_quote(sc); - goto READ_LIST; - - case '`': - sc->tok = TOKEN_BACK_QUOTE; - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case ',': - sc->tok = read_comma(sc, pt); /* at_mark or comma */ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - continue; - - case '#': - sc->tok = read_sharp(sc, pt); - break; - - case '\0': - case EOF: - missing_close_paren_error_nr(sc); - - default: - sc->strbuf[0] = (unsigned char)c; - sc->value = port_read_name(pt)(sc, pt); - goto READ_LIST; - }} - - READ_TOK: - switch (sc->tok) - { - case TOKEN_RIGHT_PAREN: /* sc->args can't be null here */ - sc->value = proper_list_reverse_in_place(sc, sc->args); - if ((is_expansion(car(sc->value))) && - (sc->is_expanding)) - switch (op_expansion(sc)) - { - case goto_begin: goto BEGIN; - case goto_apply_lambda: goto APPLY_LAMBDA; - default: break; - } - break; - - case TOKEN_EOF: missing_close_paren_error_nr(sc); /* can't happen, I believe */ - case TOKEN_ATOM: sc->value = port_read_name(current_input_port(sc))(sc, current_input_port(sc)); goto READ_LIST; - case TOKEN_SHARP_CONST: if (read_sharp_const(sc)) goto READ_TOK; goto READ_LIST; - case TOKEN_DOUBLE_QUOTE: read_double_quote(sc); goto READ_LIST; - case TOKEN_DOT: read_dot_and_expression(sc); break; - default: read_tok_default(sc); break; - } - if (main_stack_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case OP_READ_DOT: - switch (op_read_dot(sc)) - { - case goto_start: continue; - case goto_pop_read_list: goto POP_READ_LIST; - default: goto READ_TOK; - } - case OP_READ_QUOTE: if (op_read_quote(sc)) continue; goto POP_READ_LIST; - case OP_READ_QUASIQUOTE: if (op_read_quasiquote(sc)) continue; goto POP_READ_LIST; - case OP_READ_UNQUOTE: if (op_read_unquote(sc)) continue; goto POP_READ_LIST; - case OP_READ_APPLY_VALUES: if (op_read_apply_values(sc)) continue; goto POP_READ_LIST; - case OP_READ_VECTOR: if (op_read_vector(sc)) continue; goto POP_READ_LIST; - case OP_READ_INT_VECTOR: if (op_read_int_vector(sc)) continue; goto POP_READ_LIST; - case OP_READ_FLOAT_VECTOR: if (op_read_float_vector(sc)) continue; goto POP_READ_LIST; - case OP_READ_BYTE_VECTOR: if (op_read_byte_vector(sc)) continue; goto POP_READ_LIST; - - case OP_CLEAR_OPTS: - break; - - default: - return(sc->F); - } - - /* this code is reached from OP_CLEAR_OPTS and many others where the optimization has turned out to be incorrect, OP_CLOSURE_SYM for example; search for break */ - if (!tree_is_cyclic(sc, sc->code)) - clear_all_optimizations(sc, sc->code); - UNOPT: - switch (trailers(sc)) - { - case goto_top_no_pop: goto TOP_NO_POP; - case goto_eval_args_top: goto EVAL_ARGS_TOP; - case goto_eval: goto EVAL; - case goto_start: continue; /* sc->value has been set, this is OP_SYMBOL|CONSTANT on the next pass */ - default: - if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: unexpected switch default: %s\n", __func__, __LINE__, display(sc->code)); - break; - }} - return(sc->F); /* this never happens (make the compiler happy) */ -} - - -/* -------------------------------- s7_heap_scan -------------------------------- */ -#if S7_DEBUGGING -static void mark_holdee(s7_pointer holder, s7_pointer holdee, const char *root) -{ - holdee->holders++; - holdee->holder = holder; - holdee->root = root; -} - -static void mark_stack_holdees(s7_scheme *sc, s7_pointer p, s7_int top) -{ - if (stack_elements(p)) - { - s7_pointer heap0 = *(sc->heap); - s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); - for (s7_pointer *tp = (s7_pointer *)(stack_elements(p)), *tend = (s7_pointer *)(tp + top); (tp < tend); tp++) - { - s7_pointer x = *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); - x = *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); - x = *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); - }} -} - -static void save_holder_data(s7_scheme *sc, s7_pointer p) -{ - switch (unchecked_type(p)) - { - case T_PAIR: mark_holdee(p, car(p), NULL); mark_holdee(p, cdr(p), NULL); break; - case T_CATCH: mark_holdee(p, catch_tag(p), NULL); mark_holdee(p, catch_handler(p), NULL); break; - case T_DYNAMIC_WIND: mark_holdee(p, dynamic_wind_in(p), NULL); mark_holdee(p, dynamic_wind_out(p), NULL); mark_holdee(p, dynamic_wind_body(p), NULL); break; - case T_INPUT_PORT: mark_holdee(p, port_string_or_function(p), NULL); break; - case T_C_POINTER: mark_holdee(p, c_pointer_type(p), NULL); mark_holdee(p, c_pointer_info(p), NULL); break; - case T_COUNTER: mark_holdee(p, counter_result(p), NULL); mark_holdee(p, counter_list(p), NULL); mark_holdee(p, counter_let(p), NULL); break; - case T_STACK: mark_stack_holdees(sc, p, (p == sc->stack) ? current_stack_top(sc) : temp_stack_top(p)); break; - case T_OUTPUT_PORT: if (is_function_port(p)) mark_holdee(p, port_string_or_function(p), NULL); break; - - case T_ITERATOR: - mark_holdee(p, iterator_sequence(p), NULL); - if (is_mark_seq(p)) mark_holdee(p, iterator_current(p), NULL); - break; - - case T_SLOT: - mark_holdee(p, slot_value(p), NULL); - mark_holdee(p, slot_symbol(p), NULL); - if (slot_has_setter(p)) mark_holdee(p, slot_setter(p), NULL); - if (slot_has_pending_value(p)) mark_holdee(p, slot_pending_value(p), NULL); - break; - - case T_VECTOR: - if (is_subvector(p)) mark_holdee(p, subvector_vector(p), NULL); - for (s7_int i = 0, len = vector_length(p); i < len; i++) - if (vector_element(p, i)) mark_holdee(p, vector_element(p, i), NULL); - break; - - case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: - if (is_subvector(p)) mark_holdee(p, subvector_vector(p), NULL); - break; - - case T_LET: - if (p != sc->rootlet) /* do rootlet later? */ - { - for (s7_pointer slot = let_slots(p); tis_slot(slot); slot = next_slot(slot)) mark_holdee(p, slot, NULL); - if (has_dox_slot1(p)) mark_holdee(p, let_dox_slot1(p), NULL); - if ((has_dox_slot2(p)) && (is_slot(let_dox_slot2(p)))) mark_holdee(p, let_dox_slot2(p), NULL); - } - break; - - case T_C_FUNCTION_STAR: - if ((!c_func_has_simple_defaults(p)) && (c_function_call_args(p))) - for (s7_pointer arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg)) - mark_holdee(p, car(arg), NULL); - break; - - case T_CLOSURE: case T_CLOSURE_STAR: - case T_MACRO: case T_MACRO_STAR: - case T_BACRO: case T_BACRO_STAR: - mark_holdee(p, closure_args(p), NULL); - mark_holdee(p, closure_body(p), NULL); - mark_holdee(p, closure_let(p), NULL); - mark_holdee(p, closure_setter_or_map_list(p), NULL); - break; - - case T_HASH_TABLE: - mark_holdee(p, hash_table_procedures(p), NULL); - if (is_pair(hash_table_procedures(p))) - { - mark_holdee(p, hash_table_key_typer_unchecked(p), NULL); - mark_holdee(p, hash_table_value_typer_unchecked(p), NULL); - } - if (hash_table_entries(p) > 0) - { - s7_int len = hash_table_mask(p) + 1; - hash_entry_t **entries = hash_table_elements(p); - hash_entry_t **last = (hash_entry_t **)(entries + len); - if ((is_weak_hash_table(p)) && (weak_hash_iters(p) == 0)) - while (entries < last) - { - for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) - mark_holdee(p, hash_entry_value(xp), NULL); - } - else - while (entries < last) - for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) - { - mark_holdee(p, hash_entry_key(xp), NULL); - mark_holdee(p, hash_entry_value(xp), NULL); - }} - break; - - case T_CONTINUATION: - mark_holdee(p, continuation_op_stack(p), NULL); - mark_stack_holdees(sc, continuation_stack(p), continuation_stack_top(p)); - break; - - default: /* includes T_C_OBJECT */ - break; - } -} - -void s7_heap_analyze(s7_scheme *sc) -{ - /* clear possible previous data */ - for (s7_int k = 0; k < sc->heap_size; k++) - { - s7_pointer obj = sc->heap[k]; - obj->root = NULL; - obj->holders = 0; - obj->holder = NULL; - } - /* now parcel out all the holdings */ - for (s7_int k = 0; k < sc->heap_size; k++) - save_holder_data(sc, sc->heap[k]); - - { - s7_pointer *tmps = sc->free_heap_top; - s7_pointer *tmps_top = tmps + sc->gc_temps_size; - if (tmps_top > sc->previous_free_heap_top) tmps_top = sc->previous_free_heap_top; - while (tmps < tmps_top) - { - s7_pointer p = *tmps++; - mark_holdee(NULL, p, "gc temp"); - }} - - mark_holdee(NULL, sc->w, "sc->w"); - mark_holdee(NULL, sc->x, "sc->x"); - mark_holdee(NULL, sc->y, "sc->y"); - mark_holdee(NULL, sc->z, "sc->z"); - mark_holdee(NULL, sc->temp1, "sc->temp1"); - mark_holdee(NULL, sc->temp2, "sc->temp2"); - mark_holdee(NULL, sc->temp3, "sc->temp3"); - mark_holdee(NULL, sc->temp4, "sc->temp4"); - mark_holdee(NULL, sc->temp5, "sc->temp5"); - mark_holdee(NULL, sc->temp7, "sc->temp7"); - mark_holdee(NULL, sc->temp8, "sc->temp8"); - mark_holdee(NULL, sc->temp9, "sc->temp9"); - mark_holdee(NULL, sc->temp10, "sc->temp10"); - mark_holdee(NULL, sc->rec_p1, "sc->rec_p1"); - mark_holdee(NULL, sc->rec_p2, "sc->rec_p2"); - - mark_holdee(NULL, car(sc->t1_1), "car(sc->t1_1)"); - mark_holdee(NULL, car(sc->t2_1), "car(sc->t2_1)"); - mark_holdee(NULL, car(sc->t2_2), "car(sc->t2_2)"); - mark_holdee(NULL, car(sc->t3_1), "car(sc->t3_1)"); - mark_holdee(NULL, car(sc->t3_2), "car(sc->t3_2)"); - mark_holdee(NULL, car(sc->t3_3), "car(sc->t3_3)"); - mark_holdee(NULL, car(sc->t4_1), "car(sc->t4_1)"); - mark_holdee(NULL, car(sc->u1_1), "car(sc->u1_1)"); - mark_holdee(NULL, car(sc->plist_1), "car(sc->plist_1)"); - mark_holdee(NULL, car(sc->plist_2), "car(sc->plist_2)"); - mark_holdee(NULL, car(sc->plist_3), "car(sc->plist_3)"); - mark_holdee(NULL, car(sc->qlist_2), "car(sc->qlist_2)"); - mark_holdee(NULL, car(sc->qlist_3), "car(sc->qlist_3)"); - mark_holdee(NULL, car(sc->elist_1), "car(sc->elist_1)"); - mark_holdee(NULL, car(sc->elist_2), "car(sc->elist_2)"); - mark_holdee(NULL, car(sc->elist_3), "car(sc->elist_3)"); - mark_holdee(NULL, car(sc->elist_4), "car(sc->elist_4)"); - mark_holdee(NULL, car(sc->elist_5), "car(sc->elist_5)"); - mark_holdee(NULL, car(sc->elist_6), "car(sc->elist_6)"); - mark_holdee(NULL, car(sc->elist_7), "car(sc->elist_7)"); - mark_holdee(NULL, cadr(sc->plist_2), "cadr(sc->plist_2)"); - mark_holdee(NULL, cadr(sc->plist_3), "cadr(sc->plist_3)"); - mark_holdee(NULL, cadr(sc->elist_2), "cadr(sc->elist_2)"); - mark_holdee(NULL, cadr(sc->elist_3), "cadr(sc->elist_3)"); - mark_holdee(NULL, cadr(sc->qlist_2), "cadr(sc->qlist_2)"); - mark_holdee(NULL, caddr(sc->plist_3), "caddr(sc->plist_3)"); - mark_holdee(NULL, caddr(sc->elist_3), "caddr(sc->elist_3)"); - - mark_holdee(NULL, sc->code, "sc->code"); - mark_holdee(NULL, sc->value, "sc->value"); - mark_holdee(NULL, sc->args, "sc->args"); - mark_holdee(NULL, sc->curlet, "sc->curlet"); - mark_holdee(NULL, sc->stack, "sc->stack"); - mark_holdee(NULL, sc->default_random_state, "sc->default_random_state"); - mark_holdee(NULL, sc->let_temp_hook, "sc->let_temp_hook"); - mark_holdee(NULL, sc->stacktrace_defaults, "sc->stacktrace_defaults"); - mark_holdee(NULL, sc->protected_objects, "sc->protected_objects"); - mark_holdee(NULL, sc->protected_setters, "sc->protected_setters"); - mark_holdee(NULL, sc->protected_setter_symbols, "sc->protected_setter_symbols"); - mark_holdee(NULL, sc->error_type, "sc->error_type"); - mark_holdee(NULL, sc->error_data, "sc->error_data"); - mark_holdee(NULL, sc->error_code, "sc->error_code"); - mark_holdee(NULL, sc->error_line, "sc->error_line"); - mark_holdee(NULL, sc->error_file, "sc->error_file"); - mark_holdee(NULL, sc->error_position, "sc->error_position"); -#if WITH_HISTORY - mark_holdee(NULL, sc->error_history, "sc->error_history"); -#endif - - for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) - mark_holdee(NULL, g->p, "permanent object"); - - for (s7_int i = 0; i < sc->protected_objects_size; i++) - mark_holdee(NULL, vector_element(sc->protected_objects, i), "gc protected object"); - - for (s7_int i = 0; i < sc->protected_setters_loc; i++) - mark_holdee(NULL, vector_element(sc->protected_setters, i), "gc protected setter"); - - for (s7_int i = 0; i < sc->setters_loc; i++) - mark_holdee(NULL, cdr(sc->setters[i]), "setter"); - - for (s7_int i = 0; i <= sc->format_depth; i++) - if (sc->fdats[i]) - mark_holdee(NULL, sc->fdats[i]->curly_arg, "fdat curly_arg"); - - { - s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc); - for (s7_pointer *p = sc->input_port_stack; p < tp; p++) - mark_holdee(NULL, *p, "input stack"); - } - { - s7_pointer *p = sc->op_stack; - s7_pointer *tp = sc->op_stack_now; - while (p < tp) {s7_pointer x = *p++; mark_holdee(NULL, x, "op stack");} - } - - if (sc->rec_stack) - for (s7_int i = 0; i < sc->rec_loc; i++) - mark_holdee(NULL, sc->rec_els[i], "sc->rec_els"); - - { - gc_list_t *gp = sc->opt1_funcs; - for (s7_int i = 0; i < gp->loc; i++) - { - s7_pointer s1 = T_Pair(gp->list[i]); - mark_holdee(NULL, opt1_any(s1), "opt1_funcs"); - }} - - for (int32_t i = 1; i < NUM_SAFE_LISTS; i++) - if ((is_pair(sc->safe_lists[i])) && - (list_is_in_use(sc->safe_lists[i]))) - for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p)) - mark_holdee(NULL, car(p), "safe_lists"); - - for (s7_pointer p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "wrong-type-arg"); - for (s7_pointer p = sc->sole_arg_wrong_type_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple wrong-type-arg"); - for (s7_pointer p = sc->out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "out-of-range"); - for (s7_pointer p = sc->sole_arg_out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple out-of-range"); - - { - s7_pointer *tmp = rootlet_elements(sc->rootlet); - s7_pointer *top = (s7_pointer *)(tmp + sc->rootlet_entries); - while (tmp < top) {s7_pointer slot = *tmp++; mark_holdee(NULL, slot_value(slot), "rootlet");} - } -#if WITH_HISTORY - for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3)) - { - mark_holdee(NULL, car(p1), "eval history1"); - mark_holdee(NULL, car(p2), "eval history2"); - mark_holdee(NULL, car(p3), "eval history3"); - p1 = cdr(p1); - if (p1 == sc->eval_history1) break; - } -#else - mark_holdee(NULL, sc->cur_code, "current code"); -#endif -} - -void s7_heap_scan(s7_scheme *sc, int32_t typ) -{ - bool found_one = false; - for (s7_int k = 0; k < sc->heap_size; k++) - { - s7_pointer obj = sc->heap[k]; - if (unchecked_type(obj) == typ) - { - found_one = true; - if (obj->holders == 0) - fprintf(stderr, "%s has no holder (alloc: %d)\n", display_80(obj), obj->alloc_line); - else - if (obj->root) - fprintf(stderr, "%s from %s (%d holder%s)\n", display_80(obj), obj->root, - obj->holders, (obj->holders != 1) ? "s" : ""); - else fprintf(stderr, "%s from %s (%s, %p, alloc: %d, holder%s: %d)\n", - display_80(obj), display_80(obj->holder), - s7_type_names[unchecked_type(obj->holder)], obj->holder, obj->alloc_line, - (obj->holders != 1) ? "s" : "", obj->holders); - }} - if (!found_one) - fprintf(stderr, "heap-scan: no %s found\n", s7_type_names[typ]); -} - -static s7_pointer g_heap_scan(s7_scheme *sc, s7_pointer args) -{ - #define H_heap_scan "(heap-scan type) scans the heap for objects of type and reports info about them" - #define Q_heap_scan s7_make_signature(sc, 2, sc->not_symbol, sc->is_integer_symbol) - s7_pointer p = car(args); - if (!s7_is_integer(p)) - sole_arg_wrong_type_error_nr(sc, make_symbol(sc, "heap-scan", 9), p, sc->type_names[T_INTEGER]); - if ((s7_integer(p) <= 0) || (s7_integer(p) >= NUM_TYPES)) - sole_arg_out_of_range_error_nr(sc, make_symbol(sc, "heap-scan", 9), p, wrap_string(sc, "0 < type < 48", 13)); - s7_heap_scan(sc, (int32_t)s7_integer(p)); /* 0..48 currently */ - return(sc->F); -} - -static s7_pointer g_heap_analyze(s7_scheme *sc, s7_pointer args) -{ - #define H_heap_analyze "(heap-analyze type) gets heap data for subsequent heap-scan" - #define Q_heap_analyze s7_make_signature(sc, 1, sc->not_symbol) - s7_heap_analyze(sc); - return(sc->F); -} - -static s7_pointer g_heap_holder(s7_scheme *sc, s7_pointer args) -{ - #define H_heap_holder "(heap-holder obj) returns the object pointing to obj" - #define Q_heap_holder s7_make_signature(sc, 2, sc->T, sc->T) - s7_pointer p = car(args); - if ((p->holders == 0) || ((!(p->holder)) && (!(p->root)))) return(sc->F); - return((p->holder) ? p->holder : s7_make_string(sc, p->root)); -} - -static s7_pointer g_heap_holders(s7_scheme *sc, s7_pointer args) -{ - #define H_heap_holders "(heap-holders obj) returns the number of objects pointing to obj" - #define Q_heap_holders s7_make_signature(sc, 2, sc->is_integer_symbol, sc->T) - return(make_integer(sc, car(args)->holders)); -} - -/* random debugging stuff */ -static s7_pointer g_show_stack(s7_scheme *sc, s7_pointer args) -{ - #define H_show_stack "no help" - #define Q_show_stack s7_make_signature(sc, 1, sc->not_symbol) - s7_show_stack(sc); - return(sc->F); -} - -void s7_show_op_stack(s7_scheme *sc) -{ - fprintf(stderr, "op_stack:\n"); - for (s7_pointer *p = sc->op_stack, *tp = sc->op_stack_now; (p < tp); p++) - fprintf(stderr, " %s\n", display(*p)); -} - -static s7_pointer g_show_op_stack(s7_scheme *sc, s7_pointer args) -{ - #define H_show_op_stack "no help" - #define Q_show_op_stack s7_make_signature(sc, 1, sc->not_symbol) - s7_show_op_stack(sc); - return(sc->F); -} - -static s7_pointer g_is_op_stack(s7_scheme *sc, s7_pointer args) -{ - #define H_is_op_stack "no help" - #define Q_is_op_stack s7_make_signature(sc, 1, sc->is_boolean_symbol) - return(make_boolean(sc, (sc->op_stack < sc->op_stack_now))); -} -#endif - - -/* -------------------------------- *s7* let -------------------------------- */ -/* maybe *features* field in *s7*, others are *libraries*, *load-path*, *cload-directory*, *autoload*, *#readers* */ - -static noreturn void s7_starlet_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ) -{ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_5(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is ~A but should be ~A", 54), - caller, arg, object_type_name(sc, arg), typ)); -} - -static noreturn void sl_stacktrace_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer arg, s7_pointer typ, s7_pointer val) -{ - set_elist_7(sc, wrap_string(sc, "(set! (*s7* '~A) '~S): the ~:D list element ~S is ~A but should be ~A", 69), - caller, val, wrap_integer(sc, num), arg, object_type_name(sc, arg), typ); - error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_7); -} - -static noreturn void s7_starlet_out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr) -{ - error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is out of range (~A)", 52), caller, arg, descr)); -} - -static s7_int s7_starlet_length(void) {return(SL_NUM_FIELDS - 1);} - -static s7_pointer g_s7_starlet_set_fallback(s7_scheme *sc, s7_pointer args) -{ - s7_pointer sym = cadr(args); - if (!is_symbol(sym)) - sole_arg_wrong_type_error_nr(sc, sc->let_set_symbol, sym, sc->type_names[T_SYMBOL]); - return(s7_starlet_set_1(sc, sym, caddr(args))); -} - -static s7_pointer g_s7_starlet_ref_fallback(s7_scheme *sc, s7_pointer args); - -static s7_pointer make_s7_starlet(s7_scheme *sc) /* *s7* is semipermanent -- 20-May-21 */ -{ - s7_pointer slot1 = make_semipermanent_slot(sc, sc->let_set_fallback_symbol, s7_make_function(sc, "s7-let-set", g_s7_starlet_set_fallback, 3, 0, false, "*s7* writer")); - s7_pointer slot2 = make_semipermanent_slot(sc, sc->let_ref_fallback_symbol, s7_make_function(sc, "s7-let-ref", g_s7_starlet_ref_fallback, 2, 0, false, "*s7* reader")); - s7_pointer x = alloc_pointer(sc); - set_full_type(x, T_LET | T_SAFE_PROCEDURE | T_UNHEAP | T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK); - let_set_id(x, ++sc->let_number); - let_set_outlet(x, sc->nil); - symbol_set_local_slot(sc->let_set_fallback_symbol, sc->let_number, slot1); - slot_set_next(slot1, slot_end(sc)); - symbol_set_local_slot(sc->let_ref_fallback_symbol, sc->let_number, slot2); - slot_set_next(slot2, slot1); - let_set_slots(x, slot2); - set_immutable_slot(slot1); /* make the *s7* let-ref|set! fallbacks immutable */ - set_immutable_slot(slot2); - set_immutable_let(x); - sc->s7_starlet_symbol = s7_define_constant(sc, "*s7*", s7_openlet(sc, x)); /* define_constant returns the symbol */ - for (int32_t i = SL_STACK_TOP; i < SL_NUM_FIELDS; i++) - { - s7_pointer sym = make_symbol_with_strlen(sc, s7_starlet_names[i]); - s7_starlet_symbol_set(sym, (s7_starlet_t)i); /* evaluates sym twice */ - } - return(x); -} - -/* handling all *s7* fields via fallbacks lets us use direct field accesses in the rest of s7, and avoids - * using ca 100 cells for the let slots/values. We would need the fallbacks anyway for 'files et al. - * Since most of the fields need special setters, it's actually less code this way. See old/s7-let-s7.c. - */ - -#if (!_WIN32) /* (!MS_WINDOWS) */ - #include -#endif - -static s7_pointer kmg(s7_scheme *sc, s7_int bytes) -{ - block_t *b = mallocate(sc, 128); - int32_t len = 0; - if (bytes < 1000) - len = snprintf((char *)block_data(b), 128, "%" ld64, bytes); - else - if (bytes < 1000000) - len = snprintf((char *)block_data(b), 128, "%.1fk", bytes / 1000.0); - else - if (bytes < 1000000000) - len = snprintf((char *)block_data(b), 128, "%.1fM", bytes / 1000000.0); - else len = snprintf((char *)block_data(b), 128, "%.1fG", bytes / 1000000000.0); - return(cons(sc, make_integer(sc, bytes), block_to_string(sc, b, len))); -} - -static s7_pointer memory_usage(s7_scheme *sc) -{ - s7_int i, k, len, in_use = 0, vlen = 0, flen = 0, ilen = 0, blen = 0, hlen = 0; - gc_list_t *gp; - s7_int ts[NUM_TYPES]; - -#if (!_WIN32) /* (!MS_WINDOWS) */ - struct rusage info; - struct timeval ut; -#endif - - s7_pointer mu_let = s7_inlet(sc, sc->nil); - s7_int gc_loc = gc_protect_1(sc, mu_let); - -#if (!_WIN32) /* (!MS_WINDOWS) */ - getrusage(RUSAGE_SELF, &info); - ut = info.ru_utime; - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-time", 12), make_real(sc, ut.tv_sec + (floor(ut.tv_usec / 1000.0) / 1000.0))); -#ifdef __APPLE__ - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), kmg(sc, info.ru_maxrss)); - /* apple docs say this is in kilobytes, but apparently that is an error */ -#else - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), kmg(sc, info.ru_maxrss * 1024)); - /* why does this number sometimes have no relation to RES in top? */ -#endif - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "IO", 2), cons(sc, make_integer(sc, info.ru_inblock), make_integer(sc, info.ru_oublock))); -#endif - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "rootlet-size", 12), make_integer(sc, sc->rootlet_entries)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-size", 9), - cons(sc, make_integer(sc, sc->heap_size), kmg(sc, sc->heap_size * (sizeof(s7_cell) + 2 * sizeof(s7_pointer))))); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cell-size", 9), make_integer(sc, sizeof(s7_cell))); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-freed", 14), make_integer(sc, sc->gc_total_freed)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-time", 13), make_real(sc, (double)(sc->gc_total_time) / ticks_per_second())); - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "small_ints", 10), - cons(sc, make_integer(sc, NUM_SMALL_INTS), kmg(sc, NUM_SMALL_INTS * sizeof(s7_cell)))); - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent-cells", 15), - cons(sc, make_integer(sc, sc->semipermanent_cells), kmg(sc, sc->semipermanent_cells * sizeof(s7_cell)))); - i = 0; - for (gc_obj_t *g = sc->semipermanent_objects; g; i++, g = (gc_obj_t *)(g->nxt)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent_objects", 17), make_integer(sc, i)); - i = 0; - for (gc_obj_t *g = sc->semipermanent_lets; g; i++, g = (gc_obj_t *)(g->nxt)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent_lets", 14), make_integer(sc, i)); - - /* show how many active cells there are of each type (this is where all the memory_usage cpu time goes) */ - for (i = 0; i < NUM_TYPES; i++) ts[i] = 0; - for (k = 0; k < sc->heap_size; k++) - ts[unchecked_type(sc->heap[k])]++; - sc->w = sc->nil; - for (i = 0; i < NUM_TYPES; i++) - { - if (i > 0) in_use += ts[i]; - if (ts[i] > 50) - sc->w = cons_unchecked(sc, cons(sc, make_symbol_with_strlen(sc, (i == 0) ? "free" : type_name_from_type(i, NO_ARTICLE)), - make_integer(sc, ts[i])), sc->w); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cells-in-use/free", 17), - cons(sc, make_integer(sc, in_use), make_integer(sc, sc->free_heap_top - sc->free_heap))); - if (is_pair(sc->w)) - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "types", 5), proper_list_reverse_in_place(sc, sc->w)); - sc->w = sc->unused; - /* same for semipermanent cells requires traversing saved_pointers and the alloc and big_alloc blocks up to alloc_k, or keeping explicit counts */ - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-protected-objects", 20), - cons(sc, make_integer(sc, sc->protected_objects_size - sc->protected_objects_free_list_loc), - make_integer(sc, sc->protected_objects_size))); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "setters", 7), make_integer(sc, sc->protected_setters_loc)); - - /* check the symbol table, counting gensyms etc */ - { - s7_int syms = 0, gens = 0, keys = 0, mx_list = 0; - s7_pointer *els = vector_elements(sc->symbol_table); - for (i = 0; i < SYMBOL_TABLE_SIZE; i++) - { - s7_pointer x; - for (k = 0, x = els[i]; is_not_null(x); x = cdr(x), k++) - { - syms++; - if (is_gensym(car(x))) gens++; - if (is_keyword(car(x))) keys++; - } - if (k > mx_list) mx_list = k; - } - add_slot_unchecked_with_id(sc, mu_let, sc->symbol_table_symbol, - s7_list(sc, 9, - make_integer(sc, SYMBOL_TABLE_SIZE), - make_symbol(sc, "max-bin", 7), make_integer(sc, mx_list), - make_symbol(sc, "symbols", 7), cons(sc, make_integer(sc, syms), make_integer(sc, syms - gens - keys)), - make_symbol(sc, "gensyms", 7), make_integer(sc, gens), - make_symbol(sc, "keys", 4), make_integer(sc, keys))); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "stack", 5), cons(sc, make_integer(sc, current_stack_top(sc)), make_integer(sc, sc->stack_size))); - - len = sc->autoload_names_top * (sizeof(const char **) + sizeof(s7_int) + sizeof(bool)); - for (i = 0; i < sc->autoload_names_loc; i++) len += sc->autoload_names_sizes[i]; - add_slot_unchecked_with_id(sc, mu_let, sc->autoload_symbol, make_integer(sc, len)); - - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "circle_info", 11), - make_integer(sc, sc->circle_info->size * (sizeof(s7_pointer) + sizeof(int32_t) + sizeof(bool)))); - - /* check the gc lists (finalizations), at startup there are strings/input-strings from the s7_eval_c_string calls for make-polar et el */ - len = sc->strings->size + sc->vectors->size + sc->input_ports->size + sc->output_ports->size + sc->input_string_ports->size + - sc->continuations->size + sc->c_objects->size + sc->hash_tables->size + sc->gensyms->size + sc->undefineds->size + - sc->multivectors->size + sc->weak_refs->size + sc->weak_hash_iterators->size + sc->opt1_funcs->size; - { - int32_t loc = sc->strings->loc + sc->vectors->loc + sc->input_ports->loc + sc->output_ports->loc + sc->input_string_ports->loc + - sc->continuations->loc + sc->c_objects->loc + sc->hash_tables->loc + sc->gensyms->loc + sc->undefineds->loc + - sc->multivectors->loc + sc->weak_refs->loc + sc->weak_hash_iterators->loc + sc->opt1_funcs->loc; - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-lists", 8), - s7_list(sc, 4, make_integer(sc, loc), make_integer(sc, len), kmg(sc, len * sizeof(s7_pointer)), /* active, total, space allocated */ - s7_list(sc, 14, - list_3(sc, sc->string_symbol, make_integer(sc, sc->strings->loc), make_integer(sc, sc->strings->size)), - list_3(sc, sc->vector_symbol, make_integer(sc, sc->vectors->loc), make_integer(sc, sc->vectors->size)), - list_3(sc, sc->hash_table_symbol, make_integer(sc, sc->hash_tables->loc), make_integer(sc, sc->hash_tables->size)), - list_3(sc, make_symbol(sc, "multivector", 11), make_integer(sc, sc->multivectors->loc), make_integer(sc, sc->multivectors->size)), - list_3(sc, make_symbol(sc, "input", 5), make_integer(sc, sc->input_ports->loc), make_integer(sc, sc->input_ports->size)), - list_3(sc, make_symbol(sc, "output", 6), make_integer(sc, sc->output_ports->loc), make_integer(sc, sc->output_ports->size)), - list_3(sc, make_symbol(sc, "input-string", 12), make_integer(sc, sc->input_string_ports->loc), make_integer(sc, sc->input_string_ports->size)), - list_3(sc, make_symbol(sc, "continuation", 12), make_integer(sc, sc->continuations->loc), make_integer(sc, sc->continuations->size)), - list_3(sc, make_symbol(sc, "c-object", 8), make_integer(sc, sc->c_objects->loc), make_integer(sc, sc->c_objects->size)), - list_3(sc, make_symbol(sc, "gensym", 6), make_integer(sc, sc->gensyms->loc), make_integer(sc, sc->gensyms->size)), - list_3(sc, make_symbol(sc, "undefined", 9), make_integer(sc, sc->undefineds->loc), make_integer(sc, sc->undefineds->size)), - list_3(sc, make_symbol(sc, "weak-ref", 8), make_integer(sc, sc->weak_refs->loc), make_integer(sc, sc->weak_refs->size)), - list_3(sc, make_symbol(sc, "weak-hash-iter", 14),make_integer(sc, sc->weak_hash_iterators->loc), make_integer(sc, sc->weak_hash_iterators->size)), - list_3(sc, make_symbol(sc, "opt1-func", 9), make_integer(sc, sc->opt1_funcs->loc), make_integer(sc, sc->opt1_funcs->size))))); - } - - /* strings */ - gp = sc->strings; - for (len = 0, i = 0; i < (int32_t)(gp->loc); i++) - len += string_length(gp->list[i]); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "strings", 7), cons(sc, make_integer(sc, gp->loc), make_integer(sc, len))); - - /* vectors */ - for (k = 0, gp = sc->vectors; k < 2; k++, gp = sc->multivectors) - for (i = 0; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - if (is_float_vector(v)) - flen += vector_length(v); - else - if (is_int_vector(v)) - ilen += vector_length(v); - else - if (is_byte_vector(v)) - blen += vector_length(v); - else vlen += vector_length(v); - } - add_slot_unchecked_with_id(sc, mu_let, - make_symbol(sc, "vectors", 7), - s7_list(sc, 9, - make_integer(sc, sc->vectors->loc + sc->multivectors->loc), - make_symbol(sc, "vlen", 4), make_integer(sc, vlen), - make_symbol(sc, "fvlen", 5), make_integer(sc, flen), - make_symbol(sc, "ivlen", 5), make_integer(sc, ilen), - make_symbol(sc, "bvlen", 5), make_integer(sc, blen))); - /* hash-tables */ - for (i = 0, gp = sc->hash_tables; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - hlen += ((hash_table_mask(v) + 1) * sizeof(hash_entry_t *)); - hlen += (hash_table_entries(v) * sizeof(hash_entry_t)); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "hash-tables", 11), - cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, hlen))); - - /* ports */ - gp = sc->input_ports; - for (i = 0, len = 0; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - if (port_data(v)) len += port_data_size(v); - } - gp = sc->input_string_ports; - for (i = 0, len = 0; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - if (port_data(v)) len += port_data_size(v); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-ports", 11), - cons(sc, make_integer(sc, sc->input_ports->loc + sc->input_string_ports->loc), make_integer(sc, len))); - gp = sc->output_ports; - for (i = 0, len = 0; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - if (port_data(v)) len += port_data_size(v); - } - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "output-ports", 12), - cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len))); - - i = 0; - for (s7_pointer p = sc->format_ports; p; i++, p = (s7_pointer)port_next(p)); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "format-ports", 12), make_integer(sc, i)); - - /* continuations (sketchy!) */ - gp = sc->continuations; - for (i = 0, len = 0; i < gp->loc; i++) - if (is_continuation(gp->list[i])) - len += continuation_stack_size(gp->list[i]); - if (len > 0) - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "continuations", 13), - cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, len * sizeof(s7_pointer)))); - /* c-objects */ - if (sc->c_objects->loc > 0) - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-objects", 9), make_integer(sc, sc->c_objects->loc)); - if (sc->num_c_object_types > 0) - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-types", 7), - cons(sc, make_integer(sc, sc->num_c_object_types), - make_integer(sc, (sc->c_object_types_size * sizeof(c_object_t *)) + (sc->num_c_object_types * sizeof(c_object_t))))); - /* we're ignoring c_type->scheme_name: make_permanent_string(sc, name) */ -#if WITH_GMP - add_slot_unchecked_with_id(sc, mu_let, - make_symbol(sc, "bignums", 7), - s7_list(sc, 5, make_integer(sc, sc->big_integers->loc), make_integer(sc, sc->big_ratios->loc), - make_integer(sc, sc->big_reals->loc), make_integer(sc, sc->big_complexes->loc), - make_integer(sc, sc->big_random_states->loc))); -#endif - /* free-lists (mallocate) */ - { - block_t *b; - for (i = 0, len = 0, sc->w = sc->nil; i < TOP_BLOCK_LIST; i++) - { - for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++); - sc->w = cons(sc, make_integer(sc, k), sc->w); - len += ((sizeof(block_t) + (1LL << i)) * k); - } - for (b = sc->block_lists[TOP_BLOCK_LIST], k = 0; b; b = block_next(b), k++) - len += (sizeof(block_t) + block_size(b)); - sc->w = cons(sc, make_integer(sc, k), sc->w); - add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "free-lists", 10), - list_2(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)), - cons(sc, make_symbol(sc, "bins", 4), proper_list_reverse_in_place(sc, sc->w)))); - sc->w = sc->unused; - add_slot_unchecked_with_id(sc, mu_let, - make_symbol(sc, "approximate-s7-size", 19), - kmg(sc, ((sc->semipermanent_cells + NUM_SMALL_INTS + sc->heap_size) * sizeof(s7_cell)) + - ((2 * sc->heap_size + SYMBOL_TABLE_SIZE + sc->stack_size) * sizeof(s7_pointer)) + - len + hlen + (vlen * sizeof(s7_pointer)) + (flen * sizeof(s7_double)) + (ilen * sizeof(s7_int)) + blen)); - } - s7_gc_unprotect_at(sc, gc_loc); - return(mu_let); -} - -static s7_pointer sl_c_types(s7_scheme *sc) -{ - s7_pointer res; - sc->w = sc->nil; - for (int32_t i = 0; i < sc->num_c_object_types; i++) /* c-object type (tag) is i */ - sc->w = cons(sc, sc->c_object_types[i]->scheme_name, sc->w); - res = proper_list_reverse_in_place(sc, sc->w); /* so car(types) has tag 0 */ - sc->w = sc->unused; - return(res); -} - -static s7_pointer sl_file_names(s7_scheme *sc) -{ - s7_pointer p; - sc->w = sc->nil; - for (int32_t i = 0; i <= sc->file_names_top; i++) - sc->w = cons(sc, sc->file_names[i], sc->w); - p = proper_list_reverse_in_place(sc, sc->w); - sc->w = sc->unused; - return(p); -} - -static s7_pointer sl_int_fixup(s7_scheme *sc, s7_pointer val) -{ -#if WITH_GMP - return(s7_int_to_big_integer(sc, s7_integer_clamped_if_gmp(sc, val))); -#else - return(val); -#endif -} - -static s7_pointer sl_history(s7_scheme *sc) -{ -#if WITH_HISTORY - return(cull_history(sc, (sc->cur_code == sc->history_sink) ? sc->old_cur_code : sc->cur_code)); -#else - return(sc->cur_code); -#endif -} - -static s7_pointer sl_active_catches(s7_scheme *sc) -{ - s7_pointer lst = sc->nil; - for (int64_t i = current_stack_top(sc) - 1; i >= 3; i -= 4) - switch (stack_op(sc->stack, i)) - { - case OP_CATCH_ALL: - lst = cons(sc, sc->T, lst); - break; - case OP_CATCH_2: case OP_CATCH_1: case OP_CATCH: - lst = cons(sc, catch_tag(T_Cat(stack_code(sc->stack, i))), lst); - break; - } - return(reverse_in_place_unchecked(sc, sc->nil, lst)); -} - -static s7_pointer sl_stack_entries(s7_scheme *sc, s7_pointer stack, int64_t top) -{ - s7_pointer lst = sc->nil; - for (int64_t i = top - 1; i >= 3; i -= 4) - { - s7_pointer func = stack_code(stack, i), args = stack_args(stack, i), e = stack_let(stack, i); - opcode_t op = stack_op(stack, i); - s7_pointer entry = sc->nil; - if (s7_is_valid(sc, e)) entry = cons(sc, e, entry); - if (s7_is_valid(sc, args)) entry = cons_unchecked(sc, args, entry); - if (s7_is_valid(sc, func)) entry = cons_unchecked(sc, func, entry); - if ((op >= 0) && (op < NUM_OPS)) entry = cons_unchecked(sc, make_symbol_with_strlen(sc, op_names[op]), entry); - lst = cons_unchecked(sc, entry, lst); - sc->w = lst; - } - sc->w = sc->unused; - return(reverse_in_place_unchecked(sc, sc->nil, lst)); -} - -static s7_pointer sl_protected_objects(s7_scheme *sc) -{ - s7_pointer nv = s7_vector_copy(sc, sc->protected_objects); - s7_pointer *vals = vector_elements(nv); - s7_int len = vector_length(nv); - for (s7_int i = 0; i < len; i++) - if (vals[i] == sc->unused) - vals[i] = sc->F; - return(nv); -} - -static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice) -{ - switch (choice) - { - case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS: return(make_boolean(sc, sc->accept_all_keyword_arguments)); - case SL_AUTOLOADING: return(s7_make_boolean(sc, sc->is_autoloading)); - case SL_BIGNUM_PRECISION: return(make_integer(sc, sc->bignum_precision)); - case SL_CATCHES: return(sl_active_catches(sc)); - case SL_CPU_TIME: return(s7_make_real(sc, (double)clock() / (double)CLOCKS_PER_SEC)); /* cpu, not wall-clock time */ - case SL_C_TYPES: return(sl_c_types(sc)); - case SL_DEBUG: return(make_integer(sc, sc->debug)); - case SL_DEFAULT_HASH_TABLE_LENGTH: return(make_integer(sc, sc->default_hash_table_length)); - case SL_DEFAULT_RANDOM_STATE: return(sc->default_random_state); - case SL_DEFAULT_RATIONALIZE_ERROR: return(make_real(sc, sc->default_rationalize_error)); - case SL_EQUIVALENT_FLOAT_EPSILON: return(s7_make_real(sc, sc->equivalent_float_epsilon)); - case SL_EXPANSIONS: return(s7_make_boolean(sc, sc->is_expanding)); - case SL_FILE_NAMES: case SL_FILENAMES: return(sl_file_names(sc)); - case SL_FLOAT_FORMAT_PRECISION: return(make_integer(sc, sc->float_format_precision)); - case SL_FREE_HEAP_SIZE: return(make_integer(sc, sc->free_heap_top - sc->free_heap)); - case SL_GC_FREED: return(make_integer(sc, sc->gc_freed)); - case SL_GC_INFO: return(list_3(sc, make_integer(sc, sc->gc_calls), make_integer(sc, sc->gc_total_time), make_integer(sc, ticks_per_second()))); - case SL_GC_PROTECTED_OBJECTS: return(sl_protected_objects(sc)); - case SL_GC_RESIZE_HEAP_BY_4_FRACTION: return(make_real(sc, sc->gc_resize_heap_by_4_fraction)); - case SL_GC_RESIZE_HEAP_FRACTION: return(make_real(sc, sc->gc_resize_heap_fraction)); - case SL_GC_STATS: return(make_integer(sc, sc->gc_stats)); - case SL_GC_TEMPS_SIZE: return(make_integer(sc, sc->gc_temps_size)); - case SL_GC_TOTAL_FREED: return(make_integer(sc, sc->gc_total_freed)); - case SL_HASH_TABLE_FLOAT_EPSILON: return(s7_make_real(sc, sc->hash_table_float_epsilon)); - case SL_HEAP_SIZE: return(make_integer(sc, sc->heap_size)); - case SL_HISTORY: return(sl_history(sc)); - case SL_HISTORY_ENABLED: return(s7_make_boolean(sc, s7_history_enabled(sc))); - case SL_HISTORY_SIZE: return(make_integer(sc, sc->history_size)); - case SL_INITIAL_STRING_PORT_LENGTH: return(make_integer(sc, sc->initial_string_port_length)); - case SL_MAJOR_VERSION: return(make_integer(sc, S7_MAJOR_VERSION)); - case SL_MINOR_VERSION: return(make_integer(sc, S7_MINOR_VERSION)); - case SL_MAX_FORMAT_LENGTH: return(make_integer(sc, sc->max_format_length)); - case SL_MAX_HEAP_SIZE: return(make_integer(sc, sc->max_heap_size)); - case SL_MAX_LIST_LENGTH: return(make_integer(sc, sc->max_list_length)); - case SL_MAX_PORT_DATA_SIZE: return(make_integer(sc, sc->max_port_data_size)); - case SL_MAX_STACK_SIZE: return(make_integer(sc, sc->max_stack_size)); - case SL_MAX_STRING_LENGTH: return(make_integer(sc, sc->max_string_length)); - case SL_MAX_VECTOR_DIMENSIONS: return(make_integer(sc, sc->max_vector_dimensions)); - case SL_MAX_VECTOR_LENGTH: return(make_integer(sc, sc->max_vector_length)); - case SL_MEMORY_USAGE: return(memory_usage(sc)); - case SL_MOST_NEGATIVE_FIXNUM: return(sl_int_fixup(sc, leastfix)); - case SL_MOST_POSITIVE_FIXNUM: return(sl_int_fixup(sc, mostfix)); - case SL_MUFFLE_WARNINGS: return(s7_make_boolean(sc, sc->muffle_warnings)); - case SL_NUMBER_SEPARATOR: return(chars[(int)(sc->number_separator)]); - case SL_OPENLETS: return(s7_make_boolean(sc, sc->has_openlets)); - case SL_OUTPUT_PORT_DATA_SIZE: return(make_integer(sc, sc->output_port_data_size)); - case SL_PRINT_LENGTH: return(make_integer(sc, sc->print_length)); - case SL_PROFILE: return(make_integer(sc, sc->profile)); - case SL_PROFILE_INFO: return(profile_info_out(sc)); - case SL_PROFILE_PREFIX: return(sc->profile_prefix); - case SL_ROOTLET_SIZE: return(make_integer(sc, sc->rootlet_entries)); - case SL_SAFETY: return(make_integer(sc, sc->safety)); - case SL_STACK: return(sl_stack_entries(sc, sc->stack, current_stack_top(sc))); - case SL_STACKTRACE_DEFAULTS: return(sc->stacktrace_defaults); - case SL_STACK_SIZE: return(make_integer(sc, sc->stack_size)); - case SL_STACK_TOP: return(make_integer(sc, (sc->stack_end - sc->stack_start) / 4)); - case SL_UNDEFINED_CONSTANT_WARNINGS: return(s7_make_boolean(sc, sc->undefined_constant_warnings)); - case SL_UNDEFINED_IDENTIFIER_WARNINGS: return(s7_make_boolean(sc, sc->undefined_identifier_warnings)); - case SL_VERSION: return(s7_make_string(sc, "s7 " S7_VERSION ", " S7_DATE)); - } - return(sc->undefined); -} - -s7_pointer s7_starlet_ref(s7_scheme *sc, s7_pointer sym) /* s7.h, not used here */ -{ - if (is_symbol(sym)) - { - if (is_keyword(sym)) - sym = keyword_symbol(sym); - if (s7_starlet_symbol(sym) != SL_NO_FIELD) - return(s7_starlet(sc, s7_starlet_symbol(sym))); - } - return(sc->undefined); -} - -s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer sym) {return(s7_starlet_ref(sc, sym));} - -static s7_pointer g_s7_starlet_ref_fallback(s7_scheme *sc, s7_pointer args) -{ - s7_pointer sym = cadr(args); - if (!is_symbol(sym)) - sole_arg_wrong_type_error_nr(sc, sc->let_ref_symbol, sym, sc->type_names[T_SYMBOL]); - if (is_keyword(sym)) - sym = keyword_symbol(sym); - return(s7_starlet(sc, s7_starlet_symbol(sym))); -} - -static s7_pointer s7_starlet_iterate(s7_scheme *sc, s7_pointer iterator) -{ - s7_pointer symbol, value; - iterator_position(iterator)++; - if (iterator_position(iterator) >= SL_NUM_FIELDS) - return(iterator_quit(iterator)); - symbol = make_symbol_with_strlen(sc, s7_starlet_names[iterator_position(iterator)]); - - if ((iterator_position(iterator) == SL_STACK) || - (iterator_position(iterator) == SL_GC_PROTECTED_OBJECTS) || - (iterator_position(iterator) == SL_MEMORY_USAGE)) - value = sc->F; /* (format #f "~W" (inlet *s7*)) or (let->list *s7*) etc */ - else - { - s7_pointer osw = sc->w; /* protect against s7_starlet list making */ - value = s7_starlet(sc, s7_starlet_symbol(symbol)); - sc->w = osw; - } - if (iterator_let_cons(iterator)) - { - s7_pointer p = iterator_let_cons(iterator); - set_car(p, symbol); - set_cdr(p, value); - return(p); - } - return(cons(sc, symbol, value)); -} - -static s7_pointer s7_starlet_make_iterator(s7_scheme *sc, s7_pointer iter) -{ - iterator_position(iter) = SL_NO_FIELD; - iterator_next(iter) = s7_starlet_iterate; - iterator_let_cons(iter) = NULL; - return(iter); -} - -static s7_pointer sl_real_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - if (!is_real(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_REAL]); - if (s7_real(val) < 0.0) s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25)); - return(val); -} - -static s7_pointer sl_integer_gt_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - if (!s7_is_integer(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - if (s7_integer_clamped_if_gmp(sc, val) <= 0) s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be positive", 21)); - return(val); -} - -static s7_pointer sl_integer_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - if (!s7_is_integer(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - if (s7_integer_clamped_if_gmp(sc, val) < 0) s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25)); - return(val); -} - -#if WITH_HISTORY -static void sl_set_history_size(s7_scheme *sc, s7_int iv) -{ - s7_pointer p1, p2; - if (iv > MAX_HISTORY_SIZE) iv = MAX_HISTORY_SIZE; - if (iv > sc->true_history_size) - { - /* splice in the new cells, reattach the circles */ - s7_pointer p3; - s7_pointer next1 = cdr(sc->eval_history1); - s7_pointer next2 = cdr(sc->eval_history2); - s7_pointer next3 = cdr(sc->history_pairs); - set_cdr(sc->eval_history1, semipermanent_list(sc, iv - sc->true_history_size)); - set_cdr(sc->eval_history2, semipermanent_list(sc, iv - sc->true_history_size)); - set_cdr(sc->history_pairs, semipermanent_list(sc, iv - sc->true_history_size)); - for (p3 = cdr(sc->history_pairs); is_pair(cdr(p3)); p3 = cdr(p3)) set_car(p3, semipermanent_list(sc, 1)); - set_car(p3, semipermanent_list(sc, 1)); - set_cdr(p3, next3); - for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); - set_cdr(p1, next1); - set_cdr(p2, next2); - sc->true_history_size = iv; - } - sc->history_size = iv; - /* clear out both buffers to avoid GC confusion */ - for (p1 = sc->eval_history1, p2 = sc->eval_history2; ; p2 = cdr(p2)) - { - set_car(p1, sc->nil); - set_car(p2, sc->nil); - p1 = cdr(p1); - if (p1 == sc->eval_history1) break; - } -} -#endif - -#if WITH_GMP -static s7_pointer set_bignum_precision(s7_scheme *sc, int32_t precision) -{ - mp_prec_t bits = (mp_prec_t)precision; - s7_pointer bpi; - if (precision <= 1) /* (set! (*s7* 'bignum-precision) 1) causes mpfr to segfault! (also 0 and -1) */ - sole_arg_out_of_range_error_nr(sc, wrap_string(sc, "set! (*s7* 'bignum-precision)", 29), wrap_integer(sc, precision), wrap_string(sc, "has to be greater than 1", 24)); - mpfr_set_default_prec(bits); - mpc_set_default_precision(bits); - bpi = big_pi(sc); - s7_symbol_set_value(sc, sc->pi_symbol, bpi); - slot_set_value(initial_slot(sc->pi_symbol), bpi); /* if #_pi occurs after precision set, make sure #_pi is still legit (not a free cell) */ - return(sc->F); -} -#endif - -static noreturn void sl_unsettable_error_nr(s7_scheme *sc, s7_pointer sym) -{ - error_nr(sc, sc->immutable_error_symbol, set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S)", 20), sym)); -} - -static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - s7_int iv; - - if ((S7_DEBUGGING) && (!is_symbol(sym))) - { - fprintf(stderr, "%s: %s\n", __func__, display(sym)); - sole_arg_wrong_type_error_nr(sc, sc->let_set_symbol, sym, sc->type_names[T_SYMBOL]); - } - if (is_keyword(sym)) - sym = keyword_symbol(sym); - - switch (s7_starlet_symbol(sym)) - { - case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS: - if (is_boolean(val)) {sc->accept_all_keyword_arguments = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_AUTOLOADING: - if (is_boolean(val)) {sc->is_autoloading = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_BIGNUM_PRECISION: - iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); - sc->bignum_precision = iv; -#if WITH_GMP - set_bignum_precision(sc, sc->bignum_precision); - mpfr_set_prec(sc->mpfr_1, sc->bignum_precision); - mpfr_set_prec(sc->mpfr_2, sc->bignum_precision); - mpc_set_prec(sc->mpc_1, sc->bignum_precision); - mpc_set_prec(sc->mpc_2, sc->bignum_precision); -#endif - return(val); - - case SL_CATCHES: - case SL_CPU_TIME: - case SL_C_TYPES: - sl_unsettable_error_nr(sc, sym); - - case SL_DEBUG: - if (!s7_is_integer(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - sc->debug = s7_integer_clamped_if_gmp(sc, val); - sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0)); - if ((sc->debug > 0) && - (!is_memq(make_symbol(sc, "debug.scm", 9), s7_symbol_value(sc, sc->features_symbol)))) - s7_load(sc, "debug.scm"); - return(val); - - case SL_DEFAULT_HASH_TABLE_LENGTH: - sc->default_hash_table_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); - return(val); - - case SL_DEFAULT_RANDOM_STATE: - if (is_random_state(val)) - { -#if (!WITH_GMP) - random_seed(sc->default_random_state) = random_seed(val); - random_carry(sc->default_random_state) = random_carry(val); -#endif - return(val); - } - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_RANDOM_STATE]); - - case SL_DEFAULT_RATIONALIZE_ERROR: - sc->default_rationalize_error = s7_real(sl_real_geq_0(sc, sym, val)); - return(val); - - case SL_EQUIVALENT_FLOAT_EPSILON: - sc->equivalent_float_epsilon = s7_real(sl_real_geq_0(sc, sym, val)); - return(val); - - case SL_EXPANSIONS: - if (is_boolean(val)) {sc->is_expanding = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_FILE_NAMES: case SL_FILENAMES: sl_unsettable_error_nr(sc, sym); - - case SL_FLOAT_FORMAT_PRECISION: /* float-format-precision should not be huge => hangs in snprintf -- what's a reasonable limit here? */ - iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); - sc->float_format_precision = (iv < MAX_FLOAT_FORMAT_PRECISION) ? iv : MAX_FLOAT_FORMAT_PRECISION; - return(val); - - case SL_FREE_HEAP_SIZE: - case SL_GC_FREED: - case SL_GC_TOTAL_FREED: - case SL_GC_PROTECTED_OBJECTS: sl_unsettable_error_nr(sc, sym); - - case SL_GC_TEMPS_SIZE: sc->gc_temps_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_GC_RESIZE_HEAP_FRACTION: sc->gc_resize_heap_fraction = s7_real(sl_real_geq_0(sc, sym, val)); return(val); - case SL_GC_RESIZE_HEAP_BY_4_FRACTION: sc->gc_resize_heap_by_4_fraction = s7_real(sl_real_geq_0(sc, sym, val)); return(val); - - case SL_GC_STATS: - if (is_boolean(val)) - { - sc->gc_stats = ((val == sc->T) ? GC_STATS : 0); - return(val); - } - if (!s7_is_integer(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - sc->gc_stats = s7_integer_clamped_if_gmp(sc, val); - if (sc->gc_stats < 16) /* gc_stats is uint32_t */ - return(val); - sc->gc_stats = 0; - s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between 0 and 15", 29)); - - case SL_GC_INFO: /* ticks_per_second is not settable */ - if (val == sc->F) - { - sc->gc_total_time = 0; - sc->gc_calls = 0; - } - else - if ((is_pair(val)) && (s7_is_integer(car(val))) && - (is_pair(cdr(val))) && (s7_is_integer(cadr(val))) && - (is_pair(cddr(val))) && (s7_is_integer(caddr(val)))) - { - sc->gc_total_time = s7_integer(car(val)); - sc->gc_calls = s7_integer(cadr(val)); - } - else s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f or a list of three integers", 30)); - return(sc->F); - - case SL_HASH_TABLE_FLOAT_EPSILON: - sc->hash_table_float_epsilon = s7_real(sl_real_geq_0(sc, sym, val)); - return(val); - - case SL_HEAP_SIZE: - iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); - if (iv > sc->heap_size) - resize_heap_to(sc, iv); - return(val); - - case SL_HISTORY: /* (set! (*s7* 'history) val) */ - replace_current_code(sc, val); - return(val); - - case SL_HISTORY_ENABLED: /* (set! (*s7* 'history-enabled) #f|#t) */ - if (is_boolean(val)) - return(s7_make_boolean(sc, s7_set_history_enabled(sc, s7_boolean(sc, val)))); - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_HISTORY_SIZE: - iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); -#if WITH_HISTORY - sl_set_history_size(sc, iv); -#else - sc->history_size = iv; -#endif - return(val); - - case SL_INITIAL_STRING_PORT_LENGTH: sc->initial_string_port_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_FORMAT_LENGTH: sc->max_format_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_HEAP_SIZE: sc->max_heap_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_LIST_LENGTH: sc->max_list_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_PORT_DATA_SIZE: sc->max_port_data_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - - case SL_MAX_STACK_SIZE: - iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); - if (iv < INITIAL_STACK_SIZE) - s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than the initial stack size", 48)); - sc->max_stack_size = (uint32_t)iv; - return(val); - - case SL_MAX_STRING_LENGTH: sc->max_string_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_VECTOR_DIMENSIONS: sc->max_vector_dimensions = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_MAX_VECTOR_LENGTH: sc->max_vector_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - - case SL_MEMORY_USAGE: - case SL_MOST_NEGATIVE_FIXNUM: - case SL_MOST_POSITIVE_FIXNUM: sl_unsettable_error_nr(sc, sym); - - case SL_MUFFLE_WARNINGS: - if (is_boolean(val)) {sc->muffle_warnings = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_NUMBER_SEPARATOR: /* I think no PL uses the separator in output */ -#if (!WITH_NUMBER_SEPARATOR) - s7_warn(sc, 128, "(set! (*s7* 'number-separator) ...) but number-separator is not included in this s7"); -#endif - if (!is_character(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_CHARACTER]); - if ((is_char_numeric(val)) || (is_char_whitespace(val)) || (!t_number_separator_p[character(val)]) || - (character(val) == 'i') || (character(val) == 'e') || (character(val) == 'E')) - /* I guess +nan.0 and +inf.0 are not numeric literals, so we don't need to catch +n_a_n.0 */ - s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a printing, non-numeric character", 33)); - sc->number_separator = character(val); - return(val); - - case SL_OPENLETS: - if (is_boolean(val)) {sc->has_openlets = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_OUTPUT_PORT_DATA_SIZE: sc->output_port_data_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); - case SL_PRINT_LENGTH: sc->print_length = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); return(val); - - case SL_PROFILE: - if (!s7_is_integer(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - sc->profile = s7_integer_clamped_if_gmp(sc, val); - sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0)); - if (sc->profile > 0) - { - if (!is_memq(make_symbol(sc, "profile.scm", 11), s7_symbol_value(sc, sc->features_symbol))) - s7_load(sc, "profile.scm"); - if (!sc->profile_data) - make_profile_info(sc); - if (!sc->profile_out) - sc->profile_out = s7_make_function(sc, "profile-out", g_profile_out, 2, 0, false, NULL); - } - return(val); - - case SL_PROFILE_INFO: - if (val != sc->F) s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f (to clear the table)", 23)); - clear_profile_info(sc); - - case SL_PROFILE_PREFIX: - if ((is_symbol(val)) || val == sc->F) {sc->profile_prefix = val; return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a symbol or #f", 14)); - - case SL_ROOTLET_SIZE: sl_unsettable_error_nr(sc, sym); - - case SL_SAFETY: - if (!s7_is_integer(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); - if ((s7_integer_clamped_if_gmp(sc, val) > 2) || (s7_integer_clamped_if_gmp(sc, val) < -1)) - s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between -1 (no safety) and 2 (max safety)", 54)); - sc->safety = s7_integer_clamped_if_gmp(sc, val); - return(val); - - case SL_STACKTRACE_DEFAULTS: - if (!is_pair(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_PAIR]); - if (s7_list_length(sc, val) != 5) - s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a list with 5 entries", 21)); - if (!is_t_integer(car(val))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 1, car(val), wrap_string(sc, "an integer (stack frames)", 25), val); - if (!is_t_integer(cadr(val))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 2, cadr(val), wrap_string(sc, "an integer (cols-for-data)", 26), val); - if (!is_t_integer(caddr(val))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 3, caddr(val), wrap_string(sc, "an integer (line length)", 24), val); - if (!is_t_integer(cadddr(val))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 4, cadddr(val), wrap_string(sc, "an integer (comment position)", 29), val); - if (!is_boolean(s7_list_ref(sc, val, 4))) - sl_stacktrace_wrong_type_error_nr(sc, sym, 5, s7_list_ref(sc, val, 4), wrap_string(sc, "a boolean (treat-data-as-comment)", 33), val); - sc->stacktrace_defaults = copy_proper_list(sc, val); - return(val); - - case SL_STACK: - case SL_STACK_SIZE: - case SL_STACK_TOP: sl_unsettable_error_nr(sc, sym); - - case SL_UNDEFINED_CONSTANT_WARNINGS: - if (is_boolean(val)) {sc->undefined_constant_warnings = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_UNDEFINED_IDENTIFIER_WARNINGS: - if (is_boolean(val)) {sc->undefined_identifier_warnings = s7_boolean(sc, val); return(val);} - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); - - case SL_VERSION: sl_unsettable_error_nr(sc, sym); - - default: - error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S); no such field in *s7*", 43), sym)); - } - return(sc->undefined); -} - -s7_pointer s7_starlet_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value) -{ - if (is_symbol(sym)) - { - if (is_keyword(sym)) - sym = keyword_symbol(sym); - if (s7_starlet_symbol(sym) != SL_NO_FIELD) - return(s7_starlet_set_1(sc, sym, new_value)); - } - return(sc->undefined); -} - -s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value) {return(s7_starlet_set(sc, sym, new_value));} - -static void init_s7_starlet_immutable_field(void) -{ - s7_starlet_immutable_field = (bool *)Calloc(SL_NUM_FIELDS, sizeof(bool)); - s7_starlet_immutable_field[SL_CATCHES] = true; - s7_starlet_immutable_field[SL_CPU_TIME] = true; - s7_starlet_immutable_field[SL_C_TYPES] = true; - s7_starlet_immutable_field[SL_FILE_NAMES] = true; - s7_starlet_immutable_field[SL_FILENAMES] = true; - s7_starlet_immutable_field[SL_FREE_HEAP_SIZE] = true; - s7_starlet_immutable_field[SL_GC_FREED] = true; - s7_starlet_immutable_field[SL_GC_TOTAL_FREED] = true; - s7_starlet_immutable_field[SL_GC_PROTECTED_OBJECTS] = true; - s7_starlet_immutable_field[SL_MEMORY_USAGE] = true; - s7_starlet_immutable_field[SL_MOST_NEGATIVE_FIXNUM] = true; - s7_starlet_immutable_field[SL_MOST_POSITIVE_FIXNUM] = true; - s7_starlet_immutable_field[SL_ROOTLET_SIZE] = true; - s7_starlet_immutable_field[SL_STACK] = true; - s7_starlet_immutable_field[SL_STACK_SIZE] = true; - s7_starlet_immutable_field[SL_STACK_TOP] = true; - s7_starlet_immutable_field[SL_VERSION] = true; - s7_starlet_immutable_field[SL_MAJOR_VERSION] = true; - s7_starlet_immutable_field[SL_MINOR_VERSION] = true; -} - - -/* ---------------- gdbinit annotated stacktrace ---------------- */ -#if (!MS_WINDOWS) -/* s7bt, s7btfull: gdb stacktrace decoding */ - -static const char *decoded_name(s7_scheme *sc, const s7_pointer p) -{ - if (p == sc->value) return("sc->value"); - if (p == sc->args) return("sc->args"); - if (p == sc->code) return("sc->code"); - if (p == sc->cur_code) return("sc->cur_code"); - if (p == sc->curlet) return("sc->curlet"); - if (p == sc->nil) return("()"); - if (p == sc->T) return("#t"); - if (p == sc->F) return("#f"); - if (p == eof_object) return("eof_object"); - if (p == sc->undefined) return("undefined"); - if (p == sc->unspecified) return("unspecified"); - if (p == sc->no_value) return("no_value"); - if (p == sc->unused) return("#"); - if (p == sc->symbol_table) return("symbol_table"); - if (p == sc->rootlet) return("rootlet"); - if (p == sc->s7_starlet) return("*s7*"); /* this is the function */ - if (p == sc->unlet) return("unlet"); - if (p == sc->error_port) return("error_port"); - if (p == sc->owlet) return("owlet"); - if (p == sc->standard_input) return("*stdin*"); - if (p == sc->standard_output) return("*stdout*"); - if (p == sc->standard_error) return("*stderr*"); - if (p == sc->else_symbol) return("else_symbol"); - if (p == current_input_port(sc)) return("current-input-port"); - if (p == current_output_port(sc)) return("current-output-port"); - return((p == sc->stack) ? "stack" : NULL); -} - -static bool is_decodable(s7_scheme *sc, const s7_pointer p) -{ - int32_t i; - s7_pointer *tp = sc->heap; - s7_pointer *heap_top = (s7_pointer *)(sc->heap + sc->heap_size); - - /* check symbol-table */ - for (i = 0; i < SYMBOL_TABLE_SIZE; i++) - for (s7_pointer x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) - { - s7_pointer sym = car(x); - if ((sym == p) || - ((is_global(sym)) && (is_slot(global_slot(sym))) && (p == global_value(sym)))) - return(true); - } - - for (i = 0; i < NUM_CHARS; i++) if (p == chars[i]) return(true); - for (i = 0; i < NUM_SMALL_INTS; i++) if (p == small_ints[i]) return(true); - - /* check the heap */ - while (tp < heap_top) - if (p == (*tp++)) - return(true); - return(false); -} - -char *s7_decode_bt(s7_scheme *sc) -{ - FILE *fp = fopen("gdb.txt", "r"); - if (fp) - { - int64_t size; - size_t bytes; - bool in_quotes = false, old_stop = sc->stop_at_error; - uint8_t *bt; - block_t *bt_block; - - sc->stop_at_error = false; - fseek(fp, 0, SEEK_END); - size = ftell(fp); - rewind(fp); - - bt_block = mallocate(sc, (size + 1) * sizeof(uint8_t)); - bt = (uint8_t *)block_data(bt_block); - bytes = fread(bt, sizeof(uint8_t), size, fp); - if (bytes != (size_t)size) - { - fclose(fp); - liberate(sc, bt_block); - return((char *)" oops "); - } - bt[size] = '\0'; - fclose(fp); - - for (int64_t i = 0; i < size; i++) - { - fputc(bt[i], stdout); - if ((bt[i] == '"') && ((i == 0) || (bt[i - 1] != '\\'))) - in_quotes = (!in_quotes); - else - if ((!in_quotes) && (i < size - 8) && - ((bt[i] == '=') && - (((bt[i + 1] == '0') && (bt[i + 2] == 'x')) || - ((bt[i + 1] == ' ') && (bt[i + 2] == '0') && (bt[i + 3] == 'x'))))) - { - void *vp; - int32_t vals = sscanf((const char *)(bt + i + 1), "%p", &vp); - if ((vp) && (vals == 1)) - { - int32_t k; - for (k = i + ((bt[i + 2] == 'x') ? 3 : 4); (k < size) && (is_digit(bt[k], 16)); k++); - if ((bt[k] != ' ') || (bt[k + 1] != '"')) - { - if (vp == (void *)sc) - { - if (bt[i + 1] == ' ') fputc(' ', stdout); - fprintf(stdout, "%s[s7]%s", BOLD_TEXT, UNBOLD_TEXT); - i = k - 1; - } - else - { - s7_pointer p = (s7_pointer)vp; - const char *dname = decoded_name(sc, p); - if (dname) - { - if (bt[i + 1] == ' ') fputc(' ', stdout); - fprintf(stdout, "%s[%s]%s", BOLD_TEXT, dname, UNBOLD_TEXT); - } - if ((dname) || (is_decodable(sc, p))) - { - if (bt[i + 1] == ' ') fputc(' ', stdout); - i = k - 1; - if (s7_is_valid(sc, p)) - { - s7_pointer strp = object_to_truncated_string(sc, p, 80); - if (dname) fprintf(stdout, " "); - fprintf(stdout, "%s%s%s", BOLD_TEXT, string_value(strp), UNBOLD_TEXT); - if ((is_pair(p)) && - (has_location(p))) - { - uint32_t line = pair_line_number(p), file = pair_file_number(p); - if (line > 0) - fprintf(stdout, " %s(%s[%u])%s", BOLD_TEXT, string_value(sc->file_names[file]), line, UNBOLD_TEXT); - }}}}}}}} - liberate(sc, bt_block); - sc->stop_at_error = old_stop; - } - return((char *)""); -} -#endif - - -/* -------------------------------- initialization -------------------------------- */ -static void init_fx_function(void) -{ - fx_function = (s7_function *)Calloc(NUM_OPS, sizeof(s7_function)); - - fx_function[HOP_SAFE_C_NC] = fx_c_nc; - fx_function[HOP_SAFE_C_S] = fx_c_s; - fx_function[HOP_SAFE_C_SC] = fx_c_sc; - fx_function[HOP_SAFE_C_CS] = fx_c_cs; - fx_function[HOP_SAFE_C_CQ] = fx_c_cq; - fx_function[HOP_SAFE_C_FF] = fx_c_ff; - fx_function[HOP_SAFE_C_SS] = fx_c_ss; - fx_function[HOP_SAFE_C_opNCq] = fx_c_opncq; - fx_function[HOP_SAFE_C_opSq] = fx_c_opsq; - fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq; - fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq; - fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq; - fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s; - fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c; - fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs; - fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq; - fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq; - fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c; - fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s; - fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq; - fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c; - fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c; - fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s; - fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq; - fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq; - fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq; - fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq; - fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq; - fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq; - fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq; - fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq; - fx_function[HOP_SAFE_C_op_opSqq] = fx_c_op_opsqq; - fx_function[HOP_SAFE_C_op_S_opSqq] = fx_c_op_s_opsqq; - fx_function[HOP_SAFE_C_op_opSq_Sq] = fx_c_op_opsq_sq; - fx_function[HOP_SAFE_C_op_opSSqq_S] = fx_c_op_opssqq_s; - - fx_function[HOP_SAFE_C_SSC] = fx_c_ssc; - fx_function[HOP_SAFE_C_SSS] = fx_c_sss; - fx_function[HOP_SAFE_C_SCS] = fx_c_scs; - fx_function[HOP_SAFE_C_SCC] = fx_c_scc; - fx_function[HOP_SAFE_C_CSS] = fx_c_css; - fx_function[HOP_SAFE_C_CSC] = fx_c_csc; - fx_function[HOP_SAFE_C_CCS] = fx_c_ccs; - fx_function[HOP_SAFE_C_NS] = fx_c_ns; - - fx_function[HOP_SAFE_C_A] = fx_c_a; - fx_function[HOP_SAFE_C_AA] = fx_c_aa; - fx_function[HOP_SAFE_C_SA] = fx_c_sa; - fx_function[HOP_SAFE_C_AS] = fx_c_as; - fx_function[HOP_SAFE_C_CA] = fx_c_ca; - fx_function[HOP_SAFE_C_AC] = fx_c_ac; - fx_function[HOP_SAFE_C_AAA] = fx_c_aaa; - fx_function[HOP_SAFE_C_CAC] = fx_c_cac; - fx_function[HOP_SAFE_C_CSA] = fx_c_csa; - fx_function[HOP_SAFE_C_SCA] = fx_c_sca; - fx_function[HOP_SAFE_C_SAS] = fx_c_sas; - fx_function[HOP_SAFE_C_SAA] = fx_c_saa; - fx_function[HOP_SAFE_C_SSA] = fx_c_ssa; - fx_function[HOP_SAFE_C_ASS] = fx_c_ass; - fx_function[HOP_SAFE_C_AGG] = fx_c_agg; - fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca; - fx_function[HOP_SAFE_C_NA] = fx_c_na; - fx_function[HOP_SAFE_C_4A] = fx_c_4a; - fx_function[HOP_SAFE_C_opAq] = fx_c_opaq; - fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq; - fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq; - fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s; - fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq; - fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq; - - fx_function[HOP_HASH_TABLE_INCREMENT] = fx_hash_table_increment; - - fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a; - fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a; - fx_function[HOP_SAFE_CLOSURE_A_A] = fx_safe_closure_a_a; - fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_safe_closure_ss_a; - fx_function[HOP_SAFE_CLOSURE_AA_A] = fx_safe_closure_aa_a; - fx_function[HOP_SAFE_CLOSURE_3S_A] = fx_safe_closure_3s_a; - fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s; - fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc; - fx_function[HOP_SAFE_CLOSURE_A_TO_SC] = fx_safe_closure_a_to_sc; - - fx_function[OP_COND_NA_NA] = fx_cond_na_na; -#if (!WITH_GMP) - fx_function[OP_CASE_A_I_S_A] = fx_case_a_i_s_a; -#endif - fx_function[OP_CASE_A_E_S_A] = fx_case_a_e_s_a; - fx_function[OP_CASE_A_G_S_A] = fx_case_a_g_s_a; - fx_function[OP_CASE_A_S_G_A] = fx_case_a_s_g_a; - fx_function[OP_IF_A_C_C] = fx_if_a_c_c; - fx_function[OP_IF_A_A] = fx_if_a_a; - fx_function[OP_IF_S_A_A] = fx_if_s_a_a; - fx_function[OP_IF_A_A_A] = fx_if_a_a_a; - fx_function[OP_IF_AND2_S_A] = fx_if_and2_s_a; - fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a; - fx_function[OP_IF_NOT_A_A_A] = fx_if_not_a_a_a; - fx_function[OP_IF_IS_TYPE_S_A_A] = fx_if_is_type_s_a_a; - fx_function[OP_OR_2A] = fx_or_2a; - fx_function[OP_OR_S_2] = fx_or_s_2; - fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2; - fx_function[OP_OR_3A] = fx_or_3a; - fx_function[OP_OR_N] = fx_or_n; - fx_function[OP_AND_2A] = fx_and_2a; - fx_function[OP_AND_S_2] = fx_and_s_2; - fx_function[OP_AND_3A] = fx_and_3a; - fx_function[OP_AND_N] = fx_and_n; - fx_function[OP_BEGIN_NA] = fx_begin_na; - fx_function[OP_BEGIN_AA] = fx_begin_aa; - fx_function[OP_LET_TEMP_A_A] = fx_let_temp_a_a; - fx_function[OP_IMPLICIT_S7_STARLET_REF_S] = fx_implicit_s7_starlet_ref_s; - fx_function[OP_WITH_LET_S] = fx_with_let_s; - - /* these are ok even if a "z" branch is taken -- in that case the body does not have the is_optimized bit, so is_fxable returns false */ - fx_function[OP_TC_AND_A_OR_A_LA] = fx_tc_and_a_or_a_la; - fx_function[OP_TC_OR_A_AND_A_LA] = fx_tc_or_a_and_a_la; - fx_function[OP_TC_OR_A_A_AND_A_A_LA] = fx_tc_or_a_a_and_a_a_la; - fx_function[OP_TC_AND_A_OR_A_LAA] = fx_tc_and_a_or_a_laa; - fx_function[OP_TC_OR_A_AND_A_LAA] = fx_tc_or_a_and_a_laa; - fx_function[OP_TC_AND_A_OR_A_L3A] = fx_tc_and_a_or_a_l3a; - fx_function[OP_TC_OR_A_AND_A_L3A] = fx_tc_or_a_and_a_l3a; - fx_function[OP_TC_AND_A_OR_A_A_LA] = fx_tc_and_a_or_a_a_la; - fx_function[OP_TC_OR_A_AND_A_A_LA] = fx_tc_or_a_and_a_a_la; - fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la; - fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z; - fx_function[OP_TC_COND_A_Z_LA] = fx_tc_cond_a_z_la; - fx_function[OP_TC_COND_A_LA_Z] = fx_tc_cond_a_la_z; - fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa; - fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z; - fx_function[OP_TC_COND_A_Z_LAA] = fx_tc_cond_a_z_laa; - fx_function[OP_TC_COND_A_LAA_Z] = fx_tc_cond_a_laa_z; - fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a; - fx_function[OP_TC_IF_A_L3A_Z] = fx_tc_if_a_l3a_z; - fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la; - fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z; - fx_function[OP_TC_COND_A_Z_A_Z_LA] = fx_tc_cond_a_z_a_z_la; - fx_function[OP_TC_COND_A_Z_A_LA_Z] = fx_tc_cond_a_z_a_la_z; - fx_function[OP_TC_AND_A_IF_A_Z_LA] = fx_tc_and_a_if_a_z_la; - fx_function[OP_TC_AND_A_IF_A_LA_Z] = fx_tc_and_a_if_a_la_z; - fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z; - fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa; - fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa; - fx_function[OP_TC_COND_A_Z_A_LAA_Z] = fx_tc_cond_a_z_a_laa_z; - fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a; - fx_function[OP_TC_CASE_LA] = fx_tc_case_la; - fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a; - fx_function[OP_TC_LET_IF_A_Z_LA] = fx_tc_let_if_a_z_la; - fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa; - fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa; - fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa; - fx_function[OP_TC_LET_COND] = fx_tc_let_cond; - fx_function[OP_TC_COND_A_Z_A_LAA_LAA] = fx_tc_cond_a_z_a_laa_laa; - - fx_function[OP_RECUR_IF_A_A_opA_LAq] = fx_recur_if_a_a_opa_laq; - fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a; - fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] = fx_recur_if_a_a_and_a_laa_laa; - fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] = fx_recur_cond_a_a_a_a_opla_laq; /* very few calls (only s7test) */ - fx_function[OP_RECUR_AND_A_OR_A_LAA_LAA] = fx_recur_and_a_or_a_laa_laa; /* very few calls (lint) */ -} - -static void init_opt_functions(s7_scheme *sc) -{ -#if (!WITH_PURE_S7) - s7_set_b_7pp_function(sc, global_value(sc->char_ci_lt_symbol), char_ci_lt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_ci_leq_symbol), char_ci_leq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_ci_gt_symbol), char_ci_gt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_ci_geq_symbol), char_ci_geq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_ci_eq_symbol), char_ci_eq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_lt_symbol), string_ci_lt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_leq_symbol), string_ci_leq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_gt_symbol), string_ci_gt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_geq_symbol), string_ci_geq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_ci_eq_symbol), string_ci_eq_b_7pp); - - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_lt_symbol), char_ci_lt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_leq_symbol), char_ci_leq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_gt_symbol), char_ci_gt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_geq_symbol), char_ci_geq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_eq_symbol), char_ci_eq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_lt_symbol), string_ci_lt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_leq_symbol), string_ci_leq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_gt_symbol), string_ci_gt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_geq_symbol), string_ci_geq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_eq_symbol), string_ci_eq_b_unchecked); - - s7_set_p_pp_function(sc, global_value(sc->vector_append_symbol), vector_append_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->vector_append_symbol), vector_append_p_ppp); - s7_set_i_i_function(sc, global_value(sc->integer_length_symbol), integer_length_i_i); - s7_set_i_7p_function(sc, global_value(sc->string_length_symbol), string_length_i_7p); - s7_set_i_7p_function(sc, global_value(sc->vector_length_symbol), vector_length_i_7p); - s7_set_p_p_function(sc, global_value(sc->vector_to_list_symbol), vector_to_list_p_p); - s7_set_p_p_function(sc, global_value(sc->string_to_list_symbol), string_to_list_p_p); - s7_set_p_p_function(sc, global_value(sc->vector_length_symbol), vector_length_p_p); - s7_set_b_7p_function(sc, global_value(sc->is_exact_symbol), is_exact_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_inexact_symbol), is_inexact_b_7p); - s7_set_p_p_function(sc, global_value(sc->exact_to_inexact_symbol), exact_to_inexact_p_p); - s7_set_p_p_function(sc, global_value(sc->inexact_to_exact_symbol), inexact_to_exact_p_p); -#endif - - s7_set_p_pp_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_p_pp); - s7_set_d_7pi_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7pi); - s7_set_d_7pii_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7pii); - s7_set_d_7piii_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7piii); - s7_set_d_7pid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7pid); - s7_set_d_7piid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7piid); - s7_set_d_7piiid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7piiid); - - s7_set_p_pp_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_p_pp); - s7_set_i_7pi_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7pi); - s7_set_i_7pii_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7pii); - s7_set_i_7piii_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7piii); - s7_set_i_7pii_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_i_7pii); - s7_set_i_7piii_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_i_7piii); - - s7_set_i_7pi_function(sc, global_value(sc->byte_vector_ref_symbol), byte_vector_ref_i_7pi); - s7_set_i_7pii_function(sc, global_value(sc->byte_vector_ref_symbol), byte_vector_ref_i_7pii); - s7_set_i_7pii_function(sc, global_value(sc->byte_vector_set_symbol), byte_vector_set_i_7pii); - s7_set_i_7piii_function(sc, global_value(sc->byte_vector_set_symbol), byte_vector_set_i_7piii); - - s7_set_p_pp_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pp); - s7_set_p_pi_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pi); - s7_set_p_pii_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pii); - s7_set_p_pip_function(sc, global_value(sc->vector_set_symbol), vector_set_p_pip); - s7_set_p_piip_function(sc, global_value(sc->vector_set_symbol), vector_set_p_piip); - s7_set_p_pi_unchecked_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pi_unchecked); - s7_set_p_pip_unchecked_function(sc, global_value(sc->vector_set_symbol), vector_set_p_pip_unchecked); - s7_set_p_ppp_function(sc, global_value(sc->vector_set_symbol), vector_set_p_ppp); - s7_set_p_ppp_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_p_ppp); - - s7_set_p_pp_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pp); - s7_set_p_pi_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pi); - s7_set_p_pip_function(sc, global_value(sc->list_set_symbol), list_set_p_pip); - s7_set_p_pi_unchecked_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pi_unchecked); - s7_set_p_pip_unchecked_function(sc, global_value(sc->list_set_symbol), list_set_p_pip_unchecked); - s7_set_p_p_function(sc, global_value(sc->cyclic_sequences_symbol), cyclic_sequences_p_p); - s7_set_p_pp_function(sc, global_value(sc->let_ref_symbol), let_ref); - s7_set_p_ppp_function(sc, global_value(sc->let_set_symbol), let_set); - s7_set_p_pi_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pi); - s7_set_p_pp_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pp); - s7_set_p_pip_function(sc, global_value(sc->string_set_symbol), string_set_p_pip); - s7_set_p_pi_unchecked_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pi_unchecked); - s7_set_p_pip_unchecked_function(sc, global_value(sc->string_set_symbol), string_set_p_pip_unchecked); - s7_set_p_pp_function(sc, global_value(sc->hash_table_ref_symbol), hash_table_ref_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->hash_table_set_symbol), hash_table_set_p_ppp); - - s7_set_p_ii_function(sc, global_value(sc->complex_symbol), complex_p_ii); - s7_set_p_dd_function(sc, global_value(sc->complex_symbol), complex_p_dd); - s7_set_p_i_function(sc, global_value(sc->number_to_string_symbol), number_to_string_p_i); - s7_set_p_p_function(sc, global_value(sc->number_to_string_symbol), number_to_string_p_p); - s7_set_p_pp_function(sc, global_value(sc->number_to_string_symbol), number_to_string_p_pp); - s7_set_p_p_function(sc, global_value(sc->string_to_number_symbol), string_to_number_p_p); - s7_set_p_pp_function(sc, global_value(sc->string_to_number_symbol), string_to_number_p_pp); - - s7_set_p_p_function(sc, global_value(sc->car_symbol), car_p_p); - s7_set_p_pp_function(sc, global_value(sc->set_car_symbol), set_car_p_pp); - s7_set_p_p_function(sc, global_value(sc->cdr_symbol), cdr_p_p); - s7_set_p_pp_function(sc, global_value(sc->set_cdr_symbol), set_cdr_p_pp); - s7_set_p_p_function(sc, global_value(sc->caar_symbol), caar_p_p); - s7_set_p_p_function(sc, global_value(sc->cadr_symbol), cadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cdar_symbol), cdar_p_p); - s7_set_p_p_function(sc, global_value(sc->cddr_symbol), cddr_p_p); - s7_set_p_p_function(sc, global_value(sc->caddr_symbol), caddr_p_p); - s7_set_p_p_function(sc, global_value(sc->caadr_symbol), caadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cadar_symbol), cadar_p_p); - s7_set_p_p_function(sc, global_value(sc->cdddr_symbol), cdddr_p_p); - s7_set_p_p_function(sc, global_value(sc->cdadr_symbol), cdadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cddar_symbol), cddar_p_p); - s7_set_p_p_function(sc, global_value(sc->cdaar_symbol), cdaar_p_p); - s7_set_p_p_function(sc, global_value(sc->caaar_symbol), caaar_p_p); - s7_set_p_p_function(sc, global_value(sc->caddar_symbol), caddar_p_p); - s7_set_p_p_function(sc, global_value(sc->caaddr_symbol), caaddr_p_p); - s7_set_p_p_function(sc, global_value(sc->cadddr_symbol), cadddr_p_p); - s7_set_p_p_function(sc, global_value(sc->cadadr_symbol), cadadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cddadr_symbol), cddadr_p_p); - s7_set_p_p_function(sc, global_value(sc->cdddar_symbol), cdddar_p_p); - s7_set_p_p_function(sc, global_value(sc->cddddr_symbol), cddddr_p_p); - - s7_set_p_p_function(sc, global_value(sc->string_symbol), string_p_p); - s7_set_p_p_function(sc, global_value(sc->string_to_symbol_symbol), string_to_symbol_p_p); - s7_set_p_p_function(sc, global_value(sc->symbol_to_string_symbol), symbol_to_string_p_p); - s7_set_p_p_function(sc, global_value(sc->symbol_symbol), string_to_symbol_p_p); - s7_set_p_pp_function(sc, global_value(sc->symbol_symbol), symbol_p_pp); - s7_set_p_function(sc, global_value(sc->newline_symbol), newline_p); - s7_set_p_p_function(sc, global_value(sc->newline_symbol), newline_p_p); - s7_set_p_p_function(sc, global_value(sc->display_symbol), display_p_p); - s7_set_p_pp_function(sc, global_value(sc->display_symbol), display_p_pp); - s7_set_p_p_function(sc, global_value(sc->write_symbol), write_p_p); - s7_set_p_pp_function(sc, global_value(sc->write_symbol), write_p_pp); - s7_set_p_p_function(sc, global_value(sc->write_char_symbol), write_char_p_p); - s7_set_p_pp_function(sc, global_value(sc->write_char_symbol), write_char_p_pp); - s7_set_p_pp_function(sc, global_value(sc->write_string_symbol), write_string_p_pp); - s7_set_p_pp_function(sc, global_value(sc->read_line_symbol), read_line_p_pp); - s7_set_p_p_function(sc, global_value(sc->read_line_symbol), read_line_p_p); - s7_set_p_pp_function(sc, global_value(sc->inlet_symbol), inlet_p_pp); - s7_set_i_7p_function(sc, global_value(sc->port_line_number_symbol), s7_port_line_number); - s7_set_p_pp_function(sc, global_value(sc->cons_symbol), cons_p_pp); - s7_set_p_function(sc, global_value(sc->open_output_string_symbol), s7_open_output_string); - s7_set_p_ppi_function(sc, global_value(sc->char_position_symbol), char_position_p_ppi); - s7_set_p_pp_function(sc, global_value(sc->append_symbol), s7_append); - s7_set_p_pp_function(sc, global_value(sc->string_append_symbol), string_append_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->append_symbol), append_p_ppp); - s7_set_p_function(sc, global_value(sc->values_symbol), values_p); - s7_set_p_p_function(sc, global_value(sc->values_symbol), values_p_p); - s7_set_p_pp_function(sc, global_value(sc->member_symbol), member_p_pp); - s7_set_p_pp_function(sc, global_value(sc->assoc_symbol), assoc_p_pp); - - s7_set_i_i_function(sc, global_value(sc->abs_symbol), abs_i_i); - s7_set_d_d_function(sc, global_value(sc->abs_symbol), abs_d_d); - s7_set_p_p_function(sc, global_value(sc->abs_symbol), abs_p_p); - s7_set_i_i_function(sc, global_value(sc->magnitude_symbol), magnitude_i_i); - s7_set_d_d_function(sc, global_value(sc->magnitude_symbol), magnitude_d_d); - s7_set_p_p_function(sc, global_value(sc->magnitude_symbol), magnitude_p_p); - - s7_set_p_d_function(sc, global_value(sc->sin_symbol), sin_p_d); - s7_set_p_p_function(sc, global_value(sc->sin_symbol), sin_p_p); - s7_set_p_d_function(sc, global_value(sc->cos_symbol), cos_p_d); - s7_set_p_p_function(sc, global_value(sc->cos_symbol), cos_p_p); - s7_set_p_p_function(sc, global_value(sc->tan_symbol), tan_p_p); - s7_set_p_p_function(sc, global_value(sc->asin_symbol), asin_p_p); - s7_set_p_p_function(sc, global_value(sc->acos_symbol), acos_p_p); - s7_set_p_p_function(sc, global_value(sc->sinh_symbol), sinh_p_p); - s7_set_p_p_function(sc, global_value(sc->cosh_symbol), cosh_p_p); - s7_set_p_p_function(sc, global_value(sc->asinh_symbol), asinh_p_p); - s7_set_p_p_function(sc, global_value(sc->acosh_symbol), acosh_p_p); - s7_set_p_p_function(sc, global_value(sc->atanh_symbol), atanh_p_p); - s7_set_p_p_function(sc, global_value(sc->tanh_symbol), tanh_p_p); - s7_set_d_d_function(sc, global_value(sc->sin_symbol), sin_d_d); - s7_set_d_d_function(sc, global_value(sc->cos_symbol), cos_d_d); - s7_set_d_d_function(sc, global_value(sc->sinh_symbol), sinh_d_d); - s7_set_p_d_function(sc, global_value(sc->sinh_symbol), sinh_p_d); - s7_set_d_d_function(sc, global_value(sc->cosh_symbol), cosh_d_d); - s7_set_p_d_function(sc, global_value(sc->cosh_symbol), cosh_p_d); - s7_set_d_d_function(sc, global_value(sc->exp_symbol), exp_d_d); - s7_set_p_d_function(sc, global_value(sc->exp_symbol), exp_p_d); - - s7_set_p_d_function(sc, global_value(sc->rationalize_symbol), rationalize_p_d); - s7_set_p_i_function(sc, global_value(sc->rationalize_symbol), rationalize_p_i); - s7_set_i_i_function(sc, global_value(sc->rationalize_symbol), rationalize_i_i); - s7_set_p_p_function(sc, global_value(sc->truncate_symbol), truncate_p_p); - s7_set_p_p_function(sc, global_value(sc->round_symbol), round_p_p); - s7_set_p_p_function(sc, global_value(sc->ceiling_symbol), ceiling_p_p); - s7_set_p_p_function(sc, global_value(sc->floor_symbol), floor_p_p); - s7_set_p_pp_function(sc, global_value(sc->max_symbol), max_p_pp); - s7_set_p_pp_function(sc, global_value(sc->min_symbol), min_p_pp); - s7_set_p_p_function(sc, global_value(sc->sqrt_symbol), sqrt_p_p); -#if (!WITH_GMP) - s7_set_p_pp_function(sc, global_value(sc->expt_symbol), expt_p_pp); - /* same problem affects big_log|logior|logand|logxor|lcm|gcd|rationalize|remainder|modulo -- *_p_* will fail in gmp s7 */ - s7_set_p_d_function(sc, global_value(sc->ceiling_symbol), ceiling_p_d); - s7_set_p_d_function(sc, global_value(sc->floor_symbol), floor_p_d); - s7_set_p_d_function(sc, global_value(sc->truncate_symbol), truncate_p_d); - s7_set_p_d_function(sc, global_value(sc->round_symbol), round_p_d); -#endif - s7_set_d_7dd_function(sc, global_value(sc->remainder_symbol), remainder_d_7dd); - s7_set_i_7ii_function(sc, global_value(sc->remainder_symbol), remainder_i_7ii); - s7_set_i_7ii_function(sc, global_value(sc->quotient_symbol), quotient_i_7ii); - s7_set_d_7dd_function(sc, global_value(sc->modulo_symbol), modulo_d_7dd); - s7_set_i_ii_function(sc, global_value(sc->modulo_symbol), modulo_i_ii); - s7_set_p_dd_function(sc, global_value(sc->multiply_symbol), mul_p_dd); - s7_set_p_dd_function(sc, global_value(sc->add_symbol), add_p_dd); - s7_set_p_ii_function(sc, global_value(sc->add_symbol), add_p_ii); - s7_set_p_dd_function(sc, global_value(sc->subtract_symbol), subtract_p_dd); - s7_set_p_ii_function(sc, global_value(sc->subtract_symbol), subtract_p_ii); - - s7_set_p_pp_function(sc, global_value(sc->modulo_symbol), modulo_p_pp); - s7_set_p_pi_function(sc, global_value(sc->modulo_symbol), modulo_p_pi); - s7_set_p_pp_function(sc, global_value(sc->remainder_symbol), remainder_p_pp); - s7_set_p_pi_function(sc, global_value(sc->remainder_symbol), remainder_p_pi); - s7_set_p_pp_function(sc, global_value(sc->quotient_symbol), quotient_p_pp); - s7_set_p_pi_function(sc, global_value(sc->quotient_symbol), quotient_p_pi); - s7_set_p_pp_function(sc, global_value(sc->subtract_symbol), subtract_p_pp); - s7_set_p_pp_function(sc, global_value(sc->add_symbol), add_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->add_symbol), add_p_ppp); - s7_set_p_pp_function(sc, global_value(sc->multiply_symbol), multiply_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->multiply_symbol), multiply_p_ppp); - s7_set_p_pp_function(sc, global_value(sc->divide_symbol), divide_p_pp); - s7_set_p_p_function(sc, global_value(sc->divide_symbol), invert_p_p); - s7_set_p_p_function(sc, global_value(sc->subtract_symbol), negate_p_p); - s7_set_p_p_function(sc, global_value(sc->is_even_symbol), is_even_p_p); - s7_set_p_p_function(sc, global_value(sc->is_odd_symbol), is_odd_p_p); - - s7_set_p_p_function(sc, global_value(sc->random_symbol), random_p_p); - s7_set_d_7d_function(sc, global_value(sc->random_symbol), random_d_7d); - s7_set_i_7i_function(sc, global_value(sc->random_symbol), random_i_7i); - - s7_set_p_d_function(sc, global_value(sc->float_vector_symbol), float_vector_p_d); - s7_set_p_i_function(sc, global_value(sc->int_vector_symbol), int_vector_p_i); - s7_set_i_i_function(sc, global_value(sc->round_symbol), round_i_i); - s7_set_i_i_function(sc, global_value(sc->floor_symbol), floor_i_i); - s7_set_i_i_function(sc, global_value(sc->ceiling_symbol), ceiling_i_i); - s7_set_i_i_function(sc, global_value(sc->truncate_symbol), truncate_i_i); - - s7_set_d_d_function(sc, global_value(sc->tan_symbol), tan_d_d); - s7_set_d_dd_function(sc, global_value(sc->atan_symbol), atan_d_dd); - s7_set_d_d_function(sc, global_value(sc->tanh_symbol), tanh_d_d); - s7_set_p_p_function(sc, global_value(sc->exp_symbol), exp_p_p); -#if (!WITH_GMP) - s7_set_i_7ii_function(sc, global_value(sc->ash_symbol), ash_i_7ii); - s7_set_i_7d_function(sc, global_value(sc->round_symbol), round_i_7d); - s7_set_i_7d_function(sc, global_value(sc->floor_symbol), floor_i_7d); - s7_set_i_7d_function(sc, global_value(sc->ceiling_symbol), ceiling_i_7d); - s7_set_i_7p_function(sc, global_value(sc->floor_symbol), floor_i_7p); - s7_set_i_7p_function(sc, global_value(sc->ceiling_symbol), ceiling_i_7p); - s7_set_i_7d_function(sc, global_value(sc->truncate_symbol), truncate_i_7d); -#endif - - s7_set_d_d_function(sc, global_value(sc->add_symbol), add_d_d); - s7_set_d_d_function(sc, global_value(sc->subtract_symbol), subtract_d_d); - s7_set_d_d_function(sc, global_value(sc->multiply_symbol), multiply_d_d); - s7_set_d_7d_function(sc, global_value(sc->divide_symbol), divide_d_7d); - s7_set_d_dd_function(sc, global_value(sc->add_symbol), add_d_dd); - s7_set_d_dd_function(sc, global_value(sc->subtract_symbol), subtract_d_dd); - s7_set_d_dd_function(sc, global_value(sc->multiply_symbol), multiply_d_dd); - s7_set_d_7dd_function(sc, global_value(sc->divide_symbol), divide_d_7dd); - s7_set_d_ddd_function(sc, global_value(sc->add_symbol), add_d_ddd); - s7_set_d_ddd_function(sc, global_value(sc->subtract_symbol), subtract_d_ddd); - s7_set_d_ddd_function(sc, global_value(sc->multiply_symbol), multiply_d_ddd); - s7_set_d_dddd_function(sc, global_value(sc->add_symbol), add_d_dddd); - s7_set_d_dddd_function(sc, global_value(sc->subtract_symbol), subtract_d_dddd); - s7_set_d_dddd_function(sc, global_value(sc->multiply_symbol), multiply_d_dddd); - s7_set_p_i_function(sc, global_value(sc->divide_symbol), divide_p_i); - s7_set_p_ii_function(sc, global_value(sc->divide_symbol), divide_p_ii); - s7_set_d_dd_function(sc, global_value(sc->max_symbol), max_d_dd); - s7_set_d_dd_function(sc, global_value(sc->min_symbol), min_d_dd); - s7_set_d_ddd_function(sc, global_value(sc->max_symbol), max_d_ddd); - s7_set_d_ddd_function(sc, global_value(sc->min_symbol), min_d_ddd); - s7_set_d_dddd_function(sc, global_value(sc->max_symbol), max_d_dddd); - s7_set_d_dddd_function(sc, global_value(sc->min_symbol), min_d_dddd); - s7_set_i_ii_function(sc, global_value(sc->max_symbol), max_i_ii); - s7_set_i_ii_function(sc, global_value(sc->min_symbol), min_i_ii); - s7_set_i_iii_function(sc, global_value(sc->max_symbol), max_i_iii); - s7_set_i_iii_function(sc, global_value(sc->min_symbol), min_i_iii); - s7_set_i_i_function(sc, global_value(sc->subtract_symbol), subtract_i_i); - s7_set_i_ii_function(sc, global_value(sc->add_symbol), add_i_ii); - s7_set_i_iii_function(sc, global_value(sc->add_symbol), add_i_iii); - s7_set_i_ii_function(sc, global_value(sc->subtract_symbol), subtract_i_ii); - s7_set_i_iii_function(sc, global_value(sc->subtract_symbol), subtract_i_iii); - s7_set_i_ii_function(sc, global_value(sc->multiply_symbol), multiply_i_ii); - s7_set_i_iii_function(sc, global_value(sc->multiply_symbol), multiply_i_iii); - - s7_set_i_i_function(sc, global_value(sc->lognot_symbol), lognot_i_i); - s7_set_i_ii_function(sc, global_value(sc->logior_symbol), logior_i_ii); - s7_set_i_ii_function(sc, global_value(sc->logxor_symbol), logxor_i_ii); - s7_set_i_ii_function(sc, global_value(sc->logand_symbol), logand_i_ii); - s7_set_i_iii_function(sc, global_value(sc->logior_symbol), logior_i_iii); - s7_set_i_iii_function(sc, global_value(sc->logxor_symbol), logxor_i_iii); - s7_set_i_iii_function(sc, global_value(sc->logand_symbol), logand_i_iii); - s7_set_b_7ii_function(sc, global_value(sc->logbit_symbol), logbit_b_7ii); - s7_set_b_7pp_function(sc, global_value(sc->logbit_symbol), logbit_b_7pp); - - s7_set_i_7p_function(sc, global_value(sc->numerator_symbol), numerator_i_7p); - s7_set_i_7p_function(sc, global_value(sc->denominator_symbol), denominator_i_7p); - s7_set_i_7p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_i_7p); - s7_set_i_7p_function(sc, global_value(sc->hash_table_entries_symbol), hash_table_entries_i_7p); - s7_set_i_7p_function(sc, global_value(sc->tree_leaves_symbol), tree_leaves_i_7p); - s7_set_p_p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_p_p); - - s7_set_b_p_function(sc, global_value(sc->is_boolean_symbol), s7_is_boolean); - s7_set_b_p_function(sc, global_value(sc->is_byte_symbol), is_byte); - s7_set_b_p_function(sc, global_value(sc->is_byte_vector_symbol), is_byte_vector_b_p); - s7_set_b_p_function(sc, global_value(sc->is_c_object_symbol), s7_is_c_object); - s7_set_b_p_function(sc, global_value(sc->is_char_symbol), s7_is_character); - s7_set_b_p_function(sc, global_value(sc->is_complex_symbol), s7_is_complex); - s7_set_b_p_function(sc, global_value(sc->is_continuation_symbol), is_continuation_b_p); - s7_set_b_p_function(sc, global_value(sc->is_c_pointer_symbol), s7_is_c_pointer); - s7_set_b_p_function(sc, global_value(sc->is_dilambda_symbol), s7_is_dilambda); - s7_set_b_p_function(sc, global_value(sc->is_eof_object_symbol), is_eof_object_b_p); - s7_set_b_7p_function(sc, global_value(sc->is_even_symbol), is_even_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_odd_symbol), is_odd_b_7p); - s7_set_b_p_function(sc, global_value(sc->is_float_symbol), is_float_b); - s7_set_b_p_function(sc, global_value(sc->is_float_vector_symbol), s7_is_float_vector); - s7_set_b_p_function(sc, global_value(sc->is_gensym_symbol), is_gensym_b_p); - s7_set_b_p_function(sc, global_value(sc->is_hash_table_symbol), s7_is_hash_table); - s7_set_b_7p_function(sc, global_value(sc->is_infinite_symbol), is_infinite_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_nan_symbol), is_nan_b_7p); - s7_set_b_p_function(sc, global_value(sc->is_input_port_symbol), is_input_port_b); - s7_set_b_p_function(sc, global_value(sc->is_integer_symbol), s7_is_integer); - s7_set_b_p_function(sc, global_value(sc->is_int_vector_symbol), s7_is_int_vector); - s7_set_b_p_function(sc, global_value(sc->is_keyword_symbol), s7_is_keyword); - s7_set_b_p_function(sc, global_value(sc->is_let_symbol), s7_is_let); - s7_set_b_p_function(sc, global_value(sc->is_list_symbol), is_list_b); - s7_set_b_p_function(sc, global_value(sc->is_macro_symbol), is_macro_b); - s7_set_b_p_function(sc, global_value(sc->is_number_symbol), s7_is_number); - s7_set_b_p_function(sc, global_value(sc->is_output_port_symbol), is_output_port_b); - s7_set_b_p_function(sc, global_value(sc->is_pair_symbol), s7_is_pair); - s7_set_b_p_function(sc, global_value(sc->is_null_symbol), is_null_b_p); - s7_set_b_7p_function(sc, global_value(sc->is_port_closed_symbol), is_port_closed_b_7p); - s7_set_b_p_function(sc, global_value(sc->is_procedure_symbol), s7_is_procedure); - s7_set_b_7p_function(sc, global_value(sc->is_proper_list_symbol), s7_is_proper_list); - s7_set_b_p_function(sc, global_value(sc->is_random_state_symbol), s7_is_random_state); - s7_set_b_p_function(sc, global_value(sc->is_rational_symbol), s7_is_rational); - s7_set_b_p_function(sc, global_value(sc->is_real_symbol), s7_is_real); - s7_set_b_p_function(sc, global_value(sc->is_sequence_symbol), is_sequence_b); - s7_set_b_p_function(sc, global_value(sc->is_string_symbol), s7_is_string); - s7_set_b_p_function(sc, global_value(sc->is_symbol_symbol), s7_is_symbol); - s7_set_b_p_function(sc, global_value(sc->is_syntax_symbol), s7_is_syntax); - s7_set_b_p_function(sc, global_value(sc->is_vector_symbol), s7_is_vector); - s7_set_b_7p_function(sc, global_value(sc->is_iterator_symbol), is_iterator_b_7p); - - s7_set_b_7p_function(sc, global_value(sc->is_char_alphabetic_symbol), is_char_alphabetic_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_char_lower_case_symbol), is_char_lower_case_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_char_numeric_symbol), is_char_numeric_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_char_upper_case_symbol), is_char_upper_case_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_char_whitespace_symbol), is_char_whitespace_b_7p); - - s7_set_b_p_function(sc, global_value(sc->is_openlet_symbol), s7_is_openlet); - s7_set_b_7p_function(sc, global_value(sc->iterator_is_at_end_symbol), iterator_is_at_end_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_zero_symbol), is_zero_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_negative_symbol), is_negative_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_positive_symbol), is_positive_b_7p); - s7_set_b_7p_function(sc, global_value(sc->not_symbol), not_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_provided_symbol), is_provided_b_7p); - s7_set_b_7p_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7p); - s7_set_b_7pp_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->tree_memq_symbol), s7_tree_memq); - s7_set_b_7p_function(sc, global_value(sc->tree_is_cyclic_symbol), tree_is_cyclic); - s7_set_b_7pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_b_7pp); - s7_set_p_pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_p_pp); - s7_set_b_p_function(sc, global_value(sc->is_immutable_symbol), s7_is_immutable); - - s7_set_p_p_function(sc, global_value(sc->is_proper_list_symbol), is_proper_list_p_p); - s7_set_p_p_function(sc, global_value(sc->is_pair_symbol), is_pair_p_p); - s7_set_p_p_function(sc, global_value(sc->is_char_symbol), is_char_p_p); - s7_set_p_p_function(sc, global_value(sc->is_constant_symbol), is_constant_p_p); - s7_set_b_7p_function(sc, global_value(sc->is_constant_symbol), is_constant_b_7p); - s7_set_p_p_function(sc, global_value(sc->type_of_symbol), s7_type_of); - s7_set_p_i_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_i); - s7_set_p_p_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_p); - s7_set_p_p_function(sc, global_value(sc->iterate_symbol), iterate_p_p); - s7_set_p_p_function(sc, global_value(sc->list_symbol), list_p_p); - s7_set_p_pp_function(sc, global_value(sc->list_symbol), list_p_pp); - s7_set_p_ppp_function(sc, global_value(sc->list_symbol), list_p_ppp); - s7_set_p_pp_function(sc, global_value(sc->list_tail_symbol), list_tail_p_pp); - s7_set_p_pp_function(sc, global_value(sc->make_list_symbol), make_list_p_pp); - s7_set_p_pp_function(sc, global_value(sc->assq_symbol), assq_p_pp); - s7_set_p_pp_function(sc, global_value(sc->assv_symbol), assv_p_pp); - s7_set_p_pp_function(sc, global_value(sc->memq_symbol), memq_p_pp); - s7_set_p_pp_function(sc, global_value(sc->memv_symbol), memv_p_pp); - s7_set_p_p_function(sc, global_value(sc->tree_leaves_symbol), tree_leaves_p_p); - s7_set_p_p_function(sc, global_value(sc->length_symbol), s7_length); - s7_set_p_p_function(sc, global_value(sc->pair_line_number_symbol), pair_line_number_p_p); - s7_set_p_p_function(sc, global_value(sc->port_line_number_symbol), port_line_number_p_p); - s7_set_p_p_function(sc, global_value(sc->port_filename_symbol), port_filename_p_p); - s7_set_p_p_function(sc, global_value(sc->c_pointer_info_symbol), c_pointer_info_p_p); - s7_set_p_p_function(sc, global_value(sc->c_pointer_type_symbol), c_pointer_type_p_p); - s7_set_p_p_function(sc, global_value(sc->c_pointer_weak1_symbol), c_pointer_weak1_p_p); - s7_set_p_p_function(sc, global_value(sc->c_pointer_weak2_symbol), c_pointer_weak2_p_p); - s7_set_p_p_function(sc, global_value(sc->is_char_alphabetic_symbol), is_char_alphabetic_p_p); - s7_set_p_p_function(sc, global_value(sc->is_char_whitespace_symbol), is_char_whitespace_p_p); - s7_set_p_p_function(sc, global_value(sc->is_char_numeric_symbol), is_char_numeric_p_p); - s7_set_p_p_function(sc, global_value(sc->char_upcase_symbol), char_upcase_p_p); - s7_set_p_p_function(sc, global_value(sc->read_char_symbol), read_char_p_p); - s7_set_p_i_function(sc, global_value(sc->make_string_symbol), make_string_p_i); - s7_set_p_ii_function(sc, global_value(sc->make_int_vector_symbol), make_int_vector_p_ii); - s7_set_p_ii_function(sc, global_value(sc->make_byte_vector_symbol), make_byte_vector_p_ii); - s7_set_p_pp_function(sc, global_value(sc->vector_symbol), vector_p_pp); - s7_set_p_p_function(sc, global_value(sc->signature_symbol), s7_signature); - s7_set_p_p_function(sc, global_value(sc->copy_symbol), copy_p_p); - s7_set_p_p_function(sc, global_value(sc->reverse_symbol), reverse_p_p); - s7_set_p_p_function(sc, global_value(sc->object_to_let_symbol), object_to_let_p_p); - s7_set_p_p_function(sc, global_value(sc->outlet_symbol), outlet_p_p); - s7_set_p_p_function(sc, global_value(sc->make_iterator_symbol), s7_make_iterator); - -#if WITH_SYSTEM_EXTRAS - s7_set_b_7p_function(sc, global_value(sc->is_directory_symbol), is_directory_b_7p); - s7_set_b_7p_function(sc, global_value(sc->file_exists_symbol), file_exists_b_7p); -#endif - - s7_set_b_i_function(sc, global_value(sc->is_even_symbol), is_even_i); - s7_set_b_i_function(sc, global_value(sc->is_odd_symbol), is_odd_i); - s7_set_b_i_function(sc, global_value(sc->is_zero_symbol), is_zero_i); - s7_set_b_d_function(sc, global_value(sc->is_zero_symbol), is_zero_d); - s7_set_p_p_function(sc, global_value(sc->is_zero_symbol), is_zero_p_p); - s7_set_p_p_function(sc, global_value(sc->is_positive_symbol), is_positive_p_p); - s7_set_p_p_function(sc, global_value(sc->is_negative_symbol), is_negative_p_p); - s7_set_p_p_function(sc, global_value(sc->real_part_symbol), real_part_p_p); - s7_set_p_p_function(sc, global_value(sc->imag_part_symbol), imag_part_p_p); - s7_set_b_i_function(sc, global_value(sc->is_positive_symbol), is_positive_i); - s7_set_b_d_function(sc, global_value(sc->is_positive_symbol), is_positive_d); - s7_set_b_i_function(sc, global_value(sc->is_negative_symbol), is_negative_i); - s7_set_b_d_function(sc, global_value(sc->is_negative_symbol), is_negative_d); - - s7_set_p_pi_function(sc, global_value(sc->lt_symbol), lt_p_pi); - s7_set_b_pi_function(sc, global_value(sc->lt_symbol), lt_b_pi); - s7_set_p_pi_function(sc, global_value(sc->leq_symbol), leq_p_pi); - s7_set_b_pi_function(sc, global_value(sc->leq_symbol), leq_b_pi); - s7_set_p_pi_function(sc, global_value(sc->gt_symbol), gt_p_pi); - s7_set_b_pi_function(sc, global_value(sc->gt_symbol), gt_b_pi); - s7_set_p_pi_function(sc, global_value(sc->geq_symbol), geq_p_pi); - s7_set_b_pi_function(sc, global_value(sc->geq_symbol), geq_b_pi); - /* no ip pd dp! */ - s7_set_b_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_b_pi); - s7_set_p_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pi); - s7_set_p_pi_function(sc, global_value(sc->add_symbol), add_p_pi); - s7_set_p_pi_function(sc, global_value(sc->subtract_symbol), g_sub_xi); - s7_set_p_pi_function(sc, global_value(sc->multiply_symbol), multiply_p_pi); - - s7_set_p_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_p_ii); - s7_set_p_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_p_dd); - s7_set_p_pp_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->num_eq_symbol), num_eq_b_7pp); - s7_set_b_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_b_ii); - s7_set_b_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_b_dd); - - s7_set_p_ii_function(sc, global_value(sc->lt_symbol), lt_p_ii); - s7_set_p_dd_function(sc, global_value(sc->lt_symbol), lt_p_dd); - s7_set_p_pp_function(sc, global_value(sc->lt_symbol), lt_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->lt_symbol), lt_b_7pp); - s7_set_b_ii_function(sc, global_value(sc->lt_symbol), lt_b_ii); - s7_set_b_dd_function(sc, global_value(sc->lt_symbol), lt_b_dd); - - s7_set_b_ii_function(sc, global_value(sc->leq_symbol), leq_b_ii); - s7_set_p_dd_function(sc, global_value(sc->leq_symbol), leq_p_dd); - s7_set_p_ii_function(sc, global_value(sc->leq_symbol), leq_p_ii); - s7_set_b_dd_function(sc, global_value(sc->leq_symbol), leq_b_dd); - s7_set_p_pp_function(sc, global_value(sc->leq_symbol), leq_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->leq_symbol), leq_b_7pp); - - s7_set_b_ii_function(sc, global_value(sc->gt_symbol), gt_b_ii); - s7_set_b_dd_function(sc, global_value(sc->gt_symbol), gt_b_dd); - s7_set_p_dd_function(sc, global_value(sc->gt_symbol), gt_p_dd); - s7_set_p_ii_function(sc, global_value(sc->gt_symbol), gt_p_ii); - s7_set_p_pp_function(sc, global_value(sc->gt_symbol), gt_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->gt_symbol), gt_b_7pp); - - s7_set_b_ii_function(sc, global_value(sc->geq_symbol), geq_b_ii); - s7_set_b_dd_function(sc, global_value(sc->geq_symbol), geq_b_dd); - s7_set_p_ii_function(sc, global_value(sc->geq_symbol), geq_p_ii); - s7_set_p_dd_function(sc, global_value(sc->geq_symbol), geq_p_dd); - s7_set_p_pp_function(sc, global_value(sc->geq_symbol), geq_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->geq_symbol), geq_b_7pp); - - s7_set_b_pp_function(sc, global_value(sc->is_eq_symbol), s7_is_eq); - s7_set_p_pp_function(sc, global_value(sc->is_eq_symbol), is_eq_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->is_eqv_symbol), s7_is_eqv); - s7_set_p_pp_function(sc, global_value(sc->is_eqv_symbol), is_eqv_p_pp); - s7_set_b_7pp_function(sc, global_value(sc->is_equal_symbol), s7_is_equal); - s7_set_b_7pp_function(sc, global_value(sc->is_equivalent_symbol), s7_is_equivalent); - s7_set_p_pp_function(sc, global_value(sc->is_equal_symbol), is_equal_p_pp); - s7_set_p_pp_function(sc, global_value(sc->is_equivalent_symbol), is_equivalent_p_pp); - s7_set_p_pp_function(sc, global_value(sc->char_eq_symbol), char_eq_p_pp); - s7_set_p_pp_function(sc, global_value(sc->make_float_vector_symbol), make_float_vector_p_pp); - s7_set_p_pp_function(sc, global_value(sc->setter_symbol), setter_p_pp); - s7_set_p_pp_function(sc, global_value(sc->complex_symbol), complex_p_pp); - s7_set_p_pp_function(sc, global_value(sc->string_eq_symbol), string_eq_p_pp); - s7_set_p_pp_function(sc, global_value(sc->string_lt_symbol), string_lt_p_pp); - s7_set_p_pp_function(sc, global_value(sc->string_gt_symbol), string_gt_p_pp); - - s7_set_b_7pp_function(sc, global_value(sc->char_lt_symbol), char_lt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_leq_symbol), char_leq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_gt_symbol), char_gt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_geq_symbol), char_geq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->char_eq_symbol), char_eq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_lt_symbol), string_lt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_leq_symbol), string_leq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_gt_symbol), string_gt_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_geq_symbol), string_geq_b_7pp); - s7_set_b_7pp_function(sc, global_value(sc->string_eq_symbol), string_eq_b_7pp); - - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_lt_symbol), char_lt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_leq_symbol), char_leq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_gt_symbol), char_gt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_geq_symbol), char_geq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->char_eq_symbol), char_eq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_lt_symbol), string_lt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_leq_symbol), string_leq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_gt_symbol), string_gt_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_geq_symbol), string_geq_b_unchecked); - s7_set_b_pp_unchecked_function(sc, global_value(sc->string_eq_symbol), string_eq_b_unchecked); - - s7_set_b_7pp_function(sc, global_value(sc->is_aritable_symbol), is_aritable_b_7pp); -} - -static void init_features(s7_scheme *sc) -{ - s7_provide(sc, "s7"); - s7_provide(sc, "s7-" S7_VERSION); - s7_provide(sc, "ratio"); - -#if WITH_PURE_S7 - s7_provide(sc, "pure-s7"); -#endif -#if WITH_EXTRA_EXPONENT_MARKERS - s7_provide(sc, "dfls-exponents"); -#endif -#if HAVE_OVERFLOW_CHECKS - s7_provide(sc, "overflow-checks"); -#endif -#if WITH_SYSTEM_EXTRAS - s7_provide(sc, "system-extras"); -#endif -#if WITH_IMMUTABLE_UNQUOTE - s7_provide(sc, "immutable-unquote"); -#endif -#if S7_DEBUGGING - s7_provide(sc, "debugging"); -#endif -#if HAVE_COMPLEX_NUMBERS - s7_provide(sc, "complex-numbers"); -#endif -#if WITH_NUMBER_SEPARATOR - s7_provide(sc, "number-separator"); -#endif -#if WITH_HISTORY - s7_provide(sc, "history"); -#endif -#if WITH_C_LOADER - s7_provide(sc, "dlopen"); -#endif -#if (!DISABLE_AUTOLOAD) - s7_provide(sc, "autoload"); -#endif -#if S7_ALIGNED - s7_provide(sc, "aligned"); -#endif -#if POINTER_32 - s7_provide(sc, "32-bit"); -#endif - -#ifdef __APPLE__ - s7_provide(sc, "osx"); -#endif -#ifdef __linux__ - s7_provide(sc, "linux"); -#endif -#ifdef __OpenBSD__ - s7_provide(sc, "openbsd"); -#endif -#ifdef __NetBSD__ - s7_provide(sc, "netbsd"); -#endif -#ifdef __FreeBSD__ - s7_provide(sc, "freebsd"); -#endif -#if MS_WINDOWS - s7_provide(sc, "windows"); -#endif -#ifdef __bfin__ - s7_provide(sc, "blackfin"); -#endif -#ifdef __ANDROID__ - s7_provide(sc, "android"); -#endif -#ifdef __MSYS__ - s7_provide(sc, "msys2"); /* from chai xiaoxiang */ -#endif -#ifdef __MINGW32__ /* this is also defined in mingw64 */ - s7_provide(sc, "mingw"); -#endif -#ifdef __CYGWIN__ - s7_provide(sc, "cygwin"); /* this is also defined in msys2 */ -#endif -#ifdef __hpux - s7_provide(sc, "hpux"); -#endif -#if defined(__sun) && defined(__SVR4) - s7_provide(sc, "solaris"); -#endif - -#ifdef __SUNPRO_C - s7_provide(sc, "sunpro_c"); -#endif -#ifdef __clang__ - s7_provide(sc, "clang"); -#endif -#ifdef __GNUC__ - s7_provide(sc, "gcc"); -#endif -#ifdef __TINYC__ - s7_provide(sc, "tcc"); /* appears to be 3-4 times slower than gcc (compilation is at least 10 times faster however) */ -#endif -#ifdef __EMSCRIPTEN__ - s7_provide(sc, "emscripten"); -#endif -#ifdef _MSC_VER - s7_provide(sc, "msvc"); -#endif -} - -static void init_wrappers(s7_scheme *sc) -{ - s7_pointer cp, qp; - #define NUM_INTEGER_WRAPPERS 4 - #define NUM_REAL_WRAPPERS 4 - - sc->integer_wrappers = semipermanent_list(sc, NUM_INTEGER_WRAPPERS); - for (cp = sc->integer_wrappers, qp = sc->integer_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) - { - s7_pointer p = alloc_pointer(sc); - car(cp) = p; - full_type(p) = T_INTEGER | T_IMMUTABLE | T_MUTABLE | T_UNHEAP; /* mutable to turn off set_has_number_name */ - integer(p) = 0; - } - cdr(qp) = sc->integer_wrappers; - - sc->real_wrappers = semipermanent_list(sc, NUM_REAL_WRAPPERS); - for (cp = sc->real_wrappers, qp = sc->real_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) - { - s7_pointer p = alloc_pointer(sc); - car(cp) = p; - full_type(p) = T_REAL | T_IMMUTABLE | T_MUTABLE | T_UNHEAP; - real(p) = 0.0; - } - cdr(qp) = sc->real_wrappers; - - sc->string_wrappers = semipermanent_list(sc, NUM_STRING_WRAPPERS); - for (cp = sc->string_wrappers, qp = sc->string_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) - { - s7_pointer p = alloc_pointer(sc); - car(cp) = p; - full_type(p) = T_STRING | T_IMMUTABLE | T_SAFE_PROCEDURE | T_UNHEAP; - string_block(p) = NULL; - string_value(p) = NULL; - string_length(p) = 0; - string_hash(p) = 0; - } - cdr(qp) = sc->string_wrappers; -} - -static s7_pointer syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) -{ - uint64_t hash = raw_string_hash((const uint8_t *)name, safe_strlen(name)); - uint32_t loc = hash % SYMBOL_TABLE_SIZE; - s7_pointer x = new_symbol(sc, name, safe_strlen(name), hash, loc); - s7_pointer syn = alloc_pointer(sc); - - set_full_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS | T_GLOBAL | T_UNHEAP); - syntax_opcode(syn) = op; - syntax_set_symbol(syn, x); - syntax_min_args(syn) = integer(min_args); - syntax_max_args(syn) = ((max_args == max_arity) ? -1 : integer(max_args)); - syntax_documentation(syn) = doc; - set_global_slot(x, make_semipermanent_slot(sc, x, syn)); - set_initial_slot(x, make_semipermanent_slot(sc, x, syn)); /* set_local_slot(x, global_slot(x)); */ - set_type_bit(x, T_SYMBOL | T_SYNTACTIC | T_GLOBAL | T_UNHEAP); - symbol_set_local_slot_unchecked(x, 0LL, sc->nil); - symbol_clear_ctr(x); - return(x); -} - -static s7_pointer definer_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) -{ - s7_pointer x = syntax(sc, name, op, min_args, max_args, doc); - set_syntax_is_definer(x); - return(x); -} - -static s7_pointer binder_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) -{ - s7_pointer x = syntax(sc, name, op, min_args, max_args, doc); - set_syntax_is_binder(x); - return(x); -} - -static s7_pointer copy_args_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc) -{ - s7_pointer x = syntax(sc, name, op, min_args, max_args, doc); - s7_pointer p = global_value(x); - full_type(p) |= T_COPY_ARGS; - return(x); -} - -static s7_pointer make_unique(s7_scheme *sc, const char* name, uint64_t typ) -{ - s7_pointer p = alloc_pointer(sc); - set_full_type(p, typ | T_IMMUTABLE | T_UNHEAP); - if (typ != T_UNUSED) set_optimize_op(p, OP_CONSTANT); - if (typ == T_UNDEFINED) /* sc->undefined here to avoid the undefined_constant_warning */ - { - undefined_set_name_length(p, safe_strlen(name)); - undefined_name(p) = copy_string_with_length(name, undefined_name_length(p)); - } - else - { - unique_name_length(p) = safe_strlen(name); - unique_name(p) = copy_string_with_length(name, unique_name_length(p)); - add_saved_pointer(sc, (void *)unique_name(p)); - } - return(p); -} - -static s7_pointer symbol_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) -{ - s7_pointer slot = lookup_slot_from(sym, sc->curlet); - if (!is_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "set!: '~S, is unbound", 21), sym)); - if (is_immutable(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->symbol_symbol, sym)); - slot_set_value(slot, val); - return(val); -} - -static s7_pointer g_symbol_set(s7_scheme *sc, s7_pointer args) /* (set! (symbol ) ) */ -{ - s7_int i = 0, len; - s7_pointer lst, val; - if (is_null(cddr(args))) - return(symbol_set_1(sc, g_symbol(sc, set_plist_1(sc, car(args))), cadr(args))); - len = proper_list_length(args) - 1; - lst = safe_list_if_possible(sc, len); - if (in_heap(lst)) gc_protect_via_stack(sc, lst); - for (s7_pointer ap = args, lp = lst; i < len; ap = cdr(ap), lp = cdr(lp), i++) car(lp) = car(ap); - val = symbol_set_1(sc, g_symbol(sc, lst), s7_list_ref(sc, args, len)); - if (in_heap(lst)) unstack(sc); else clear_list_in_use(lst); - return(val); -} - -static void init_setters(s7_scheme *sc) -{ - sc->vector_set_function = global_value(sc->vector_set_symbol); - set_is_setter(sc->vector_set_symbol); - /* not float-vector-set! here */ - - sc->list_set_function = global_value(sc->list_set_symbol); - set_is_setter(sc->list_set_symbol); - - sc->hash_table_set_function = global_value(sc->hash_table_set_symbol); - set_is_setter(sc->hash_table_set_symbol); - - sc->let_set_function = global_value(sc->let_set_symbol); - set_is_setter(sc->let_set_symbol); - - sc->string_set_function = global_value(sc->string_set_symbol); - set_is_setter(sc->string_set_symbol); - - set_is_setter(sc->byte_vector_set_symbol); - set_is_setter(sc->set_car_symbol); - set_is_setter(sc->set_cdr_symbol); - set_is_safe_setter(sc->byte_vector_set_symbol); - set_is_safe_setter(sc->int_vector_set_symbol); - set_is_safe_setter(sc->float_vector_set_symbol); - set_is_safe_setter(sc->string_set_symbol); - -#if (WITH_PURE_S7) - /* we need to be able at least to set (current-output-port) to #f */ - c_function_set_setter(global_value(sc->current_input_port_symbol), - s7_make_safe_function(sc, "#", g_set_current_input_port, 1, 0, false, "*stdin* setter")); - c_function_set_setter(global_value(sc->current_output_port_symbol), - s7_make_safe_function(sc, "#", g_set_current_output_port, 1, 0, false, "*stdout* setter")); -#else - set_is_setter(sc->set_current_input_port_symbol); - set_is_setter(sc->set_current_output_port_symbol); - s7_function_set_setter(sc, sc->current_input_port_symbol, sc->set_current_input_port_symbol); - s7_function_set_setter(sc, sc->current_output_port_symbol, sc->set_current_output_port_symbol); -#endif - - set_is_setter(sc->set_current_error_port_symbol); - s7_function_set_setter(sc, sc->current_error_port_symbol, sc->set_current_error_port_symbol); - /* despite the similar names, current-error-port is different from the other two, and a setter is needed - * in scheme because error and warn send output to it by default. It is not a "dynamic variable". - */ - - s7_function_set_setter(sc, sc->car_symbol, sc->set_car_symbol); - s7_function_set_setter(sc, sc->cdr_symbol, sc->set_cdr_symbol); - s7_function_set_setter(sc, sc->hash_table_ref_symbol, sc->hash_table_set_symbol); - s7_function_set_setter(sc, sc->vector_ref_symbol, sc->vector_set_symbol); - s7_function_set_setter(sc, sc->float_vector_ref_symbol, sc->float_vector_set_symbol); - s7_function_set_setter(sc, sc->int_vector_ref_symbol, sc->int_vector_set_symbol); - s7_function_set_setter(sc, sc->byte_vector_ref_symbol, sc->byte_vector_set_symbol); - s7_function_set_setter(sc, sc->list_ref_symbol, sc->list_set_symbol); - s7_function_set_setter(sc, sc->let_ref_symbol, sc->let_set_symbol); - s7_function_set_setter(sc, sc->string_ref_symbol, sc->string_set_symbol); - c_function_set_setter(global_value(sc->outlet_symbol), - s7_make_safe_function(sc, "#", g_set_outlet, 2, 0, false, "outlet setter")); - c_function_set_setter(global_value(sc->port_line_number_symbol), - s7_make_safe_function(sc, "#", g_set_port_line_number, 1, 1, false, "port-line setter")); - c_function_set_setter(global_value(sc->port_position_symbol), - s7_make_safe_function(sc, "#", g_set_port_position, 2, 0, false, "port-position setter")); - c_function_set_setter(global_value(sc->vector_typer_symbol), - s7_make_safe_function(sc, "#", g_set_vector_typer, 2, 0, false, "vector-typer setter")); - c_function_set_setter(global_value(sc->hash_table_key_typer_symbol), - s7_make_safe_function(sc, "#", g_set_hash_table_key_typer, 2, 0, false, "hash-table-key-typer setter")); - c_function_set_setter(global_value(sc->hash_table_value_typer_symbol), - s7_make_safe_function(sc, "#", g_set_hash_table_value_typer, 2, 0, false, "hash-table-value-typer setter")); - c_function_set_setter(global_value(sc->symbol_symbol), s7_make_safe_function(sc, "symbol-set", g_symbol_set, 2, 0, true, "symbol setter")); -} - -static void init_syntax(s7_scheme *sc) -{ - #define H_quote "(quote obj) returns obj unevaluated. 'obj is an abbreviation for (quote obj)." - #define H_if "(if expr true-stuff optional-false-stuff) evaluates expr, then if it is true, evaluates true-stuff; otherwise, \ -if optional-false-stuff exists, it is evaluated." - #define H_when "(when expr ...) evaluates expr, and if it is true, evaluates each form in its body, returning the value of the last" - #define H_unless "(unless expr ...) evaluates expr, and if it is false, evaluates each form in its body, returning the value of the last" - #define H_begin "(begin ...) evaluates each form in its body, returning the value of the last one" - #define H_set "(set! variable value) sets the value of variable to value." - #define H_let "(let ((var val)...) ...) binds each variable to its initial value, then evaluates its body,\ -returning the value of the last form. The let variables are local to it, and are not available for use until all have been initialized." - #define H_let_star "(let* ((var val)...) ...) binds each variable to its initial value, then evaluates its body, \ -returning the value of the last form. The let* variables are local to it, and are available immediately." - #define H_letrec "(letrec ((var (lambda ...)))...) is like let, but var can refer to itself in its value \ -(i.e. you can define local recursive functions)" - #define H_letrec_star "(letrec* ((var val))...) is like letrec, but successive bindings are handled as in let*" - #define H_cond "(cond (expr clause...)...) is like if..then. Each expr is evaluated in order, and if one is not #f, \ -the associated clauses are evaluated, whereupon cond returns." - #define H_and "(and expr expr ...) evaluates each of its arguments in order, quitting (and returning #f) \ -as soon as one of them returns #f. If all are non-#f, it returns the last value." - #define H_or "(or expr expr ...) evaluates each of its arguments in order, quitting as soon as one of them is not #f. \ -If all are #f, or returns #f." - #define H_case "(case val ((key...) clause...)...) looks for val in the various lists of keys, and if a \ -match is found (via eqv?), the associated clauses are evaluated, and case returns." - #define H_do "(do (vars...) (loop control and return value) ...) is a do-loop." - #define H_lambda "(lambda args ...) returns a function." - #define H_lambda_star "(lambda* args ...) returns a function; the args list can have default values, \ -the parameters themselves can be accessed via keywords." - #define H_define "(define var val) assigns val to the variable (symbol) var. (define (func args) ...) is \ -shorthand for (define func (lambda args ...))" - #define H_define_star "(define* (func args) ...) defines a function with optional/keyword arguments." - #define H_define_constant "(define-constant var val) defines var to be a constant (it can't be set or bound), with the value val." - #define H_define_macro "(define-macro (mac args) ...) defines mac to be a macro." - #define H_define_macro_star "(define-macro* (mac args) ...) defines mac to be a macro with optional/keyword arguments." - #define H_macro "(macro args ...) defines an unnamed macro." - #define H_macro_star "(macro* args ...) defines an unnamed macro with optional/keyword arguments." - #define H_define_expansion "(define-expansion (mac args) ...) defines mac to be a read-time macro." - #define H_define_expansion_star "(define-expansion* (mac args) ...) defines mac to be a read-time macro*." - #define H_define_bacro "(define-bacro (mac args) ...) defines mac to be a bacro." - #define H_define_bacro_star "(define-bacro* (mac args) ...) defines mac to be a bacro with optional/keyword arguments." - #define H_bacro "(bacro args ...) defines an unnamed bacro." - #define H_bacro_star "(bacro* args ...) defines an unnamed bacro with optional/keyword arguments." - #define H_with_baffle "(with-baffle ...) evaluates its body in a context that blocks re-entry via call/cc." - #define H_macroexpand "(macroexpand macro-call) returns the result of the expansion phase of evaluating the macro call." - #define H_with_let "(with-let let ...) evaluates its body in the environment let." - #define H_let_temporarily "(let-temporarily ((var value)...) . body) sets each var to its new value, evals body, \ -then returns each var to its original value." - - sc->quote_symbol = syntax(sc, "quote", OP_QUOTE, int_one, int_one, H_quote); - sc->if_symbol = syntax(sc, "if", OP_IF, int_two, int_three, H_if); - sc->when_symbol = syntax(sc, "when", OP_WHEN, int_two, max_arity, H_when); - sc->unless_symbol = syntax(sc, "unless", OP_UNLESS, int_two, max_arity, H_unless); - sc->begin_symbol = syntax(sc, "begin", OP_BEGIN, int_zero, max_arity, H_begin); /* (begin) is () */ - sc->set_symbol = syntax(sc, "set!", OP_SET, int_two, int_two, H_set); - sc->cond_symbol = copy_args_syntax(sc, "cond", OP_COND, int_one, max_arity, H_cond); - sc->and_symbol = copy_args_syntax(sc, "and", OP_AND, int_zero, max_arity, H_and); - sc->or_symbol = copy_args_syntax(sc, "or", OP_OR, int_zero, max_arity, H_or); - sc->case_symbol = syntax(sc, "case", OP_CASE, int_two, max_arity, H_case); - sc->macroexpand_symbol = syntax(sc, "macroexpand", OP_MACROEXPAND, int_one, int_one, H_macroexpand); - sc->let_temporarily_symbol = syntax(sc, "let-temporarily", OP_LET_TEMPORARILY, int_two, max_arity, H_let_temporarily); - sc->define_symbol = definer_syntax(sc, "define", OP_DEFINE, int_two, max_arity, H_define); - sc->define_star_symbol = definer_syntax(sc, "define*", OP_DEFINE_STAR, int_two, max_arity, H_define_star); - sc->define_constant_symbol = definer_syntax(sc, "define-constant", OP_DEFINE_CONSTANT, int_two, max_arity, H_define_constant); - sc->define_macro_symbol = definer_syntax(sc, "define-macro", OP_DEFINE_MACRO, int_two, max_arity, H_define_macro); - sc->define_macro_star_symbol = definer_syntax(sc, "define-macro*", OP_DEFINE_MACRO_STAR, int_two, max_arity, H_define_macro_star); - sc->define_expansion_symbol = definer_syntax(sc, "define-expansion",OP_DEFINE_EXPANSION, int_two, max_arity, H_define_expansion); - sc->define_expansion_star_symbol = definer_syntax(sc, "define-expansion*",OP_DEFINE_EXPANSION_STAR, int_two, max_arity, H_define_expansion_star); - sc->define_bacro_symbol = definer_syntax(sc, "define-bacro", OP_DEFINE_BACRO, int_two, max_arity, H_define_bacro); - sc->define_bacro_star_symbol = definer_syntax(sc, "define-bacro*", OP_DEFINE_BACRO_STAR, int_two, max_arity, H_define_bacro_star); - sc->let_symbol = binder_syntax(sc, "let", OP_LET, int_two, max_arity, H_let); - sc->let_star_symbol = binder_syntax(sc, "let*", OP_LET_STAR, int_two, max_arity, H_let_star); - sc->letrec_symbol = binder_syntax(sc, "letrec", OP_LETREC, int_two, max_arity, H_letrec); - sc->letrec_star_symbol = binder_syntax(sc, "letrec*", OP_LETREC_STAR, int_two, max_arity, H_letrec_star); - sc->do_symbol = binder_syntax(sc, "do", OP_DO, int_two, max_arity, H_do); /* 2 because body can be null */ - sc->lambda_symbol = binder_syntax(sc, "lambda", OP_LAMBDA, int_two, max_arity, H_lambda); - sc->lambda_star_symbol = binder_syntax(sc, "lambda*", OP_LAMBDA_STAR, int_two, max_arity, H_lambda_star); - sc->macro_symbol = binder_syntax(sc, "macro", OP_MACRO, int_two, max_arity, H_macro); - sc->macro_star_symbol = binder_syntax(sc, "macro*", OP_MACRO_STAR, int_two, max_arity, H_macro_star); - sc->bacro_symbol = binder_syntax(sc, "bacro", OP_BACRO, int_two, max_arity, H_bacro); - sc->bacro_star_symbol = binder_syntax(sc, "bacro*", OP_BACRO_STAR, int_two, max_arity, H_bacro_star); - sc->with_let_symbol = binder_syntax(sc, "with-let", OP_WITH_LET, int_one, max_arity, H_with_let); - sc->with_baffle_symbol = binder_syntax(sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, H_with_baffle); /* (with-baffle) is () */ - set_local_slot(sc->with_let_symbol, global_slot(sc->with_let_symbol)); /* for set_locals */ - set_immutable(sc->with_let_symbol); - set_immutable_slot(global_slot(sc->with_let_symbol)); - sc->setter_symbol = make_symbol(sc, "setter", 6); - -#if WITH_IMMUTABLE_UNQUOTE - /* this code solves the various unquote redefinition troubles - * if "," -> "(unquote...)" in the reader, (let (, (lambda (x) (+ x 1))) ,,,,'1) -> 5 - */ - sc->unquote_symbol = make_symbol(sc, ",", 1); - set_immutable(sc->unquote_symbol); -#else - sc->unquote_symbol = make_symbol(sc, "unquote", 7); -#endif - - sc->feed_to_symbol = make_symbol(sc, "=>", 2); - sc->body_symbol = make_symbol(sc, "body", 4); - sc->read_error_symbol = make_symbol(sc, "read-error", 10); - sc->string_read_error_symbol = make_symbol(sc, "string-read-error", 17); - sc->syntax_error_symbol = make_symbol(sc, "syntax-error", 12); - sc->unbound_variable_symbol = make_symbol(sc, "unbound-variable", 16); - sc->wrong_type_arg_symbol = make_symbol(sc, "wrong-type-arg", 14); - sc->wrong_number_of_args_symbol = make_symbol(sc, "wrong-number-of-args", 20); - sc->format_error_symbol = make_symbol(sc, "format-error", 12); - sc->autoload_error_symbol = make_symbol(sc, "autoload-error", 14); - sc->out_of_range_symbol = make_symbol(sc, "out-of-range", 12); - sc->out_of_memory_symbol = make_symbol(sc, "out-of-memory", 13); - sc->io_error_symbol = make_symbol(sc, "io-error", 8); - sc->missing_method_symbol = make_symbol(sc, "missing-method", 14); - sc->number_to_real_symbol = make_symbol(sc, "number_to_real", 14); - sc->invalid_escape_function_symbol = make_symbol(sc, "invalid-escape-function", 23); - sc->immutable_error_symbol = make_symbol(sc, "immutable-error", 15); - sc->division_by_zero_symbol = make_symbol(sc, "division-by-zero", 16); - sc->bad_result_symbol = make_symbol(sc, "bad-result", 10); - sc->no_setter_symbol = make_symbol(sc, "no-setter", 9); - sc->baffled_symbol = make_symbol(sc, "baffled!", 8); - sc->value_symbol = make_symbol(sc, "value", 5); - sc->type_symbol = make_symbol(sc, "type", 4); - sc->position_symbol = make_symbol(sc, "position", 8); - sc->file_symbol = make_symbol(sc, "file", 4); - sc->line_symbol = make_symbol(sc, "line", 4); - sc->function_symbol = make_symbol(sc, "function", 8); - sc->else_symbol = make_symbol(sc, "else", 4); - s7_make_slot(sc, sc->nil, sc->else_symbol, sc->else_symbol); - slot_set_value(initial_slot(sc->else_symbol), sc->T); - /* if we set #_else to 'else, it can pick up a local else value: (let ((else #f)) (cond (#_else 2)...)) */ - - sc->allow_other_keys_keyword = s7_make_keyword(sc, "allow-other-keys"); - sc->rest_keyword = s7_make_keyword(sc, "rest"); - sc->if_keyword = s7_make_keyword(sc, "if"); /* internal optimizer local-let marker */ - sc->readable_keyword = s7_make_keyword(sc, "readable"); - sc->display_keyword = s7_make_keyword(sc, "display"); - sc->write_keyword = s7_make_keyword(sc, "write"); -} - -static void init_rootlet(s7_scheme *sc) -{ - /* most of init_rootlet (the built-in functions for example), could be shared by all s7 instances. - * currently, each s7_init call allocates room for them, then s7_free frees it -- kinda wasteful. - * allocate separately filling unlet then set symbols in init_rootlet by running through unlet and calling s7_define for each? - * need pre-unlet separate from thread-local unlet (dynamic loads). - * but currently the init_unlet run through the symbol table is wasting lots of time. - * unlet has only c_functions/syntax but should we support #_gsl* etc? - * split init_unlet, add load to defun macros - */ - s7_pointer sym; - init_syntax(sc); - - sc->owlet = init_owlet(sc); - - sc->wrong_type_arg_info = semipermanent_list(sc, 6); - set_car(sc->wrong_type_arg_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is ~A but should be ~A")); - - sc->sole_arg_wrong_type_info = semipermanent_list(sc, 5); - set_car(sc->sole_arg_wrong_type_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is ~A but should be ~A")); - - sc->out_of_range_info = semipermanent_list(sc, 5); - set_car(sc->out_of_range_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is out of range (~A)")); - - sc->sole_arg_out_of_range_info = semipermanent_list(sc, 4); - set_car(sc->sole_arg_out_of_range_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is out of range (~A)")); - - sc->gc_off = false; - - #define defun(Scheme_Name, C_Name, Req, Opt, Rst) \ - s7_define_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name) - - #define unsafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \ - s7_define_unsafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name) - - #define semisafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \ - s7_define_semisafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name) - - #define b_defun(Scheme_Name, C_Name, Opt, SymId, Marker, Simple) \ - define_bool_function(sc, Scheme_Name, g_ ## C_Name, Opt, H_ ## C_Name, Q_ ## C_Name, SymId, Marker, Simple, b_ ## C_Name ## _setter) - - /* we need the sc->is_* symbols first for the procedure signature lists */ - sc->is_boolean_symbol = make_symbol(sc, "boolean?", 8); - sc->pl_bt = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->T); - - sc->is_symbol_symbol = b_defun("symbol?", is_symbol, 0, T_SYMBOL, mark_symbol_vector, true); - sc->is_syntax_symbol = b_defun("syntax?", is_syntax, 0, T_SYNTAX, just_mark_vector, true); - sc->is_gensym_symbol = b_defun("gensym?", is_gensym, 0, T_FREE, mark_symbol_vector, true); - sc->is_keyword_symbol = b_defun("keyword?", is_keyword, 0, T_FREE, just_mark_vector, true); - sc->is_let_symbol = b_defun("let?", is_let, 0, T_LET, mark_vector_1, false); - sc->is_openlet_symbol = b_defun("openlet?", is_openlet, 0, T_FREE, mark_vector_1, false); - sc->is_iterator_symbol = b_defun("iterator?", is_iterator, 0, T_ITERATOR, mark_vector_1, false); - sc->is_macro_symbol = b_defun("macro?", is_macro, 0, T_FREE, mark_vector_1, false); - sc->is_c_pointer_symbol = b_defun("c-pointer?", is_c_pointer, 1, T_C_POINTER, mark_vector_1, false); - sc->is_input_port_symbol = b_defun("input-port?", is_input_port, 0, T_INPUT_PORT, mark_vector_1, true); - sc->is_output_port_symbol = b_defun("output-port?", is_output_port, 0, T_OUTPUT_PORT, mark_simple_vector, true); - sc->is_eof_object_symbol = b_defun("eof-object?", is_eof_object, 0, T_EOF, just_mark_vector, true); - sc->is_integer_symbol = b_defun("integer?", is_integer, 0, (WITH_GMP) ? T_FREE : T_INTEGER, mark_simple_vector, true); - sc->is_byte_symbol = b_defun("byte?", is_byte, 0, T_FREE, mark_simple_vector, true); - sc->is_number_symbol = b_defun("number?", is_number, 0, T_FREE, mark_simple_vector, true); - sc->is_real_symbol = b_defun("real?", is_real, 0, T_FREE, mark_simple_vector, true); - sc->is_float_symbol = b_defun("float?", is_float, 0, T_FREE, mark_simple_vector, true); - sc->is_complex_symbol = b_defun("complex?", is_complex, 0, T_FREE, mark_simple_vector, true); - sc->is_rational_symbol = b_defun("rational?", is_rational, 0, T_FREE, mark_simple_vector, true); - sc->is_random_state_symbol = b_defun("random-state?", is_random_state, 0, T_RANDOM_STATE, mark_simple_vector, true); - sc->is_char_symbol = b_defun("char?", is_char, 0, T_CHARACTER, just_mark_vector, true); - sc->is_string_symbol = b_defun("string?", is_string, 0, T_STRING, mark_simple_vector, true); - sc->is_list_symbol = b_defun("list?", is_list, 0, T_FREE, mark_vector_1, false); - sc->is_pair_symbol = b_defun("pair?", is_pair, 0, T_PAIR, mark_vector_1, false); - sc->is_vector_symbol = b_defun("vector?", is_vector, 0, T_FREE, mark_vector_1, false); - sc->is_float_vector_symbol = b_defun("float-vector?", is_float_vector, 0, T_FLOAT_VECTOR, mark_simple_vector, true); - sc->is_int_vector_symbol = b_defun("int-vector?", is_int_vector, 0, T_INT_VECTOR, mark_simple_vector, true); - sc->is_byte_vector_symbol = b_defun("byte-vector?", is_byte_vector, 0, T_BYTE_VECTOR, mark_simple_vector, true); - sc->is_hash_table_symbol = b_defun("hash-table?", is_hash_table, 0, T_HASH_TABLE, mark_vector_1, false); - sc->is_continuation_symbol = b_defun("continuation?", is_continuation, 0, T_CONTINUATION, mark_vector_1, false); - sc->is_procedure_symbol = b_defun("procedure?", is_procedure, 0, T_FREE, mark_vector_1, false); - sc->is_dilambda_symbol = b_defun("dilambda?", is_dilambda, 0, T_FREE, mark_vector_1, false); - /* set above */ b_defun("boolean?", is_boolean, 0, T_BOOLEAN, just_mark_vector, true); - sc->is_proper_list_symbol = b_defun("proper-list?", is_proper_list, 0, T_FREE, mark_vector_1, false); - sc->is_sequence_symbol = b_defun("sequence?", is_sequence, 0, T_FREE, mark_vector_1, false); - sc->is_null_symbol = b_defun("null?", is_null, 0, T_NIL, just_mark_vector, true); - sc->is_undefined_symbol = b_defun("undefined?", is_undefined, 0, T_UNDEFINED, just_mark_vector, true); - sc->is_unspecified_symbol = b_defun("unspecified?", is_unspecified, 0, T_UNSPECIFIED, just_mark_vector, true); - sc->is_c_object_symbol = b_defun("c-object?", is_c_object, 0, T_C_OBJECT, mark_vector_1, false); - sc->is_subvector_symbol = b_defun("subvector?", is_subvector, 0, T_FREE, mark_vector_1, false); - sc->is_weak_hash_table_symbol = b_defun("weak-hash-table?", is_weak_hash_table, 0, T_FREE, mark_vector_1, false); - sc->is_goto_symbol = b_defun("goto?", is_goto, 0, T_GOTO, mark_vector_1, true); - - /* these are for signatures */ - sc->not_symbol = defun("not", not, 1, 0, false); - sc->is_integer_or_real_at_end_symbol = make_symbol(sc, "integer:real?", 13); - sc->is_integer_or_any_at_end_symbol = make_symbol(sc, "integer:any?", 12); - - sc->pl_p = s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol); - sc->pl_tl = s7_make_signature(sc, 3, - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol); /* memq and memv signature */ - sc->pl_bc = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_char_symbol); - sc->pl_bn = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_number_symbol); - sc->pl_nn = s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol); - sc->pl_sf = s7_make_signature(sc, 3, sc->T, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)); - sc->pcl_bt = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->T); - sc->pcl_bc = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_char_symbol); - sc->pcl_bs = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_string_symbol); - sc->pcl_i = s7_make_circular_signature(sc, 0, 1, sc->is_integer_symbol); - sc->pcl_r = s7_make_circular_signature(sc, 0, 1, sc->is_real_symbol); - sc->pcl_f = s7_make_circular_signature(sc, 0, 1, sc->is_rational_symbol); - sc->pcl_n = s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol); - sc->pcl_s = s7_make_circular_signature(sc, 0, 1, sc->is_string_symbol); - sc->pcl_v = s7_make_circular_signature(sc, 0, 1, sc->is_vector_symbol); - sc->pcl_c = s7_make_circular_signature(sc, 0, 1, sc->is_char_symbol); - sc->pcl_e = s7_make_circular_signature(sc, 0, 1, - s7_make_signature(sc, 4, sc->is_let_symbol, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_c_object_symbol)); - - sc->values_symbol = make_symbol(sc, "values", 6); - - sc->is_bignum_symbol = defun("bignum?", is_bignum, 1, 0, false); - sc->bignum_symbol = defun("bignum", bignum, 1, 1, false); - - sc->gensym_symbol = defun("gensym", gensym, 0, 1, false); - sc->symbol_table_symbol = defun("symbol-table", symbol_table, 0, 0, false); - sc->symbol_to_string_symbol = defun("symbol->string", symbol_to_string, 1, 0, false); - sc->string_to_symbol_symbol = defun("string->symbol", string_to_symbol, 1, 0, false); - sc->symbol_symbol = defun("symbol", symbol, 1, 0, true); - sc->symbol_to_value_symbol = defun("symbol->value", symbol_to_value, 1, 1, false); - sc->symbol_to_dynamic_value_symbol = defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0, false); - sc->immutable_symbol = defun("immutable!", immutable, 1, 0, false); - sc->is_immutable_symbol = defun("immutable?", is_immutable, 1, 0, false); - sc->is_constant_symbol = defun("constant?", is_constant, 1, 0, false); - sc->string_to_keyword_symbol = defun("string->keyword", string_to_keyword, 1, 0, false); - sc->symbol_to_keyword_symbol = defun("symbol->keyword", symbol_to_keyword, 1, 0, false); - sc->keyword_to_symbol_symbol = defun("keyword->symbol", keyword_to_symbol, 1, 0, false); - - sc->outlet_symbol = unsafe_defun("outlet", outlet, 1, 0, false); - sc->rootlet_symbol = unsafe_defun("rootlet", rootlet, 0, 0, false); /* unsafe else unbound var in g_is_defined_in_rootlet? */ - sc->curlet_symbol = unsafe_defun("curlet", curlet, 0, 0, false); /* (define (f a) (curlet)) exports the funclet */ - set_func_is_definer(sc->curlet_symbol); - sc->unlet_symbol = defun("unlet", unlet, 0, 0, false); - set_local_slot(sc->unlet_symbol, global_slot(sc->unlet_symbol)); /* for set_locals */ - set_immutable(sc->unlet_symbol); - set_immutable_slot(global_slot(sc->unlet_symbol)); - /* unlet (and with-let) don't actually need to be immutable, but s7.html says they are... */ - sc->is_funclet_symbol = defun("funclet?", is_funclet, 1, 0, false); - sc->sublet_symbol = defun("sublet", sublet, 1, 0, true); - sc->varlet_symbol = semisafe_defun("varlet", varlet, 2, 0, true); /* was 1,0 13-Aug-22 */ - set_func_is_definer(sc->varlet_symbol); - sc->cutlet_symbol = semisafe_defun("cutlet", cutlet, 2, 0, true); /* was 1,0 13-Aug-22 */ - set_func_is_definer(sc->cutlet_symbol); - sc->inlet_symbol = defun("inlet", inlet, 0, 0, true); - sc->owlet_symbol = defun("owlet", owlet, 0, 0, false); - sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false); - sc->openlet_symbol = defun("openlet", openlet, 1, 0, false); - sc->let_ref_symbol = defun("let-ref", let_ref, 2, 0, false); - set_immutable(sc->let_ref_symbol); /* 16-Sep-19 */ - set_immutable_slot(global_slot(sc->let_ref_symbol)); - sc->let_set_symbol = defun("let-set!", let_set, 3, 0, false); - set_immutable(sc->let_set_symbol); - set_immutable_slot(global_slot(sc->let_set_symbol)); - sc->let_ref_fallback_symbol = make_symbol(sc, "let-ref-fallback", 16); - sc->let_set_fallback_symbol = make_symbol(sc, "let-set-fallback", 16); /* was let-set!-fallback until 9-Oct-17 */ - - sc->make_iterator_symbol = defun("make-iterator", make_iterator, 1, 1, false); - sc->iterate_symbol = defun("iterate", iterate, 1, 0, false); - sc->iterator_sequence_symbol = defun("iterator-sequence", iterator_sequence, 1, 0, false); - sc->iterator_is_at_end_symbol = defun("iterator-at-end?", iterator_is_at_end, 1, 0, false); - - sc->is_provided_symbol = defun("provided?", is_provided, 1, 0, false); - sc->provide_symbol = semisafe_defun("provide", provide, 1, 0, false); /* can add *features* to curlet */ - set_func_is_definer(sc->provide_symbol); - sc->is_defined_symbol = defun("defined?", is_defined, 1, 2, false); - - sc->c_object_type_symbol = defun("c-object-type", c_object_type, 1, 0, false); - sc->c_pointer_symbol = defun("c-pointer", c_pointer, 1, 4, false); - sc->c_pointer_info_symbol = defun("c-pointer-info", c_pointer_info, 1, 0, false); - sc->c_pointer_type_symbol = defun("c-pointer-type", c_pointer_type, 1, 0, false); - sc->c_pointer_weak1_symbol = defun("c-pointer-weak1", c_pointer_weak1, 1, 0, false); - sc->c_pointer_weak2_symbol = defun("c-pointer-weak2", c_pointer_weak2, 1, 0, false); - sc->c_pointer_to_list_symbol = defun("c-pointer->list", c_pointer_to_list, 1, 0, false); - - sc->port_file_symbol = defun("port-file", port_file, 1, 0, false); - sc->port_position_symbol = defun("port-position", port_position, 1, 0, false); - sc->port_line_number_symbol = defun("port-line-number", port_line_number, 0, 1, false); - sc->port_filename_symbol = defun("port-filename", port_filename, 0, 1, false); - sc->pair_line_number_symbol = defun("pair-line-number", pair_line_number, 1, 0, false); - sc->pair_filename_symbol = defun("pair-filename", pair_filename, 1, 0, false); - sc->is_port_closed_symbol = defun("port-closed?", is_port_closed, 1, 0, false); - - sc->current_input_port_symbol = defun("current-input-port", current_input_port, 0, 0, false); - sc->current_output_port_symbol = defun("current-output-port", current_output_port, 0, 0, false); - sc->current_error_port_symbol = defun("current-error-port", current_error_port, 0, 0, false); - sc->set_current_error_port_symbol = defun("set-current-error-port", set_current_error_port, 1, 0, false); -#if (!WITH_PURE_S7) - sc->let_to_list_symbol = defun("let->list", let_to_list, 1, 0, false); - sc->set_current_input_port_symbol = defun("set-current-input-port", set_current_input_port, 1, 0, false); - sc->set_current_output_port_symbol = defun("set-current-output-port", set_current_output_port, 1, 0, false); - sc->is_char_ready_symbol = defun("char-ready?", is_char_ready, 0, 1, false); /* the least-used scheme function */ -#endif - - sc->close_input_port_symbol = defun("close-input-port", close_input_port, 1, 0, false); - sc->close_output_port_symbol = defun("close-output-port", close_output_port, 1, 0, false); - sc->flush_output_port_symbol = defun("flush-output-port", flush_output_port, 0, 1, false); - sc->open_input_file_symbol = defun("open-input-file", open_input_file, 1, 1, false); - sc->open_output_file_symbol = defun("open-output-file", open_output_file, 1, 1, false); - sc->open_input_string_symbol = defun("open-input-string", open_input_string, 1, 0, false); - sc->open_output_string_symbol = defun("open-output-string", open_output_string, 0, 0, false); - sc->get_output_string_symbol = defun("get-output-string", get_output_string, 1, 1, false); - sc->get_output_string_uncopied = s7_make_safe_function(sc, "get-output-string", g_get_output_string_uncopied, 1, 1, false, NULL); - sc->open_input_function_symbol = defun("open-input-function",open_input_function, 1, 0, false); - sc->open_output_function_symbol = defun("open-output-function",open_output_function, 1, 0, false); - - sc->closed_input_function = s7_make_safe_function(sc, "closed-input-function", g_closed_input_function_port, 2, 0, false, "input-function error"), - sc->closed_output_function = s7_make_safe_function(sc, "closed-output-function", g_closed_output_function_port, 1, 0, false, "output-function error"), - - sc->newline_symbol = defun("newline", newline, 0, 1, false); - sc->write_symbol = defun("write", write, 1, 1, false); - sc->display_symbol = defun("display", display, 1, 1, false); - sc->read_char_symbol = defun("read-char", read_char, 0, 1, false); - sc->peek_char_symbol = defun("peek-char", peek_char, 0, 1, false); - sc->write_char_symbol = defun("write-char", write_char, 1, 1, false); - sc->write_string_symbol = defun("write-string", write_string, 1, 3, false); - sc->read_byte_symbol = defun("read-byte", read_byte, 0, 1, false); - sc->write_byte_symbol = defun("write-byte", write_byte, 1, 1, false); - sc->read_line_symbol = defun("read-line", read_line, 0, 2, false); - sc->read_string_symbol = defun("read-string", read_string, 1, 1, false); - sc->read_symbol = semisafe_defun("read", read, 0, 1, false); - /* read can't be safe because it messes with the stack, expecting to be all by itself in the call sequence - * (not embedded in OP_SAFE_C_opSq for example) -- that is, it pushes OP_READ_INTERNAL, then returns - * expecting continue (goto top-of-eval-loop), which would be nonsense if arg=fn|x_proc(read) -> fn|x_proc(arg). - * a safe procedure leaves its argument list alone, does not push anything on the stack, - * and leaves sc->code|args unscathed (fx_call assumes that is the case). The stack part can - * be hidden: if a c_function calls s7_apply_function (lambda passed as arg as in some clm gens) - * then is called with args that use fx*, and the lambda func does the same, the two calls - * can step on each other. - */ - - sc->call_with_input_string_symbol = semisafe_defun("call-with-input-string", call_with_input_string, 2, 0, false); /* body unsafe if func=read */ - sc->call_with_input_file_symbol = semisafe_defun("call-with-input-file", call_with_input_file, 2, 0, false); - sc->with_input_from_string_symbol = semisafe_defun("with-input-from-string", with_input_from_string, 2, 0, false); - sc->with_input_from_file_symbol = semisafe_defun("with-input-from-file", with_input_from_file, 2, 0, false); - - sc->call_with_output_string_symbol = semisafe_defun("call-with-output-string", call_with_output_string, 1, 0, false); - sc->call_with_output_file_symbol = semisafe_defun("call-with-output-file", call_with_output_file, 2, 0, false); - sc->with_output_to_string_symbol = semisafe_defun("with-output-to-string", with_output_to_string, 1, 0, false); - sc->with_output_to_file_symbol = semisafe_defun("with-output-to-file", with_output_to_file, 2, 0, false); - -#if WITH_SYSTEM_EXTRAS - sc->is_directory_symbol = defun("directory?", is_directory, 1, 0, false); - sc->file_exists_symbol = defun("file-exists?", file_exists, 1, 0, false); - sc->delete_file_symbol = defun("delete-file", delete_file, 1, 0, false); - sc->getenv_symbol = defun("getenv", getenv, 1, 0, false); - sc->system_symbol = defun("system", system, 1, 1, false); -#if (!MS_WINDOWS) - sc->directory_to_list_symbol = defun("directory->list", directory_to_list, 1, 0, false); - sc->file_mtime_symbol = defun("file-mtime", file_mtime, 1, 0, false); -#endif -#endif - - sc->real_part_symbol = defun("real-part", real_part, 1, 0, false); - sc->imag_part_symbol = defun("imag-part", imag_part, 1, 0, false); - sc->numerator_symbol = defun("numerator", numerator, 1, 0, false); - sc->denominator_symbol = defun("denominator", denominator, 1, 0, false); - sc->is_even_symbol = defun("even?", is_even, 1, 0, false); - sc->is_odd_symbol = defun("odd?", is_odd, 1, 0, false); - sc->is_zero_symbol = defun("zero?", is_zero, 1, 0, false); - sc->is_positive_symbol = defun("positive?", is_positive, 1, 0, false); - sc->is_negative_symbol = defun("negative?", is_negative, 1, 0, false); - sc->is_infinite_symbol = defun("infinite?", is_infinite, 1, 0, false); - sc->is_nan_symbol = defun("nan?", is_nan, 1, 0, false); - sc->complex_symbol = defun("complex", complex, 2, 0, false); - - sc->add_symbol = defun("+", add, 0, 0, true); set_all_integer_and_float(sc->add_symbol); - sc->subtract_symbol = defun("-", subtract, 1, 0, true); set_all_integer_and_float(sc->subtract_symbol); - sc->multiply_symbol = defun("*", multiply, 0, 0, true); set_all_integer_and_float(sc->multiply_symbol); - sc->divide_symbol = defun("/", divide, 1, 0, true); set_all_float(sc->divide_symbol); - sc->min_symbol = defun("min", min, 1, 0, true); set_all_integer_and_float(sc->min_symbol); - sc->max_symbol = defun("max", max, 1, 0, true); set_all_integer_and_float(sc->max_symbol); - - sc->quotient_symbol = defun("quotient", quotient, 2, 0, false); set_all_integer(sc->quotient_symbol); - sc->remainder_symbol = defun("remainder", remainder, 2, 0, false); set_all_integer(sc->remainder_symbol); - sc->modulo_symbol = defun("modulo", modulo, 2, 0, false); set_all_integer(sc->modulo_symbol); - sc->num_eq_symbol = defun("=", num_eq, 2, 0, true); - sc->lt_symbol = defun("<", less, 2, 0, true); - sc->gt_symbol = defun(">", greater, 2, 0, true); - sc->leq_symbol = defun("<=", less_or_equal, 2, 0, true); - sc->geq_symbol = defun(">=", greater_or_equal, 2, 0, true); - sc->gcd_symbol = defun("gcd", gcd, 0, 0, true); - sc->lcm_symbol = defun("lcm", lcm, 0, 0, true); - sc->rationalize_symbol = defun("rationalize", rationalize, 1, 1, false); - sc->random_symbol = defun("random", random, 1, 1, false); set_all_integer_and_float(sc->random_symbol); - sc->random_state_symbol = defun("random-state", random_state, 0, (WITH_GMP) ? 1 : 2, false); - sc->expt_symbol = defun("expt", expt, 2, 0, false); - sc->log_symbol = defun("log", log, 1, 1, false); - sc->ash_symbol = defun("ash", ash, 2, 0, false); - sc->exp_symbol = defun("exp", exp, 1, 0, false); set_all_float(sc->exp_symbol); - sc->abs_symbol = defun("abs", abs, 1, 0, false); set_all_integer_and_float(sc->abs_symbol); - sc->magnitude_symbol = defun("magnitude", magnitude, 1, 0, false); set_all_integer_and_float(sc->magnitude_symbol); - sc->angle_symbol = defun("angle", angle, 1, 0, false); - sc->sin_symbol = defun("sin", sin, 1, 0, false); set_all_float(sc->sin_symbol); - sc->cos_symbol = defun("cos", cos, 1, 0, false); set_all_float(sc->cos_symbol); - sc->tan_symbol = defun("tan", tan, 1, 0, false); set_all_float(sc->tan_symbol); - sc->sinh_symbol = defun("sinh", sinh, 1, 0, false); set_all_float(sc->sinh_symbol); - sc->cosh_symbol = defun("cosh", cosh, 1, 0, false); set_all_float(sc->cosh_symbol); - sc->tanh_symbol = defun("tanh", tanh, 1, 0, false); set_all_float(sc->tanh_symbol); - sc->asin_symbol = defun("asin", asin, 1, 0, false); - sc->acos_symbol = defun("acos", acos, 1, 0, false); - sc->atan_symbol = defun("atan", atan, 1, 1, false); - sc->asinh_symbol = defun("asinh", asinh, 1, 0, false); - sc->acosh_symbol = defun("acosh", acosh, 1, 0, false); - sc->atanh_symbol = defun("atanh", atanh, 1, 0, false); - sc->sqrt_symbol = defun("sqrt", sqrt, 1, 0, false); - sc->floor_symbol = defun("floor", floor, 1, 0, false); - sc->ceiling_symbol = defun("ceiling", ceiling, 1, 0, false); - sc->truncate_symbol = defun("truncate", truncate, 1, 0, false); - sc->round_symbol = defun("round", round, 1, 0, false); - sc->logand_symbol = defun("logand", logand, 0, 0, true); - sc->logior_symbol = defun("logior", logior, 0, 0, true); - sc->logxor_symbol = defun("logxor", logxor, 0, 0, true); - sc->lognot_symbol = defun("lognot", lognot, 1, 0, false); - sc->logbit_symbol = defun("logbit?", logbit, 2, 0, false); - sc->integer_decode_float_symbol = defun("integer-decode-float", integer_decode_float, 1, 0, false); - sc->nan_symbol = defun("nan", nan, 0, 1, false); /* (nan) -> +nan.0, (nan 123) -> +nan.123 */ - sc->nan_payload_symbol = defun("nan-payload", nan_payload, 1, 0, false); - -#if (!WITH_PURE_S7) - sc->integer_length_symbol = defun("integer-length", integer_length, 1, 0, false); - sc->inexact_to_exact_symbol = defun("inexact->exact", inexact_to_exact, 1, 0, false); - sc->exact_to_inexact_symbol = defun("exact->inexact", exact_to_inexact, 1, 0, false); - sc->is_exact_symbol = defun("exact?", is_exact, 1, 0, false); - sc->is_inexact_symbol = defun("inexact?", is_inexact, 1, 0, false); -#endif - sc->random_state_to_list_symbol = defun("random-state->list", random_state_to_list, 0, 1, false); - sc->number_to_string_symbol = defun("number->string", number_to_string, 1, 1, false); - sc->string_to_number_symbol = defun("string->number", string_to_number, 1, 1, false); - - sc->char_upcase_symbol = defun("char-upcase", char_upcase, 1, 0, false); - sc->char_downcase_symbol = defun("char-downcase", char_downcase, 1, 0, false); - sc->char_to_integer_symbol = defun("char->integer", char_to_integer, 1, 0, false); - sc->integer_to_char_symbol = defun("integer->char", integer_to_char, 1, 0, false); - - sc->is_char_upper_case_symbol = defun("char-upper-case?", is_char_upper_case, 1, 0, false); - sc->is_char_lower_case_symbol = defun("char-lower-case?", is_char_lower_case, 1, 0, false); - sc->is_char_alphabetic_symbol = defun("char-alphabetic?", is_char_alphabetic, 1, 0, false); - sc->is_char_numeric_symbol = defun("char-numeric?", is_char_numeric, 1, 0, false); - sc->is_char_whitespace_symbol = defun("char-whitespace?", is_char_whitespace, 1, 0, false); - - sc->char_eq_symbol = defun("char=?", chars_are_equal, 2, 0, true); - sc->char_lt_symbol = defun("charchar_gt_symbol = defun("char>?", chars_are_greater, 2, 0, true); - sc->char_leq_symbol = defun("char<=?", chars_are_leq, 2, 0, true); - sc->char_geq_symbol = defun("char>=?", chars_are_geq, 2, 0, true); - sc->char_position_symbol = defun("char-position", char_position, 2, 1, false); - sc->string_position_symbol = defun("string-position", string_position, 2, 1, false); - - sc->make_string_symbol = defun("make-string", make_string, 1, 1, false); - sc->string_ref_symbol = defun("string-ref", string_ref, 2, 0, false); - sc->string_set_symbol = defun("string-set!", string_set, 3, 0, false); - - sc->string_eq_symbol = defun("string=?", strings_are_equal, 2, 0, true); - sc->string_lt_symbol = defun("stringstring_gt_symbol = defun("string>?", strings_are_greater, 2, 0, true); - sc->string_leq_symbol = defun("string<=?", strings_are_leq, 2, 0, true); - sc->string_geq_symbol = defun("string>=?", strings_are_geq, 2, 0, true); - -#if (!WITH_PURE_S7) - sc->char_ci_eq_symbol = defun("char-ci=?", chars_are_ci_equal, 2, 0, true); - sc->char_ci_lt_symbol = defun("char-cichar_ci_gt_symbol = defun("char-ci>?", chars_are_ci_greater, 2, 0, true); - sc->char_ci_leq_symbol = defun("char-ci<=?", chars_are_ci_leq, 2, 0, true); - sc->char_ci_geq_symbol = defun("char-ci>=?", chars_are_ci_geq, 2, 0, true); - sc->string_ci_eq_symbol = defun("string-ci=?", strings_are_ci_equal, 2, 0, true); - sc->string_ci_lt_symbol = defun("string-cistring_ci_gt_symbol = defun("string-ci>?", strings_are_ci_greater, 2, 0, true); - sc->string_ci_leq_symbol = defun("string-ci<=?", strings_are_ci_leq, 2, 0, true); - sc->string_ci_geq_symbol = defun("string-ci>=?", strings_are_ci_geq, 2, 0, true); - sc->string_fill_symbol = defun("string-fill!", string_fill, 2, 2, false); - sc->list_to_string_symbol = defun("list->string", list_to_string, 1, 0, false); - sc->string_length_symbol = defun("string-length", string_length, 1, 0, false); - sc->string_to_list_symbol = defun("string->list", string_to_list, 1, 2, false); -#endif - sc->string_copy_symbol = defun("string-copy", string_copy, 1, 3, false); - - sc->string_downcase_symbol = defun("string-downcase", string_downcase, 1, 0, false); - sc->string_upcase_symbol = defun("string-upcase", string_upcase, 1, 0, false); - sc->string_append_symbol = defun("string-append", string_append, 0, 0, true); - sc->substring_symbol = defun("substring", substring, 2, 1, false); - sc->string_symbol = defun("string", string, 0, 0, true); - sc->object_to_string_symbol = defun("object->string", object_to_string, 1, 2, false); - sc->format_symbol = defun("format", format, 2, 0, true); - sc->object_to_let_symbol = defun("object->let", object_to_let, 1, 0, false); - - sc->cons_symbol = defun("cons", cons, 2, 0, false); - sc->car_symbol = defun("car", car, 1, 0, false); - sc->cdr_symbol = defun("cdr", cdr, 1, 0, false); - sc->set_car_symbol = defun("set-car!", set_car, 2, 0, false); - sc->set_cdr_symbol = defun("set-cdr!", set_cdr, 2, 0, false); - sc->caar_symbol = defun("caar", caar, 1, 0, false); - sc->cadr_symbol = defun("cadr", cadr, 1, 0, false); - sc->cdar_symbol = defun("cdar", cdar, 1, 0, false); - sc->cddr_symbol = defun("cddr", cddr, 1, 0, false); - sc->caaar_symbol = defun("caaar", caaar, 1, 0, false); - sc->caadr_symbol = defun("caadr", caadr, 1, 0, false); - sc->cadar_symbol = defun("cadar", cadar, 1, 0, false); - sc->cdaar_symbol = defun("cdaar", cdaar, 1, 0, false); - sc->caddr_symbol = defun("caddr", caddr, 1, 0, false); - sc->cdddr_symbol = defun("cdddr", cdddr, 1, 0, false); - sc->cdadr_symbol = defun("cdadr", cdadr, 1, 0, false); - sc->cddar_symbol = defun("cddar", cddar, 1, 0, false); - sc->caaaar_symbol = defun("caaaar", caaaar, 1, 0, false); - sc->caaadr_symbol = defun("caaadr", caaadr, 1, 0, false); - sc->caadar_symbol = defun("caadar", caadar, 1, 0, false); - sc->cadaar_symbol = defun("cadaar", cadaar, 1, 0, false); - sc->caaddr_symbol = defun("caaddr", caaddr, 1, 0, false); - sc->cadddr_symbol = defun("cadddr", cadddr, 1, 0, false); - sc->cadadr_symbol = defun("cadadr", cadadr, 1, 0, false); - sc->caddar_symbol = defun("caddar", caddar, 1, 0, false); - sc->cdaaar_symbol = defun("cdaaar", cdaaar, 1, 0, false); - sc->cdaadr_symbol = defun("cdaadr", cdaadr, 1, 0, false); - sc->cdadar_symbol = defun("cdadar", cdadar, 1, 0, false); - sc->cddaar_symbol = defun("cddaar", cddaar, 1, 0, false); - sc->cdaddr_symbol = defun("cdaddr", cdaddr, 1, 0, false); - sc->cddddr_symbol = defun("cddddr", cddddr, 1, 0, false); - sc->cddadr_symbol = defun("cddadr", cddadr, 1, 0, false); - sc->cdddar_symbol = defun("cdddar", cdddar, 1, 0, false); - - sc->assq_symbol = defun("assq", assq, 2, 0, false); - sc->assv_symbol = defun("assv", assv, 2, 0, false); - sc->assoc_symbol = semisafe_defun("assoc", assoc, 2, 1, false); - sc->memq_symbol = defun("memq", memq, 2, 0, false); - sc->memv_symbol = defun("memv", memv, 2, 0, false); - sc->member_symbol = semisafe_defun("member", member, 2, 1, false); - - sc->list_symbol = defun("list", list, 0, 0, true); - sc->list_ref_symbol = defun("list-ref", list_ref, 2, 0, true); - sc->list_set_symbol = defun("list-set!", list_set, 3, 0, true); - sc->list_tail_symbol = defun("list-tail", list_tail, 2, 0, false); - sc->make_list_symbol = defun("make-list", make_list, 1, 1, false); - - sc->length_symbol = defun("length", length, 1, 0, false); - sc->copy_symbol = defun("copy", copy, 1, 3, false); - /* set_is_definer(sc->copy_symbol); */ /* (copy (inlet 'a 1) (curlet)), but this check needs to be smarter */ - sc->fill_symbol = defun("fill!", fill, 2, 2, false); - sc->reverse_symbol = defun("reverse", reverse, 1, 0, false); - sc->reverseb_symbol = defun("reverse!", reverse_in_place, 1, 0, false); - sc->sort_symbol = unsafe_defun("sort!", sort, 2, 0, false); /* not semisafe! */ - sc->append_symbol = defun("append", append, 0, 0, true); - sc->qq_append_symbol = defun("[list*]", qq_append, 2, 0, false); - -#if (!WITH_PURE_S7) - sc->vector_append_symbol = defun("vector-append", vector_append, 0, 0, true); - sc->list_to_vector_symbol = defun("list->vector", list_to_vector, 1, 0, false); - sc->vector_fill_symbol = defun("vector-fill!", vector_fill, 2, 2, false); - sc->vector_length_symbol = defun("vector-length", vector_length, 1, 0, false); - sc->vector_to_list_symbol = defun("vector->list", vector_to_list, 1, 2, false); -#else - sc->vector_append_symbol = sc->append_symbol; - sc->vector_fill_symbol = sc->fill_symbol; - sc->string_fill_symbol = sc->fill_symbol; -#endif - sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true); - sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true); - sc->vector_dimension_symbol = defun("vector-dimension", vector_dimension, 2, 0, false); - sc->vector_dimensions_symbol = defun("vector-dimensions", vector_dimensions, 1, 0, false); - sc->vector_rank_symbol = defun("vector-rank", vector_rank, 1, 0, false); - sc->make_vector_symbol = defun("make-vector", make_vector, 1, 2, false); - sc->vector_symbol = defun("vector", vector, 0, 0, true); - set_is_setter(sc->vector_symbol); /* like cons, I guess */ - sc->vector_typer_symbol = defun("vector-typer", vector_typer, 1, 0, false); - - sc->subvector_symbol = defun("subvector", subvector, 1, 3, false); - sc->subvector_position_symbol = defun("subvector-position", subvector_position, 1, 0, false); - sc->subvector_vector_symbol = defun("subvector-vector", subvector_vector, 1, 0, false); - - sc->float_vector_symbol = defun("float-vector", float_vector, 0, 0, true); - sc->make_float_vector_symbol = defun("make-float-vector", make_float_vector, 1, 1, false); - sc->float_vector_set_symbol = defun("float-vector-set!", float_vector_set, 3, 0, true); - sc->float_vector_ref_symbol = defun("float-vector-ref", float_vector_ref, 2, 0, true); - - sc->int_vector_symbol = defun("int-vector", int_vector, 0, 0, true); - sc->make_int_vector_symbol = defun("make-int-vector", make_int_vector, 1, 1, false); - sc->int_vector_set_symbol = defun("int-vector-set!", int_vector_set, 3, 0, true); - sc->int_vector_ref_symbol = defun("int-vector-ref", int_vector_ref, 2, 0, true); - - sc->byte_vector_symbol = defun("byte-vector", byte_vector, 0, 0, true); - sc->make_byte_vector_symbol = defun("make-byte-vector", make_byte_vector, 1, 1, false); - sc->byte_vector_ref_symbol = defun("byte-vector-ref", byte_vector_ref, 2, 0, true); - sc->byte_vector_set_symbol = defun("byte-vector-set!", byte_vector_set, 3, 0, true); - sc->string_to_byte_vector_symbol = defun("string->byte-vector", string_to_byte_vector, 1, 0, false); - sc->byte_vector_to_string_symbol = defun("byte-vector->string", byte_vector_to_string, 1, 0, false); - - sc->hash_table_symbol = defun("hash-table", hash_table, 0, 0, true); - sc->make_hash_table_symbol = defun("make-hash-table", make_hash_table, 0, 3, false); - sc->make_weak_hash_table_symbol = defun("make-weak-hash-table", make_weak_hash_table,0, 3, false); - sc->weak_hash_table_symbol = defun("weak-hash-table", weak_hash_table, 0, 0, true); - sc->hash_table_ref_symbol = defun("hash-table-ref", hash_table_ref, 2, 0, true); - sc->hash_table_set_symbol = defun("hash-table-set!", hash_table_set, 3, 0, false); - sc->hash_table_entries_symbol = defun("hash-table-entries", hash_table_entries, 1, 0, false); - sc->hash_code_symbol = defun("hash-code", hash_code, 1, 1, false); - sc->dummy_equal_hash_table = make_dummy_hash_table(sc); - sc->hash_table_key_typer_symbol = defun("hash-table-key-typer", hash_table_key_typer, 1, 0, false); - sc->hash_table_value_typer_symbol = defun("hash-table-value-typer", hash_table_value_typer, 1, 0, false); - - sc->cyclic_sequences_symbol = defun("cyclic-sequences", cyclic_sequences, 1, 0, false); - sc->call_cc_symbol = semisafe_defun("call/cc", call_cc, 1, 0, false); - sc->call_with_current_continuation_symbol = unsafe_defun("call-with-current-continuation", call_cc, 1, 0, false); - sc->call_with_exit_symbol = semisafe_defun("call-with-exit", call_with_exit, 1, 0, false); - - sc->load_symbol = semisafe_defun("load", load, 1, 1, false); - sc->autoload_symbol = defun("autoload", autoload, 2, 0, false); - sc->eval_symbol = semisafe_defun("eval", eval, 1, 1, false); - set_func_is_definer(sc->eval_symbol); - sc->eval_string_symbol = semisafe_defun("eval-string", eval_string, 1, 1, false); - set_func_is_definer(sc->eval_string_symbol); - sc->apply_symbol = unsafe_defun("apply", apply, 1, 0, true); /* not semisafe (note that type is reset below) */ - set_func_is_definer(sc->apply_symbol); - /* yow... (apply (inlet) (f)) in do body where (f) returns '(define...) -- see s7test.scm under apply - * perhaps better: if closure returns a definer in some way set its name as a definer? even this is not fool-proof - */ - - sc->for_each_symbol = semisafe_defun("for-each", for_each, 2, 0, true); - sc->map_symbol = semisafe_defun("map", map, 2, 0, true); - sc->dynamic_wind_symbol = semisafe_defun("dynamic-wind", dynamic_wind, 3, 0, false); - sc->dynamic_unwind_symbol = semisafe_defun("dynamic-unwind", dynamic_unwind, 2, 0, false); - sc->catch_symbol = semisafe_defun("catch", catch, 3, 0, false); - sc->throw_symbol = unsafe_defun("throw", throw, 1, 0, true); - sc->error_symbol = unsafe_defun("error", error, 1, 0, true); /* was 0,0 -- 1-Aug-22 */ - /* not safe in catch if macro as error handler, (define-macro (m . args) `(apply ,(car args) ',(cadr args))) (catch #t (lambda () (error abs -1)) m) */ - sc->stacktrace_symbol = defun("stacktrace", stacktrace, 0, 5, false); - - /* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true); /* values_symbol set above for signatures, not semisafe! */ - sc->apply_values_symbol = unsafe_defun("apply-values", apply_values, 0, 1, false); - set_immutable(sc->apply_values_symbol); - set_immutable_slot(global_slot(sc->apply_values_symbol)); - sc->list_values_symbol = defun("list-values", list_values, 0, 0, true); - set_immutable(sc->list_values_symbol); - set_immutable_slot(global_slot(sc->list_values_symbol)); - - sc->documentation_symbol = defun("documentation", documentation, 1, 0, false); - sc->signature_symbol = defun("signature", signature, 1, 0, false); - sc->help_symbol = defun("help", help, 1, 0, false); - sc->procedure_source_symbol = defun("procedure-source", procedure_source, 1, 0, false); - sc->funclet_symbol = defun("funclet", funclet, 1, 0, false); - sc->_function__symbol = defun("*function*", function, 0, 2, false); - sc->dilambda_symbol = defun("dilambda", dilambda, 2, 0, false); - s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1, H_setter, Q_setter, NULL); - sc->arity_symbol = defun("arity", arity, 1, 0, false); - sc->is_aritable_symbol = defun("aritable?", is_aritable, 2, 0, false); - - sc->is_eq_symbol = defun("eq?", is_eq, 2, 0, false); - sc->is_eqv_symbol = defun("eqv?", is_eqv, 2, 0, false); - sc->is_equal_symbol = defun("equal?", is_equal, 2, 0, false); - sc->is_equivalent_symbol = defun("equivalent?", is_equivalent, 2, 0, false); - sc->type_of_symbol = defun("type-of", type_of, 1, 0, false); - - sc->gc_symbol = semisafe_defun("gc", gc, 0, 1, false); - defun("emergency-exit", emergency_exit, 0, 1, false); - sc->exit_symbol = defun("exit", exit, 0, 1, false); - -#if WITH_GCC - s7_define_function(sc, "abort", g_abort, 0, 0, false, "drop into gdb I hope"); -#endif -#if S7_DEBUGGING - defun("heap-scan", heap_scan, 1, 0, false); - defun("heap-analyze", heap_analyze, 0, 0, false); - defun("heap-holder", heap_holder, 1, 0, false); - defun("heap-holders", heap_holders, 1, 0, false); - - defun("show-stack", show_stack, 0, 0, false); - defun("show-op-stack", show_op_stack, 0, 0, false); - defun("op-stack?", is_op_stack, 0, 0, false); -#endif - s7_define_function(sc, "s7-optimize", g_optimize, 1, 0, false, "short-term debugging aid"); - sc->c_object_set_function = s7_make_safe_function(sc, "#", g_c_object_set, 1, 0, true, "c-object setter"); - /* c_function_signature(sc->c_object_set_function) = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T); */ - - set_scope_safe(global_value(sc->call_with_input_string_symbol)); - set_scope_safe(global_value(sc->call_with_input_file_symbol)); - set_scope_safe(global_value(sc->call_with_output_string_symbol)); - set_scope_safe(global_value(sc->call_with_output_file_symbol)); - set_scope_safe(global_value(sc->with_input_from_string_symbol)); - set_scope_safe(global_value(sc->with_input_from_file_symbol)); - set_scope_safe(global_value(sc->with_output_to_string_symbol)); - set_scope_safe(global_value(sc->with_output_to_file_symbol)); - set_maybe_safe(global_value(sc->assoc_symbol)); - set_scope_safe(global_value(sc->assoc_symbol)); - set_maybe_safe(global_value(sc->member_symbol)); - set_scope_safe(global_value(sc->member_symbol)); - set_scope_safe(global_value(sc->sort_symbol)); - set_scope_safe(global_value(sc->call_with_exit_symbol)); - set_scope_safe(global_value(sc->for_each_symbol)); - set_maybe_safe(global_value(sc->for_each_symbol)); - set_scope_safe(global_value(sc->map_symbol)); - set_maybe_safe(global_value(sc->map_symbol)); - set_scope_safe(global_value(sc->dynamic_wind_symbol)); - set_scope_safe(global_value(sc->catch_symbol)); - set_scope_safe(global_value(sc->throw_symbol)); - set_scope_safe(global_value(sc->error_symbol)); - set_scope_safe(global_value(sc->apply_values_symbol)); - - sc->tree_leaves_symbol = defun("tree-leaves", tree_leaves, 1, 0, false); - sc->tree_memq_symbol = defun("tree-memq", tree_memq, 2, 0, false); - sc->tree_set_memq_symbol = defun("tree-set-memq", tree_set_memq, 2, 0, false); - sc->tree_count_symbol = defun("tree-count", tree_count, 2, 1, false); - sc->tree_is_cyclic_symbol = defun("tree-cyclic?", tree_is_cyclic, 1, 0, false); - - sc->quasiquote_symbol = s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote); /* is this considered syntax? r7rs says yes; also unquote */ - sc->profile_in_symbol = unsafe_defun("profile-in", profile_in, 2, 0, false); /* calls dynamic-unwind */ - sc->profile_out = NULL; - - /* -------- *features* -------- */ - sc->features_symbol = s7_define_variable_with_documentation(sc, "*features*", sc->nil, "list of currently available features ('complex-numbers, etc)"); - s7_set_setter(sc, sc->features_symbol, s7_make_safe_function(sc, "#", g_features_set, 2, 0, false, "*features* setter")); - - /* -------- *load-path* -------- */ - sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", list_1(sc, make_string_with_length(sc, ".", 1)), /* not plist! */ - "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name"); - s7_set_setter(sc, sc->load_path_symbol, s7_make_safe_function(sc, "#", g_load_path_set, 2, 0, false, "*load-path* setter")); - -#ifdef CLOAD_DIR - sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", s7_make_string(sc, (char *)CLOAD_DIR)); - s7_add_to_load_path(sc, (const char *)CLOAD_DIR); -#else - sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", nil_string); -#endif - s7_set_setter(sc, sc->cload_directory_symbol, - s7_make_safe_function(sc, "#", g_cload_directory_set, 2, 0, false, "*cload-directory* setter")); - - /* -------- *autoload* -------- this pretends to be a hash-table or environment, but it's actually a function */ - sc->autoloader_symbol = s7_define_typed_function(sc, "*autoload*", g_autoloader, 1, 0, false, H_autoloader, Q_autoloader); - c_function_set_setter(global_value(sc->autoloader_symbol), global_value(sc->autoload_symbol)); /* (set! (*autoload* x) y) */ - - sc->libraries_symbol = s7_define_variable_with_documentation(sc, "*libraries*", sc->nil, "list of currently loaded libraries (libc.scm, etc)"); - s7_set_setter(sc, sc->libraries_symbol, s7_make_safe_function(sc, "#", g_libraries_set, 2, 0, false, "*libraries* setter")); - - s7_autoload(sc, make_symbol(sc, "cload.scm", 9), s7_make_semipermanent_string(sc, "cload.scm")); - s7_autoload(sc, make_symbol(sc, "lint.scm", 8), s7_make_semipermanent_string(sc, "lint.scm")); - s7_autoload(sc, make_symbol(sc, "stuff.scm", 9), s7_make_semipermanent_string(sc, "stuff.scm")); - s7_autoload(sc, make_symbol(sc, "mockery.scm", 11), s7_make_semipermanent_string(sc, "mockery.scm")); - s7_autoload(sc, make_symbol(sc, "write.scm", 9), s7_make_semipermanent_string(sc, "write.scm")); - s7_autoload(sc, make_symbol(sc, "reactive.scm", 12), s7_make_semipermanent_string(sc, "reactive.scm")); - s7_autoload(sc, make_symbol(sc, "repl.scm", 8), s7_make_semipermanent_string(sc, "repl.scm")); - s7_autoload(sc, make_symbol(sc, "r7rs.scm", 8), s7_make_semipermanent_string(sc, "r7rs.scm")); - s7_autoload(sc, make_symbol(sc, "profile.scm", 11), s7_make_semipermanent_string(sc, "profile.scm")); - s7_autoload(sc, make_symbol(sc, "debug.scm", 9), s7_make_semipermanent_string(sc, "debug.scm")); - s7_autoload(sc, make_symbol(sc, "case.scm", 8), s7_make_semipermanent_string(sc, "case.scm")); - - s7_autoload(sc, make_symbol(sc, "libc.scm", 8), s7_make_semipermanent_string(sc, "libc.scm")); - s7_autoload(sc, make_symbol(sc, "libm.scm", 8), s7_make_semipermanent_string(sc, "libm.scm")); /* repl.scm adds *libm* */ - s7_autoload(sc, make_symbol(sc, "libdl.scm", 9), s7_make_semipermanent_string(sc, "libdl.scm")); - s7_autoload(sc, make_symbol(sc, "libgsl.scm", 10), s7_make_semipermanent_string(sc, "libgsl.scm")); /* repl.scm adds *libgsl* */ - s7_autoload(sc, make_symbol(sc, "libgdbm.scm", 11), s7_make_semipermanent_string(sc, "libgdbm.scm")); - s7_autoload(sc, make_symbol(sc, "libutf8proc.scm", 15), s7_make_semipermanent_string(sc, "libutf8proc.scm")); - - sc->require_symbol = s7_define_macro(sc, "require", g_require, 1, 0, true, H_require); - sc->stacktrace_defaults = s7_list(sc, 5, int_three, small_int(45), small_int(80), small_int(45), sc->T); /* assume NUM_SMALL_INTS >= NUM_CHARS == 256 */ - - /* -------- *#readers* -------- */ - sym = s7_define_variable_with_documentation(sc, "*#readers*", sc->nil, "list of current reader macros"); - sc->sharp_readers = global_slot(sym); - s7_set_setter(sc, sym, s7_make_safe_function(sc, "#", g_sharp_readers_set, 2, 0, false, "*#readers* setter")); - - sc->local_documentation_symbol = make_symbol(sc, "+documentation+", 15); - sc->local_signature_symbol = make_symbol(sc, "+signature+", 11); - sc->local_setter_symbol = make_symbol(sc, "+setter+", 8); - sc->local_iterator_symbol = make_symbol(sc, "+iterator+", 10); - - init_features(sc); - init_setters(sc); -} - -#if (!MS_WINDOWS) -static pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER; -#endif - -s7_scheme *s7_init(void) -{ - int32_t i; - s7_scheme *sc; - static bool already_inited = false; - -#if (!MS_WINDOWS) - setlocale(LC_NUMERIC, "C"); /* use decimal point in floats */ - pthread_mutex_lock(&init_lock); -#endif - - if (!already_inited) - { - init_types(); - init_ctables(); - init_mark_functions(); - init_display_functions(); - init_length_functions(); - init_equals(); - init_hash_maps(); - init_pows(); - init_int_limits(); - init_small_ints(); - init_uppers(); - init_chars(); - init_strings(); - init_fx_function(); - init_catchers(); - init_s7_starlet_immutable_field(); - already_inited = true; - } - -#if (!MS_WINDOWS) - pthread_mutex_unlock(&init_lock); -#endif - sc = (s7_scheme *)Calloc(1, sizeof(s7_scheme)); /* not malloc! */ -#if S7_DEBUGGING || POINTER_32 || WITH_WARNINGS - cur_sc = sc; /* for gdb/debugging */ -#endif - sc->gc_off = true; /* sc->args and so on are not set yet, so a gc during init -> segfault */ - sc->gc_in_progress = false; - sc->gc_stats = 0; - - sc->saved_pointers = (void **)Malloc(INITIAL_SAVED_POINTERS_SIZE * sizeof(void *)); - sc->saved_pointers_loc = 0; - sc->saved_pointers_size = INITIAL_SAVED_POINTERS_SIZE; - - init_gc_caches(sc); - sc->semipermanent_cells = 0; - sc->alloc_pointer_k = ALLOC_POINTER_SIZE; - sc->alloc_pointer_cells = NULL; - sc->alloc_big_pointer_k = ALLOC_BIG_POINTER_SIZE; - sc->alloc_big_pointer_cells = NULL; - sc->alloc_function_k = ALLOC_FUNCTION_SIZE; - sc->alloc_function_cells = NULL; - sc->alloc_symbol_k = ALLOC_SYMBOL_SIZE; - sc->alloc_symbol_cells = NULL; - sc->num_to_str_size = -1; - sc->num_to_str = NULL; - init_block_lists(sc); - sc->alloc_string_k = ALLOC_STRING_SIZE; - sc->alloc_string_cells = NULL; - sc->alloc_opt_func_cells = NULL; - sc->alloc_opt_func_k = ALLOC_FUNCTION_SIZE; - sc->longjmp_ok = false; - sc->setjmp_loc = NO_SET_JUMP; - sc->max_vector_length = (1LL << 32); - sc->max_string_length = 1073741824; /* 1 << 30 */ - sc->max_format_length = 10000; - sc->max_list_length = 1073741824; - sc->max_vector_dimensions = 512; - sc->strbuf_size = INITIAL_STRBUF_SIZE; - sc->strbuf = (char *)Calloc(sc->strbuf_size, 1); - sc->print_width = sc->max_string_length; - sc->short_print = false; - sc->in_with_let = false; - sc->object_out_locked = false; - sc->has_openlets = true; - sc->is_expanding = true; - sc->accept_all_keyword_arguments = false; - sc->muffle_warnings = false; - sc->initial_string_port_length = 128; - sc->format_depth = -1; - sc->singletons = (s7_pointer *)Calloc(256, sizeof(s7_pointer)); - add_saved_pointer(sc, sc->singletons); - sc->read_line_buf = NULL; - sc->read_line_buf_size = 0; - sc->stop_at_error = true; - - sc->nil = make_unique(sc, "()", T_NIL); - sc->unused = make_unique(sc, "#", T_UNUSED); - sc->T = make_unique(sc, "#t", T_BOOLEAN); - sc->F = make_unique(sc, "#f", T_BOOLEAN); - sc->undefined = make_unique(sc, "#", T_UNDEFINED); - sc->unspecified = make_unique(sc, "#", T_UNSPECIFIED); - sc->no_value = make_unique(sc, "#", T_UNSPECIFIED); - - unique_car(sc->nil) = sc->unspecified; - unique_cdr(sc->nil) = sc->unspecified; - /* this is mixing two different s7_cell structs, cons and envr, but luckily envr has two initial s7_pointer fields, equivalent to car and cdr, so - * let_id which is the same as opt1 is unaffected. To get the names built-in, I'll append unique_name and unique_name_length fields to the envr struct. - */ - let_set_id(sc->nil, -1); - unique_cdr(sc->unspecified) = sc->unspecified; - - sc->t1_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); - sc->t2_2 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); - sc->t2_1 = semipermanent_cons(sc, sc->unused, sc->t2_2, T_PAIR | T_IMMUTABLE); - sc->t3_3 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); - sc->t3_2 = semipermanent_cons(sc, sc->unused, sc->t3_3, T_PAIR | T_IMMUTABLE); - sc->t3_1 = semipermanent_cons(sc, sc->unused, sc->t3_2, T_PAIR | T_IMMUTABLE); - sc->t4_1 = semipermanent_cons(sc, sc->unused, sc->t3_1, T_PAIR | T_IMMUTABLE); - sc->u1_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); /* ulist */ - - sc->safe_lists[0] = sc->nil; - for (i = 1; i < NUM_SAFE_PRELISTS; i++) - sc->safe_lists[i] = semipermanent_list(sc, i); - for (i = NUM_SAFE_PRELISTS; i < NUM_SAFE_LISTS; i++) - sc->safe_lists[i] = sc->nil; - sc->current_safe_list = 0; - - sc->input_port_stack_size = INPUT_PORT_STACK_INITIAL_SIZE; - sc->input_port_stack = (s7_pointer *)Malloc(sc->input_port_stack_size * sizeof(s7_pointer)); - sc->input_port_stack_loc = 0; - - sc->code = sc->nil; -#if WITH_HISTORY - sc->eval_history1 = semipermanent_list(sc, DEFAULT_HISTORY_SIZE); - sc->eval_history2 = semipermanent_list(sc, DEFAULT_HISTORY_SIZE); - sc->history_pairs = semipermanent_list(sc, DEFAULT_HISTORY_SIZE); - sc->history_sink = semipermanent_list(sc, 1); - cdr(sc->history_sink) = sc->history_sink; - { - s7_pointer p1, p2, p3; - for (p3 = sc->history_pairs; is_pair(cdr(p3)); p3 = cdr(p3)) set_car(p3, semipermanent_list(sc, 1)); - set_car(p3, semipermanent_list(sc, 1)); - set_cdr(p3, sc->history_pairs); - for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); - set_cdr(p1, sc->eval_history1); - set_cdr(p2, sc->eval_history2); - sc->cur_code = sc->eval_history1; - sc->using_history1 = true; - sc->old_cur_code = sc->cur_code; - } -#else - sc->cur_code = sc->F; -#endif - sc->args = sc->nil; - sc->value = sc->nil; - sc->w = sc->unused; - sc->x = sc->unused; - sc->y = sc->unused; - sc->z = sc->unused; - sc->temp1 = sc->unused; - sc->temp2 = sc->unused; - sc->temp3 = sc->unused; - sc->temp4 = sc->unused; - sc->temp5 = sc->unused; - sc->temp7 = sc->unused; - sc->temp8 = sc->unused; - sc->temp9 = sc->unused; - sc->temp10 = sc->unused; - sc->rec_p1 = sc->unused; - sc->rec_p2 = sc->unused; - - sc->begin_hook = NULL; - sc->autoload_table = sc->nil; - sc->autoload_names = NULL; - sc->autoload_names_sizes = NULL; - sc->autoloaded_already = NULL; - sc->autoload_names_loc = 0; -#if DISABLE_AUTOLOAD - sc->is_autoloading = false; -#else - sc->is_autoloading = true; -#endif - sc->rec_stack = NULL; - - sc->heap_size = INITIAL_HEAP_SIZE; - if ((sc->heap_size % 32) != 0) - sc->heap_size = 32 * (int64_t)ceil((double)(sc->heap_size) / 32.0); - sc->heap = (s7_pointer *)Malloc(sc->heap_size * sizeof(s7_pointer)); - sc->free_heap = (s7_cell **)Malloc(sc->heap_size * sizeof(s7_cell *)); - sc->free_heap_top = (s7_cell **)(sc->free_heap + INITIAL_HEAP_SIZE); - sc->free_heap_trigger = (s7_cell **)(sc->free_heap + GC_TRIGGER_SIZE); - sc->previous_free_heap_top = sc->free_heap_top; - { - s7_cell *cells = (s7_cell *)Malloc(INITIAL_HEAP_SIZE * sizeof(s7_cell)); /* was calloc 14-Apr-22 */ - add_saved_pointer(sc, (void *)cells); - for (i = 0; i < INITIAL_HEAP_SIZE; i++) /* LOOP_4 here is slower! */ - { - sc->heap[i] = &cells[i]; - sc->free_heap[i] = sc->heap[i]; -#if S7_DEBUGGING - sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; -#endif - clear_type(sc->heap[i]); - i++; - sc->heap[i] = &cells[i]; - sc->free_heap[i] = sc->heap[i]; -#if S7_DEBUGGING - sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; -#endif - clear_type(sc->heap[i]); - } - sc->heap_blocks = (heap_block_t *)Malloc(sizeof(heap_block_t)); - sc->heap_blocks->start = (intptr_t)cells; - sc->heap_blocks->end = (intptr_t)cells + (sc->heap_size * sizeof(s7_cell)); - sc->heap_blocks->offset = 0; - sc->heap_blocks->next = NULL; - } - sc->gc_temps_size = GC_TEMPS_SIZE; - sc->gc_resize_heap_fraction = GC_RESIZE_HEAP_FRACTION; - sc->gc_resize_heap_by_4_fraction = GC_RESIZE_HEAP_BY_4_FRACTION; - sc->max_heap_size = (1LL << 62); - sc->gc_calls = 0; - sc->gc_total_time = 0; - - sc->max_port_data_size = (1LL << 62); -#ifndef OUTPUT_PORT_DATA_SIZE - #define OUTPUT_PORT_DATA_SIZE 2048 -#endif - sc->output_port_data_size = OUTPUT_PORT_DATA_SIZE; - - /* this has to precede s7_make_* allocations */ - sc->protected_setters_size = INITIAL_PROTECTED_OBJECTS_SIZE; - sc->protected_setters_loc = 0; - sc->protected_setters = make_vector_1(sc, INITIAL_PROTECTED_OBJECTS_SIZE, FILLED, T_VECTOR); - sc->protected_setter_symbols = make_vector_1(sc, INITIAL_PROTECTED_OBJECTS_SIZE, FILLED, T_VECTOR); - - sc->protected_objects_size = INITIAL_PROTECTED_OBJECTS_SIZE; - sc->protected_objects_free_list = (s7_int *)Malloc(INITIAL_PROTECTED_OBJECTS_SIZE * sizeof(s7_int)); - sc->protected_objects_free_list_loc = INITIAL_PROTECTED_OBJECTS_SIZE - 1; - sc->protected_objects = make_vector_1(sc, INITIAL_PROTECTED_OBJECTS_SIZE, FILLED, T_VECTOR); - for (i = 0; i < INITIAL_PROTECTED_OBJECTS_SIZE; i++) /* using # as the not-set indicator here lets that value leak out! */ - { - vector_element(sc->protected_objects, i) = sc->unused; - vector_element(sc->protected_setters, i) = sc->unused; - vector_element(sc->protected_setter_symbols, i) = sc->unused; - sc->protected_objects_free_list[i] = i; - } - - sc->stack = make_vector_1(sc, INITIAL_STACK_SIZE, FILLED, T_VECTOR); - /* if not_filled, segfault in gc_mark in mark_stack_1 after size check? probably unfilled OP_BARRIER etc? */ - sc->stack_start = vector_elements(sc->stack); /* stack type set below */ - sc->stack_end = sc->stack_start; - sc->stack_size = INITIAL_STACK_SIZE; - sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (INITIAL_STACK_SIZE - STACK_RESIZE_TRIGGER)); - set_full_type(sc->stack, T_STACK); - sc->max_stack_size = (1 << 30); - stack_clear_flags(sc->stack); - initialize_op_stack(sc); - - /* keep the symbol table out of the heap */ - sc->symbol_table = (s7_pointer)Malloc(sizeof(s7_cell)); /* was calloc 14-Apr-22 */ - full_type(sc->symbol_table) = T_VECTOR | T_UNHEAP; - vector_length(sc->symbol_table) = SYMBOL_TABLE_SIZE; - vector_elements(sc->symbol_table) = (s7_pointer *)Malloc(SYMBOL_TABLE_SIZE * sizeof(s7_pointer)); - vector_getter(sc->symbol_table) = normal_vector_getter; - vector_setter(sc->symbol_table) = normal_vector_setter; - normal_vector_fill(sc->symbol_table, sc->nil); - - { /* sc->opts */ - opt_info *os = (opt_info *)Malloc(OPTS_SIZE * sizeof(opt_info)); /* was calloc, 17-Oct-21 */ - add_saved_pointer(sc, os); - for (i = 0; i < OPTS_SIZE; i++) - { - opt_info *o = &os[i]; - sc->opts[i] = o; - o->sc = sc; - }} - - for (i = 0; i < NUM_TYPES; i++) - sc->type_names[i] = s7_make_semipermanent_string(sc, (const char *)type_name_from_type(i, INDEFINITE_ARTICLE)); - -#if WITH_MULTITHREAD_CHECKS - sc->lock_count = 0; - { - pthread_mutexattr_t attr; - pthread_mutexattr_init(&attr); - pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE); - pthread_mutex_init(&sc->lock, &attr); - } -#endif - - sc->c_object_types = NULL; - sc->c_object_types_size = 0; - sc->num_c_object_types = 0; - sc->typnam = NULL; - sc->typnam_len = 0; - sc->default_rationalize_error = 1.0e-12; - sc->hash_table_float_epsilon = 1.0e-12; - sc->equivalent_float_epsilon = 1.0e-15; - sc->float_format_precision = WRITE_REAL_PRECISION; - sc->number_separator = '\0'; - sc->default_hash_table_length = 8; - sc->gensym_counter = 0; - sc->capture_let_counter = 0; - sc->continuation_counter = 0; - sc->f_class = 0; - sc->add_class = 0; - sc->num_eq_class = 0; - sc->let_number = 0; - sc->format_column = 0; - sc->format_ports = NULL; - sc->file_names = NULL; - sc->file_names_size = 0; - sc->file_names_top = -1; - sc->s7_call_line = 0; - sc->s7_call_file = NULL; - sc->s7_call_name = NULL; - sc->safety = NO_SAFETY; - sc->debug = 0; - sc->profile = 0; - sc->profile_position = 0; - sc->debug_or_profile = false; - sc->profiling_gensyms = false; - sc->profile_data = NULL; - sc->profile_prefix = sc->F; - sc->print_length = DEFAULT_PRINT_LENGTH; - sc->history_size = DEFAULT_HISTORY_SIZE; - sc->true_history_size = DEFAULT_HISTORY_SIZE; - sc->baffle_ctr = 0; - sc->map_call_ctr = 0; - sc->syms_tag = 0; - sc->syms_tag2 = 0; - sc->class_name_symbol = make_symbol(sc, "class-name", 10); - sc->name_symbol = make_symbol(sc, "name", 4); - sc->trace_in_symbol = make_symbol(sc, "trace-in", 8); - sc->size_symbol = make_symbol(sc, "size", 4); - sc->mutable_symbol = make_symbol(sc, "mutable?", 8); - sc->file__symbol = make_symbol(sc, "FILE*", 5); - sc->circle_info = init_circle_info(sc); - sc->fdats = (format_data_t **)Calloc(8, sizeof(format_data_t *)); - sc->num_fdats = 8; - sc->mlist_1 = semipermanent_list(sc, 1); - sc->mlist_2 = semipermanent_list(sc, 2); - sc->plist_1 = semipermanent_list(sc, 1); - sc->plist_2 = semipermanent_list(sc, 2); - sc->plist_2_2 = cdr(sc->plist_2); - sc->plist_3 = semipermanent_list(sc, 3); - sc->qlist_2 = semipermanent_list(sc, 2); - sc->qlist_3 = semipermanent_cons(sc, sc->unused, sc->qlist_2, T_PAIR | T_IMMUTABLE); - sc->clist_1 = semipermanent_list(sc, 1); - sc->clist_2 = semipermanent_list(sc, 2); - sc->dlist_1 = semipermanent_list(sc, 1); - sc->elist_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_2 = semipermanent_list(sc, 2); set_is_elist(sc->elist_2); - sc->elist_3 = semipermanent_list(sc, 3); set_is_elist(sc->elist_3); - sc->elist_4 = semipermanent_cons(sc, sc->unused, sc->elist_3, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_5 = semipermanent_cons(sc, sc->unused, sc->elist_4, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_6 = semipermanent_cons(sc, sc->unused, sc->elist_5, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->elist_7 = semipermanent_cons(sc, sc->unused, sc->elist_6, T_PAIR | T_IMMUTABLE | T_IS_ELIST); - sc->undefined_identifier_warnings = false; - sc->undefined_constant_warnings = false; - sc->wrap_only = make_wrap_only(sc); - sc->unentry = (hash_entry_t *)Malloc(sizeof(hash_entry_t)); - hash_entry_set_value(sc->unentry, sc->F); - sc->begin_op = OP_BEGIN_NO_HOOK; - /* we used to laboriously set various other fields to null, but the calloc takes care of that */ - sc->tree_pointers = NULL; - sc->tree_pointers_size = 0; - sc->tree_pointers_top = 0; - - sc->rootlet = make_vector_1(sc, INITIAL_ROOTLET_SIZE, FILLED, T_VECTOR); - set_full_type(sc->rootlet, T_LET | T_SAFE_PROCEDURE); - sc->rootlet_entries = 0; - for (i = 0; i < INITIAL_ROOTLET_SIZE; i++) rootlet_element(sc->rootlet, i) = sc->nil; - sc->curlet = sc->nil; - sc->shadow_rootlet = sc->nil; - sc->objstr_max_len = S7_INT64_MAX; - - init_wrappers(sc); - init_standard_ports(sc); - init_rootlet(sc); - init_open_input_function_choices(sc); - - { - s7_pointer p; - new_cell(sc, p, T_RANDOM_STATE); /* s7_set_default_random_state might set sc->default_random_state, so this shouldn't be permanent */ - sc->default_random_state = p; - - sc->bignum_precision = DEFAULT_BIGNUM_PRECISION; -#if WITH_GMP - sc->bigints = NULL; - sc->bigrats = NULL; - sc->bigflts = NULL; - sc->bigcmps = NULL; - - mpfr_set_default_prec((mp_prec_t)DEFAULT_BIGNUM_PRECISION); - mpc_set_default_precision((mp_prec_t)DEFAULT_BIGNUM_PRECISION); - - mpz_inits(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL); - mpq_inits(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL); - mpfr_inits2(DEFAULT_BIGNUM_PRECISION, sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL); - mpc_init(sc->mpc_1); - mpc_init(sc->mpc_2); - - mpz_set_ui(sc->mpz_1, (uint64_t)my_clock()); - gmp_randinit_default(random_gmp_state(p)); - gmp_randseed(random_gmp_state(p), sc->mpz_1); - - sc->pi_symbol = s7_define_constant(sc, "pi", big_pi(sc)); - set_initial_slot(sc->pi_symbol, make_semipermanent_slot(sc, sc->pi_symbol, big_pi(sc))); /* s7_make_slot does not handle this */ - s7_provide(sc, "gmp"); -#else - random_seed(p) = (uint64_t)my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */ - random_carry(p) = 1675393560; - sc->pi_symbol = s7_define_constant(sc, "pi", real_pi); -#endif - } - for (i = 0; i < 10; i++) sc->singletons[(uint8_t)'0' + i] = small_int(i); - sc->singletons[(uint8_t)'+'] = sc->add_symbol; - sc->singletons[(uint8_t)'-'] = sc->subtract_symbol; - sc->singletons[(uint8_t)'*'] = sc->multiply_symbol; - sc->singletons[(uint8_t)'/'] = sc->divide_symbol; - sc->singletons[(uint8_t)'<'] = sc->lt_symbol; - sc->singletons[(uint8_t)'>'] = sc->gt_symbol; - sc->singletons[(uint8_t)'='] = sc->num_eq_symbol; - - init_choosers(sc); - init_typers(sc); - init_opt_functions(sc); - s7_set_history_enabled(sc, false); -#if S7_DEBUGGING - init_tc_rec(sc); -#endif - - init_unlet(sc); - init_signatures(sc); /* depends on procedure symbols */ - sc->s7_starlet = make_s7_starlet(sc); - s7_set_history_enabled(sc, true); - -#if (!WITH_PURE_S7) - s7_define_variable(sc, "make-rectangular", global_value(sc->complex_symbol)); - s7_eval_c_string(sc, "(define make-polar \n\ - (let ((+signature+ '(number? real? real?))) \n\ - (lambda (mag ang) \n\ - (if (and (real? mag) (real? ang)) \n\ - (complex (* mag (cos ang)) (* mag (sin ang))) \n\ - (error 'wrong-type-arg \"make-polar arguments should be real\")))))"); - - s7_eval_c_string(sc, "(define (call-with-values producer consumer) (apply consumer (list (producer))))"); - /* (consumer (producer)) will work in any "normal" context. If consumer is syntax and then subsequently not syntax, there is confusion */ - - s7_eval_c_string(sc, "(define-macro (multiple-value-bind vars expression . body) \n\ - (list (cons 'lambda (cons vars body)) expression))"); - - s7_eval_c_string(sc, "(define-macro (cond-expand . clauses) \n\ - (letrec ((traverse (lambda (tree) \n\ - (if (pair? tree) \n\ - (cons (traverse (car tree)) \n\ - (case (cdr tree) ((())) (else => traverse))) \n\ - (if (memq tree '(and or not else)) tree \n\ - (and (symbol? tree) (provided? tree))))))) \n\ - (cons 'cond (map (lambda (clause) \n\ - (if (pair? clause) \n\ - (cons (traverse (car clause)) \n\ - (case (cdr clause) ((()) '(#f)) (else))) \n\ - (error 'read-error \"cond-expand: bad clause\"))) \n\ - clauses))))"); -#endif - - s7_eval_c_string(sc, "(define-expansion (reader-cond . clauses) \n\ - (call-with-exit \n\ - (lambda (return) \n\ - (for-each \n\ - (lambda (clause) \n\ - (let ((val (eval (car clause)))) \n\ - (when val \n\ - (return \n\ - (cond ((null? (cdr clause)) val) \n\ - ((eq? (cadr clause) '=>) ((eval (caddr clause)) val)) \n\ - ((null? (cddr clause)) (cadr clause)) \n\ - (else (apply values (map quote (cdr clause))))))))) \n\ - clauses) \n\ - (values))))"); /* this is not redundant */ /* map above ignores trailing cdr if improper */ - - s7_eval_c_string(sc, "(define make-hook \n\ - (let ((+documentation+ \"(make-hook . pars) returns a new hook (a function) that passes the parameters to its function list.\")) \n\ - (lambda hook-args \n\ - (let ((body ())) \n\ - (apply lambda* hook-args \n\ - `((let ((result #)) \n\ - (let ((hook (openlet (sublet (curlet) 'let-ref-fallback (lambda (e sym) #))))) \n\ - (for-each (lambda (hook-function) (hook-function hook)) body) \n\ - result))))))))"); - /* (procedure-source (make-hook 'x 'y)): (lambda* (x y) (let ((result #)) ... result)), see stuff.scm for commentary */ - - s7_eval_c_string(sc, "(define hook-functions \n\ - (let ((+signature+ '(#t procedure?)) \n\ - (+documentation+ \"(hook-functions hook) gets or sets the list of functions associated with the hook\")) \n\ - (dilambda \n\ - (lambda (hook) \n\ - (when (or (not (procedure? hook)) (continuation? hook) (goto? hook)) \n\ - (error 'wrong-type-arg \"hook-functions hook must be a procedure created by make-hook: ~S\" hook)) \n\ - ((funclet hook) 'body)) \n\ - (lambda (hook lst) \n\ - (when (or (not (procedure? hook)) (continuation? hook) (goto? hook)) \n\ - (error 'wrong-type-arg \"hook-functions hook must be a procedure created by make-hook: ~S\" hook)) \n\ - (if (do ((p lst (cdr p))) \n\ - ((not (and (pair? p) \n\ - (procedure? (car p)) \n\ - (aritable? (car p) 1))) \n\ - (null? p))) \n\ - (set! ((funclet hook) 'body) lst) \n\ - (error 'wrong-type-arg \"hook-functions must be a list of functions, each accepting one argument: ~S\" lst))))))"); - - /* -------- *unbound-variable-hook* -------- */ - sc->unbound_variable_hook = s7_eval_c_string(sc, "(make-hook 'variable)"); - s7_define_constant_with_documentation(sc, "*unbound-variable-hook*", sc->unbound_variable_hook, - "*unbound-variable-hook* functions are called when an unbound variable is encountered, passed (hook 'variable)."); - - /* -------- *missing-close-paren-hook* -------- */ - sc->missing_close_paren_hook = s7_eval_c_string(sc, "(make-hook)"); - s7_define_constant_with_documentation(sc, "*missing-close-paren-hook*", sc->missing_close_paren_hook, - "*missing-close-paren-hook* functions are called when the reader thinks a close paren is missing"); - - /* -------- *load-hook* -------- */ - sc->load_hook = s7_eval_c_string(sc, "(make-hook 'name)"); - s7_define_constant_with_documentation(sc, "*load-hook*", sc->load_hook, - "*load-hook* functions are invoked by load, passing the to-be-loaded filename as (hook 'name)"); - - /* -------- *autoload-hook* -------- */ - sc->autoload_hook = s7_eval_c_string(sc, "(make-hook 'name 'file)"); - s7_define_constant_with_documentation(sc, "*autoload-hook*", sc->autoload_hook, - "*autoload-hook* functions are invoked by autoload, passing the to-be-autoloaded filename as (hook 'name) and (hook 'file))"); - - /* -------- *error-hook* -------- */ - sc->error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); - s7_define_constant_with_documentation(sc, "*error-hook*", sc->error_hook, - "*error-hook* functions are called in the error handler, passed (hook 'type) and (hook 'data)."); - - /* -------- *read-error-hook* -------- */ - sc->read_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); - s7_define_constant_with_documentation(sc, "*read-error-hook*", sc->read_error_hook, - "*read-error-hook* functions are called by the reader if it is unhappy, passing the current program string as (hook 'data)."); - - /* -------- *rootlet-redefinition-hook* -------- */ - sc->rootlet_redefinition_hook = s7_eval_c_string(sc, "(make-hook 'name 'value)"); - s7_define_constant_with_documentation(sc, "*rootlet-redefinition-hook*", sc->rootlet_redefinition_hook, - "*rootlet-redefinition-hook* functions are called when a top-level variable's value is changed, (hook 'name 'value)."); - - sc->let_temp_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); - -#if S7_DEBUGGING - s7_define_function(sc, "report-missed-calls", g_report_missed_calls, 0, 0, false, NULL); - if (!s7_type_names[0]) {fprintf(stderr, "no type_names\n"); gdb_break();} /* squelch very stupid warnings! */ - if (strcmp(op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0) - fprintf(stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]); - if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) - fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]); - if (NUM_OPS != 924) - fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info)); - /* cell size: 48, 120 if debugging, block size: 40, opt: 128 or 280 */ -#endif - - return(sc); -} - - -/* -------------------------------- s7_free -------------------------------- */ -static void gc_list_free(gc_list_t *g) -{ - free(g->list); - free(g); -} - -void s7_free(s7_scheme *sc) -{ - /* free the memory associated with sc - * most pointers are in the saved_pointers table, but any that might be realloc'd need to be handled explicitly - * valgrind --leak-check=full --show-reachable=yes --suppressions=/home/bil/cl/free.supp repl s7test.scm - * valgrind --leak-check=full --show-reachable=yes --gen-suppressions=all --error-limit=no --log-file=raw.log repl s7test.scm - */ - s7_int i; - gc_list_t *gp; - - /* g_gc(sc, sc->nil); */ /* probably not needed (my simple tests work fine if the gc call is omitted) */ /* removed 14-Apr-22 */ - /* s7_quit(sc); */ /* not always needed -- will clean up the C stack if we haven't returned to the top level */ - - gp = sc->c_objects; /* do this first since they might involve gc_unprotect etc */ - for (i = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (c_object_gc_free(sc, s1)) - (*(c_object_gc_free(sc, s1)))(sc, s1); - else (*(c_object_free(sc, s1)))(c_object_value(s1)); - } - gc_list_free(gp); - - gp = sc->vectors; - for (i = 0; i < gp->loc; i++) - if (block_index(unchecked_vector_block(gp->list[i])) == TOP_BLOCK_LIST) - free(block_data(unchecked_vector_block(gp->list[i]))); - gc_list_free(gp); - gc_list_free(sc->multivectors); /* I assume vector_dimension_info won't need 131072 bytes */ - - gp = sc->strings; - for (i = 0; i < gp->loc; i++) - if (block_index(unchecked_string_block(gp->list[i])) == TOP_BLOCK_LIST) - free(block_data(unchecked_string_block(gp->list[i]))); - gc_list_free(gp); - - gp = sc->output_ports; - for (i = 0; i < gp->loc; i++) - { - if ((unchecked_port_data_block(gp->list[i])) && - (block_index(unchecked_port_data_block(gp->list[i])) == TOP_BLOCK_LIST)) - free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */ - if ((is_file_port(gp->list[i])) && - (!port_is_closed(gp->list[i]))) - fclose(port_file(gp->list[i])); - } - gc_list_free(gp); - - gp = sc->input_ports; - for (i = 0; i < gp->loc; i++) - if ((unchecked_port_data_block(gp->list[i])) && - (block_index(unchecked_port_data_block(gp->list[i])) == TOP_BLOCK_LIST)) - free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */ - gc_list_free(gp); - gc_list_free(sc->input_string_ports); /* port_data_block is null, port_block is the const char* data, so I assume it is handled elsewhere */ - - gp = sc->hash_tables; - for (i = 0; i < gp->loc; i++) - if (block_index(unchecked_hash_table_block(gp->list[i])) == TOP_BLOCK_LIST) - free(block_data(unchecked_hash_table_block(gp->list[i]))); - gc_list_free(gp); - -#if WITH_GMP - /* free lists */ - {bigint *p, *np; for (p = sc->bigints; p; p = np) {mpz_clear(p->n); np = p->nxt; free(p);}} - {bigrat *p, *np; for (p = sc->bigrats; p; p = np) {mpq_clear(p->q); np = p->nxt; free(p);}} - {bigflt *p, *np; for (p = sc->bigflts; p; p = np) {mpfr_clear(p->x); np = p->nxt; free(p);}} - {bigcmp *p, *np; for (p = sc->bigcmps; p; p = np) {mpc_clear(p->z); np = p->nxt; free(p);}} - - gp = sc->big_integers; - for (i = 0; i < gp->loc; i++) {bigint *p; p = big_integer_bgi(gp->list[i]); mpz_clear(p->n); free(p);} - gc_list_free(gp); - - gp = sc->big_ratios; - for (i = 0; i < gp->loc; i++) {bigrat *p; p = big_ratio_bgr(gp->list[i]); mpq_clear(p->q); free(p);} - gc_list_free(gp); - - gp = sc->big_reals; - for (i = 0; i < gp->loc; i++) {bigflt *p; p = big_real_bgf(gp->list[i]); mpfr_clear(p->x); free(p);} - gc_list_free(gp); - - gp = sc->big_complexes; - for (i = 0; i < gp->loc; i++) {bigcmp *p; p = big_complex_bgc(gp->list[i]); mpc_clear(p->z); free(p);} - gc_list_free(gp); - - gp = sc->big_random_states; - for (i = 0; i < gp->loc; i++) gmp_randclear(random_gmp_state(gp->list[i])); - gc_list_free(gp); - - gmp_randclear(random_gmp_state(sc->default_random_state)); - - /* temps */ - if (sc->ratloc) free_rat_locals(sc); - mpz_clears(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL); - mpq_clears(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL); - mpfr_clears(sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL); - mpc_clear(sc->mpc_1); - mpc_clear(sc->mpc_2); - /* I claim the leftovers (864 bytes, all from mpfr_cosh) are gmp's fault */ -#endif - - free(undefined_name(sc->undefined)); - gp = sc->undefineds; - for (i = 0; i < gp->loc; i++) - free(undefined_name(gp->list[i])); - gc_list_free(gp); - - gc_list_free(sc->gensyms); - gc_list_free(sc->continuations); /* stack is simple vector (handled above) */ - gc_list_free(sc->weak_refs); - gc_list_free(sc->weak_hash_iterators); - gc_list_free(sc->opt1_funcs); - - free(port_port(sc->standard_output)); - free(port_port(sc->standard_error)); - free(port_port(sc->standard_input)); - - if (sc->autoload_names) free(sc->autoload_names); - if (sc->autoload_names_sizes) free(sc->autoload_names_sizes); - if (sc->autoloaded_already) free(sc->autoloaded_already); - - for (block_t *top = sc->block_lists[TOP_BLOCK_LIST]; top; top = block_next(top)) - if (block_data(top)) - free(block_data(top)); - - for (i = 0; i < sc->saved_pointers_loc; i++) - free(sc->saved_pointers[i]); - free(sc->saved_pointers); - - { - gc_obj_t *g, *gnxt; - heap_block_t *hpnxt; - for (g = sc->semipermanent_lets; g; g = gnxt) {gnxt = g->nxt; free(g);} - for (g = sc->semipermanent_objects; g; g = gnxt) {gnxt = g->nxt; free(g);} - for (heap_block_t *hp = sc->heap_blocks; hp; hp = hpnxt) {hpnxt = hp->next; free(hp);} - } - - free(sc->heap); - free(sc->free_heap); - free(vector_elements(sc->symbol_table)); /* alloc'd directly, not via block */ - free(sc->symbol_table); - free(sc->unlet); - free(sc->setters); - free(sc->op_stack); - if (sc->tree_pointers) free(sc->tree_pointers); - free(sc->num_to_str); - free(sc->protected_objects_free_list); - if (sc->read_line_buf) free(sc->read_line_buf); - free(sc->strbuf); - free(sc->circle_info->objs); - free(sc->circle_info->refs); - free(sc->circle_info->defined); - free(sc->circle_info); - if (sc->file_names) free(sc->file_names); - free(sc->unentry); - free(sc->input_port_stack); - if (sc->typnam) free(sc->typnam); - - for (i = 0; i < sc->num_fdats; i++) - if (sc->fdats[i]) /* init val is NULL */ - { - if (sc->fdats[i]->curly_str) - free(sc->fdats[i]->curly_str); - free(sc->fdats[i]); - } - free(sc->fdats); - - if (sc->profile_data) - { - free(sc->profile_data->funcs); - free(sc->profile_data->let_names); - free(sc->profile_data->files); - free(sc->profile_data->lines); - free(sc->profile_data->excl); - free(sc->profile_data->timing_data); - free(sc->profile_data); - } - if (sc->c_object_types) - { - for (i = 0; i < sc->num_c_object_types; i++) - free(sc->c_object_types[i]); - free(sc->c_object_types); - } - free(sc); -} - - -/* -------------------------------- repl -------------------------------- */ -#ifndef USE_SND - #define USE_SND 0 -#endif -#ifndef WITH_MAIN - #define WITH_MAIN 0 -#endif - -#if WITH_MAIN && WITH_NOTCURSES - #include "nrepl.c" - /* gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core */ -#else - -static void dumb_repl(s7_scheme *sc) -{ - while (true) - { - char buffer[512]; - fprintf(stdout, "\n> "); - if (!fgets(buffer, 512, stdin)) break; /* error or ctrl-D */ - if (((buffer[0] != '\n') || (strlen(buffer) > 1))) - { - char response[1024]; - snprintf(response, 1024, "(write %s)", buffer); - s7_eval_c_string(sc, response); - }} - fprintf(stdout, "\n"); - if (ferror(stdin)) - fprintf(stderr, "read error on stdin\n"); -} - -void s7_repl(s7_scheme *sc) -{ -#if (!WITH_C_LOADER) - dumb_repl(sc); -#else -#if WITH_NOTCURSES - s7_load(sc, "nrepl.scm"); -#else - /* try to get lib_s7.so from the repl's directory, and set *libc*. - * otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h - */ - bool repl_loaded = false; - s7_pointer e = s7_inlet(sc, set_clist_2(sc, make_symbol(sc, "init_func", 9), make_symbol(sc, "libc_s7_init", 12))); - s7_int gc_loc = s7_gc_protect(sc, e); - s7_pointer old_e = s7_set_curlet(sc, e); /* e is now (curlet) so loaded names from libc will be placed there, not in (rootlet) */ - s7_pointer val = s7_load_with_environment(sc, "libc_s7.so", e); - if (val) - { - s7_pointer libs = global_slot(sc->libraries_symbol); - uint64_t hash = raw_string_hash((const uint8_t *)"*libc*", 6); /* hack around an idiotic gcc 10.2.1 warning */ - s7_define(sc, sc->nil, new_symbol(sc, "*libc*", 6, hash, hash % SYMBOL_TABLE_SIZE), e); - slot_set_value(libs, cons(sc, cons(sc, s7_make_semipermanent_string(sc, "libc.scm"), e), slot_value(libs))); - } - - s7_set_curlet(sc, old_e); /* restore incoming (curlet) */ - s7_gc_unprotect_at(sc, gc_loc); - - if (!val) /* s7_load was unable to find/load libc_s7.so */ - dumb_repl(sc); - else - { -#if S7_DEBUGGING - s7_autoload(sc, make_symbol(sc, "compare-calls", 13), s7_make_string(sc, "compare-calls.scm")); - s7_autoload(sc, make_symbol(sc, "get-overheads", 13), s7_make_string(sc, "compare-calls.scm")); -#endif - s7_provide(sc, "libc.scm"); - if (!repl_loaded) s7_load(sc, "repl.scm"); - s7_eval_c_string(sc, "((*repl* 'run))"); - } -#endif -#endif -} - -#if WITH_MAIN && (!USE_SND) - -#if (!MS_WINDOWS) && WITH_C_LOADER -static char *realdir(const char *filename) /* this code courtesy Lassi Kortela 4-Nov-19 */ -{ - char *path; - char *p; - /* s7_repl wants to load libc_s7.o (for tcsetattr et al), but if it is started in a directory other than the libc_s7.so - * directory, it fails (it tries to build the library but that requires s7.h and libc.scm). So here we are trying to - * guess the libc_s7 directory from the command line program name. This can't work in general, but it works often - * enough to be worth the effort. If S7_LOAD_PATH is set, it is used instead. - */ - if (!strchr(filename, '/')) - return(NULL); - - if (!(path = realpath(filename, NULL))) /* in Windows maybe GetModuleFileName(NULL, buffer, buffer_size) */ - { - fprintf(stderr, "%s: %s\n", strerror(errno), filename); - exit(2); - } - if (!(p = strrchr(path, '/'))) - { - free(path); - fprintf(stderr, "please provide the full pathname for %s\n", filename); - exit(2); - } - if (p > path) *p = '\0'; else p[1] = 0; - return(path); -} -#endif - -int main(int argc, char **argv) -{ - s7_scheme *sc = s7_init(); - fprintf(stderr, "s7: %s\n", S7_DATE); - - if (argc == 2) - { - fprintf(stderr, "load %s\n", argv[1]); - if (!s7_load(sc, argv[1])) - { - fprintf(stderr, "can't load %s\n", argv[1]); - return(2); - }} - else - { -#if (MS_WINDOWS) || (!WITH_C_LOADER) || ((defined(__linux__)) && (!defined(__GLIBC__))) /* musl? */ - dumb_repl(sc); -#else -#ifdef S7_LOAD_PATH - s7_add_to_load_path(sc, S7_LOAD_PATH); -#else - char *dir = realdir(argv[0]); - if (dir) - { - s7_add_to_load_path(sc, dir); - free(dir); - } -#endif - s7_repl(sc); -#endif - } - return(0); -} - -/* in Linux: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic ; also need libc.scm cload.scm repl.scm to get a decent repl - * in *BSD: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm -Wl,-export-dynamic - * in OSX: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm - * (clang also needs LDFLAGS="-Wl,-export-dynamic" in Linux and "-fPIC") - * in msys2: gcc s7.c -o s7 -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib - * for tcc: tcc -o s7 s7.c -I. -lm -DWITH_MAIN -ldl -rdynamic -DWITH_C_LOADER - * - * for nrepl: gcc s7.c -o repl -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm -Wl,-export-dynamic - * - * (s7.c compile time 27-Oct-22 49 secs) - * musl works, but there is some problem in libgsl.scm with gsl/gsl_blas.h I think - */ -#endif -#endif - -/* --------------------------------------------- - * 20.9 21.0 22.0 22.9 23.0 - * --------------------------------------------- - * tpeak 115 114 108 105 105 - * tref 691 687 463 459 459 - * index 1026 1016 973 966 967 - * tmock 1177 1165 1057 1019 1019 - * tvect 2519 2464 1772 1670 1669 - * timp 2637 2575 1930 1689 1694 - * texit ---- ---- 1778 1741 1741 - * s7test 1873 1831 1818 1826 1829 - * thook ---- ---- 2590 2030 2030 - * tauto ---- ---- 2562 2055 2048 - * lt 2187 2172 2150 2182 2185 - * dup 3805 3788 2492 2243 2239 - * tcopy 8035 5546 2539 2373 2375 - * tload ---- ---- 3046 2370 2408 - * tread 2440 2421 2419 2407 2408 - * fbench 2688 2583 2460 2428 2430 - * trclo 2735 2574 2454 2446 2445 - * titer 2865 2842 2641 2509 2509 - * tmat 3065 3042 2524 2567 2574 - * tb 2735 2681 2612 2603 2604 - * tsort 3105 3104 2856 2804 2804 - * teq 4068 4045 3536 3487 3486 - * tobj 4016 3970 3828 3570 3577 - * tio 3816 3752 3683 3620 3620 - * tmac 3950 3873 3033 3677 3677 - * tclo 4787 4735 4390 4389 4384 - * tcase 4960 4793 4439 4425 4430 - * tlet 7775 5640 4450 4431 4427 - * tstar 6139 5923 5519 4414 4451 - * tfft 7820 7729 4755 4465 4476 - * tmap 8869 8774 4489 4541 4541 - * tshoot 5525 5447 5183 5055 5055 - * tstr 6880 6342 5488 5161 5162 - * tform 5357 5348 5307 5304 5316 - * tnum 6348 6013 5433 5385 5396 - * tlamb 6423 6273 5720 5554 5560 - * tmisc 8869 7612 6435 6085 6076 - * tset ---- ---- ---- 6242 6260 - * tlist 7896 7546 6558 6244 6240 - * tgsl 8485 7802 6373 6281 6282 - * tari 13.0 12.7 6827 6543 6543 - * trec 6936 6922 6521 6588 6588 - * tleft 10.4 10.2 7657 7477 7479 - * tgc 11.9 11.1 8177 7868 7857 - * thash 11.8 11.7 9734 9483 9479 - * cb 11.2 11.0 9658 9551 9564 - * tgen 11.2 11.4 12.0 12.1 12.1 - * tall 15.6 15.6 15.6 15.6 15.6 - * calls 36.7 37.5 37.0 37.6 37.5 - * sg ---- ---- 55.9 55.8 55.8 - * lg ---- ---- 105.2 106.2 106.5 - * tbig 177.4 175.8 156.5 148.1 148.1 - * --------------------------------------------- - * - * (let-temporarily (((setter list) list)) (set! (list 1 2) (values 3 4 5))) should be an error? (any mv 3rd arg) - * se 79352 -- there is no way to treat this as an error consistently - * where are non-symbols->*s7* set? eval at op and g_s7... both could be checked - */ diff --git a/source/engine/s7.h b/source/engine/s7.h deleted file mode 100644 index aeacedf2..00000000 --- a/source/engine/s7.h +++ /dev/null @@ -1,1239 +0,0 @@ -#ifndef S7_H -#define S7_H - -#define S7_VERSION "10.5" -#define S7_DATE "12-Dec-2022" -#define S7_MAJOR_VERSION 10 -#define S7_MINOR_VERSION 5 - -#include /* for int64_t */ - -typedef int64_t s7_int; -typedef double s7_double; - -#ifndef __cplusplus -#ifndef _MSC_VER - #include -#else -#ifndef true - #define bool unsigned char - #define true 1 - #define false 0 -#endif -#endif -#endif - -#if WITH_GMP - /* in g++ these includes need to be outside the extern "C" business */ - #include - #include - #include -#endif - -#ifdef __cplusplus -extern "C" { -#endif - -typedef struct s7_scheme s7_scheme; -typedef struct s7_cell *s7_pointer; - -s7_scheme *s7_init(void); - /* s7_scheme is our interpreter - * s7_pointer is a Scheme object of any (Scheme) type - * s7_init creates the interpreter. - */ -void s7_free(s7_scheme *sc); - -typedef s7_pointer (*s7_function)(s7_scheme *sc, s7_pointer args); /* that is, obj = func(s7, args) -- args is a list of arguments */ -typedef s7_pointer (*s7_pfunc)(s7_scheme *sc); - -s7_pointer s7_f(s7_scheme *sc); /* #f */ -s7_pointer s7_t(s7_scheme *sc); /* #t */ -s7_pointer s7_nil(s7_scheme *sc); /* () */ -s7_pointer s7_undefined(s7_scheme *sc); /* # */ -s7_pointer s7_unspecified(s7_scheme *sc); /* # */ -bool s7_is_unspecified(s7_scheme *sc, s7_pointer val); /* returns true if val is # */ -s7_pointer s7_eof_object(s7_scheme *sc); /* # */ -bool s7_is_null(s7_scheme *sc, s7_pointer p); /* null? */ - - /* these are the Scheme constants; they do not change in value during a run, - * so they can be safely assigned to C global variables if desired. - */ - -bool s7_is_valid(s7_scheme *sc, s7_pointer arg); /* does 'arg' look like an s7 object? */ -bool s7_is_c_pointer(s7_pointer arg); /* (c-pointer? arg) */ -bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type); -void *s7_c_pointer(s7_pointer p); -void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer p, s7_pointer expected_type, const char *caller, s7_int argnum); -s7_pointer s7_c_pointer_type(s7_pointer p); -s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr); /* these are for passing uninterpreted C pointers through Scheme */ -s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info); - -s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str); /* (eval-string str) */ -s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e); -s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer arg, bool use_write); - /* (object->string obj) */ -char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj); /* same as object->string but returns a C char* directly */ - /* the returned value should be freed by the caller */ - -s7_pointer s7_load(s7_scheme *sc, const char *file); /* (load file) */ -s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e); -s7_pointer s7_load_c_string(s7_scheme *sc, const char *content, s7_int bytes); -s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e); -s7_pointer s7_load_path(s7_scheme *sc); /* *load-path* */ -s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir); /* (set! *load-path* (cons dir *load-path*)) */ -s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function); /* (autoload symbol file-or-function) */ -void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size); - - /* the load path is a list of directories to search if load can't find the file passed as its argument. - * - * s7_load and s7_load_with_environment can load shared object files as well as scheme code. - * The scheme (load "somelib.so" (inlet 'init_func 'somelib_init)) is equivalent to - * s7_load_with_environment(s7, "somelib.so", s7_inlet(s7, s7_list(s7, 2, s7_make_symbol(s7, "init_func"), s7_make_symbol(s7, "somelib_init")))) - * s7_load_with_environment returns NULL if it can't load the file. - */ -void s7_quit(s7_scheme *sc); - /* this tries to break out of the current evaluation, leaving everything else intact */ - -void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val); -void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val)); - /* call "hook" at the start of any block; use NULL to cancel. - * s7_begin_hook returns the current begin_hook function or NULL. - */ - -s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e); /* (eval code e) -- e is the optional environment */ -s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer e, const char *caller, const char *file, s7_int line); -void s7_provide(s7_scheme *sc, const char *feature); /* add feature (as a symbol) to the *features* list */ -bool s7_is_provided(s7_scheme *sc, const char *feature); /* (provided? feature) */ -void s7_repl(s7_scheme *sc); - -s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info); -s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr); -s7_pointer s7_wrong_type_error(s7_scheme *sc, s7_pointer caller, s7_int arg_n, s7_pointer arg, s7_pointer descr); - /* set arg_n to 0 to indicate that caller takes only one argument (so the argument number need not be reported */ -s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr); -s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args); - - /* these are equivalent to (error ...) in Scheme - * the first argument to s7_error is a symbol that can be caught (via (catch tag ...)) - * the rest of the arguments are passed to the error handler (if in catch) - * or printed out (in the default case). If the first element of the list - * of args ("info") is a string, the default error handler treats it as - * a format control string, and passes it to format with the rest of the - * info list as the format function arguments. - * - * s7_wrong_type_arg_error is equivalent to s7_error with a type of 'wrong-type-arg - * and similarly s7_out_of_range_error with type 'out-of-range. - * - * catch in Scheme is taken from Guile: - * - * (catch tag thunk handler) - * - * evaluates 'thunk'. If an error occurs, and the type matches 'tag' (or if 'tag' is #t), - * the handler is called, passing it the arguments (including the type) passed to the - * error function. If no handler is found, the default error handler is called, - * normally printing the error arguments to current-error-port. - */ - -s7_pointer s7_stacktrace(s7_scheme *sc); -s7_pointer s7_history(s7_scheme *sc); /* the current (circular backwards) history buffer */ -s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry); /* add entry to the history buffer */ -bool s7_history_enabled(s7_scheme *sc); -bool s7_set_history_enabled(s7_scheme *sc, bool enabled); - -s7_pointer s7_gc_on(s7_scheme *sc, bool on); /* (gc on) */ - -s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x); -void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc); -s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc); -s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x); -s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x); -s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc); -s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc); - - /* any s7_pointer object held in C (as a local variable for example) needs to be - * protected from garbage collection if there is any chance the GC may run without - * an existing Scheme-level reference to that object. s7_gc_protect places the - * object in a vector that the GC always checks, returning the object's location - * in that table. s7_gc_unprotect_at unprotects the object (removes it from the - * vector) using the location passed to it. s7_gc_protected_at returns the object - * at the given location. - * - * You can turn the GC on and off via s7_gc_on. - * - * There is a built-in lag between the creation of a new object and its first possible GC - * (the lag time is set indirectly by GC_TEMPS_SIZE in s7.c), so you don't need to worry about - * very short term temps such as the arguments to s7_cons in: - * - * s7_cons(s7, s7_make_real(s7, 3.14), - * s7_cons(s7, s7_make_integer(s7, 123), s7_nil(s7))); - */ - -bool s7_is_eq(s7_pointer a, s7_pointer b); /* (eq? a b) */ -bool s7_is_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (eqv? a b) */ -bool s7_is_equal(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (equal? a b) */ -bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y); /* (equivalent? x y) */ - -bool s7_is_boolean(s7_pointer x); /* (boolean? x) */ -bool s7_boolean(s7_scheme *sc, s7_pointer x); /* Scheme boolean -> C bool */ -s7_pointer s7_make_boolean(s7_scheme *sc, bool x); /* C bool -> Scheme boolean */ - - /* for each Scheme type (boolean, integer, string, etc), there are three - * functions: s7_(...), s7_make_(...), and s7_is_(...): - * - * s7_boolean(s7, obj) returns the C bool corresponding to the value of 'obj' (#f -> false) - * s7_make_boolean(s7, false|true) returns the s7 boolean corresponding to the C bool argument (false -> #f) - * s7_is_boolean(s7, obj) returns true if 'obj' has a boolean value (#f or #t). - */ - - -bool s7_is_pair(s7_pointer p); /* (pair? p) */ -s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (cons a b) */ - -s7_pointer s7_car(s7_pointer p); /* (car p) */ -s7_pointer s7_cdr(s7_pointer p); /* (cdr p) */ - -s7_pointer s7_set_car(s7_pointer p, s7_pointer q); /* (set-car! p q) */ -s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q); /* (set-cdr! p q) */ - -s7_pointer s7_cadr(s7_pointer p); /* (cadr p) */ -s7_pointer s7_cddr(s7_pointer p); /* (cddr p) */ -s7_pointer s7_cdar(s7_pointer p); /* (cdar p) */ -s7_pointer s7_caar(s7_pointer p); /* (caar p) */ - -s7_pointer s7_caadr(s7_pointer p); /* etc */ -s7_pointer s7_caddr(s7_pointer p); -s7_pointer s7_cadar(s7_pointer p); -s7_pointer s7_caaar(s7_pointer p); -s7_pointer s7_cdadr(s7_pointer p); -s7_pointer s7_cdddr(s7_pointer p); -s7_pointer s7_cddar(s7_pointer p); -s7_pointer s7_cdaar(s7_pointer p); - -s7_pointer s7_caaadr(s7_pointer p); -s7_pointer s7_caaddr(s7_pointer p); -s7_pointer s7_caadar(s7_pointer p); -s7_pointer s7_caaaar(s7_pointer p); -s7_pointer s7_cadadr(s7_pointer p); -s7_pointer s7_cadddr(s7_pointer p); -s7_pointer s7_caddar(s7_pointer p); -s7_pointer s7_cadaar(s7_pointer p); -s7_pointer s7_cdaadr(s7_pointer p); -s7_pointer s7_cdaddr(s7_pointer p); -s7_pointer s7_cdadar(s7_pointer p); -s7_pointer s7_cdaaar(s7_pointer p); -s7_pointer s7_cddadr(s7_pointer p); -s7_pointer s7_cddddr(s7_pointer p); -s7_pointer s7_cdddar(s7_pointer p); -s7_pointer s7_cddaar(s7_pointer p); - -bool s7_is_list(s7_scheme *sc, s7_pointer p); /* (list? p) -> (or (pair? p) (null? p)) */ -bool s7_is_proper_list(s7_scheme *sc, s7_pointer p); /* (proper-list? p) */ -s7_int s7_list_length(s7_scheme *sc, s7_pointer a); /* (length a) */ -s7_pointer s7_make_list(s7_scheme *sc, s7_int len, s7_pointer init); /* (make-list len init) */ -s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...); /* (list ...) */ -s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...); /* (list ...) arglist should be NULL terminated (more error checks than s7_list) */ -s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array); /* array contents -> list */ -void s7_list_to_array(s7_scheme *sc, s7_pointer list, s7_pointer *array, int32_t len); /* list -> array (intended for old code) */ -s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a); /* (reverse a) */ -s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (append a b) */ -s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num); /* (list-ref lst num) */ -s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val); /* (list-set! lst num val) */ -s7_pointer s7_assoc(s7_scheme *sc, s7_pointer obj, s7_pointer lst); /* (assoc obj lst) */ -s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x); /* (assq obj lst) */ -s7_pointer s7_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst); /* (member obj lst) */ -s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x); /* (memq obj lst) */ -bool s7_tree_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree); /* (tree-memq sym tree) */ - - -bool s7_is_string(s7_pointer p); /* (string? p) */ -const char *s7_string(s7_pointer p); /* Scheme string -> C string (do not free the string) */ -s7_pointer s7_make_string(s7_scheme *sc, const char *str); /* C string -> Scheme string (str is copied) */ -s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len); /* same as s7_make_string, but provides strlen */ -s7_pointer s7_make_string_wrapper(s7_scheme *sc, const char *str); -s7_pointer s7_make_string_wrapper_with_length(s7_scheme *sc, const char *str, s7_int len); -s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str); /* make a string that will never be GC'd */ -s7_pointer s7_make_semipermanent_string(s7_scheme *sc, const char *str); /* for (s7) string permanent within one s7 instance (freed upon s7_free) */ -s7_int s7_string_length(s7_pointer str); /* (string-length str) */ - - -bool s7_is_character(s7_pointer p); /* (character? p) */ -uint8_t s7_character(s7_pointer p); /* Scheme character -> unsigned C char */ -s7_pointer s7_make_character(s7_scheme *sc, uint8_t c); /* unsigned C char -> Scheme character */ - - -bool s7_is_number(s7_pointer p); /* (number? p) */ -bool s7_is_integer(s7_pointer p); /* (integer? p) */ -s7_int s7_integer(s7_pointer p); /* Scheme integer -> C integer (s7_int) */ -s7_pointer s7_make_integer(s7_scheme *sc, s7_int num); /* C s7_int -> Scheme integer */ - -bool s7_is_real(s7_pointer p); /* (real? p) */ -s7_double s7_real(s7_pointer p); /* Scheme real -> C double */ -s7_pointer s7_make_real(s7_scheme *sc, s7_double num); /* C double -> Scheme real */ -s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n); -s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x); /* x can be any kind of number */ -s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller); -s7_double s7_number_to_real_with_location(s7_scheme *sc, s7_pointer x, s7_pointer caller); -s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x); -s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller); - -bool s7_is_rational(s7_pointer arg); /* (rational? arg) -- integer or ratio */ -bool s7_is_ratio(s7_pointer arg); /* true if arg is a ratio, not an integer */ -s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b); /* returns the Scheme object a/b */ -s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error); /* (rationalize x error) */ -s7_int s7_numerator(s7_pointer x); /* (numerator x) */ -s7_int s7_denominator(s7_pointer x); /* (denominator x) */ -s7_double s7_random(s7_scheme *sc, s7_pointer state); /* (random x) */ -s7_pointer s7_random_state(s7_scheme *sc, s7_pointer seed); /* (random-state seed) */ -s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args); /* (random-state->list r) */ -void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry); -bool s7_is_random_state(s7_pointer p); /* (random-state? p) */ - -bool s7_is_complex(s7_pointer arg); /* (complex? arg) */ -s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b); /* returns the Scheme object a+bi */ -s7_double s7_real_part(s7_pointer z); /* (real-part z) */ -s7_double s7_imag_part(s7_pointer z); /* (imag-part z) */ -char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix); /* (number->string obj radix) */ - -bool s7_is_vector(s7_pointer p); /* (vector? p) */ -s7_int s7_vector_length(s7_pointer vec); /* (vector-length vec) */ -s7_int s7_vector_rank(s7_pointer vect); /* number of dimensions in vect */ -s7_int s7_vector_dimension(s7_pointer vec, s7_int dim); -s7_pointer *s7_vector_elements(s7_pointer vec); /* a pointer to the array of s7_pointers */ -s7_int *s7_int_vector_elements(s7_pointer vec); -uint8_t *s7_byte_vector_elements(s7_pointer vec); -s7_double *s7_float_vector_elements(s7_pointer vec); -bool s7_is_float_vector(s7_pointer p); /* (float-vector? p) */ -bool s7_is_int_vector(s7_pointer p); /* (int-vector? p) */ -bool s7_is_byte_vector(s7_pointer p); /* (byte-vector? p) */ - -s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index); /* (vector-ref vec index) */ -s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a); /* (vector-set! vec index a) */ -s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, s7_int indices, ...); /* multidimensional vector-ref */ -s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, s7_int indices, ...); /* multidimensional vector-set! */ -s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size); /* vector dimensions */ -s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size); - -s7_int s7_int_vector_ref(s7_pointer vec, s7_int index); -s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value); -uint8_t s7_byte_vector_ref(s7_pointer vec, s7_int index); -uint8_t s7_byte_vector_set(s7_pointer vec, s7_int index, uint8_t value); -s7_double s7_float_vector_ref(s7_pointer vec, s7_int index); -s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value); - -s7_pointer s7_make_vector(s7_scheme *sc, s7_int len); /* (make-vector len) */ -s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); -s7_pointer s7_make_byte_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); -s7_pointer s7_make_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); -s7_pointer s7_make_normal_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); /* make-vector but possibly multidimensional */ -s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_int len, s7_double *data, s7_int dims, s7_int *dim_info, bool free_data); -s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill); /* (make-vector len fill) */ - -void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj); /* (vector-fill! vec obj) */ -s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect); -s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect); /* (vector->list vec) */ - /* - * (vect i) is the same as (vector-ref vect i) - * (set! (vect i) x) is the same as (vector-set! vect i x) - * (vect i j k) accesses the 3-dimensional vect - * (set! (vect i j k) x) sets that element (vector-ref and vector-set! can also be used) - * (make-vector (list 2 3 4)) returns a 3-dimensional vector with the given dimension sizes - * (make-vector '(2 3) 1.0) returns a 2-dim vector with all elements set to 1.0 - */ - -bool s7_is_hash_table(s7_pointer p); /* (hash-table? p) */ -s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size); /* (make-hash-table size) */ -s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key); - /* (hash-table-ref table key) */ -s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value); - /* (hash-table-set! table key value) */ -s7_int s7_hash_code(s7_scheme *sc, s7_pointer obj, s7_pointer eqfunc); /* (hash-code obj [eqfunc]) */ - -s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook); /* (hook-functions hook) */ -s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions); /* (set! (hook-functions hook) ...) */ - - -bool s7_is_input_port(s7_scheme *sc, s7_pointer p); /* (input-port? p) */ -bool s7_is_output_port(s7_scheme *sc, s7_pointer p); /* (output-port? p) */ -const char *s7_port_filename(s7_scheme *sc, s7_pointer x); /* (port-filename p) */ -s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p); /* (port-line-number p) */ - -s7_pointer s7_current_input_port(s7_scheme *sc); /* (current-input-port) */ -s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer p); /* (set-current-input-port) */ -s7_pointer s7_current_output_port(s7_scheme *sc); /* (current-output-port) */ -s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer p); /* (set-current-output-port) */ -s7_pointer s7_current_error_port(s7_scheme *sc); /* (current-error-port) */ -s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port); /* (set-current-error-port port) */ -void s7_close_input_port(s7_scheme *sc, s7_pointer p); /* (close-input-port p) */ -void s7_close_output_port(s7_scheme *sc, s7_pointer p); /* (close-output-port p) */ -s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode); - /* (open-input-file name mode) */ -s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode); - /* (open-output-file name mode) */ - /* mode here is an optional C style flag, "a" for "alter", etc ("r" is the input default, "w" is the output default) */ -s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string); - /* (open-input-string str) */ -s7_pointer s7_open_output_string(s7_scheme *sc); /* (open-output-string) */ -const char *s7_get_output_string(s7_scheme *sc, s7_pointer out_port); /* (get-output-string port) -- current contents of output string */ - /* don't free the string */ -s7_pointer s7_output_string(s7_scheme *sc, s7_pointer p); /* same but returns an s7 string */ -bool s7_flush_output_port(s7_scheme *sc, s7_pointer p); /* (flush-output-port port) */ - -typedef enum {S7_READ, S7_READ_CHAR, S7_READ_LINE, S7_PEEK_CHAR, S7_IS_CHAR_READY, S7_NUM_READ_CHOICES} s7_read_t; -s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port)); -s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port)); - -s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port); /* (read-char port) */ -s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port); /* (peek-char port) */ -s7_pointer s7_read(s7_scheme *sc, s7_pointer port); /* (read port) */ -void s7_newline(s7_scheme *sc, s7_pointer port); /* (newline port) */ -s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer port); /* (write-char c port) */ -s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port); /* (write obj port) */ -s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port); /* (display obj port) */ -const char *s7_format(s7_scheme *sc, s7_pointer args); /* (format ... */ - - -bool s7_is_syntax(s7_pointer p); /* (syntax? p) */ -bool s7_is_symbol(s7_pointer p); /* (symbol? p) */ -const char *s7_symbol_name(s7_pointer p); /* (symbol->string p) -- don't free the string */ -s7_pointer s7_make_symbol(s7_scheme *sc, const char *name); /* (string->symbol name) */ -s7_pointer s7_gensym(s7_scheme *sc, const char *prefix); /* (gensym prefix) */ - -bool s7_is_keyword(s7_pointer obj); /* (keyword? obj) */ -s7_pointer s7_make_keyword(s7_scheme *sc, const char *key); /* (string->keyword key) */ -s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key); /* (keyword->symbol key) */ - -s7_pointer s7_rootlet(s7_scheme *sc); /* (rootlet) */ -s7_pointer s7_shadow_rootlet(s7_scheme *sc); -s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let); -s7_pointer s7_curlet(s7_scheme *sc); /* (curlet) */ -s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e); /* returns previous curlet */ -s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e); /* (outlet e) */ -s7_pointer s7_sublet(s7_scheme *sc, s7_pointer env, s7_pointer bindings); /* (sublet e ...) */ -s7_pointer s7_inlet(s7_scheme *sc, s7_pointer bindings); /* (inlet ...) */ -s7_pointer s7_varlet(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value); /* (varlet env symbol value) */ -s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env); /* (let->list env) */ -bool s7_is_let(s7_pointer e); /* )let? e) */ -s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer env, s7_pointer sym); /* (let-ref e sym) */ -s7_pointer s7_let_set(s7_scheme *sc, s7_pointer env, s7_pointer sym, s7_pointer val); /* (let-set! e sym val) */ -s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e); /* (openlet e) */ -bool s7_is_openlet(s7_pointer e); /* (openlet? e) */ -s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method); - -/* *s7* */ -/* these renamed because "s7_let_field" seems the same as "s7_let", but here we're referring to *s7*, not any let */ -s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer sym); /* (*s7* sym) */ -s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value); /* (set! (*s7* sym) new_value) */ -/* new names */ -s7_pointer s7_starlet_ref(s7_scheme *sc, s7_pointer sym); /* (*s7* sym) */ -s7_pointer s7_starlet_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value); /* (set! (*s7* sym) new_value) */ - -s7_pointer s7_name_to_value(s7_scheme *sc, const char *name); /* name's value in the current environment (after turning name into a symbol) */ -s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name); -s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym); -s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val); -s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer local_env); -bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data); -bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data); - - /* these access the current environment and symbol table, providing - * a symbol's current binding (s7_name_to_value takes the symbol name as a char*, - * s7_symbol_value takes the symbol itself, s7_symbol_set_value changes the - * current binding, and s7_symbol_local_value uses the environment passed - * as its third argument). - * - * To iterate over the complete symbol table, use s7_for_each_symbol_name, - * and s7_for_each_symbol. Both call 'symbol_func' on each symbol, passing it - * the symbol or symbol name, and the uninterpreted 'data' pointer. - * the current binding. The for-each loop stops if the symbol_func returns true, - * or at the end of the table. - */ - -s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish); - -bool s7_is_immutable(s7_pointer p); -s7_pointer s7_immutable(s7_pointer p); - -void s7_define(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value); -bool s7_is_defined(s7_scheme *sc, const char *name); -s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value); -s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help); -s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value); -s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help); -s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer envir, const char *name, s7_pointer value); - /* These functions add a symbol and its binding to either the top-level environment - * or the 'env' passed as the second argument to s7_define. Except for s7_define, they return - * the name as a symbol. - * - * s7_define_variable(sc, "*features*", s7_nil(sc)); - * - * in s7.c is equivalent to the top level form - * - * (define *features* ()) - * - * s7_define_variable is simply s7_define with string->symbol and the global environment. - * s7_define_constant is s7_define but makes its "definee" immutable. - * s7_define is equivalent to define in Scheme, except that it does not return the value. - */ - -bool s7_is_function(s7_pointer p); -bool s7_is_procedure(s7_pointer x); /* (procedure? x) */ -bool s7_is_macro(s7_scheme *sc, s7_pointer x); /* (macro? x) */ -s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p); -s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p); -s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p); -s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p); /* (funclet x) */ -bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args); /* (aritable? x args) */ -s7_pointer s7_arity(s7_scheme *sc, s7_pointer x); /* (arity x) */ -const char *s7_help(s7_scheme *sc, s7_pointer obj); /* (help obj) */ -s7_pointer s7_make_continuation(s7_scheme *sc); /* call/cc... (see example below) */ - -const char *s7_documentation(s7_scheme *sc, s7_pointer p); /* (documentation x) if any (don't free the string) */ -const char *s7_set_documentation(s7_scheme *sc, s7_pointer p, const char *new_doc); -s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj); /* (setter obj) */ -s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter); /* (set! (setter p) setter) */ -s7_pointer s7_signature(s7_scheme *sc, s7_pointer func); /* (signature obj) */ -s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...); /* procedure-signature data */ -s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...); - -/* possibly unsafe functions: */ -s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); - -/* safe functions: */ -s7_pointer s7_make_safe_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); -s7_pointer s7_make_typed_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc, s7_pointer signature); - -/* arglist or body possibly unsafe: */ -s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); - -/* arglist and body safe: */ -s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); -s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature); - -/* arglist unsafe or body unsafe: */ -s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature); - -/* arglist safe, body possibly unsafe: */ -s7_pointer s7_define_semisafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature); - -s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc); -s7_pointer s7_make_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc); -void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc); -void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc); -void s7_define_typed_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, s7_pointer signature); -s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc); - - /* s7_make_function creates a Scheme function object from the s7_function 'fnc'. - * Its name (for s7_describe_object) is 'name', it requires 'required_args' arguments, - * can accept 'optional_args' other arguments, and if 'rest_arg' is true, it accepts - * a "rest" argument (a list of all the trailing arguments). The function's documentation - * is 'doc'. The s7_make_functions return the new function, but the s7_define_function (and macro) - * procedures return the name as a symbol (a desire for backwards compatibility brought about this split). - * - * s7_define_function is the same as s7_make_function, but it also adds 'name' (as a symbol) to the - * global (top-level) environment, with the function as its value (and returns the symbol, not the function). - * For example, the Scheme function 'car' is essentially: - * - * s7_pointer g_car(s7_scheme *sc, s7_pointer args) {return(s7_car(s7_car(args)));} - * - * then bound to the name "car": - * - * s7_define_function(sc, "car", g_car, 1, 0, false, "(car obj)"); - * ^ one required arg, no optional arg, no "rest" arg - * - * s7_is_function returns true if its argument is a function defined in this manner. - * s7_apply_function applies the function (the result of s7_make_function) to the arguments. - * - * s7_define_macro defines a Scheme macro; its arguments are not evaluated (unlike a function), - * but the macro's returned value (assumed to be some sort of Scheme expression) is evaluated. - * s7_define_macro returns the name as a symbol. - * - * Use the "unsafe" definer if the function might call the evaluator itself in some way (s7_apply_function for example), - * or messes with s7's stack. - */ - - /* In s7, (define* (name . args) body) or (define name (lambda* args body)) - * define a function that takes optional (keyword) named arguments. - * The "args" is a list that can contain either names (normal arguments), - * or lists of the form (name default-value), in any order. When called, - * the names are bound to their default values (or #f), then the function's - * current arglist is scanned. Any name that occurs as a keyword (":name") - * precedes that argument's new value. Otherwise, as values occur, they - * are plugged into the environment based on their position in the arglist - * (as normal for a function). So, - * - * (define* (hi a (b 32) (c "hi")) (list a b c)) - * (hi 1) -> '(1 32 "hi") - * (hi :b 2 :a 3) -> '(3 2 "hi") - * (hi 3 2 1) -> '(3 2 1) - * - * :rest causes its argument to be bound to the rest of the arguments at that point. - * - * The C connection to this takes the function name, the C function to call, the argument - * list as written in Scheme, and the documentation string. s7 makes sure the arguments - * are ordered correctly and have the specified defaults before calling the C function. - * s7_define_function_star(sc, "a-func", a_func, "arg1 (arg2 32)", "an example of C define*"); - * Now (a-func :arg1 2) calls the C function a_func(2, 32). See the example program in s7.html. - * - * In s7 Scheme, define* can be used just for its optional arguments feature, but that is - * included in s7_define_function. s7_define_function_star implements keyword arguments - * for C-level functions (as well as optional/rest arguments). - */ - -s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args); -s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args); - -s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args); -s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line); -s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler); - - /* s7_call takes a Scheme function and applies it to 'args' (a list of arguments) returning the result. - * s7_pointer kar; - * kar = s7_make_function(sc, "car", g_car, 1, 0, false, "(car obj)"); - * s7_integer(s7_call(sc, kar, s7_cons(sc, s7_cons(sc, s7_make_integer(sc, 123), s7_nil(sc)), s7_nil(sc)))); - * returns 123. - * - * s7_call_with_location passes some information to the error handler. - * s7_call makes sure some sort of catch exists if an error occurs during the call, but - * s7_apply_function does not -- it assumes the catch has been set up already. - * s7_call_with_catch wraps an explicit catch around a function call ("body" above); - * s7_call_with_catch(sc, tag, body, err) is equivalent to (catch tag body err). - */ - -bool s7_is_dilambda(s7_pointer obj); -s7_pointer s7_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), - s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), - s7_int set_req_args, s7_int set_opt_args, - const char *documentation); -s7_pointer s7_typed_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), - s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), - s7_int set_req_args, s7_int set_opt_args, - const char *documentation, - s7_pointer get_sig, s7_pointer set_sig); -s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer envir, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), - s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), - s7_int set_req_args, s7_int set_opt_args, - const char *documentation); - -s7_pointer s7_values(s7_scheme *sc, s7_pointer args); /* (values ...) */ -bool s7_is_multiple_value(s7_pointer obj); /* is obj the results of (values ...) */ - -s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e); /* (make-iterator e) */ -bool s7_is_iterator(s7_pointer obj); /* (iterator? obj) */ -bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer obj); /* (iterator-at-end? obj) */ -s7_pointer s7_iterate(s7_scheme *sc, s7_pointer iter); /* (iterate iter) */ - -s7_pointer s7_copy(s7_scheme *sc, s7_pointer args); /* (copy ...) */ -s7_pointer s7_fill(s7_scheme *sc, s7_pointer args); /* (fill! ...) */ -s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg); /* (type-of arg) */ - - - -/* -------------------------------------------------------------------------------- */ -/* c types/objects */ - -void s7_mark(s7_pointer p); - -bool s7_is_c_object(s7_pointer p); -s7_int s7_c_object_type(s7_pointer obj); -void *s7_c_object_value(s7_pointer obj); -void *s7_c_object_value_checked(s7_pointer obj, s7_int type); -s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value); -s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let); -s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value); -s7_pointer s7_c_object_let(s7_pointer obj); -s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e); -/* the "let" in s7_make_c_object_with_let and s7_c_object_set_let needs to be GC protected by marking it in the c_object's mark function */ - -s7_int s7_make_c_type(s7_scheme *sc, const char *name); /* create a new c_object type */ - -/* old style free/mark/equal */ -void s7_c_type_set_free (s7_scheme *sc, s7_int tag, void (*gc_free)(void *value)); -void s7_c_type_set_mark (s7_scheme *sc, s7_int tag, void (*mark)(void *value)); -void s7_c_type_set_equal (s7_scheme *sc, s7_int tag, bool (*equal)(void *value1, void *value2)); - -/* new style free/mark/equal and equivalent */ -void s7_c_type_set_gc_free (s7_scheme *sc, s7_int tag, s7_pointer (*gc_free) (s7_scheme *sc, s7_pointer obj)); /* free c_object function, new style*/ -void s7_c_type_set_gc_mark (s7_scheme *sc, s7_int tag, s7_pointer (*mark) (s7_scheme *sc, s7_pointer obj)); /* mark function, new style */ -void s7_c_type_set_is_equal (s7_scheme *sc, s7_int tag, s7_pointer (*is_equal) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int tag, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args)); - -void s7_c_type_set_ref (s7_scheme *sc, s7_int tag, s7_pointer (*ref) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_set (s7_scheme *sc, s7_int tag, s7_pointer (*set) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_length (s7_scheme *sc, s7_int tag, s7_pointer (*length) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_copy (s7_scheme *sc, s7_int tag, s7_pointer (*copy) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_fill (s7_scheme *sc, s7_int tag, s7_pointer (*fill) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_reverse (s7_scheme *sc, s7_int tag, s7_pointer (*reverse) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_to_list (s7_scheme *sc, s7_int tag, s7_pointer (*to_list) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_to_string (s7_scheme *sc, s7_int tag, s7_pointer (*to_string) (s7_scheme *sc, s7_pointer args)); -void s7_c_type_set_getter (s7_scheme *sc, s7_int tag, s7_pointer getter); -void s7_c_type_set_setter (s7_scheme *sc, s7_int tag, s7_pointer setter); -/* For the copy function, either the first or second argument can be a c-object of the given type. */ - - /* These functions create a new Scheme object type. There is a simple example in s7.html. - * - * s7_make_c_type creates a new C-based type for Scheme. It returns an s7_int "tag" used to indentify this type elsewhere. - * The functions associated with this type are set via s7_c_type_set*: - * - * free: the function called when an object of this type is about to be garbage collected - * mark: called during the GC mark pass -- you should call s7_mark - * on any embedded s7_pointer associated with the object (including its "let") to protect if from the GC. - * gc_mark and gc_free are new forms of mark and free, taking the c_object s7_pointer rather than its void* value - * equal: compare two objects of this type; (equal? obj1 obj2) -- this is the old form - * is_equal: compare objects as in equal? -- this is the new form of equal? - * is_equivalent: compare objects as in equivalent? - * ref: a function that is called whenever an object of this type - * occurs in the function position (at the car of a list; the rest of the list - * is passed to the ref function as the arguments: (obj ...)) - * set: a function that is called whenever an object of this type occurs as - * the target of a generalized set! (set! (obj ...) val) - * length: the function called when the object is asked what its length is. - * copy: the function called when a copy of the object is needed. - * fill: the function called to fill the object with some value. - * reverse: similarly... - * to_string: object->string for an object of this type - * getter/setter: these help the optimizer handle applicable c-objects (see s7test.scm for an example) - * - * s7_is_c_object returns true if 'p' is a c_object - * s7_c_object_type returns the c_object's type (the s7_int passed to s7_make_c_object) - * s7_c_object_value returns the value bound to that c_object (the void *value of s7_make_c_object) - * s7_make_c_object creates a new Scheme entity of the given type with the given (uninterpreted) value - * s7_mark marks any Scheme c_object as in-use (use this in the mark function to mark - * any embedded s7_pointer variables). - */ - -/* -------------------------------------------------------------------------------- */ -/* the new clm optimizer! this time for sure! - * d=double, i=integer, v=c_object, p=s7_pointer - * first return type, then arg types, d_vd -> returns double takes c_object and double (i.e. a standard clm generator) - * - * It is possible to tell s7 to call a foreign function directly, without any scheme-related - * overhead. The call needs to take the form of one of the s7_*_t functions in s7.h. For example, - * one way to call + is to pass it two s7_double arguments and get an s7_double back. This is the - * s7_d_dd_t function (the first letter gives the return type, the rest give successive argument types). - * We tell s7 about it via s7_set_d_dd_function. Whenever s7's optimizer encounters + with two arguments - * that it (the optimizer) knows are s7_doubles, in a context where an s7_double result is expected, - * s7 calls the s7_d_dd_t function directly without consing a list of arguments, and without - * wrapping up the result as a scheme cell. - */ - -s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr); - -typedef s7_double (*s7_float_function)(s7_scheme *sc); -s7_float_function s7_float_optimize(s7_scheme *sc, s7_pointer expr); - -typedef s7_double (*s7_d_t)(void); -void s7_set_d_function(s7_scheme *sc, s7_pointer f, s7_d_t df); -s7_d_t s7_d_function(s7_pointer f); - -typedef s7_double (*s7_d_d_t)(s7_double x); -void s7_set_d_d_function(s7_scheme *sc, s7_pointer f, s7_d_d_t df); -s7_d_d_t s7_d_d_function(s7_pointer f); - -typedef s7_double (*s7_d_dd_t)(s7_double x1, s7_double x2); -void s7_set_d_dd_function(s7_scheme *sc, s7_pointer f, s7_d_dd_t df); -s7_d_dd_t s7_d_dd_function(s7_pointer f); - -typedef s7_double (*s7_d_ddd_t)(s7_double x1, s7_double x2, s7_double x3); -void s7_set_d_ddd_function(s7_scheme *sc, s7_pointer f, s7_d_ddd_t df); -s7_d_ddd_t s7_d_ddd_function(s7_pointer f); - -typedef s7_double (*s7_d_dddd_t)(s7_double x1, s7_double x2, s7_double x3, s7_double x4); -void s7_set_d_dddd_function(s7_scheme *sc, s7_pointer f, s7_d_dddd_t df); -s7_d_dddd_t s7_d_dddd_function(s7_pointer f); - -typedef s7_double (*s7_d_v_t)(void *v); -void s7_set_d_v_function(s7_scheme *sc, s7_pointer f, s7_d_v_t df); -s7_d_v_t s7_d_v_function(s7_pointer f); - -typedef s7_double (*s7_d_vd_t)(void *v, s7_double d); -void s7_set_d_vd_function(s7_scheme *sc, s7_pointer f, s7_d_vd_t df); -s7_d_vd_t s7_d_vd_function(s7_pointer f); - -typedef s7_double (*s7_d_vdd_t)(void *v, s7_double x1, s7_double x2); -void s7_set_d_vdd_function(s7_scheme *sc, s7_pointer f, s7_d_vdd_t df); -s7_d_vdd_t s7_d_vdd_function(s7_pointer f); - -typedef s7_double (*s7_d_vid_t)(void *v, s7_int i, s7_double d); -void s7_set_d_vid_function(s7_scheme *sc, s7_pointer f, s7_d_vid_t df); -s7_d_vid_t s7_d_vid_function(s7_pointer f); - -typedef s7_double (*s7_d_p_t)(s7_pointer p); -void s7_set_d_p_function(s7_scheme *sc, s7_pointer f, s7_d_p_t df); -s7_d_p_t s7_d_p_function(s7_pointer f); - -typedef s7_double (*s7_d_pd_t)(s7_pointer v, s7_double x); -void s7_set_d_pd_function(s7_scheme *sc, s7_pointer f, s7_d_pd_t df); -s7_d_pd_t s7_d_pd_function(s7_pointer f); - -typedef s7_double (*s7_d_7pi_t)(s7_scheme *sc, s7_pointer v, s7_int i); -void s7_set_d_7pi_function(s7_scheme *sc, s7_pointer f, s7_d_7pi_t df); -s7_d_7pi_t s7_d_7pi_function(s7_pointer f); - -typedef s7_double (*s7_d_7pid_t)(s7_scheme *sc, s7_pointer v, s7_int i, s7_double d); -void s7_set_d_7pid_function(s7_scheme *sc, s7_pointer f, s7_d_7pid_t df); -s7_d_7pid_t s7_d_7pid_function(s7_pointer f); - -typedef s7_double (*s7_d_id_t)(s7_int i, s7_double d); -void s7_set_d_id_function(s7_scheme *sc, s7_pointer f, s7_d_id_t df); -s7_d_id_t s7_d_id_function(s7_pointer f); - -typedef s7_double (*s7_d_ip_t)(s7_int i, s7_pointer p); -void s7_set_d_ip_function(s7_scheme *sc, s7_pointer f, s7_d_ip_t df); -s7_d_ip_t s7_d_ip_function(s7_pointer f); - -typedef s7_int (*s7_i_i_t)(s7_int x); -void s7_set_i_i_function(s7_scheme *sc, s7_pointer f, s7_i_i_t df); -s7_i_i_t s7_i_i_function(s7_pointer f); - -typedef s7_int (*s7_i_7d_t)(s7_scheme *sc, s7_double x); -void s7_set_i_7d_function(s7_scheme *sc, s7_pointer f, s7_i_7d_t df); -s7_i_7d_t s7_i_7d_function(s7_pointer f); - -typedef s7_int (*s7_i_ii_t)(s7_int i1, s7_int i2); -void s7_set_i_ii_function(s7_scheme *sc, s7_pointer f, s7_i_ii_t df); -s7_i_ii_t s7_i_ii_function(s7_pointer f); - -typedef s7_int (*s7_i_7p_t)(s7_scheme *sc, s7_pointer p); -void s7_set_i_7p_function(s7_scheme *sc, s7_pointer f, s7_i_7p_t df); -s7_i_7p_t s7_i_7p_function(s7_pointer f); - -typedef bool (*s7_b_p_t)(s7_pointer p); -void s7_set_b_p_function(s7_scheme *sc, s7_pointer f, s7_b_p_t df); -s7_b_p_t s7_b_p_function(s7_pointer f); - -typedef s7_pointer (*s7_p_d_t)(s7_scheme *sc, s7_double x); -void s7_set_p_d_function(s7_scheme *sc, s7_pointer f, s7_p_d_t df); -s7_p_d_t s7_p_d_function(s7_pointer f); - -typedef s7_pointer (*s7_p_p_t)(s7_scheme *sc, s7_pointer p); -void s7_set_p_p_function(s7_scheme *sc, s7_pointer f, s7_p_p_t df); -s7_p_p_t s7_p_p_function(s7_pointer f); - -typedef s7_pointer (*s7_p_pp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2); -void s7_set_p_pp_function(s7_scheme *sc, s7_pointer f, s7_p_pp_t df); -s7_p_pp_t s7_p_pp_function(s7_pointer f); - -typedef s7_pointer (*s7_p_ppp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3); -void s7_set_p_ppp_function(s7_scheme *sc, s7_pointer f, s7_p_ppp_t df); -s7_p_ppp_t s7_p_ppp_function(s7_pointer f); - -/* Here is an example of using these functions; more extensive examples are in clm2xen.c in sndlib, and in s7.c. - * (This example comes from a HackerNews discussion): - * plus.c: - * -------- - * #include "s7.h" - * - * s7_pointer g_plusone(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1));} - * s7_int plusone(s7_int x) {return(x + 1);} - * - * void plusone_init(s7_scheme *sc) - * { - * s7_define_safe_function(sc, "plusone", g_plusone, 1, 0, false, ""); - * s7_set_i_i_function(sc, s7_name_to_value(sc, "plusone"), plusone); - * } - * -------- - * gcc -c plus.c -fPIC -O2 -lm - * gcc plus.o -shared -o plus.so -ldl -lm -Wl,-export-dynamic - * repl - * <1> (load "plus.so" (inlet 'init_func 'plusone_init)) - * -------- - */ - -/* -------------------------------------------------------------------------------- */ - -/* maybe remove these? */ -s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol); -s7_pointer s7_slot_value(s7_pointer slot); -s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value); -s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value); -void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value); - -/* -------------------------------------------------------------------------------- */ - -#if (!DISABLE_DEPRECATED) -typedef s7_int s7_Int; -typedef s7_double s7_Double; - -#define s7_is_object s7_is_c_object -#define s7_object_type s7_c_object_type -#define s7_object_value s7_c_object_value -#define s7_make_object s7_make_c_object -#define s7_mark_object s7_mark -#define s7_UNSPECIFIED(Sc) s7_unspecified(Sc) -#endif - - -#if WITH_GMP - mpfr_t *s7_big_real(s7_pointer x); - mpz_t *s7_big_integer(s7_pointer x); - mpq_t *s7_big_ratio(s7_pointer x); - mpc_t *s7_big_complex(s7_pointer x); - - bool s7_is_bignum(s7_pointer obj); - bool s7_is_big_real(s7_pointer x); - bool s7_is_big_integer(s7_pointer x); - bool s7_is_big_ratio(s7_pointer x); - bool s7_is_big_complex(s7_pointer x); - - s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val); - s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val); - s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val); - s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val); -#endif - - -/* -------------------------------------------------------------------------------- - * - * s7 changes - * - * -------- - * 9-Nov: nan, nan-payload, +nan.. - * 19-Oct: s7_let_field* synonyms: s7_starlet*. - * 16-Sep: s7_number_to_real_with_location. s7_wrong_type_error. s7_make_string_wrapper_with_length. s7_make_semipermanent_string. - * 21-Apr: s7_is_multiple_value. - * 11-Apr: removed s7_apply_*. - * 22-Mar: s7_eval_with_location. - * 16-Mar: s7_list_to_array for the s7_apply_* changes. - * 8-Mar-22: moved s7_apply_* to xen.h if DISABLE_DEPRECATED. - * -------- - * 24-Nov: moved s7_p_p_t and friends into s7.h. - * 23-Sep: s7_make_byte_vector, s7_is_byte_vector, s7_byte_vector_ref|set|elements. - * 25-Aug: s7_output_string (like s7_get_output_string, but returns an s7 string). - * 19-Jul: s7_is_random_state, s7_make_normal_vector. s7_array_to_list. - * 12-Apr: s7_optimize now returns an s7_pfunc, not an s7_function. - * 7-Apr: removed the "args" parameter from s7_float_function. added s7_make_c_object_without_gc. - * 31-Mar: vector-rank, vector-dimension. - * 17-Mar: removed deprecated nan.0 and inf.0 due to compiler stupidity. - * 25-Jan: s7_define_semisafe_typed_function. - * 6-Jan-21: s7_hash_code. - * -------- - * 14-Oct: s7_load_c_string and s7_load_c_string_with_environment. - * 10-Sep: s7_free. - * 5-Aug: s7_make_list. - * 31-July: s7_define_constant_with_environment and s7_dilambda_with_environment. - * 29-July: open-input|output-function. add S7_NUM_READ_CHOICES to s7_read_t enum and remove (unused) S7_READ_BYTE. - * 20-July: s7_c_pointer_with_type. notcurses_s7.c and nrepl.scm. *autoload-hook*. - * 8-July: s7_int|float_vector_ref|set. subvector parameter order changed. - * 17-June: removed deprecated *s7* accessors. - * 20-May: libarb_s7.c. - * 12-May: s7_is_big*. - * 6-May: added s7_scheme* initial arguments to s7_set_* opt_func calls (s7_set_d_d_function for example). - * 23-Apr: added s7_scheme* initial argument to s7_is_eqv. - * 9-Mar: move openlets to (*s7* 'openlets), s7-version to (*s7* 'version), deprecate nan.0 and inf.0. - * 17-Feb: s7_let_field_ref|set for *s7* access. *function* to replace __func__. - * deprecate __func__, s7_print_length, s7_float_format_precision, s7_set_gc_stats. - * 31-Jan: macro(*) and bacro(*) -- unnamed macros analogous to lambda(*). - * 20-Jan: debug.scm and (*s7* 'debug), trace-in, dynamic-unwind. - * remove coverlets (openlets is now a dilambda). - * 10-Jan: s7_c_type_set_gc_free and s7_c_type_set_gc_mark. - * 2-Jan-20: s7_c_type_set_is_equal and s7_c_type_set_is_equivalent. - * -------- - * 2-Nov: s7_repl. - * 30-Oct: change S7_DATE format, and start updating it to reflect s7.c. - * 30-Jul: define-expansion*. - * 12-Jul: s7_call_with_catch, s7_load now returns NULL if file not found (rather than raise an error). - * 8-July: most-positive-fixnum and most-negative-fixnum moved to *s7*. - * 23-May: added s7_scheme argument to s7_c_object_set_let. - * 19-May: s7_gc_stats renamed s7_set_gc_stats. - * 7-May: s7_gc_unprotect_via_stack and s7_gc_(un)protect_via_location. - * 22-Mar: s7_float_format_precision. port-position. port-file. - * 4-Jan-19: morally-equal? -> equivalent? - * -------- - * 29-Dec: s7_c_type_set_getter|setter (implicit c-object access). - * 23-Dec: remove hash-table, rename hash-table* to hash-table. add weak-hash-table. - * 3-Dec: deprecate s7_gc_unprotect (use s7_gc_unprotect_at). - * 21-Nov: added s7_history_enabled and s7_set_history_enabled. - * 3-Nov: removed the "value" argument from s7_for_each_symbol. - * 22-Sep: s7_list_nl. - * 12-Sep: byte-vectors can be multidimensional; homogenous vectors of any built-in type. typed hash-tables. - * 29-Jul: symbol-setter deprecated (use setter). s7_symbol_documentation (and setter) folded into s7_documentation. - * 12-Jul: changed s7_vector_dimensions|offsets. - * Added s7_scheme* arg to make_permanent_string and several of the optimizer functions. - * 3-Jul: changed make-shared-vector to subvector. - * 20-May: s7_keyword_to_symbol. - * 6-May: s7_mark_c_object -> s7_mark. - * 26-Apr: s7_c_type_set_to_list|string, s7_c_type_set_apply -> s7_c_type_set_ref, removed s7_c_type_set_set|apply_direct - * c_type length|set|ref are now s7_functions (args, not obj, etc). - * 23-Mar: s7_peek_char and s7_read_char now return s7_pointer, s7_write_char takes s7_pointer, not int32_t c - * s7_gc_protect and friends now return/take s7_int location, not uint32_t. - * removed s7_new_type_x. - * 19-Mar: int32_t -> s7_int in various functions. - * 17-Mar: deprecate s7_ulong and s7_ulong_long functions. - * 26-Jan-18: s7_set_setter. - * -------- - * 11-Dec: s7_gc_protect_via_stack - * 3-Oct: renamed procedure-signature -> signature, procedure-documentation -> documentation, and procedure-setter -> setter. - * 18-Sep: s7_immutable, s7_is_immutable. define-constant follows lexical scope now. - * s7_symbol_access -> s7_symbol_setter, symbol-access -> symbol-setter. - * 3-Aug: object->c_object name changes. - * 28-Jul: s7_make_c_pointer_with_type and s7_c_pointer_type. - * 24-Jul: int64_t rather than long long int, and various related changes. - * 18-Jul: s7_make_object_with_let. - * 8-July: s7_define_typed_function_star, s7_make_function_star. s7_apply_function_star. - * 27-June: s7_make_string_wrapper. - * 22-May: lambda* keyword arg handling changed slightly. - * 9-May: s7_history, s7_add_to_history. - * 20-Apr: s7_tree_memq (for Snd), s7_type_of, many changes for new clm optimizer. - * 10-Apr: added s7_scheme first argument to s7_iterator_is_at_end. - * 28-Mar: removed the "rf", "pf" and "if" clm optimization functions. - * s7_optimize, s7_float_optimize, s7_procedure_signature. - * 22-Feb: removed the "gf" clm optimization functions. - * 11-Feb: #e, #i, #d removed. #i(...) is an int-vector constant, #r(...) a float-vector. - * 2-Jan-17: {apply_values} -> apply-values, {list} -> list-values, and {append} -> append. - * -------- - * 23-Sep: make-keyword -> string->keyword. - * 9-Aug: s7_varlet. - * 29-Jul: s7_define_unsafe_typed_function. - * 30-May: symbol takes any number of args. make-vector no longer takes an optional fourth argument. - * 24-May: let-ref/set! check rootlet now if let is not an open let; setter for with-let. - * 20-Feb: removed last vestiges of quasiquoted vector support. - * 3-Feb: *cload-directory*. - * 14-Jan: profile.scm. Moved multiple-value-set! to stuff.scm. Setter for port-line-number. - * 7-Jan: s7_load_with_environment. - * s7_eval_c_string takes only one statement now (use begin to handle multiple statements) - * 4-Jan-16: remove s7_eval_form, change s7_eval to take its place. - * -------- - * 11-Dec: owlet error-history field if WITH_HISTORY=1 - * 6-Nov: removed :key and :optional. - * 16-Oct: s7_make_random_state -> s7_random_state. - * 16-Aug: remove s7_define_integer_function, s7_function_set_removes_temp, - * add s7_define_typed_function, s7_make_signature. - * 5-Aug: added s7_scheme* arg to s7_openlet and s7_outlet. - * 3-Jul: s7_Double -> s7_double, s7_Int -> s7_int. Removed function_chooser_data. - * 27-Jun: s7_rf_t, s7_rp_t etc. - * 19-Jun: removed the ex_parser stuff, set_step_safe, s7_ex_fallback. - * 5-May: s7_make_iterator and friends. - * 16-Apr: added s7_fill, changed arg interpretation of s7_copy, s7_dynamic_wind. - * 30-Mar: s7_eval_c_string_with_environment (repl experiment). - * 19-Mar: repl.scm. - * 28-Feb: s7_vector_print_length -> s7_print_length, set case also. - * 25-Feb: s7_closure_* funcs to replace clumsy (deprecated) s7_procedure_source. - * 29-Jan: changed args to s7_new_type_x (added s7_scheme arg, fill! takes s7_function). - * 14-Jan-15: make-iterator, iterator? - * -------- - * 26-Dec: s7_arity replaces s7_procedure_arity. s7_define_integer_function. deprecate s7_procedure_name. - * 5-Nov: s7_shadow_rootlet and s7_set_shadow_rootlet. - * 30-Aug: s7_make_safe_function (for cload.scm). - * 25-July: define and friends now return the value, not the symbol. - * procedure_with_setter -> dilambda. - * environment -> let. All the replaced names are deprecated. - * 30-June: s7_method. - * 16-June: remove unoptimize and s7_unoptimize. - * 14-May: s7_define_safe_function_star. Removed s7_catch_all. - * 22-Apr: remove s7_apply_n_10, s7_is_valid_pointer, s7_keyword_eq_p. - * 5-Mar-14: s7_heap_size, s7_gc_freed (subsequently removed). - * -------- - * 8-Nov: s7_symbol_documentation, s7_define_constant_with_documentation. - * 17-Oct: bignum-precision (procedure-with-setter) is now an integer variable named *bignum-precision*. - * 28-Aug: s7_int|float_vector_elements (homogeneous vectors), libc.scm. - * 16-Aug: ~W directive in format, make-shared-vector. - * 23-Jul: s7_autoload_set_names, libm.scm, libdl.scm, libgdbm.scm, r7rs.scm, s7libtest.scm. - * 21-Jul: s7_is_valid (replaces deprecated s7_is_valid_pointer). - * 24-Jun: some bool-related changes for Windows Visual C++, including change to s7_begin_hook. - * 3-June: s7_autoload. - * 28-May: export s7_is_provided. Added s7_scheme* arg to s7_procedure_environment. - * 21-May: equality predicate optional arg in make-hash-table. - * 14-May: glistener.c, glistener.h, s7_symbol_table_find_name (for glistener). - * 2-May: r7rs changes: flush-output-port, vector-append, read|write-string, boolean=?, symbol=?. - * start/end args for string-fill!, vector-fill!, string->list, vector->list, and copy. - * exit, emergency-exit. - * 7-Apr: removed s7_scheme* arg from s7_slot_value, added s7_is_local_variable. - * 25-Mar: char-position, string-position, environment-ref, environment-set! added to the scheme side. - * 9-Jan-13: s7_cos, s7_sin, other optimization changes. - * -------- - * 24-Dec: s7_set_object_array_info and other such changes. - * 20-Nov: removed s7_set_error_exiter and s7_error_and_exit which I think have never been used. - * 22-Oct: changed args to s7_function_class and s7_function_set_class. - * 22-Aug: symbol->dynamic-value. - * 10-Aug: exported s7_outer_environment. - * 6-Aug: removed WITH_OPTIMIZATION. - * 25-July: environment (in scheme). s7_vector_ref_n and s7_vector_set_n. s7_copy. - * added s7_scheme arg to s7_number_to_real|integer. - * 16-July: s7_function_returns_temp (an experiment). - * 2-July: s7_object_set_* functions. - * 11-June: throw. - * 4-June. s7_object_environment. - * 31-May: added s7_scheme argument to all the optimizer chooser functions. - * 24-May: open-environment? - * 17-May: arity, aritable? - * removed trace and untrace. - * 14-May: s7_list. s7_procedure_set_setter. Removed s7_procedure_getter. - * procedure-setter is settable: removed most of procedure-with-setter. - * make-type replaced by open-environment. - * 11-May: s7 2.0: hook implementation changed completely. - * s7_environment_ref|set. - * 4-May: *error-info* replaced by error-environment, and stacktrace has changed. - * 22-Apr: #_ = startup (built-in) value of name - * 17-Apr: with-baffle. - * 14-Apr: WITH_SYSTEM_EXTRAS (default 0) has additional OS and IO functions: - * directory? file-exists? delete-file getenv directory->list system - * 26-Mar: "@" as exponent, WITH_AT_SIGN_AS_EXPONENT switch (default is 1). - * 18-Mar: removed *trace-hook*. - * 6-Feb: random-state?, hash-table-iterator?, and morally-equal? - * 18-Jan: s7_environment_to_list and environment->list return just the local environment's bindings. - * outer-environment returns the environment enclosing its argument (an environment). - * environments are now applicable objects. - * added the object system example to s7.html. - * 12-Jan: added reverse argument to s7_new_type_x. This is needed because an object might implement - * the apply and set methods, but they might refer to different things. - * 6-Jan-12: added (scheme side) logbit?. - * -------- - * 21-Dec: s7_eval, s7_make_slot, s7_slot_set_value. - * changed s7_symbol_slot to s7_slot, and s7_symbol_slot_value to s7_slot_value. - * 26-Oct: s7_procedure_name. - * 6-Oct: changed s7_make_closure args: split the code argument in two (args and body). - * s7_make_closure(... code ...) is now s7_make_closure(... car(code), cdr(code) ...) - * s7_is_environment. - * 19-Aug: s7_function_chooser_data. - * 11-Aug: s7_symbol_accessor functions. s7_cxxxxr. - * 9-Aug: s7_function_chooser, s7_function_choice, s7_function_choice_set_direct. - * 20-Jul: s7_function_class, s7_function_set_class, and s7_function_set_chooser. - * 14-Jul: removed thread and profiling support. - * 5-June: s7_define_safe_function and s7_unoptimize exported; added unoptimize function in scheme. - * 30-May: environment->list and s7_environment_to_list since environments are no longer alists internally. - * 26-May: added s7_scheme argument to s7_procedure_setter and getter (old names had "with_setter_"). - * 28-Apr: s7_help. - * 5-Apr: pair-line-number. - * 14-Mar: s7_make_random_state, optional state argument to s7_random, random-state->list, s7_random_state_to_list. - * 10-Feb: s7_vector_print_length, s7_set_vector_print_length. - * 7-Feb: s7_begin_hook, s7_set_begin_hook. - * 25-Jan: s7_is_thread, s7_thread, s7_make_thread, s7_thread_s7, s7_thread_data. - * s7_is_lock, s7_make_lock, s7_lock. - * changed s7_thread_variable_value to s7_thread_variable. - * 23-Jan: removed (scheme-level) quit. - * 17-Jan-11: make-hash-table-iterator. - * map and for-each accept any applicable object as the first argument. - * format's ~{...~} directive can handle any applicable object. - * -------- - * 17-Dec: removed unquote-splicing; replaced by (unquote (apply values ...)). - * 12-Dec: environment? - * 7-Dec: member and assoc have an optional third arg, the comparison function. - * 1-Dec: *gc-stats* in Scheme, s7_gc_stats in C. - * gmp and gtk-repl examples in s7.html. - * 21-Nov: Load C module example in s7.html. - * 12-Nov: *trace-hook*, *load-hook*, *error-hook*, and *unbound-variable-hook* are now s7 hooks. - * 9-Nov: hooks: C side: s7_is_hook, s7_make_hook, s7_hook_apply, s7_hook_functions, s7_hook_arity, s7_hook_documentation. - * s7 side: hook?, make-hook, hook, hook-apply, hook-functions, hook-arity, hook-documentation. - * 8-Nov: Closure defined in C example in s7.html. - * 23-Oct: s7_call_with_location for better error reporting. - * 19-Oct: *stdin*, *stdout*, *stderr* for default IO ports (rather than nil which is ambiguous). - * 14-Oct: removed special variable support. - * 30-Sep: setters for current-input-port, current-output-port, and current-error-port. - * 30-Aug: :allow-other-keys in define*. - * 10-Aug: added boolean argument use_write to s7_object_to_string (true=write, false=display). - * 30-July: special macro for access to dynamic binding. - * s7_symbol_special_value for C-side access to dynamic bindings. - * s7_is_macro. - * port-closed? returns #t if its argument (a port) is closed. - * 22-July: s7_make_character takes uint32_t, rather than int. - * added symbol function for funny symbol names. - * 12-July: initial-environment. - * 7-July: removed force and delay: use slib. - * 3-July: new backquote implementation. - * 28-June: syntactic keywords (e.g. lambda) are applicable. - * 7-June: changed key arg in s7_hash_table_ref|set to be s7_pointer, not const char*. - * hash-tables can now handle any s7 object as the key. - * map and for-each now pass a hash-table entry to the function, rather than an internal alist. - * reverse of a hash-table reverses the keys and values (i.e. old value becomes new key, etc). - * 2-June: removed procedure-with-setter-setter-arity and folded that info into procedure-arity (use cdddr). - * 22-May: multidimensional vectors are no longer optional. - * 9-May: s7_read_char and s7_peek_char have to return an int, not a char (=-1, but 255 is a legit char). - * s7_write_char and s7_open_output_function have similar changes. - * 3-May: *#readers* to customize #... reading. Also nan? and infinite?. - * multidimensional vector constants using #nD(...): (#2D((1 2 3) (4 5 6)) 0 0) -> 1. - * 13-Apr: removed hash-table|vector|string-for-each -- these are handled by for-each. - * also removed vector-map -- map is generic, but always returns a list. - * 12-Apr: removed immutable constant checks -- see s7.html. - * 7-Apr: *unbound-variable-hook*. - * augment-environment and s7_augment_environment. - * 29-Mar: symbol-access, s7_symbol_access, s7_symbol_set_access. - * C example of notification in s7.html. - * 25-Mar: make-type. s7_is_equal now includes an s7_scheme pointer as its first argument. - * 24-Mar: s7_is_defined. - * 19-Mar: removed encapsulation mechanism and s7_define_set_function. - * 18-Mar: added macro?. - * 27-Feb: removed r4rs-style macro syntax. - * 17-Feb: s7_number_to_integer. - * 20-Jan-10: removed the stack function. - * -------- - * 16-Dec: hash-table-for-each. - * 1-Dec: mpc versions before 0.8.0 are no longer supported. - * 24-Nov: define-macro* and defmacro*. - * force and delay included only if WITH_FORCE set, promise? removed. - * 17-Nov: s7_is_boolean no longer takes the s7_scheme argument. - * 7-Nov: s7_vector_dimensions, s7_vector_offsets, example of use. - * 3-Nov: s7_vector_rank. - * 30-Oct: *trace-hook*. - * 12-Oct: s7_port_filename. - * 5-Oct: s7_c_pointer and friends. - * 14-Sep: s7_values, s7_make_continuation, and a better interrupt example. - * vector-for-each, vector-map, string-for-each. - * 7-Sep: s7_open_input_function. with-environment. receive. - * 3-Sep: s7.html, s7-slib-init.scm. - * s7_stacktrace in s7.h. - * 27-Aug: vector and hash-table sizes are now s7_ints, rather than ints. - * 20-Aug: s7_remove_from_heap. - * 17-Aug: *error-info*. - * 7-Aug: s7_define_function_with_setter. - * s7_quit and example of signal handling. - * 6-Aug: encapsulation. s7_define_set_function. s7_new_type_x. - * generic function: copy, and length is generic. - * 1-Aug: lower-case versions of s7_T and friends. - * s7_define_macro. macroexpand. - * strings are set-applicable (like vectors). - * 31-Jul: *error-hook*. - * 30-Jul: changed backtrace handling: removed backtrace stuff, added stacktrace. - * removed gc-verbose and load-verbose replaced by *load-hook*. - * 23-Jul: __func__. - * 20-Jul: trace and untrace. - * 14-Jul: replaced s7_make_closure_star with s7_define_function_star. - * 29-Jun: s7_format declaration. - * 12-May: s7_is_constant. - * 20-Apr: changed rationalize to be both r5rs-acceptable and fast. - * 6-Apr: added s7_make_permanent_string. - * 14-Mar: removed s7_local_gc_protect and s7_local_gc_unprotect. - * 4-Mar: multidimensional and applicable vectors. - * 1-Mar: s7_random added to s7.h. - * 29-Jan: s7_is_bignum and friends. - * 26-Jan: added s7_scheme arg to s7_vector_fill. - * 16-Jan: s7_is_ulong_long and friends for C pointers in 64-bit situations. - * 9-Jan-09 multiprecision arithmetic (gmp, mpfr, mpc) on the WITH_GMP switch - * -------- - * 29-Dec: "+" specialization example, s7_apply_function. - * 3-Dec: s7_open_output_function. - * 30-Nov: s7_wrong_number_of_args_error. - * 24-Nov: changed s7_make_counted_string to s7_make_string_with_length. - * also added built-in format and define* - * 10-Nov: s7_define_constant, - * built-in (scheme-side) pi, most-positive-fixnum, most-negative-fixnum - * 7-Nov: removed s7_is_immutable and friends, s7_reverse_in_place. - * removed the s7_pointer arg to s7_gc_on. - * added s7_UNSPECIFIED - * 25-Oct: added name arg to s7_make_procedure_with_setter, - * and s7_scheme arg to new_type print func. - * 1-Oct-08 version 1.0 - */ - - -#ifdef __cplusplus -} -#endif - -#endif diff --git a/source/engine/script.c b/source/engine/script.c index fbd36e7f..07ab6253 100644 --- a/source/engine/script.c +++ b/source/engine/script.c @@ -9,7 +9,7 @@ #include "stb_ds.h" -s7_scheme *s7 = NULL; +duk_context *duk = NULL; s7_pointer cpvec2s7(cpVect v) { s7_pointer ret = s7_make_vector(s7, 2); @@ -65,9 +65,11 @@ static int load_prefab(const char *fpath, const struct stat *sb, int typeflag) { } void script_init() { - s7 = s7_init(); + duk = duk_create_heap_default(); + /* s7_set_current_error_port(s7, s7_open_output_function(s7, my_err)); s7_set_current_output_port(s7, s7_open_output_function(s7, my_print)); + */ ffi_load(); /* Load all prefabs into memory */ diff --git a/source/engine/script.h b/source/engine/script.h index 65ec98ce..524c67a6 100644 --- a/source/engine/script.h +++ b/source/engine/script.h @@ -1,10 +1,10 @@ #ifndef SCRIPT_H #define SCRIPT_H -#include "s7.h" +#include "duktape.h" #include -extern s7_scheme *s7; +extern duk_context *duk; void script_init(); void script_run(const char *script); diff --git a/source/engine/yugine.c b/source/engine/yugine.c index c33c5598..c24d3cf9 100644 --- a/source/engine/yugine.c +++ b/source/engine/yugine.c @@ -12,7 +12,7 @@ #include #include - +#include "duktape.h" #include "2dphysics.h" @@ -119,6 +119,13 @@ int main(int argc, char **args) { } } + + duk_context *duk = duk_create_heap_default(); + duk_eval_string(duk, "1+2"); + printf("DUK RESULT: %d", duk_get_int(duk, -1)); + + + #if DBG if (logout) { time_t now = time(NULL);